packages feed

synthesizer (empty) → 0.0.3

raw patch · 194 files changed

+32151/−0 lines, 194 filesdep +QuickCheckdep +arraydep +basesetup-changed

Dependencies added: QuickCheck, array, base, binary, bytestring, containers, directory, event-list, mtl, non-negative, numeric-prelude, numeric-quest, old-time, process, random, special-functors, storablevector, unix

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,124 @@++OBJECT_DIR    := build/$(shell uname -s)-$(shell uname -m)+INTERFACE_DIR := build/Interface+++SOURCE = $(patsubst %, src/%, $(TOPLEVEL)) \+	 $(HASKORE_INTERFACE) $(MUSIC) \+	 $(PLAIN) $(FILTER) $(DIMENSION) $(VOLUME) $(SRCONTEXT) $(PHYSICAL) \+         $(FUSION) $(STORABLE) \+         $(INFERENCE) $(SOX)++TOPLEVEL = \+	 BinarySample.hs+#	 DiscreteWavelet/Lifting DiscreteWavelet/Lattice \+#	 Signal.hs ShiftedSignal.hs++MUSIC = $(patsubst %, src/Music/%, \+	    WinterAde.hs FilterSaw.hs FMBassLine.hs SwanLake.hs \+            ChildSong6ToSignal.hs Guitar.hs )++HASKORE_INTERFACE = \+	 $(patsubst %, src/Haskore/Interface/Signal/%, \+	            Note.hs InstrumentMap.hs Write.hs)++SIGNAL    = $(wildcard src/Sound/Signal/*.hs) src/Sound/Signal.hs++PLAIN     = $(wildcard src/Synthesizer/Plain/*.hs) \+            $(wildcard src/Synthesizer/Plain/Effect/*.hs) \+            $(wildcard src/Synthesizer/Plain/Filter/*.hs) \+            $(wildcard src/Synthesizer/Plain/Filter/Delay/*.hs)+FILTER    = $(wildcard src/Filter/*.hs)+DIMENSION = $(wildcard src/Synthesizer/Dimension/*.hs) \+            $(wildcard src/Synthesizer/Dimension/Amplitude/*.hs) \+            $(wildcard src/Synthesizer/Dimension/Rate/*.hs) \+            $(wildcard src/Synthesizer/Dimension/RateAmplitude/*.hs)+VOLUME    = $(wildcard src/Synthesizer/Amplitude/*.hs)+SRCONTEXT = $(wildcard src/Synthesizer/SampleRateContext/*.hs)+FUSION    = $(wildcard src/Synthesizer/FusionList/*.hs)+STORABLE  = $(wildcard src/Synthesizer/Storable/*.hs)+PHYSICAL  = $(wildcard src/Synthesizer/Physical/*.hs)+INFERENCE = $(wildcard src/Synthesizer/Inference/Monad/*.hs) \+            $(wildcard src/Synthesizer/Inference/Monad/Signal/*.hs) \+            $(wildcard src/Synthesizer/Inference/Monad/SignalSeq/*.hs) \+            $(wildcard src/Synthesizer/Inference/Reader/*.hs)+SOX = src/Sox.hs $(wildcard src/Sox/*.hs)++++HTML = doc/html++STDHADDOCK = base/base.haddock++CUSTOMHADDOCK = numericprelude/docs/numericprelude.haddock haskore/docs/haskore.haddock++HADDOCK_INCL = $(patsubst %, -i /usr/local/share/ghc-6.2/html/libraries/%, $(STDHADDOCK)) \+               $(patsubst %, -i $(HOME)/programming/haskell/%, $(CUSTOMHADDOCK))++# if the 6.4.1 files are used, many identifiers like ExitCode can not be found+# CUSTOMHADDOCK = numericprelude/docs/numericprelude.haddock haskore/docs/haskore.haddock+# HADDOCK_INCL = $(patsubst %, -i /usr/share/doc/ghc-6.4.1/libraries/%, $(STDHADDOCK)) \+#                $(patsubst %, -i $(HOME)/programming/haskell/%, $(CUSTOMHADDOCK))++HADDOCK_SOURCE = $(SOURCE) src/Synthesizer/Physical.hs src/Synthesizer/Inference/Monad.hs+++#MODULES = Synthesizer Instruments SignalIO Signal Test Filter/Test++MODULE_PATH = src  # the other modules are now present by (Cabal) packages+# MODULE_PATH = src:..:../numericprelude/src:../linearalgebra:../math:../shell-haskell:../haskore/src:../haskore/src/GHC+++HC      = ghc   # ghc-6.2.2+HCINT   = ghci  # ghci-6.2.2++GHC_OPTIONS = -O -Wall -odir$(OBJECT_DIR) -hidir$(INTERFACE_DIR) -hide-package synthesizer+++.PHONY:	all doc build test clean perm++all:	build++clean:+	rm -r $(OBJECT_DIR) $(INTERFACE_DIR)/*++doc:	$(SOURCE)+	haddock --html-help=devhelp -o $(HTML) -t Synthesizer -p doc/Prologue.txt -h --dump-interface=doc/synthesizer.haddock \+	        $(HADDOCK_INCL) $(HADDOCK_SOURCE)+	chmod -R o+rx $(HTML)++publish-doc:	doc+	tar cz $(HTML) | ssh cvs.haskell.org tar xz --directory=/home/darcs/synthesizer++build:+	-mkdir $(OBJECT_DIR)+	$(HC) --make $(GHC_OPTIONS) -i:$(MODULE_PATH) $(SOURCE)+#       $(HC) --make -O -Wall $(patsubst %, %.hs, $(MODULES))++perm:+	(cd /home/thielema; \+	chgrp -R perform projects/paper/haskellsignal programming/haskell/synthesizer; \+	chmod -R g+rw projects/paper/haskellsignal programming/haskell; \+	chmod g+x `find programming/haskell -type d`; \+	rm /tmp/curve.dat; )++test:+	$(HC) $(GHC_OPTIONS) -i:$(MODULE_PATH) --make src/Test.hs+	time $(HC) $(GHC_OPTIONS) -i:$(MODULE_PATH) -e main src/Test.hs+#	time a.out++main:+	$(HC) $(GHC_OPTIONS) -i:$(MODULE_PATH) --make Main.hs+	time a.out++ghci:+	$(HCINT) -Wall -odirdist/build -hidirdist/build -hide-package synthesizer -i:$(MODULE_PATH)++ghci-custom:+	$(HCINT) $(GHC_OPTIONS) -i:$(MODULE_PATH)++%.o:	%.hs+	$(HC) -i:$(MODULE_PATH) -O --make $<++%.o:	%.c+	gcc -c -o $@ $<
+ Setup.lhs view
@@ -0,0 +1,3 @@+#! /usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ doc/Prologue.txt view
@@ -0,0 +1,272 @@++This is a collection of modules for synthesizing and processing audio signals.+It allows generation of effects, instruments and+even music using the Haskore package.+It can write raw audio data to files,+convert them to common audio formats or+play them using external commands from the Sox package.++A signal is modeled by a list of values.+E.g. @[Double]@ represents a mono signal,+@[(Double, Double)]@ stores a stereo signal.+Since a list is lazy, it can be infinitely long,+and it also supports feedback.+(The drawback is, that its implementation is very slow.+I'm working on that issue.)+We are using the NumericPrelude type class hierarchy+which is cleaner than the one of Haskell 98+and provides us with type classes for vector spaces.+This allows us to formulate many algorithms for mono, stereo and multi-channel signals at once.+The drawback is that the vector space type class has multiple type parameters.+This type extension is availabe in GHC and Hugs and maybe other compilers.+It may hurt you, because type inference fails sometimes,+resulting in strange type errors.+(To be precise: GHC suggests type constraints intended for fixing the problem,+but if you copy them to your program, they won't fix the problem,+because the constraint refers to local variables+that you have no access to at the signature.+In this case you have to use 'asTypeOf' or similar self-written helpers.)++There must also be information about how fast sample values are emitted.+This is specified by the sample rate.+44100 Hz means that 44100 sample values are emitted per second.+This information must be stored along with the sample values.+This is where things become complicated.++In the very basic modules in the "Synthesizer.Plain" directory,+there is no notion of sample rate.+You have to base all computations on the number of samples.+This is unintuitive and disallows easy adaption to different audio devices+(CD, DAT, ...).+But it is very simple and can be re-used in the higher level modules.++Let's continue with the sample rate issue.+Sounds of different sources may differ in their sampling rate+(and also with respect to its amplitude and the unit of the values).+Sampled sounds have 44100 Hz on a compact disk,+48000 Hz or 32000 Hz on DAT recorders.+We want to respect different sampling rates and volumes,+we want to let signals in different formats coexist nicely,+and we want to let the user choose when to do which conversion+(called /resampling/)+in order to bring them together.++In fact this view generalises the concept of note, control, and audio rates,+which is found in some software synthesizers,+like CSound and SuperCollider.+If signals of different rate are fed to a signal processor+in such a software synthesizer,+all signals are converted to the highest rate among the inputs.+Then the processor runs at this rate.+The conversion is usually done by \"constant\" interpolation,+in order to minimize recomputation of internal parameters.+However the handling of different signal rates must be built into every processor,+and may even reduce the computation speed.+Consider an exponential envelope which is computed at control rate+and an amplifier which applies this envelope to an audio signal.+The amplifier has to upsample the exponential envelope before applying it to the signal.+But the generation of the exponential is very simple,+one multiplication per sample,+and the amplifier is very simple, too,+again only one multiplication per sample.+So, is there a need for trouble of the resampling?+Does it really accelerates computation?+Many other envelope generators like straight lines, sines, oscillators,+are comparably simple.+However there are some processors like filters,+which need some recomputation when a control parameter changes.++Our approach is this one:+We try to avoid resampling and compute all signals at the same rate,+if no speed loss must be expected.+If a speed loss is to be expected,+we can interpolate the internal parameters of the processor explicitly.+This way we can also specify an interpolation method.+Alternatively we can move the interpolation into the processor+but let the user specify an interpolation method.+(Currently it can be used only manually for the low-level routines in "Synthesizer.Plain"+and there is no support for that mechanism in the high level variants.)++Additional to the treatment of sampling rates,+we also want to separate amplitude information from the signal.+The separated amplitude serves two purposes:++(1) The amplitude can be equipped with a physical unit,+    whereas this information is omitted for the samples.+    Since I can hardly imagine that it is sensible to mix samples+    with different physical units,+    it would be only wasted time to always check+    if all physical values of a sequence have the same unit.++(2) The amplitude can be a floating point number,+    but the samples can be fixed point numbers.+    This is interesting for hardware digital signal processors+    or other low-level applications.+    With this method we can separate the overall dynamics from the samples.+++Let's elaborate on the physical units now.+With them we can work with values from the real world immediately+and we have additional (dynamic) safety by unit checks.++Of course I prefer static safety.+E.g. I want to avoid+to accidentally call a function with conflicting parameters.+However, I see no way for both applying the unit checks statically+and let the user enter physical quantities.+Phantom types or unit vectors stored in a type do not seem to help here.+We have two solutions:++(1) Store units in a data structure and check them dynamically.+    This is imported from NumericPreludes's "Number.Physical".+    Units can be fetched from the user.+    The API of signal processing functions is generic enough+    to cover both values without units and values with units.+    Debugging of unit errors is cumbersome.++(2) Store physical dimensions in types+    either using Buckwalter's dimensional package+    or using NumericPreludes's "Number.DimensionTerm".+    Here we use the latter one.+    This is the most useful if user interaction is not needed.+    If data is fetched from an audio file+    the dimensions are statically fixed.++There are still several alternatives+of how to handle the sample rates+(that can be equipped with physical dimensions).++(1) Stick to simple lists as data and+    pass additional information directly to the functions.+    E.g. mixing several signals is easy+    since only one sampleRate is given+    which applies to all signals.+    But it leads to the problem+    that subsequent function calls must receive the same value.+    This cannot be guaranteed and is thus a source of error.+    E.g. the mistake+       @play (44100*hertz) (osciSine (22050*hertz) (440*hertz))@+    can't be detected.+    In this approach the signal data structure is very simple,+    the values may be passed to multiple functions,+    the combinations are simply done by function application,+    a supervisor is not necessary,+    consistency checks can hardly be performed.+    This approach is certainly the most basic one,+    on which others, more safer ones, can sit on top.+    It is implemented in "Synthesizer.Plain" with numbers without units.++(2) Equip signals with sample rate and amplitude.+    Processors without input need the sample rate as explicit parameter.+    If there is more than one signal as input,+    then there must be additional checks.+    The error in+    @+       mix (osciSine (22050*hertz) (440*hertz))+           (osciSine (44100*hertz) (330*hertz))+    @+    can be detected at runtime.+    However the sample rate has to be specified for both input signals,+    although it is obvious, that both signals have to share the sample rate.+    In this approach the data structure is more complex,+    the values may be passed to multiple functions+    but consistency checks can be performed+    and a supervisor is still not necessary.+    This strategy is implemented in the "Synthesizer.Physical" modules.++(3) We still like to hide the sample rate where possible.+    All processors should work as good as possible at each rate.+    Here we provide the sample rate to each processor.+    The result of a processor is not just a list of samples+    but it is a function, which computes the list of samples+    depending on the sample rate.+    Sample rate is fixed not until it comes to the rendering of a sound,+    e.g. for playing or writing of a file.+       @play (44100*hertz) (osciSine (440*hertz))@+    Returning a function instead of computed data+    has the disadvantage that multiply used data cannot be shared.+    For these situations we need a @share@ function.+    Combinator functions similar to @($)@ are used+    to plug sample rate dependent output from one processor+    into plain signal parameters.+    With this approach, the type signature tells+    which signals share the sample rate.+    Infinitely many signals can be handled.+    Types for time and volume can be chosen quite freely.+    Supervision is not necessary.+    This strategy is implemented in the "Synthesizer.Inference.Reader" modules,+    where we hide the sample rate in a 'Control.Monad.Reader.Reader'.+    There is also "Synthesizer.SampleRateContext"+    which exposes the sample rate.+    It is more convenient to implement and to call,+    but I think it is more unsafe,+    because you can mix sample rates from different sources accidentally.+    The same is available for numbers with dimension terms in types.+    See "Synthesizer.Dimensional".+    /In most cases this will be the method of choice!/+    Maybe I'm going to wrap this in a Reader monad\/applicative functor.+    It also requires that Haddock supports comments in parameters of type constructors.++(4) I have tried more sophisticated approaches+    in order to handle not only the sample rates but also the amplitudes.+    However I feel that I wanted more than I actually needed.+    I do no longer maintain these approaches but explain them for completeness.+    The most convenient solution for handling sample rates and amplitudes+    is certainly an inference system like Haskell's type system.+    If some input and output signals of a processor+    must have the same sampling rate,+    then the concrete rate must only be known for one of these signals.+    If no participating signal has a fixed rate, this is an error.+    The dependencies of sampling rates become very large by this system.+    The direction can be from inputs to outputs and vice versa,+    not to mention loops.+    This approach needs a lot of management,+    e.g. a supervisor which runs the network,+    but it is very convenient and safe.+    However, sometimes you have to fiddle with monads.+    Unfortunately it is restricted to finitely many monads+    and the types for time and volume are restricted.+    Thus this concept does not scale to physical units expressed in types.+    This strategy is implemented in the modules under "Synthesizer.Inference.Monad".++(5) We try to work-around the restrictions+    using a function based approach.+    Since the parameters are functions,+    sharing cannot take place.+    There is no way to spread sample rate from one consumer to another one.+    E.g. If there is+    @+       let y = f x;+           z = g x+    @+    and it is known that @f@ and @g@ maintain the sample rate,+    and the sample rate of @z@ is known - how to infer the sample rate of @y@?+    This approach was dropped quickly and+    exists for historical reasons in "Synthesizer.Inference.Func".++(6) There is a very cool approach,+    which implements the equation solver of the monadic approach+    by lazy evaluation and Peano numbers.+    This poses no restriction on types+    and works for infinitely many equations as well.+    The drawbacks are difficult application+    (you cannot simply apply a function to a signal,+    but you must compose functions in a special way),+    and slow solution of the equation system+    (quadratic time although in principle+    only run-time around linear time is necessary,+    it's similar to topological sort).+    However it's as slow as the explicit solver using monads in "Synthesizer.Inference.Monad".+    This strategy is tested in the modules under "InferenceFix".+++An interface to the music composition library Haskore+can be found in "Haskore.Interface.Signal.Write".+Example songs based on this interface+are stored in the directory "Music".++The module "Presentation" in the @dafx@ package contains functions+for demonstrating synthesizer functions in GHCi+and "DAFx" contains some examples based on them.+Just hit @make dafx@ in a shell in order to compile the modules+and enter the interactive GHC with all modules loaded.
+ speedtest/FusionTest.hs view
@@ -0,0 +1,821 @@+{-# OPTIONS_GHC -O2 -fglasgow-exts #-}+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.Control as CtrlS+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.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 BinarySample (numToInt16Packed, doubleToInt16Packed)+import Data.Int (Int8, Int16)+import Foreign.Storable (Storable)+import qualified Sound.Signal as Signal+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 numToInt16Packed $+--   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 $+   -- numToInt16Packed is not only slow in execution but also blocks fusion - why?+   SigFL.map numToInt16Packed $+   (OsciFL.staticSaw zeroPhase 0.01 :: SigFL.T Double)++osciTest0a :: SigSt.T Int16+osciTest0a =+   storableFromFusionList $+   SigFL.take 200000 $+   SigFL.map doubleToInt16Packed $+   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 doubleToInt16Packed $+   FiltNRFL.envelope+      (CtrlFL.exponential2 50000 1)+      (OsciFL.staticSaw zeroPhase 0.01)++osciTest0ba :: SigSt.T Int16+osciTest0ba =+   storableFromFusionList $+   SigFL.take 200000 $+   SigFL.map doubleToInt16Packed $+   CtrlFL.exponential2 50000 1++osciTest0c :: SigSt.T Int16+osciTest0c =+   storableFromFusionList $+   SigFL.take 200000 $+   SigFL.map doubleToInt16Packed $+   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 doubleToInt16Packed $+   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 doubleToInt16Packed $+   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 doubleToInt16Packed $+      (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 doubleToInt16Packed $+   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 doubleToInt16Packed $+   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 numToInt16Packed $  -- 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 doubleToInt16Packed $+   (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 doubleToInt16Packed $+   (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 doubleToInt16Packed $+--   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 doubleToInt16Packed $+   (OsciSt.staticSaw defaultChunkSize zeroPhase 0.01 :: SigSt.T Double)+++appendTest0 :: SigSt.T Int16+appendTest0 =+   storableFromFusionList $+   SigFL.map doubleToInt16Packed $+      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 doubleToInt16Packed $+       SigFL.append tone0 tone1++appendTest2 :: SigSt.T Int16+appendTest2 =+   SigSt.map doubleToInt16Packed $+   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 doubleToInt16Packed $+   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 doubleToInt16Packed $+   SigSt.mixSize defaultChunkSize+      (SigSt.replicate defaultChunkSize 100000 NP.zero)+      (SigSt.replicate defaultChunkSize 100001 NP.one)++mixTest3 :: SigSt.T Int16+mixTest3 =+   SigSt.map doubleToInt16Packed $+   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 doubleToInt16Packed $+   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 doubleToInt16Packed $+   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 doubleToInt16Packed $+   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 doubleToInt16Packed $+   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 doubleToInt16Packed $+   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 doubleToInt16Packed $+   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 numToInt16Packed $+   (OsciS.static Wave.saw zeroPhase 0.01 :: SigS.T Double)++stateOsciTest0a :: SigSt.T Int16+stateOsciTest0a =+   SigS.toStorableSignal defaultChunkSize $+   SigS.take 200000 $+   SigS.map doubleToInt16Packed $+   OsciS.static Wave.saw zeroPhase 0.01++stateOsciTest0fa :: SigSt.T Int16+stateOsciTest0fa =+   SigS.toStorableSignal defaultChunkSize $+   SigS.take 200000 $+   SigS.map doubleToInt16Packed $+--   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 doubleToInt16Packed $+   SigS.map (0.2*) $+   chord++stateFilterTest :: SigSt.T Int16+stateFilterTest =+   SigS.toStorableSignal defaultChunkSize $+   SigS.take 200000 $+   SigS.map doubleToInt16Packed $+   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 doubleToInt16Packed $+      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 doubleToInt16Packed $+      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 doubleToInt16Packed $+      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 doubleToInt16Packed $+      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 doubleToInt16Packed $+      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 doubleToInt16Packed $+   SigSt.concat $+   take 13 $+   map storablePercTone $+   iterate (* 2^?(1/12)) 0.005++storableArrangeTest :: SigSt.T Int16+storableArrangeTest =+   SigSt.map doubleToInt16Packed $+   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 doubleToInt16Packed $+   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 doubleToInt16Packed $+   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 doubleToInt16Packed $+   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 doubleToInt16Packed $+   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 doubleToInt16Packed $+   SigS.take 440000 $+   stateBubbles++storableCombTest :: SigSt.T Int16+storableCombTest =+   SigSt.map doubleToInt16Packed $+   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 doubleToInt16Packed $+   OsciS.static Wave.saw zeroPhase 0.01+++stateNoiseTest :: SigSt.T Int16+stateNoiseTest =+   SigS.toStorableSignal defaultChunkSize $+   SigS.take 440000 $+   SigS.map doubleToInt16Packed $+   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 doubleToInt16Packed $+   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 doubleToInt16Packed $+   SigSt.map (0.5*) $+   (\noise ->+       SigSt.mix+          noise+--          (DelayG.modulated InterpolationG.linear (-500)+          (DelayG.modulated (InterpolationS.toGeneric InterpolationS.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 doubleToInt16Packed $+   DelayG.modulated InterpolationG.constant (-500)+      (SigSt.repeat defaultChunkSize (142::Double)) $+   SigSt.repeat defaultChunkSize (23::Double)+++phaserTest1 :: SigSt.T Int16+phaserTest1 =+   SigSt.take 440000 $+   SigSt.map doubleToInt16Packed $+--   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 NumericPrelude.Condition (toMaybe)+import NumericPrelude.List (sliceVert)++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 = sliceVert 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/BinarySample.hs view
@@ -0,0 +1,210 @@+{-# OPTIONS -fno-implicit-prelude #-}+module BinarySample+   (C(..),+    signalToBinary, signalToBinaryMono, signalToBinaryStereo,+    writeInt16Stream, readInt16Stream,+    writeLEInt16Stream, readLEInt16Stream,+    int16ToNum, putInt16Stream,+    numToInt16Packed, int16PackedToNum,+    floatToInt16Packed, doubleToInt16Packed,+    ) 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 qualified Algebra.Field     as Field+import qualified Algebra.RealField as RealField+import qualified Algebra.Ring      as Ring++import Synthesizer.Utility (clip)++import Data.Char(ord)++import GHC.Float (float2Int, double2Int)++import qualified Prelude as P98++import PreludeBase+import NumericPrelude+++++class C a where+   toInt16 :: a -> [Int]+   numChannels :: a -> Int++instance C Float where+--   toInt16 = (:[]) . numToInt16+   toInt16 x =+      [float2Int (if x<0+                    then scale16 x - 0.5+                    else scale16 x + 0.5)]+   numChannels _ = 1++instance C Double where+--   toInt16 = (:[]) . numToInt16+   toInt16 x =+      [double2Int (if x<0+                     then scale16 x - 0.5+                     else scale16 x + 0.5)]+   numChannels _ = 1++instance (C a, C b) => C (a,b) where+   toInt16 (x0,x1) = toInt16 x0 ++ toInt16 x1+   numChannels ~(x0,x1) = numChannels x0 + numChannels x1++++{-# INLINE scale16 #-}+scale16 :: (Ring.C a, Ord a) => a -> a+scale16 x = 32767 * clip (-1) 1 x++{-# INLINE numToInt16 #-}+numToInt16 :: (RealField.C a) => a -> Int+numToInt16 = round . scale16++{-# INLINE numToInt16Packed #-}+numToInt16Packed :: (RealField.C a) => a -> Int16+numToInt16Packed = P98.fromIntegral . numToInt16++{-# INLINE floatToInt16Packed #-}+floatToInt16Packed :: Float -> Int16+floatToInt16Packed = P98.fromIntegral . float2Int . scale16+++{-+{-# INLINE scale16Double #-}+scale16Double :: (Ring.C a, Ord a) => a -> a+scale16Double x = 32767 * clip (-1) 1 x+-}++{-# INLINE doubleToInt16Packed #-}+doubleToInt16Packed :: Double -> Int16+{- Why is scale16 not inlined here? See FusionTest.mixTest3+doubleToInt16Packed = P98.fromIntegral . double2Int . scale16+-}+-- doubleToInt16Packed = P98.fromIntegral . double2Int . scale16Double+-- doubleToInt16Packed x = P98.fromIntegral (double2Int (scale16 x))+doubleToInt16Packed = P98.fromIntegral . double2Int . (32767*) . clip (-1) 1++{-# INLINE int16ToNum #-}+int16ToNum :: (Field.C a) => Int -> a+int16ToNum x = fromIntegral x / 32768++{-# INLINE int16PackedToNum #-}+int16PackedToNum :: (Field.C a) => Int16 -> a+int16PackedToNum = int16ToNum . P98.fromIntegral++-- | little endian (Intel)+{-# INLINE int16ToLEChars #-}+int16ToLEChars :: Int -> [Char]+int16ToLEChars x =+   let (hi,lo) = divMod x 256+   in  [toEnum lo, toEnum (mod hi 256)]++-- | little endian (Intel)+{-# INLINE leCharsToInt16 #-}+leCharsToInt16 :: Char -> Char -> Int+leCharsToInt16 hi lo =+   let unsigned = ord lo + 256 * ord hi+   in  mod (unsigned + 32768) 65536 - 32768+++{-# INLINE signalToBinary #-}+signalToBinary :: (C v) => [v] -> [Int]+signalToBinary = concatMap toInt16++{-# INLINE signalToBinaryMono #-}+signalToBinaryMono :: (RealField.C a) => [a] -> [Int]+signalToBinaryMono = map numToInt16++{-# INLINE signalToBinaryStereo #-}+signalToBinaryStereo :: (RealField.C a) => [(a,a)] -> [Int]+signalToBinaryStereo =+   concatMap (\(l,r) -> [numToInt16 l, numToInt16 r])+++{-# INLINE binaryToIntsMono16 #-}+binaryToIntsMono16 :: [Char] -> [Int]+binaryToIntsMono16 sig =+   case sig of+      (lo:hi:xs) ->+         leCharsToInt16 hi lo : binaryToIntsMono16 xs+      (_:[]) ->+         error "binaryToIntsMono16: 16 bit sample files must have even length"+      [] -> []++++{- * I\/O -}++{- |+Write a little endian 16 bit integer stream+via String data and 'writeFile'.+-}+writeLEInt16Stream :: FilePath -> [Int] -> IO ()+writeLEInt16Stream fileName =+   writeFile fileName . concatMap int16ToLEChars++{- |+Uses endianess of the machine, like Sox does.+-}+writeInt16Stream :: FilePath -> [Int] -> IO ()+writeInt16Stream fileName stream =+   bracket (openBinaryFile fileName WriteMode) hClose+      (flip putInt16Stream stream)++putInt16Stream :: Handle -> [Int] -> IO ()+putInt16Stream h stream =+   alloca $+      \p -> mapM_ (putInt16 h p . P98.fromIntegral) 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 [Int]+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.+-}+readInt16Stream :: FilePath -> IO [Int]+readInt16Stream fileName =+   bracket (openBinaryFile fileName ReadMode) hClose+      getInt16Stream++{- |+In contrast to hGetContents this is strict!+-}+getInt16Stream :: Handle -> IO [Int]+getInt16Stream 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/Filter/Basic.hs view
@@ -0,0 +1,57 @@+{-# OPTIONS -fno-implicit-prelude -fglasgow-exts #-}+module 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/Filter/Composition.hs view
@@ -0,0 +1,146 @@+{-# OPTIONS -fglasgow-exts -fno-implicit-prelude -fallow-undecidable-instances #-}+module Filter.Composition where++import Filter.Basic (Filter,apply,transferFunction)++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 (Filter.Basic.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/Filter/Example.hs view
@@ -0,0 +1,241 @@+{-# OPTIONS -fno-implicit-prelude #-}+module Filter.Example where++import Filter.Basic+import qualified Filter.OneWay+import qualified Filter.TwoWay+import Filter.Composition+import qualified Filter.Graph+import qualified Synthesizer.Plain.Interpolation as Interpolation++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] -> Filter.Composition.T Filter.TwoWay.T Double a a+guitarCompShort past = Feedback (Prim (Filter.TwoWay.Past past)) (Parallel [+   Serial [Prim (Filter.TwoWay.Delay   1),+           Prim (Filter.TwoWay.Mask [0.6519177892575342, 0.2331904728998289])],+   Serial [Prim (Filter.TwoWay.Delay 126),+           Prim (Filter.TwoWay.Mask [0.08253506238277844,+               0.2369601607320473,   0.18367848836060044,+              -0.06422525077173147, -0.31836517142623727])]])+guitarCompLong past = Feedback (Prim (Filter.TwoWay.Past past)) (+   Serial [Prim (Filter.TwoWay.Delay 122),+           Prim (Filter.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 = Filter.TwoWay.future+              (Filter.TwoWay.delay (length gi)+                 (apply (guitarCompLong (reverse gi))+                        (Filter.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 = Filter.TwoWay.future+              (Filter.TwoWay.delay len+                 (apply (guitarCompLong wave)+                        (Filter.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 =+        Filter.Composition.T Filter.TwoWay.T Double Double Double++{-| a simple lowpass used to create an exponential2 -}+--expo :: (RealField.C a, Module.C a a) => Filter.TwoWay.Signal a+expo :: Filter.TwoWay.Signal Double+expo =+   let _flt1 = Feedback (Serial [Prim (Filter.OneWay.Delay ([0] `asTypeOf` past))])+                       (Serial [Prim (Filter.OneWay.Mask+                                        ([0.9] `asTypeOf` past))])+       _flt2 = (Prim (Filter.TwoWay.Mask ([0.5] `asTypeOf` past)))+                 :: CompositionDouble+       flt3 = (Feedback (Serial [])+                        (Prim (Filter.TwoWay.Delay 1)))+                 :: CompositionDouble+       Filter.TwoWay.Signal past future = apply flt3 (Filter.TwoWay.Signal [] [1])+   in  Filter.TwoWay.Signal past (take 10 future)++type GraphDouble f = Filter.Graph.T f Int Double Double Double++simpleGraph :: Filter.TwoWay.Signal Double+simpleGraph =+   let out =+          Filter.Graph.apply+             (Filter.Graph.fromList+                [(0, []),+                 (1, [(0, Filter.TwoWay.Delay (-1))]),+                 (2, [(1, Filter.TwoWay.Mask [0.95])])] ::+                    GraphDouble Filter.TwoWay.T)+             (Filter.Graph.signalFromList+                [(0, Filter.TwoWay.Signal [] [1])])+   in  fromMaybe (error "requested output of non-existing socket")+                 (Filter.Graph.lookupSignal out (2::Int))++expoGraphTwoWay :: [Double]+expoGraphTwoWay =+   let out =+          Filter.Graph.apply+             (Filter.Graph.fromList+                [(0, [(2, Filter.TwoWay.Past [1])]),+                 (1, [(0, Filter.TwoWay.Delay 1)]),+                 (2, [(1, Filter.TwoWay.Mask [0.95])])] ::+                    GraphDouble Filter.TwoWay.T)+             (Filter.Graph.signalFromList+                [(0, Filter.TwoWay.Signal [] [])])+   in  Filter.TwoWay.take 20 $ Filter.TwoWay.delay 10+          (fromMaybe (error "requested output of non-existing socket")+             (Filter.Graph.lookupSignal out (0::Int)))+++expoGraph :: [Double]+expoGraph =+   let out =+          Filter.Graph.apply+             (Filter.Graph.fromList+                [(0, [(1, Filter.OneWay.Delay [0])]),+                 (1, [(0, Filter.OneWay.Mask [0.99])])] ::+                    GraphDouble Filter.OneWay.T)+             (Filter.Graph.signalFromList+                [(0, [1])])+   in  fromMaybe (error "requested output of non-existing socket")+                 (Filter.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 (Filter.TwoWay.Mask [vol]))+                (Serial [Prim (Filter.TwoWay.Mask [gain]),+                         Prim (Filter.TwoWay.Past []),+                         Prim (Filter.TwoWay.ModFracDelay+                                  Interpolation.linear +                                     (Filter.TwoWay.Signal [] control))])+                :: CompositionDouble++   in  Filter.TwoWay.future+          (apply flt (Filter.TwoWay.Signal sawPast sawFuture))
+ src/Filter/Fix.hs view
@@ -0,0 +1,38 @@+module Filter.Fix where++import qualified 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/Filter/Graph.hs view
@@ -0,0 +1,178 @@+{-# OPTIONS -fglasgow-exts -fallow-undecidable-instances -fno-implicit-prelude #-}+module Filter.Graph where++import qualified Prelude as P+import PreludeBase+import NumericPrelude++import Filter.Basic(Filter,apply,transferFunction)+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) ->+                   Filter.Basic.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 -> Filter.Basic.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/Filter/Graphic.hs view
@@ -0,0 +1,7 @@+module Filter.Graphic where++{-|+  This module should be populated with functions+  that create flowchart graphics from the filter networks+  of the 'Composition' module.+-}
+ src/Filter/MonadFix.hs view
@@ -0,0 +1,43 @@+module Filter.MonadFix where++import qualified Filter.Graph as Graph+import qualified Filter.Fix   as FFix++import Filter.Fix (Channel(Channel), ChannelId)++import Control.Monad.State (StateT, evalStateT, get, modify, lift)+import Control.Monad.Writer (Writer, execWriter, tell)+++{-|+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/Filter/OneWay.hs view
@@ -0,0 +1,74 @@+{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}+module Filter.OneWay where++import 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/Filter/TwoWay.hs view
@@ -0,0 +1,245 @@+{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}+module Filter.TwoWay where++import Filter.Basic++import Synthesizer.Plain.Interpolation (minLength,)+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 Synthesizer.Utility(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 && minLength (1+Ip.number ip) xFuture+    then interpolateHalfWay ip (phase-1) freqs+            (Signal (head xFuture : xPast) (tail xFuture))+    else if phase < 0 && minLength 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/FourierSeries.hs view
@@ -0,0 +1,15 @@+module FourierSeries where++evalL :: Floating a => [(a,a)] -> a -> a+evalL [] _ = 0+evalL ((c,_):cs) t =+   c/2 + sum (zipWith (\(r,i) tk -> r * cos tk + i * sin tk)+                      cs (iterate (t+) t))++evalSineL, evalCosineL :: Floating a => [a] -> a -> a+evalSineL       [] _ = 0+evalSineL   (_:cs) t =+         sum (zipWith (*) cs (map sin (iterate (t+) t)))+evalCosineL     [] _ = 0+evalCosineL (c:cs) t =+   c/2 + sum (zipWith (*) cs (map cos (iterate (t+) t)))
+ src/OsciDiffEq.hs view
@@ -0,0 +1,75 @@+module OsciDiffEq where++{-+ghci -fglasgow-exts -fno-implicit-prelude ../numericprelude/MyPrelude.hs ../numericprelude/NumExtras.lhs ../numericprelude/VectorSpace.lhs ../numericprelude/PreludeBase.lhs ../numericprelude/NumericPrelude.lhs OsciDiffEq.hs++import MyPrelude+but then (+) ends up in a loop Exception :-(+-}++import Number.Complex((+:),phase)++infixl 6 .++infixr 7 *>++integrate :: Num a => a -> [a] -> [a]+integrate = scanl (+)++(.+) :: Num a => [a] -> [a] -> [a]+(.+) = zipWith (+)++(*>) :: Num a => a -> [a] -> [a]+(*>) v = map (v*)++wave :: Num a => (a,a) -> (a,a) -> [a]+wave (k0,c0) (k1,c1) =+   let y'  = integrate c1 y''+       y   = integrate c0 y'+       y'' = map negate (k0 *> y  .+  k1 *> y')+   in  y++waveExample :: [Double]+waveExample = wave (0.07, 1) (0.08, 0)+++waveSqr :: Num a => (a,a,a) -> (a,a) -> (a,a) -> [a]+waveSqr (a00,a01,a11) (k0,c0) (k1,c1) =+   let mul = zipWith (*)+       y'  = integrate c1 y''+       y   = integrate c0 y'+       y'' = map negate (foldl1 (.+)+               (zipWith (*>) [k0, k1, a00, a01, a11]+                             [y, y', mul y y, mul y y', mul y' y']))+   in  y++{- the square term destabilizes the solution -}+waveSqrExample :: [Double]+waveSqrExample = waveSqr (0.04,0,0) (0.07, 1) (0.08, 0)+++waveSin :: Floating a => (a,a) -> (a,a) -> (a,a) -> [a]+waveSin (a0,a1) (k0,c0) (k1,c1) =+   let y'  = integrate c1 y''+       y   = integrate c0 y'+       y'' = map negate (foldl1 (.+)+               (zipWith (*>) [k0, k1, a0, a1]+                             [y, y', map sin y, map sin y']))+   in  y++{- the square term destabilizes the solution -}+waveSinExample :: [Double]+waveSinExample = waveSin (0.1,0) (0.07, 10) (0.08, 0)+++wavePhase :: RealFloat a => a -> (a,a) -> (a,a) -> [a]+wavePhase (a0) (k0,c0) (k1,c1) =+   let y'  = integrate c1 y''+       y   = integrate c0 y'+       y'' = map negate (foldl1 (.+)+               (zipWith (*>) [k0, k1, a0]+                             [y, y', zipWith (\r i -> phase (r +: i)) y y']))+   in  y++{- the square term destabilizes the solution -}+wavePhaseExample :: [Double]+wavePhaseExample = wavePhase (0.005) (0.07, 1) (0.08, 0)
+ src/Sound/Signal.hs view
@@ -0,0 +1,231 @@+{-# OPTIONS_GHC -O -fglasgow-exts #-}+{- glasgow-exts are for the rules -}+module Sound.Signal where++import Synthesizer.Utility (viewListL)+import NumericPrelude.Condition (toMaybe)+import Prelude hiding+   ((++), iterate, foldl, map, repeat, replicate,+    zipWith, zipWith3, take, takeWhile)++{-+Signals can be lazy, but not necessarily element-wise lazy.+All values of signals must be defined.++In future it may re-use functionality+from "Data.Foldable" and "Data.Traversable".++Functions with accumulators always have a 'Maybe' result,+in order to be able to fuse them.+-}+class C s where+   singleton :: a -> s a+   unfoldR   :: (acc -> Maybe (y, acc)) -> acc -> (acc, s y)+   reduceL   :: (x -> acc -> Maybe acc) -> acc -> s x -> acc+   mapAccumL :: (x -> acc -> Maybe (y, acc)) -> acc -> s x -> (acc, s y)+   (++)      :: s a -> s a -> s a+   zipWith   :: (a -> b -> c) -> s a -> s b -> s c+++{-+Typical examples for neither generate nor crochet:+   data from disk+   toList (this is a foldR)+   reverse+   drop+   resample+   Fourier transform+   (++) (it could be fused,+         but the fused variant needs checking a phase state each cycle+         which is certainly less efficient than separate loops)+-}++{-+Typical examples for zipWith:+   mixer+   controlled recursive filter+-}++{-+Typical examples for foldL:+   volume computation+   DC offset+   histogram+-}+++{-+'generate' could be expressed as 'crochetL' on an empty signal (type @s ()@).+This would reduce the number of rules,+but at the end of optimization+there shouldn't be such 'crochetL's left that can represented as 'generate',+because 'generate' is more efficient.++Typical examples for generate:+   fromList+   uncontrolled oscillator+   constant curve+   linear curve+   exponential curve+   noise generation+-}+generate :: C s => (acc -> Maybe (y, acc)) -> acc -> s y+generate f = snd . unfoldR f++{-# INLINE fromList #-}+fromList :: C s => [y] -> s y+fromList = generate viewListL+++{-# INLINE iterate #-}+iterate :: C s => (a -> a) -> a -> s a+iterate f = generate (\x -> Just (x, f x))++{-# INLINE repeat #-}+repeat :: C s => a -> s a+repeat = iterate id++cycle :: C s => s a -> s a+cycle x =+   let result = x ++ result+   in  result+++{-# INLINE foldL' #-}+foldL' :: C s => (x -> acc -> acc) -> acc -> s x -> acc+foldL' f = reduceL (\x -> Just . f x)++{-# INLINE lengthSlow #-}+{- | can be used to check against native length implementation -}+lengthSlow :: C s => s a -> Int+lengthSlow = foldL' (const succ) 0++recurse :: (acc -> Maybe acc) -> acc -> acc+recurse f =+   let aux x = maybe x aux (f x)+   in  aux++{-+Typical examples for crochetL:+   controlled oscillator+   enveloping+   uncontrolled recursive filter+   small delay+   take+-}+crochetL :: C s => (x -> acc -> Maybe (y, acc)) -> acc -> s x -> s y+crochetL f a = snd . mapAccumL f a++{-# INLINE scanL #-}+scanL :: C s => (x -> acc -> acc) -> acc -> s x -> s acc+scanL f start xs =+   singleton start +++   crochetL (\x acc -> let y = f x acc in Just (y, y)) start xs++{-# INLINE map #-}+map :: C s => (a -> b) -> (s a -> s b)+map f = crochetL (\x _ -> Just (f x, ())) ()++unzip :: C s => s (a,b) -> (s a, s b)+unzip x = (map fst x, map snd x)++{-# 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 :: C s => a -> s a -> s a+delay1 = crochetL (flip (curry Just))++{-# INLINE take #-}+take :: C s => Int -> s a -> s a+take = crochetL (\x n -> toMaybe (n>0) (x, pred n))++{-# INLINE takeWhile #-}+takeWhile :: C s => (a -> Bool) -> s a -> s a+takeWhile p = crochetL (\x _ -> toMaybe (p x) (x, ())) ()++{-# INLINE replicate #-}+replicate :: C s => Int -> a -> s a+replicate n = take n . repeat+++{-# INLINE zipWith3 #-}+zipWith3 :: C s => (a -> b -> c -> d) -> (s a -> s b -> s c -> s d)+zipWith3 f s0 s1 =+   zipWith (uncurry f) (zipWith (,) s0 s1)++{-# INLINE zipWith4 #-}+zipWith4 :: C s => (a -> b -> c -> d -> e) -> (s a -> s b -> s c -> s d -> s e)+zipWith4 f s0 s1 =+   zipWith3 (uncurry f) (zipWith (,) s0 s1)+++{-+The rules+ "zipWith/*,generate" and+ "zipWith/*,crochetL"+may generate infinite loops because GHC is free+to choose "zipWith/generate,*" or "zipWith/*,generate".+If it always chooses the latter one, it will loop forever.+-}++{-# RULES+  "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+               return (z0, (a1,b1))) (a,b) ;++  "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+               return (z0, (a1,b1))) (a,b) x ;+++  "zipWith/generate,*" forall f h a y.+     zipWith h (generate f a) y =+        crochetL (\y0 a0 ->+            do (x0,a1) <- f a0+               return (h x0 y0, a1)) a y ;++  "zipWith/crochetL,*" forall f h a x y.+     zipWith h (crochetL f a x) y =+        crochetL (\(x0,y0) a0 ->+            do (z0,a1) <- f x0 a0+               return (h z0 y0, a1))+           a (zipWith (,) x y) ;++  "zipWith/*,generate" forall f h a y.+     zipWith h y (generate f a) =+        zipWith (flip h) (generate f a) y ;++  "zipWith/*,crochetL" forall f h a x y.+     zipWith h y (crochetL f a x) =+        zipWith (flip h) (crochetL f a x) y ;++  "zipWith/double" forall (h :: a->a->b) (x :: s a).+     zipWith h x x = map (\xi -> h xi xi) x ;+++  "reduceL/generate" forall f g a b.+     reduceL g b (generate f a) =+        snd+          (recurse (\(a0,b0) ->+              do (y,a1) <- f a0+                 b1 <- g y b0+                 return (a1, b1)) (a,b)) ;++  "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+                 return (a1, b1)) (a,b) x) ;+  #-}
+ src/Sound/Signal/Block.hs view
@@ -0,0 +1,143 @@+module Sound.Signal.Block where++import Data.Array (Array, (!), listArray)++import qualified Sound.Signal as Signal+import qualified Synthesizer.Plain.Signal as ListSignal++import qualified Data.List as List++import NumericPrelude.Condition (toMaybe)+import Prelude hiding ((++), iterate, foldl, zipWith, tail, head)+++instance Signal.C T where+   singleton = singleton+   unfoldR   = unfoldR defaultChunkSize+   reduceL   = reduceL+   mapAccumL = mapAccumL defaultChunkSize+   (++)      = append+   zipWith   = zipWith defaultChunkSize+++type ChunkSize = Int++defaultChunkSize :: ChunkSize+defaultChunkSize = 256++newtype T a = Cons {+   chunks :: [Chunk a]+  }+   deriving (Show)++{- |+The array starts with index 0.+We always consider a subarray of 'body'+starting at 'offset' with size 'size'.+This way we safe copy operations+and we can efficiently 'drop', 'take' and 'append' chunk lists.+Unfortunately, 'Data.Array' does not provide subarrays with sharing.+Every chunk must have at least size 1.+-}+data Chunk a = Chunk {+   offset :: Int,+   size   :: ChunkSize,+   body   :: Array Int a+  }+   deriving (Show)+++singleton :: a -> T a+singleton x = Cons [Chunk 0 1 (listArray (0,0) [x])]++isEmpty :: T a -> Bool+isEmpty (Cons x) = null x++head :: T a -> a+head (Cons xt) =+   case xt of+      [] -> error "Signal.Block.head: empty list"+      (Chunk start _ arr : _) -> arr ! start++tail :: T a -> T a+tail (Cons xt) =+   case xt of+      [] -> error "Signal.Block.tail: empty list"+      (Chunk start sz arr : xs) -> Cons+          (if sz>1+             then Chunk (succ start) (pred sz) arr : xs+             else xs)++tails :: T a -> [T a]+tails =+   List.unfoldr+      (\x -> toMaybe (not (isEmpty x))+         (let tailX = tail x in (tailX,tailX)))++toList :: T a -> [a]+toList =+   List.concatMap+      (\(Chunk start sz arr) ->+           take sz (map (arr!) [start..])) . chunks++toListAlt :: T a -> [a]+toListAlt = List.init . map head . tails++fromList :: ChunkSize -> [a] -> T a+fromList chunkSize =+   let recurse [] = []+       recurse xs =+          let actSize = minLength chunkSize xs+          in  Chunk 0 actSize (listArray (0,actSize-1) xs) :+                if actSize < chunkSize+                  then []+                  else recurse (drop chunkSize xs)+   in  Cons . recurse++{-+@minLength n x = min n (length x)@,+but 'minLength' is more lazy than 'length'.+-}+minLength :: Int -> [a] -> Int+minLength =+   let recurse seenSoFar expected xt =+          case xt of+             [] -> seenSoFar+             (_:xs) ->+                 if expected == 0+                   then seenSoFar+                   else recurse (succ seenSoFar) (pred expected) xs+   in  recurse 0++{-+poor man's implementation via lists+I do not know which array function could be of help here.+-}+unfoldR :: ChunkSize -> (acc -> Maybe (y, acc)) -> acc -> (acc, T y)+unfoldR chunkSize f acc =+   let (accEnd, xs) = ListSignal.unfoldR f acc+   in  (accEnd, fromList chunkSize xs)++reduceL :: (a -> acc -> Maybe acc) -> acc -> T a -> acc+reduceL f start =+   ListSignal.reduceL f start . toList+{- when running on array separately it would be complicated+to distinguish between termination because the signal is finished+and because the abort condition is fulfilled. -}+--   List.foldl' (\acc -> List.reduceL f acc . elems) start . toChunkList+++mapAccumL :: ChunkSize ->+   (x -> acc -> Maybe (y, acc)) -> acc -> T x -> (acc, T y)+mapAccumL chunkSize f accStart xs =+   let (accEnd, ys) = ListSignal.mapAccumL f accStart (toList xs)+   in  (accEnd, fromList chunkSize ys)+++append :: T a -> T a -> T a+append (Cons x) (Cons y) = Cons (x List.++ y)++zipWith :: ChunkSize -> (a -> b -> c) -> (T a -> T b -> T c)+zipWith chunkSize f x y =+   fromList chunkSize $+   List.zipWith f (toList x) (toList y)
+ src/Sound/Signal/StrictBlock.hs view
@@ -0,0 +1,54 @@+{-# OPTIONS -fglasgow-exts #-}+{- |+Needs generalized instances for IArray.+-}+module Sound.Signal.StrictBlock where++import Data.Array.Unboxed (UArray)+import Data.Array.IArray (IArray, ixmap, bounds, elems, listArray)++-- import qualified Sound.Signal as Signal++import qualified Data.List as List++import Prelude hiding ((++), iterate, foldl)+++{-+instance Signal.C T where+   singleton x = Cons 0 [x]+--   unfoldr f = List.unfoldr (Just . f)+--   foldl'    = List.foldl'+   (Cons k x) ++ y = Cons k (x List.++ toChunkList y)+--   mapAccumL = List.mapAccumL+-}+++data T a = Cons {+   offset :: Int,+   chunks :: [UArray Int a]+   }++toChunkList :: (IArray UArray a) => T a -> [UArray Int a]+toChunkList (Cons k (x:xs)) =+   ixmap (let (0,n) = bounds x in (0,n-k)) (k+) x+      : xs+toChunkList (Cons 0 []) = []+toChunkList _ =+   error "Sound.Signal.Block: invalid empty structure"++singleton :: (IArray UArray a) => a -> T a+singleton x = Cons 0 [listArray (0,0) [x]]++-- unfoldr :: (a -> (b,a)) -> a -> T b+--   unfoldr f = List.unfoldr (Just . f)++foldl' :: (IArray UArray a) => (acc -> a -> acc) -> acc -> T a -> acc+foldl' f start =+   List.foldl' (\acc -> List.foldl' f acc . elems) start . toChunkList++(++) :: (IArray UArray a) => T a -> T a -> T a+(Cons k x) ++ y = Cons k (x List.++ toChunkList y)++-- mapAccumL :: (acc -> x -> (acc, y)) -> acc -> T x -> (acc, T y)+-- mapAccumL = List.mapAccumL
+ src/Sox.hs view
@@ -0,0 +1,16 @@+module Sox where++import qualified Algebra.RealField as RealField+++channelOption :: Int -> [String]+channelOption n =+   ["-c", show n]+{-+   if n == 1+     then []+     else ["-c", show n]+-}++sampleRateOption :: (RealField.C a) => a -> [String]+sampleRateOption r = ["-r", show (RealField.round r :: Int)]
+ src/Sox/File.hs view
@@ -0,0 +1,101 @@+{-# OPTIONS -fno-implicit-prelude #-}+module Sox.File where++import qualified BinarySample as BinSmp+import qualified Sox          as Sox++import System.Cmd(rawSystem)+import System.Exit(ExitCode)+import Data.List(isSuffixOf)++import qualified Algebra.RealField          as RealField+import qualified Algebra.Field              as Field++import PreludeBase+import NumericPrelude+++render :: (RealField.C a, BinSmp.C v) =>+   FilePath -> a -> (a -> [v]) -> IO ExitCode+render fileName sampleRate renderer =+   write fileName sampleRate (renderer sampleRate)++renderMono :: (RealField.C a) =>+   FilePath -> a -> (a -> [a]) -> IO ExitCode+renderMono fileName sampleRate renderer =+   writeMono fileName sampleRate (renderer sampleRate)++renderStereo :: (RealField.C a) =>+   FilePath -> a -> (a -> [(a,a)]) -> IO ExitCode+renderStereo fileName sampleRate renderer =+   writeStereo fileName sampleRate (renderer sampleRate)+++write :: (RealField.C a, BinSmp.C v) =>+   FilePath -> a -> [v] -> IO ExitCode+write fileName sampleRate signal =+   writeSignalRaw fileName [] sampleRate+      (BinSmp.numChannels (head signal))+      (BinSmp.signalToBinary signal)++writeMono :: (RealField.C a) =>+   FilePath -> a -> [a] -> IO ExitCode+writeMono fileName sampleRate signal =+   writeSignalRaw fileName []+      sampleRate 1 (BinSmp.signalToBinaryMono signal)++writeStereo :: (RealField.C a) =>+   FilePath -> a -> [(a,a)] -> IO ExitCode+writeStereo fileName sampleRate signal =+   writeSignalRaw fileName []+      sampleRate 2 (BinSmp.signalToBinaryStereo signal)+++writeSignalRaw :: (RealField.C a) =>+   FilePath -> [String] -> a -> Int -> [Int] -> IO ExitCode+writeSignalRaw fileName soxOptions sampleRate numChannels stream =+   let fileNameRaw  = fileName ++ ".sw"+   in  do BinSmp.writeInt16Stream fileNameRaw stream+          rawToAIFF fileName soxOptions sampleRate numChannels+          encode fileName++rawToAIFF :: (RealField.C a) =>+   FilePath -> [String] -> a -> Int -> IO ExitCode+rawToAIFF fileName soxOptions sampleRate numChannels =+   let fileNameRaw  = fileName ++ ".sw"+       fileNameAIFF = fileName ++ ".aiff"+   in  rawSystem "sox"+          (soxOptions +++           Sox.sampleRateOption sampleRate +++           Sox.channelOption numChannels +++           [fileNameRaw, fileNameAIFF])++encode :: FilePath -> IO ExitCode+encode fileName =+     let fileNameAIFF = fileName ++ ".aiff"+         --fileNameOGG  = fileName ++ ".ogg"+         fileNameMP3  = fileName ++ ".mp3"+     in do rawSystem "oggenc" ["--quality", "5", fileNameAIFF]+           rawSystem "lame"   ["-h", fileNameAIFF, fileNameMP3]+++{- 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 =+   let stem = if isSuffixOf ".aiff" file+                then take (length file - 5) file+                else file+       tmp  = stem ++ ".sw"+   in  do --putStrLn ("sox "++file++" "++tmp)+          rawSystem "sox" [file, tmp]+          fmap (map BinSmp.int16ToNum) (BinSmp.readInt16Stream tmp)
+ src/Sox/Play.hs view
@@ -0,0 +1,95 @@+{-# OPTIONS -fno-implicit-prelude #-}+module Sox.Play where++import qualified BinarySample as BinSmp+import qualified Sox          as Sox++import System.IO(IO)+import qualified System.IO as IO++import qualified System.Process as Proc+import Control.Exception(bracket)++{-+import qualified Shell+-}+import qualified System.Posix.Signals as Signals++import qualified Algebra.RealField      as RealField++import PreludeBase+import NumericPrelude+++autoR :: (RealField.C a, BinSmp.C v) => a -> (a -> [v]) -> IO ()+autoR sampleRate renderer =+   auto sampleRate (renderer sampleRate)++monoR :: (RealField.C a) => a -> (a -> [a]) -> IO ()+monoR sampleRate renderer =+   mono sampleRate (renderer sampleRate)++stereoR :: (RealField.C a) => a -> (a -> [(a,a)]) -> IO ()+stereoR sampleRate renderer =+   stereo sampleRate (renderer sampleRate)+++auto :: (RealField.C a, BinSmp.C v) => a -> [v] -> IO ()+auto sampleRate signal =+   raw [] sampleRate (BinSmp.numChannels (head signal))+      (BinSmp.signalToBinary signal)++mono :: (RealField.C a) => a -> [a] -> IO ()+mono sampleRate signal =+   raw [] sampleRate 1 (BinSmp.signalToBinaryMono signal)++stereo :: (RealField.C a) => a -> [(a,a)] -> IO ()+stereo sampleRate signal =+   raw [] sampleRate 2 (BinSmp.signalToBinaryStereo signal)++{- |+Disable sigPIPE.+This means that the whole program won't crash when the tool exits.+Unfortunately there doesn't seem to be another way of doing this.++If we don't call this, GHCi quits,+when the playing command is aborted with CTRL-C.+-}+catchCtrlC :: IO Signals.Handler+catchCtrlC =+      Signals.installHandler Signals.sigPIPE +		  Signals.Ignore Nothing++{-+raw :: Show a => [String] -> a -> [Int] -> IO ()+raw args sampleRate stream =+   do catchCtrlC+      (input,_,_) <- Shell.launch "play"+          (["auto"] ++ Sox.sampleRateOption sampleRate +++           ["-t","sw","-"] ++ args)+      BinSmp.putInt16Stream input stream+      IO.hClose input+-}++{- |+This routine is probably portable+if there were not the CTRL-C problem.+-}+raw :: (RealField.C a) => [String] -> a -> Int -> [Int] -> IO ()+raw args sampleRate numChannels stream =+   bracket+      (Proc.runInteractiveProcess "play"+          (Sox.channelOption numChannels +++           Sox.sampleRateOption sampleRate +++           ["-t","sw","-"] ++ args)+          Nothing Nothing)+      (\(input,output,err,proc) -> do+          mapM IO.hClose [input, output, err]+          -- wait for end of replay+          Proc.waitForProcess proc)+      (\(input,_,_,_) ->+         catchCtrlC >>+         BinSmp.putInt16Stream input stream)++example :: IO ()+example = auto (11025::Double) (map sin [0::Double,0.1..])
+ src/StorableInstance.hs view
@@ -0,0 +1,78 @@+{-+This should be in the standard library.+-}+module StorableInstance where++import Foreign.Storable (Storable (..), )+import Foreign.Ptr (castPtr, )+import qualified Number.Complex as Complex+import qualified Number.Ratio   as Ratio+import qualified Algebra.PrincipalIdealDomain as PID+++roundUp :: Int -> Int -> Int+roundUp m x = x + mod (-x) m++-- is handling of alignment correct?+instance (Storable a, Storable b) => Storable (a,b) where+   sizeOf ~(a,b) =+      roundUp (alignment b) (sizeOf a) + sizeOf b+   alignment ~(a,b) = gcd (alignment a) (alignment b)+{- doesn't work - no monomorphism+   peek ptr =+      do a <- peekByteOff ptr 0+         let bu = undefined+         b <- peekByteOff ptr (roundUp (alignment bu) (sizeOf a))+         return (a, asTypeOf b bu)+-}+   peek ptr =+      do a <- peekByteOff ptr 0+         let peekSecond :: Storable b => b -> IO b+             peekSecond bu =+                peekByteOff ptr (roundUp (alignment bu) (sizeOf a))+         b <- peekSecond undefined+         return (a, b)+   poke ptr (a,b) =+      pokeByteOff ptr 0 a >>+      pokeByteOff ptr (roundUp (alignment b) (sizeOf a)) b+++instance (Storable a, Storable b, Storable c) => Storable (a,b,c) where+   sizeOf    = sizeOf    . tripleToPair+   alignment = alignment . tripleToPair+   peek ptr = fmap (\ ~(~(a,b),c) -> (a,b,c)) (peek (castPtr ptr))+   poke ptr = poke (castPtr ptr) . tripleToPair++tripleToPair :: (a,b,c) -> ((a,b),c)+tripleToPair ~(a,b,c) = ((a,b),c)++instance (Storable a) => Storable (Complex.T a) where+   sizeOf    = sizeOf    . complexToPair+   alignment = alignment . complexToPair+   peek ptr = fmap (uncurry (Complex.+:)) (peek (castPtr ptr))+   poke ptr = poke (castPtr ptr) . complexToPair++complexToPair :: Complex.T a -> (a,a)+complexToPair a = (Complex.real a, Complex.imag a)++instance (Storable a, PID.C a) => Storable (Ratio.T a) where+   sizeOf    = sizeOf    . ratioToPair+   alignment = alignment . ratioToPair+   peek ptr = fmap (uncurry (Ratio.%)) (peek (castPtr ptr))+   poke ptr = poke (castPtr ptr) . ratioToPair++ratioToPair :: Ratio.T a -> (a,a)+ratioToPair x = (Ratio.numerator x, Ratio.denominator x)+++{-+{- Why is this allowed? -}+test :: Char+test = const 'a' undefined++{- Why is type defaulting applied here? The type of 'c' should be fixed. -}+test1 :: (Integral a, RealField.C a) => a+test1 =+   let c = undefined+   in  asTypeOf (round c) c+-}
+ src/Synthesizer/Amplitude/Control.hs view
@@ -0,0 +1,88 @@+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes+++Control curves which can be used+as envelopes, for controlling filter parameters and so on.+-}+module Synthesizer.Amplitude.Control+   ({- * Primitives -}+    constant, constantVector,+    {- * Preparation -}+    mapLinear, mapExponential,+   ) where++import qualified Synthesizer.Plain.Control as Ctrl++import qualified Synthesizer.Amplitude.Signal as SigV+import Synthesizer.Amplitude.Signal (toAmplitudeScalar)++import qualified Algebra.OccasionallyScalar as OccScalar+import qualified Algebra.Module             as Module+import qualified Algebra.Transcendental     as Trans+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 PreludeBase as P+import Prelude ()+++constant :: (Field.C y', Real.C y', OccScalar.C y y') =>+      y' {-^ value -}+   -> SigV.T y y' y+constant y =+   constantVector (abs y) (OccScalar.toScalar (signum y))++{- |+The amplitude must be positive!+This is not checked.+-}+constantVector :: -- (Field.C y', Real.C y', OccScalar.C y y') =>+      y' {-^ amplitude -}+   -> yv {-^ value -}+   -> SigV.T y y' yv+constantVector y yv =+   SigV.Cons y (Ctrl.constant yv)+++{- |+Map a control curve without amplitude unit+by a linear (affine) function with a unit.+-}+mapLinear :: (Ring.C y, Field.C y', Real.C y', OccScalar.C y y') =>+      y'  {- ^ range: one is mapped to @center+range@ -}+   -> y'  {- ^ center: zero is mapped to @center@ -}+   -> SigV.T y y' y+   -> SigV.T y y' y+mapLinear range center (SigV.Cons amp ss) =+   let absRange  = abs range * amp+       absCenter = abs center+       rng = toAmplitudeScalar z absRange+       cnt = toAmplitudeScalar z absCenter+       z = SigV.Cons+              (absRange + absCenter)+              (map (\y -> cnt + rng*y) ss)+   in  z+-- SynI.mapScalar 1 (absRange + absCenter) (\y -> cnt + rng*y) x++{- |+Map a control curve without amplitude unit+exponentially to one with a unit.+-}+mapExponential :: (Field.C y', Trans.C y, Module.C y y') =>+      y   {- ^ range: one is mapped to @center*range@, must be positive -}+   -> y'  {- ^ center: zero is mapped to @center@ -}+   -> SigV.T y y  y+   -> SigV.T y y' y+mapExponential range center (SigV.Cons amp ss) =+   let b = range**amp+   in  SigV.Cons (b*>center) (map (\x -> b**(x-one)) ss)+-- SynI.mapScalar 1 center (range**)
+ src/Synthesizer/Amplitude/Cut.hs view
@@ -0,0 +1,156 @@+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes+-}+module Synthesizer.Amplitude.Cut (+   {- * dissection -}+   unzip,+   unzip3,++   {- * glueing -}+   concat,   concatVolume,+   append,   appendVolume,+   zip,      zipVolume,+   zip3,     zip3Volume,+  ) where++import qualified Synthesizer.Amplitude.Signal as SigV+import Synthesizer.Amplitude.Signal (toAmplitudeScalar)++-- import qualified Algebra.NormedSpace.Maximum as NormedMax+import qualified Algebra.OccasionallyScalar  as OccScalar+import qualified Algebra.Module              as Module+import qualified Algebra.Field               as Field+-- import qualified Algebra.Ring                as Ring++import qualified Data.List as List++import PreludeBase (Ord, max, map)+-- import NumericPrelude+import Prelude ()+++{- * dissection -}++unzip ::+   SigV.T y y' (yv0, yv1) ->+   (SigV.T y y' yv0, SigV.T y y' yv1)+unzip x =+   let (ss0,ss1) = List.unzip (SigV.samples x)+   in  (SigV.replaceSamples ss0 x, SigV.replaceSamples ss1 x)++unzip3 ::+   SigV.T y y' (yv0, yv1, yv2) ->+   (SigV.T y y' yv0, SigV.T y y' yv1, SigV.T y y' yv2)+unzip3 x =+   let (ss0,ss1,ss2) = List.unzip3 (SigV.samples x)+   in  (SigV.replaceSamples ss0 x, SigV.replaceSamples ss1 x, SigV.replaceSamples ss2 x)++++{- * glueing -}++{- |+Similar to @foldr1 append@ but more efficient and accurate,+because it reduces the number of amplifications.+Does not work for infinite lists,+because no maximum amplitude can be computed.+-}+concat ::+   (Ord y', Field.C y', OccScalar.C y y',+    Module.C y yv) =>+   [SigV.T y y' yv] -> SigV.T y y' yv+concat xs =+   concatVolume (List.maximum (map SigV.amplitude xs)) xs++{- |+Give the output volume explicitly.+Does also work for infinite lists.+-}+concatVolume ::+   (Field.C y', OccScalar.C y y',+    Module.C y yv) =>+   y' -> [SigV.T y y' yv] -> SigV.T y y' yv+concatVolume amp xs =+   let smps = map (SigV.vectorSamples (toAmplitudeScalar z)) xs+       z = SigV.Cons amp (List.concat smps)+   in  z+++merge ::+   (Ord y', Field.C y', OccScalar.C y y',+    Module.C y yv0, Module.C y yv1) =>+   ([yv0] -> [yv1] -> [yv2]) ->+   SigV.T y y' yv0 -> SigV.T y y' yv1 -> SigV.T y y' yv2+merge f x0 x1 =+   mergeVolume f (max (SigV.amplitude x0) (SigV.amplitude x1)) x0 x1++mergeVolume ::+   (Field.C y', OccScalar.C y y',+    Module.C y yv0, Module.C y yv1) =>+   ([yv0] -> [yv1] -> [yv2]) ->+   y' ->+   SigV.T y y' yv0 -> SigV.T y y' yv1 -> SigV.T y y' yv2+mergeVolume f amp x y =+   let sampX = SigV.vectorSamples (toAmplitudeScalar z) x+       sampY = SigV.vectorSamples (toAmplitudeScalar z) y+       z = SigV.Cons amp (f sampX sampY)+   in  z+++append ::+   (Ord y', Field.C y', OccScalar.C y y',+    Module.C y yv) =>+   SigV.T y y' yv -> SigV.T y y' yv -> SigV.T y y' yv+append = merge (List.++)++appendVolume ::+   (Field.C y', OccScalar.C y y',+    Module.C y yv) =>+   y' ->+   SigV.T y y' yv -> SigV.T y y' yv -> SigV.T y y' yv+appendVolume = mergeVolume (List.++)+++zip ::+   (Ord y', Field.C y', OccScalar.C y y',+    Module.C y yv0, Module.C y yv1) =>+   SigV.T y y' yv0 -> SigV.T y y' yv1 -> SigV.T y y' (yv0,yv1)+zip = merge List.zip++zipVolume ::+   (Field.C y', OccScalar.C y y',+    Module.C y yv0, Module.C y yv1) =>+   y' ->+   SigV.T y y' yv0 -> SigV.T y y' yv1 -> SigV.T y y' (yv0,yv1)+zipVolume = mergeVolume List.zip++++zip3 ::+   (Ord y', Field.C y', OccScalar.C y y',+    Module.C y yv0, Module.C y yv1, Module.C y yv2) =>+   SigV.T y y' yv0 -> SigV.T y y' yv1 -> SigV.T y y' yv2 ->+   SigV.T y y' (yv0,yv1,yv2)+zip3 x0 x1 x2 =+   zip3Volume+      (SigV.amplitude x0 `max` SigV.amplitude x1 `max` SigV.amplitude x2)+      x0 x1 x2++zip3Volume ::+   (Field.C y', OccScalar.C y y',+    Module.C y yv0, Module.C y yv1, Module.C y yv2) =>+   y' ->+   SigV.T y y' yv0 -> SigV.T y y' yv1 -> SigV.T y y' yv2 ->+   SigV.T y y' (yv0,yv1,yv2)+zip3Volume amp x0 x1 x2 =+   let sampX0 = SigV.vectorSamples (toAmplitudeScalar z) x0+       sampX1 = SigV.vectorSamples (toAmplitudeScalar z) x1+       sampX2 = SigV.vectorSamples (toAmplitudeScalar z) x2+       z = SigV.Cons amp (List.zip3 sampX0 sampX1 sampX2)+   in  z+
+ src/Synthesizer/Amplitude/Displacement.hs view
@@ -0,0 +1,88 @@+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes+-}+module Synthesizer.Amplitude.Displacement (+   mix, mixVolume,+   mixMulti, mixMultiVolume,+   raise,+   ) where++import qualified Synthesizer.Amplitude.Signal as SigV++import Synthesizer.Amplitude.Signal (toAmplitudeScalar)++import qualified Synthesizer.Plain.Displacement as Synthesizer++import qualified Algebra.OccasionallyScalar as OccScalar+import qualified Algebra.Module         as Module+-- import qualified Algebra.Transcendental as Trans+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 Algebra.Module ((*>))++import PreludeBase+import NumericPrelude+import Prelude ()+++{- * Mixing -}++{-| Mix two signals.+    In opposition to 'zipWith' the result has the length of the longer signal. -}+mix ::+   (Real.C y', Field.C y', Module.C y yv, OccScalar.C y y') =>+      SigV.T y y' yv+   -> SigV.T y y' yv+   -> SigV.T y y' yv+mix x y =+   mixVolume (abs (SigV.amplitude x) + abs (SigV.amplitude y)) x y++mixVolume ::+   (Real.C y', Field.C y', Module.C y yv, OccScalar.C y y') =>+      y'+   -> SigV.T y y' yv+   -> SigV.T y y' yv+   -> SigV.T y y' yv+mixVolume v x y =+   let z = SigV.Cons v+              (toAmplitudeScalar z (SigV.amplitude x) *> SigV.samples x ++               toAmplitudeScalar z (SigV.amplitude y) *> SigV.samples y)+   in  z++{-| Mix one or more signals. -}+mixMulti ::+   (Real.C y', Field.C y', Module.C y yv, OccScalar.C y y') =>+      [SigV.T y y' yv]+   ->  SigV.T y y' yv+mixMulti x =+   mixMultiVolume (sum (map (abs . SigV.amplitude) x)) x++mixMultiVolume ::+   (Real.C y', Field.C y', Module.C y yv, OccScalar.C y y') =>+      y'+   -> [SigV.T y y' yv]+   ->  SigV.T y y' yv+mixMultiVolume v x =+   let z = SigV.Cons v+              (foldr (\y -> (toAmplitudeScalar z (SigV.amplitude y) *>+                             SigV.samples y +)) [] x)+   in  z++{-| Add a number to all of the signal values.+    This is useful for adjusting the center of a modulation. -}+raise :: (Field.C y', Module.C y yv, OccScalar.C y y') =>+      y'+   -> yv+   -> SigV.T y y' yv+   -> SigV.T y y' yv+raise y' yv x =+   SigV.Cons (SigV.amplitude x)+      (Synthesizer.raise (toAmplitudeScalar x y' *> yv) (SigV.samples x))
+ src/Synthesizer/Amplitude/Filter.hs view
@@ -0,0 +1,58 @@+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes+-}+module Synthesizer.Amplitude.Filter (+   {- * Non-recursive -}++   {- ** Amplification -}+   amplify,+   negate,+   envelope,++) where+++import qualified Synthesizer.Amplitude.Signal as SigV++import qualified Synthesizer.Plain.Filter.NonRecursive as FiltNR++-- import qualified Algebra.OccasionallyScalar as OccScalar+-- 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 Algebra.Module         as Module++import NumericPrelude hiding (negate)+-- import PreludeBase as P+import Prelude ()+++{- | The amplification factor must be positive. -}+amplify :: (Ring.C y') =>+      y'+   -> SigV.T y y' yv+   -> SigV.T y y' yv+amplify volume x =+   SigV.Cons (volume * SigV.amplitude x) (SigV.samples x)++negate :: (Additive.C yv) =>+      SigV.T y y' yv+   -> SigV.T y y' yv+negate x =+   SigV.Cons (SigV.amplitude x) (Additive.negate (SigV.samples x))+++envelope :: (Module.C y0 yv, Ring.C y') =>+      SigV.T y y' y0  {- ^ the envelope -}+   -> SigV.T y y' yv  {- ^ the signal to be enveloped -}+   -> SigV.T y y' yv+envelope y x =+   SigV.Cons+      (SigV.amplitude y * SigV.amplitude x)+      (FiltNR.envelopeVector (SigV.samples y) (SigV.samples x))
+ src/Synthesizer/Amplitude/Signal.hs view
@@ -0,0 +1,61 @@+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes (OccasionallyScalar)++Signals equipped with a volume information that may carry a unit.+-}+module Synthesizer.Amplitude.Signal where++import qualified Algebra.OccasionallyScalar as OccScalar+import qualified Algebra.Module         as Module+import qualified Algebra.Field          as Field+import qualified Algebra.Ring           as Ring++import Algebra.OccasionallyScalar (toScalar)++import NumericPrelude+import PreludeBase as P+import Prelude ()+++data T y y' yv =+   Cons {+        amplitude  :: y'   {-^ scaling of the values -}+      , samples    :: [yv] {-^ the sampled values -}+     }+   deriving (Eq, Show)+++instance Functor (T y y') where+   fmap f (Cons amp ss) = Cons amp (map f ss)+++toAmplitudeScalar :: (Field.C y', OccScalar.C y y') =>+   T y y' yv -> y' -> y+toAmplitudeScalar sig y =+   toScalar (y / amplitude sig)+++scalarSamples :: (Ring.C y) =>+   (y' -> y) -> T y y' y -> [y]+scalarSamples toAmpScalar sig =+   let y = toAmpScalar (amplitude sig)+   in  map (y*) (samples sig)++vectorSamples :: (Module.C y yv) =>+   (y' -> y) -> T y y' yv -> [yv]+vectorSamples toAmpScalar sig =+   let y = toAmpScalar (amplitude sig)+   in  y *> samples sig++++replaceAmplitude :: y1' -> T y y0' yv -> T y y1' yv+replaceAmplitude amp (Cons _ ss)  =  Cons amp ss++replaceSamples :: [yv1] -> T y y' yv0 -> T y y' yv1+replaceSamples ss (Cons amp _)  =  Cons amp ss
+ src/Synthesizer/ApplicativeUtility.hs view
@@ -0,0 +1,88 @@+module Synthesizer.ApplicativeUtility where++import Control.Applicative (Applicative, pure, (<*>), (<$>), liftA2, )+import Data.Traversable (Traversable, sequenceA, )++import Control.Monad.Fix (fix, )+++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+++{- |+Create a loop (feedback) from one node to another one.+That is, compute the fix point of a process iteration.+-}+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.<*>'+-}+($:) :: (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.+-}+($::) :: (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)++(.:) :: (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++($^) :: (Functor f) => (a -> b) -> f a -> f b+($^) = fmap+-- ($^) = (.)+-- ($^) f x = pure f $: x++(.^) :: (Functor f) => (b -> c) -> f (a -> b) -> f (a -> c)+(.^) f = fmap (f.)+-- (.^) f = (.:) (pure f)++($#) :: (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.+-}++liftP :: (Applicative f) =>+   f (a -> b) -> f a -> f b+liftP = ($:)++liftP2 :: (Applicative f) =>+   f (a -> b -> c) -> f a -> f b -> f c+liftP2 f a b = f $: a $: b++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++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/Distortion.hs view
@@ -0,0 +1,66 @@+{-# OPTIONS -fno-implicit-prelude #-}+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 qualified Synthesizer.Utility as Util++-- import qualified Prelude as P+-- import PreludeBase+import NumericPrelude+++{- * Clipping -}++{- |+limit, fuzz booster+-}+clip :: (Real.C a) => a -> a+clip = Util.clip (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 @@+{-# OPTIONS -fno-implicit-prelude #-}+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 qualified Synthesizer.Utility as Util++-- import qualified Prelude as P+-- import PreludeBase+import NumericPrelude++{- * Clipping -}++{- |+limit, fuzz booster+-}+clip :: (Real.C a) => a -> a -> a+clip c = Util.clip (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,82 @@+module Synthesizer.Basic.Phase+   (T,+    fromRepresentative,+    toRepresentative,+    increment,+    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 qualified Synthesizer.Generic.SampledValue as Sample+import Foreign.Storable (Storable(..), )+import Foreign.Ptr (castPtr, )++import Synthesizer.Utility (mapFst)+import qualified NumericPrelude as NP+++newtype T a = Cons {decons :: a}+++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 Sample.C a => Sample.C (T a) -- where+++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 x = fromRepresentative (toRepresentative x Additive.+ 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 = fromRepresentative . Additive.negate . toRepresentative
+ src/Synthesizer/Basic/Wave.hs view
@@ -0,0 +1,825 @@+{-# OPTIONS -O2 -fno-implicit-prelude -fglasgow-exts #-}+{- |+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.Plain.ToneModulation as ToneMod+import qualified Synthesizer.Plain.Interpolation  as Interpolation+import Data.Array ((!), listArray)++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 MathObj.Polynomial as Poly+import qualified Number.Complex     as Complex++import Synthesizer.Utility (swap)++import NumericPrelude.Condition (select, )+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 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)+-}++sample :: (RealField.C a) =>+   Interpolation.T a v -> [v] -> T a v+sample ip wave =+   let len = length wave+       arr = listArray (0, pred len) wave+   in  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+++{- ** 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+-}+{-# 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+-}+{-# 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+++{- |+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 -> [v] -> a -> T a v+sampledTone ipLeap ipStep period tone shape = Cons $ \phase ->+   uncurry (ToneMod.interpolateCell ipLeap ipStep) $+   ToneMod.sampledToneCell+      (ToneMod.makePrototype ipLeap ipStep period tone)+      shape phase++{- |+Interpolate first within waves and then across waves,+which is simpler but maybe less efficient.+-}+sampledToneAlt :: (RealField.C a) =>+   Interpolation.T a v ->+   Interpolation.T a v ->+   a -> [v] -> a -> T a v+sampledToneAlt ipLeap ipStep period tone shape = Cons $ \phase ->+   uncurry (ToneMod.interpolateCell ipStep ipLeap . swap) $+   ToneMod.sampledToneAltCell+      (ToneMod.makePrototype ipLeap ipStep 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))+-}+++{- |+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,193 @@+{-# OPTIONS -O2 -fno-implicit-prelude -fglasgow-exts #-}+{- |+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 @@+{-# OPTIONS -fno-implicit-prelude #-}+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,107 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+ToDo:+use AffineSpace instead of Module for the particular interpolation types,+since affine combinations assert reconstruction of constant functions.+They are more natural for interpolation of internal control parameters.+However, how can cubic interpolation expressed by affine combinations+without divisions?+-}+module Synthesizer.Causal.Interpolation (+   Interpolation.T,+   Interpolation.toGeneric,++   relative,+   relativeZeroPad,+   relativeConstantPad,+   relativeCyclicPad,+   relativeExtrapolationPad,+   relativeZeroPadConstant,+   relativeZeroPadLinear,+   relativeZeroPadCubic,+   ) where++import qualified Synthesizer.State.Interpolation as Interpolation++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) = Interpolation.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 =+   Interpolation.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 =+   Interpolation.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 =+   Interpolation.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 =+   Interpolation.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 Interpolation.constant++{-# INLINE relativeZeroPadLinear #-}+relativeZeroPadLinear ::+   (RealField.C t, Module.C t y) =>+   t -> Sig.T y -> Causal.T t y+relativeZeroPadLinear =+   relativeZeroPad zero Interpolation.linear++{-# INLINE relativeZeroPadCubic #-}+relativeZeroPadCubic ::+   (RealField.C t, Module.C t y) =>+   t -> Sig.T y -> Causal.T t y+relativeZeroPadCubic =+   relativeZeroPad zero Interpolation.cubic+
+ src/Synthesizer/Causal/Oscillator.hs view
@@ -0,0 +1,173 @@+{-# OPTIONS_GHC -O2 -fno-implicit-prelude #-}+{- |+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 Interpolation++{-+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 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.+-}+freqsToPhases :: RealField.C a =>+   Phase.T a -> Causal.T a (Phase.T a)+freqsToPhases phase =+   Causal.scanL (flip Phase.increment) 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  = Phase.toRepresentative $ Phase.multiply len phase+    in  Interpolation.relativeCyclicPad ip pr wave+          <<< Causal.map (fromIntegral len *)++++{- * 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/Process.hs view
@@ -0,0 +1,214 @@+{-# OPTIONS -fglasgow-exts #-}+{- |+Processes that use only the current and past data.+Essentially this is a data type for the 'Synthesizer.State.Signal.crochetL' function.+-}+module Synthesizer.Causal.Process (+   T,+   fromStateMaybe,+   fromState,+   fromSimpleModifier,++   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,+   apply2,+   feed,++   crochetL,+   scanL,+   zipWith,+) where++import qualified Synthesizer.State.Signal as Sig++import qualified Synthesizer.Plain.Modifier as Modifier++-- import qualified Control.Arrow as Arrow++import Control.Arrow+          (Arrow(..), {- ArrowApply(..), -} ArrowLoop(..),+           Kleisli(Kleisli), runKleisli, )+import Control.Monad.State+          (State(State), runState,+           StateT(StateT), runStateT, liftM, )++import Synthesizer.Utility (mapSnd)+import Prelude hiding (map, zipWith, )++++-- TODO: include ST monad for mutable arrays++-- | 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 s0 =+   fromStateMaybe (\x -> StateT (Just . runState (f x))) s0++{-# 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 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 apply #-}+apply :: T a b -> Sig.T a -> Sig.T b+apply (Cons f s) =+   Sig.crochetL (runStateT . f) s++{-# INLINE applyFst #-}+applyFst :: T (a,b) c -> Sig.T a -> T b c+applyFst (Cons f s) x =+   Cons (\b ->+           do a <- extendStateFstT $ StateT $ Sig.viewL+              extendStateSndT (f (a,b)))+        (s,x)++{-# INLINE applySnd #-}+applySnd :: T (a,b) c -> Sig.T b -> T a c+applySnd (Cons f s) x =+   Cons (\b ->+           do a <- extendStateFstT $ StateT $ Sig.viewL+              extendStateSndT (f (b,a)))+        (s,x)++{-# 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 feed #-}+feed :: Sig.T a -> T () a+feed = fromStateMaybe (const (StateT Sig.viewL))+++{-# 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 zipWith #-}+zipWith :: (a -> b -> c) -> Sig.T a -> T b c+zipWith f = applyFst (map (uncurry f))
+ src/Synthesizer/Dimensional/Abstraction/Flat.hs view
@@ -0,0 +1,65 @@+{-# OPTIONS -fglasgow-exts #-}+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++Class that allows unified handling of+@SigS.T@ and @Sig.D Dim.Scalar@+which is often used for control curves.+-}+module Synthesizer.Dimensional.Abstraction.Flat where++import qualified Synthesizer.Dimensional.RatePhantom as RP+import qualified Synthesizer.Dimensional.Straight.Signal as SigS+import qualified Synthesizer.Dimensional.Amplitude.Signal as SigA++import qualified Synthesizer.State.Signal as Sig++import qualified Number.DimensionTerm        as DN+import qualified Algebra.DimensionTerm       as Dim++{-+import qualified Algebra.Module         as Module+import qualified Algebra.Field          as Field+-}+import qualified Algebra.Ring           as Ring++-- import Number.DimensionTerm ((&/&))+++-- import NumericPrelude+import PreludeBase+-- import Prelude ()+++toSamples :: C sig y => RP.T s sig y -> Sig.T y+toSamples = unwrappedToSamples . RP.toSignal++class C sig y where+   unwrappedToSamples :: sig y -> Sig.T y++instance C Sig.T y where+   unwrappedToSamples = id++instance C sig y => C (SigS.T sig) y where+   unwrappedToSamples = unwrappedToSamples . SigS.samples+++{-+instance (Dim.IsScalar scalar, Module.C y yv) => C (SigA.T scalar y) yv where+   toSamples =+      SigA.vectorSamples (DN.toNumber . DN.rewriteDimension Dim.toScalar)+-}++instance (C flat y, Dim.IsScalar scalar, Ring.C y) =>+             C (SigA.T scalar y flat) y where+   unwrappedToSamples =+      SigA.scalarSamples (DN.toNumber . DN.rewriteDimension Dim.toScalar) .+      (\x ->+         SigA.fromSamples+            (SigA.privateAmplitude x)+            (unwrappedToSamples (SigA.signal x)))
+ src/Synthesizer/Dimensional/Abstraction/Homogeneous.hs view
@@ -0,0 +1,70 @@+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++Class that allows unified handling of+@SigS.T@ and @Sig.D s u@+whenever the applied function is homogeneous (with degree one),+that is scaling of the input must only result in scaling of the output.+Unfortunately, Haskell's type system cannot check this property,+so use this abstraction only for signal processes that are actually homogeneous.+-}+module Synthesizer.Dimensional.Abstraction.Homogeneous where++import qualified Synthesizer.State.Signal as Sig+import qualified Synthesizer.Dimensional.RatePhantom as RP+import qualified Synthesizer.Dimensional.Straight.Signal as SigS+import qualified Synthesizer.Dimensional.Amplitude.Signal as SigA++-- import qualified Number.DimensionTerm        as DN+import qualified Algebra.DimensionTerm       as Dim++{-+import qualified Algebra.Module         as Module+import qualified Algebra.Field          as Field+import qualified Algebra.Ring           as Ring+-}++-- import Number.DimensionTerm ((&/&))+++-- import NumericPrelude+-- import PreludeBase+-- import Prelude ()++{-# INLINE processSamples #-}+processSamples :: C sig =>+   (Sig.T y0 -> Sig.T y1) -> RP.T s sig y0 -> RP.T s sig y1+processSamples f =+   RP.fromSignal . unwrappedProcessSamples f . RP.toSignal+++{-# INLINE processSampleList #-}+processSampleList :: C sig =>+   ([y0] -> [y1]) ->+   RP.T s sig y0 ->+   RP.T s sig y1+processSampleList f =+   processSamples (Sig.fromList . f . Sig.toList)+++class C sig where+   unwrappedProcessSamples :: (Sig.T y0 -> Sig.T y1) -> sig y0 -> sig y1+++instance C Sig.T where+   unwrappedProcessSamples f = f++instance C sig => C (SigS.T sig) where+--   processSamples = SigS.processSamples+   unwrappedProcessSamples f =+      SigS.Cons . unwrappedProcessSamples f . SigS.samples++instance (C sig, Dim.C u) => C (SigA.T u y sig) where+   unwrappedProcessSamples f =+      (\(SigA.Cons amp sig) ->+         SigA.Cons amp (unwrappedProcessSamples f sig))
+ src/Synthesizer/Dimensional/Abstraction/RateIndependent.hs view
@@ -0,0 +1,38 @@+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++Class that allows unified handling of @RP.T@ and @SigP.T@+whenever the applied function does not depend on the sample rate.+Unfortunately, Haskell's type system cannot check this property,+so use this abstraction only for signal processes that are actually sample rate independent.+-}+module Synthesizer.Dimensional.Abstraction.RateIndependent where++-- import qualified Synthesizer.Dimensional.RatePhantom as RP+-- import qualified Synthesizer.Dimensional.RateWrapper as SigP++-- import qualified Number.DimensionTerm        as DN+-- import qualified Algebra.DimensionTerm       as Dim++{-+import qualified Algebra.Module         as Module+import qualified Algebra.Field          as Field+import qualified Algebra.Ring           as Ring+-}++-- import Number.DimensionTerm ((&/&))+++-- import NumericPrelude+-- import PreludeBase+-- import Prelude ()+++class C w where+   toSignal :: w sig y -> sig y+   processSignal :: (sig0 y0 -> sig1 y1) -> w sig0 y0 -> w sig1 y1
+ src/Synthesizer/Dimensional/Amplitude/Analysis.hs view
@@ -0,0 +1,174 @@+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes+-}+module Synthesizer.Dimensional.Amplitude.Analysis (+    volumeMaximum,+    volumeEuclidean,+    volumeSum,+    volumeVectorMaximum,+    volumeVectorEuclidean,+    volumeVectorSum,++    directCurrentOffset,+    rectify,+    flipFlopHysteresis,++    compare,+    lessOrEqual,+  ) where++import qualified Synthesizer.Dimensional.Abstraction.RateIndependent as Ind+import qualified Synthesizer.Dimensional.Abstraction.Homogeneous as Hom++-- import qualified Synthesizer.Dimensional.RatePhantom as RP+import qualified Synthesizer.Dimensional.Straight.Signal as SigS++import qualified Synthesizer.Dimensional.Amplitude.Signal as SigA+import qualified Synthesizer.Dimensional.Amplitude.Cut    as CutD+-- import Synthesizer.Dimensional.Amplitude.Signal (toAmplitudeScalar)++import qualified Synthesizer.State.Analysis as Ana+import qualified Synthesizer.State.Signal   as Sig++import qualified Number.DimensionTerm        as DN+import qualified Algebra.DimensionTerm       as Dim++import Number.DimensionTerm ((*&))++import qualified Algebra.NormedSpace.Maximum   as NormedMax+import qualified Algebra.NormedSpace.Euclidean as NormedEuc+import qualified Algebra.NormedSpace.Sum       as NormedSum++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 Data.List as List+-- import NumericPrelude.List (zipWithMatch, )++import PreludeBase (Ord, Bool, (<=), ($), (.), uncurry, )+-- import NumericPrelude+import qualified Prelude as P++++{- * Notions of volume -}++{- |+Volume based on Manhattan norm.+-}+{-# INLINE volumeMaximum #-}+volumeMaximum :: (Ind.C w, Real.C y, Dim.C u) =>+   w (SigA.S u y) y -> DN.T u y+volumeMaximum = volumeAux Ana.volumeMaximum++{- |+Volume based on Energy norm.+-}+{-# INLINE volumeEuclidean #-}+volumeEuclidean :: (Ind.C w, Algebraic.C y, Dim.C u) =>+   w (SigA.S u y) y -> DN.T u y+volumeEuclidean = volumeAux Ana.volumeEuclidean++{- |+Volume based on Sum norm.+-}+{-# INLINE volumeSum #-}+volumeSum :: (Ind.C w, Field.C y, Real.C y, Dim.C u) =>+   w (SigA.S u y) y -> DN.T u y+volumeSum = volumeAux Ana.volumeSum++++{- |+Volume based on Manhattan norm.+-}+{-# INLINE volumeVectorMaximum #-}+volumeVectorMaximum :: (Ind.C w, NormedMax.C y yv, Ord y, Dim.C u) =>+   w (SigA.S u y) yv -> DN.T u y+volumeVectorMaximum = volumeAux Ana.volumeVectorMaximum++{- |+Volume based on Energy norm.+-}+{-# INLINE volumeVectorEuclidean #-}+volumeVectorEuclidean :: (Ind.C w, NormedEuc.C y yv, Algebraic.C y, Dim.C u) =>+   w (SigA.S u y) yv -> DN.T u y+volumeVectorEuclidean = volumeAux Ana.volumeVectorEuclidean++{- |+Volume based on Sum norm.+-}+{-# INLINE volumeVectorSum #-}+volumeVectorSum :: (Ind.C w, NormedSum.C y yv, Field.C y, Dim.C u) =>+   w (SigA.S u y) yv -> DN.T u y+volumeVectorSum = volumeAux Ana.volumeVectorSum+++{-# INLINE volumeAux #-}+volumeAux :: (Ind.C w, Ring.C y, Dim.C u) =>+   (Sig.T yv -> y) -> w (SigA.S u y) yv -> DN.T u y+volumeAux vol x =+   vol (SigA.samples x) *& SigA.amplitude x+++{- * Miscellaneous -}++{- |+Requires finite length.+This is identical to the arithmetic mean.+-}+{-# INLINE directCurrentOffset #-}+directCurrentOffset :: (Ind.C w, Field.C y, Dim.C u) =>+   w (SigA.S u y) y -> DN.T u y+directCurrentOffset =+   volumeAux Ana.directCurrentOffset++{-# INLINE rectify #-}+rectify :: (Ind.C w, Hom.C sig, Real.C y) =>+   w sig y -> w sig y+rectify = Ind.processSignal (Hom.unwrappedProcessSamples Ana.rectify)+++{- |+Detect thresholds with a hysteresis.+-}+{-# INLINE flipFlopHysteresis #-}+flipFlopHysteresis :: (Ind.C w, Ord y, Field.C y, Dim.C u) =>+   (DN.T u y, DN.T u y) -> Bool ->+   w (SigA.S u y) y -> w (SigS.T Sig.T) Bool+--   SigA.R s u y y -> SigS.Binary s+flipFlopHysteresis (lower,upper) start x =+   let l = SigA.toAmplitudeScalar x lower+       h = SigA.toAmplitudeScalar x upper+   in  Ind.processSignal+          (SigS.Cons .+           Ana.flipFlopHysteresis (l,h) start .+           SigA.privateSamples) x+++{- * comparison -}++{-# INLINE compare #-}+compare ::+   (Ord y, Field.C y, Dim.C u,+    Module.C y yv, Ord yv) =>+   SigA.R s u y yv -> SigA.R s u y yv -> SigS.R s P.Ordering+compare x y =+   SigS.fromSamples $ Sig.map (uncurry P.compare) $ SigA.samples $ CutD.zip x y++{-# INLINE lessOrEqual #-}+lessOrEqual ::+   (Ord y, Field.C y, Dim.C u,+    Module.C y yv, Ord yv) =>+   SigA.R s u y yv -> SigA.R s u y yv -> SigS.Binary s+lessOrEqual x y =+   P.fmap (<= P.EQ) $ compare x y
+ src/Synthesizer/Dimensional/Amplitude/Control.hs view
@@ -0,0 +1,132 @@+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes+++Control curves which can be used+as envelopes, for controlling filter parameters and so on.+-}+module Synthesizer.Dimensional.Amplitude.Control+   ({- * Primitives -}+    constant, constantVector,+    {- * Preparation -}+    mapLinear, mapLinearDimension,+    mapExponential,+   ) where++import qualified Synthesizer.Dimensional.Abstraction.RateIndependent as Ind+import qualified Synthesizer.Dimensional.Abstraction.Flat as Flat++-- import qualified Synthesizer.Dimensional.RatePhantom as RP+import qualified Synthesizer.Dimensional.Straight.Signal as SigS+import qualified Synthesizer.Dimensional.Amplitude.Signal as SigA+import Synthesizer.Dimensional.Amplitude.Signal (toAmplitudeScalar)++import qualified Synthesizer.State.Control as Ctrl+import qualified Synthesizer.State.Signal  as Sig++import qualified Number.DimensionTerm        as DN+import qualified Algebra.DimensionTerm       as Dim++import Number.DimensionTerm ((&*&))++-- import qualified Algebra.Module             as Module+import qualified Algebra.Transcendental     as Trans+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 PreludeBase as P+import Prelude ()+++{-# INLINE constant #-}+constant :: (Real.C y, Dim.C u) =>+      DN.T u y {-^ value -}+   -> SigA.R s u y y+constant =+   uncurry constantVector .+   DN.absSignum++{- |+The amplitude must be positive!+This is not checked.+-}+{-# INLINE constantVector #-}+constantVector :: -- (Field.C y', Real.C y', OccScalar.C y y') =>+      DN.T u y {-^ amplitude -}+   -> yv       {-^ value -}+   -> SigA.R s u y yv+constantVector y yv =+   SigA.fromSamples y (Ctrl.constant yv)++++{-+This signature is too general.+It will cause strange type errors+if u is Scalar and further process want to use the Flat instance.+The Flat instance cannot be found, if q cannot be determined.++mapLinear :: (Ind.C w, Flat.C flat y, Ring.C y, Dim.C u) =>+    y ->+    DN.T u q ->+    w flat y ->+    w (SigA.S u q) y+-}++{-# INLINE mapLinear #-}+mapLinear :: (Ind.C w, Flat.C flat y, Ring.C y, Dim.C u) =>+    y ->+    DN.T u y ->+    w flat y ->+    w (SigA.S u y) y+mapLinear depth center =+   Ind.processSignal+      (SigA.Cons center . SigS.Cons .+       Sig.map (\x -> one+x*depth) .+       Flat.unwrappedToSamples)++{-# INLINE mapExponential #-}+mapExponential :: (Ind.C w, Flat.C flat y, Trans.C y, Dim.C u) =>+    y ->+    DN.T u q ->+    w flat y ->+    w (SigA.S u q) y+mapExponential depth center =+   Ind.processSignal+      (SigA.Cons center . SigS.Cons .+       Sig.map (depth**) .+       Flat.unwrappedToSamples)+++-- combination of 'raise' and 'amplify' ***+{- |+Map a control curve without amplitude unit+by a linear (affine) function with a unit.+-}+{-# INLINE mapLinearDimension #-}+mapLinearDimension ::+   (Ind.C w, Field.C y, Real.C y, Dim.C u, Dim.C v) =>+      DN.T v y               {- ^ range: one is mapped to @center + range * ampX@ -}+   -> DN.T (Dim.Mul v u) y  {- ^ center: zero is mapped to @center@ -}+   -> w (SigA.S u y) y+   -> w (SigA.S (Dim.Mul v u) y) y+mapLinearDimension range center x =+   let absRange  = DN.abs range &*& SigA.amplitude x+       absCenter = DN.abs center+       rng = toAmplitudeScalar z absRange+       cnt = toAmplitudeScalar z absCenter+       z =+          Ind.processSignal+             (SigA.Cons (absRange + absCenter) . SigS.Cons .+              Sig.map (\y -> cnt + rng*y) .+              SigA.privateSamples) x+   in  z+-- SynI.mapScalar 1 (absRange + absCenter) (\y -> cnt + rng*y) x
+ src/Synthesizer/Dimensional/Amplitude/Cut.hs view
@@ -0,0 +1,222 @@+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes+-}+module Synthesizer.Dimensional.Amplitude.Cut (+   {- * dissection -}+   unzip,+   unzip3,+   leftFromStereo, rightFromStereo,++   {- * glueing -}+   concat,      concatVolume,+   append,      appendVolume,+   zip,         zipVolume,+   zip3,        zip3Volume,+   mergeStereo, mergeStereoVolume,+   selectBool,+  ) where++import qualified Synthesizer.Dimensional.Straight.Signal as SigS+import qualified Synthesizer.Dimensional.Amplitude.Signal as SigA+import Synthesizer.Dimensional.Amplitude.Signal (toAmplitudeScalar)++import qualified Synthesizer.State.Signal  as Sig++import qualified Synthesizer.Frame.Stereo as Stereo++import qualified Number.DimensionTerm        as DN+import qualified Algebra.DimensionTerm       as Dim++-- import Number.DimensionTerm ((&*&))++-- import qualified Algebra.NormedSpace.Maximum as NormedMax+import qualified Algebra.Module              as Module+import qualified Algebra.Field               as Field+-- import qualified Algebra.Ring                as Ring++import qualified Data.List as List+-- import NumericPrelude.List (zipWithMatch, )++import PreludeBase (Ord, max, )+-- import NumericPrelude+import Prelude ()+++{- * dissection -}++{-# INLINE unzip #-}+unzip :: (Dim.C u) =>+   SigA.R s u y (yv0, yv1) ->+   (SigA.R s u y yv0, SigA.R s u y yv1)+unzip x =+   let (ss0,ss1) = Sig.unzip (SigA.samples x)+   in  (SigA.replaceSamples ss0 x, SigA.replaceSamples ss1 x)++{-# INLINE unzip3 #-}+unzip3 :: (Dim.C u) =>+   SigA.R s u y (yv0, yv1, yv2) ->+   (SigA.R s u y yv0, SigA.R s u y yv1, SigA.R s u y yv2)+unzip3 x =+   let (ss0,ss1,ss2) = Sig.unzip3 (SigA.samples x)+   in  (SigA.replaceSamples ss0 x, SigA.replaceSamples ss1 x, SigA.replaceSamples ss2 x)+++{-# INLINE leftFromStereo #-}+leftFromStereo :: (Dim.C u) =>+   SigA.R s u y (Stereo.T yv) -> SigA.R s u y yv+leftFromStereo = SigA.processSamples (Sig.map Stereo.left)++{-# INLINE rightFromStereo #-}+rightFromStereo :: (Dim.C u) =>+   SigA.R s u y (Stereo.T yv) -> SigA.R s u y yv+rightFromStereo = SigA.processSamples (Sig.map Stereo.right)++++{- * glueing -}++{- |+Similar to @foldr1 append@ but more efficient and accurate,+because it reduces the number of amplifications.+Does not work for infinite lists,+because no maximum amplitude can be computed.+-}+{-# INLINE concat #-}+concat ::+   (Ord y, Field.C y, Dim.C u,+    Module.C y yv) =>+   [SigA.R s u y yv] -> SigA.R s u y yv+concat xs =+   concatVolume (List.maximum (List.map SigA.amplitude xs)) xs++{- |+Give the output volume explicitly.+Does also work for infinite lists.+-}+{-# INLINE concatVolume #-}+concatVolume ::+   (Field.C y, Dim.C u,+    Module.C y yv) =>+   DN.T u y -> [SigA.R s u y yv] -> SigA.R s u y yv+concatVolume amp xs =+   let smps = List.map (SigA.vectorSamples (toAmplitudeScalar z)) xs+       z = SigA.fromSamples amp (Sig.concat smps)+   in  z+++{-# INLINE merge #-}+merge ::+   (Ord y, Field.C y, Dim.C u,+    Module.C y yv0, Module.C y yv1) =>+   (Sig.T yv0 -> Sig.T yv1 -> Sig.T yv2) ->+   SigA.R s u y yv0 -> SigA.R s u y yv1 -> SigA.R s u y yv2+merge f x0 x1 =+   mergeVolume f (max (SigA.amplitude x0) (SigA.amplitude x1)) x0 x1++{-# INLINE mergeVolume #-}+mergeVolume ::+   (Field.C y, Dim.C u,+    Module.C y yv0, Module.C y yv1) =>+   (Sig.T yv0 -> Sig.T yv1 -> Sig.T yv2) ->+   DN.T u y ->+   SigA.R s u y yv0 -> SigA.R s u y yv1 -> SigA.R s u y yv2+mergeVolume f amp x y =+   let sampX = SigA.vectorSamples (toAmplitudeScalar z) x+       sampY = SigA.vectorSamples (toAmplitudeScalar z) y+       z = SigA.fromSamples amp (f sampX sampY)+   in  z+++{-# INLINE append #-}+append ::+   (Ord y, Field.C y, Dim.C u,+    Module.C y yv) =>+   SigA.R s u y yv -> SigA.R s u y yv -> SigA.R s u y yv+append = merge Sig.append++{-# INLINE appendVolume #-}+appendVolume ::+   (Field.C y, Dim.C u,+    Module.C y yv) =>+   DN.T u y ->+   SigA.R s u y yv -> SigA.R s u y yv -> SigA.R s u y yv+appendVolume = mergeVolume Sig.append+++{-# INLINE zip #-}+zip ::+   (Ord y, Field.C y, Dim.C u,+    Module.C y yv0, Module.C y yv1) =>+   SigA.R s u y yv0 -> SigA.R s u y yv1 -> SigA.R s u y (yv0,yv1)+zip = merge Sig.zip++{-# INLINE zipVolume #-}+zipVolume ::+   (Field.C y, Dim.C u,+    Module.C y yv0, Module.C y yv1) =>+   DN.T u y ->+   SigA.R s u y yv0 -> SigA.R s u y yv1 -> SigA.R s u y (yv0,yv1)+zipVolume = mergeVolume Sig.zip++++{-# INLINE mergeStereo #-}+mergeStereo ::+   (Ord y, Field.C y, Dim.C u,+    Module.C y yv) =>+   SigA.R s u y yv -> SigA.R s u y yv -> SigA.R s u y (Stereo.T yv)+mergeStereo = merge (Sig.zipWith Stereo.cons)++{-# INLINE mergeStereoVolume #-}+mergeStereoVolume ::+   (Field.C y, Dim.C u,+    Module.C y yv) =>+   DN.T u y ->+   SigA.R s u y yv -> SigA.R s u y yv -> SigA.R s u y (Stereo.T yv)+mergeStereoVolume = mergeVolume (Sig.zipWith Stereo.cons)++++{-# INLINE zip3 #-}+zip3 ::+   (Ord y, Field.C y, Dim.C u,+    Module.C y yv0, Module.C y yv1, Module.C y yv2) =>+   SigA.R s u y yv0 -> SigA.R s u y yv1 -> SigA.R s u y yv2 ->+   SigA.R s u y (yv0,yv1,yv2)+zip3 x0 x1 x2 =+   zip3Volume+      (SigA.amplitude x0 `max` SigA.amplitude x1 `max` SigA.amplitude x2)+      x0 x1 x2++{-# INLINE zip3Volume #-}+zip3Volume ::+   (Field.C y, Dim.C u,+    Module.C y yv0, Module.C y yv1, Module.C y yv2) =>+   DN.T u y ->+   SigA.R s u y yv0 -> SigA.R s u y yv1 -> SigA.R s u y yv2 ->+   SigA.R s u y (yv0,yv1,yv2)+zip3Volume amp x0 x1 x2 =+   let sampX0 = SigA.vectorSamples (toAmplitudeScalar z) x0+       sampX1 = SigA.vectorSamples (toAmplitudeScalar z) x1+       sampX2 = SigA.vectorSamples (toAmplitudeScalar z) x2+       z = SigA.fromSamples amp (Sig.zip3 sampX0 sampX1 sampX2)+   in  z+++{-# INLINE selectBool #-}+selectBool ::+   (Ord y, Field.C y, Dim.C u,+    Module.C y yv) =>+   SigA.R s u y yv {- ^ False -} ->+   SigA.R s u y yv {- ^ True -} ->+   SigS.Binary s ->+   SigA.R s u y yv+selectBool xf xt cs =+   SigA.processSamples+      (Sig.zipWith (\c (xfi,xti) -> if c then xti else xfi) (SigS.toSamples cs))+      (zip xf xt)
+ src/Synthesizer/Dimensional/Amplitude/Displacement.hs view
@@ -0,0 +1,110 @@+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes+-}+module Synthesizer.Dimensional.Amplitude.Displacement (+   mix, mixVolume,+   mixMulti, mixMultiVolume,+   raise, distort,+   ) where++import qualified Synthesizer.Dimensional.Abstraction.RateIndependent as Ind++import qualified Synthesizer.Dimensional.Amplitude.Signal as SigA+import Synthesizer.Dimensional.Amplitude.Signal (toAmplitudeScalar)++import qualified Number.DimensionTerm        as DN+import qualified Algebra.DimensionTerm       as Dim++-- import Number.DimensionTerm ((&*&))++import qualified Synthesizer.State.Displacement as Disp+import qualified Synthesizer.State.Signal  as Sig++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 Algebra.Module ((*>))++import PreludeBase+import NumericPrelude+import Prelude ()+++{- * Mixing -}++{-| Mix two signals.+    In opposition to 'zipWith' the result has the length of the longer signal. -}+{-# INLINE mix #-}+mix ::+   (Real.C y, Field.C y, Module.C y yv, Dim.C u) =>+      SigA.R s u y yv+   -> SigA.R s u y yv+   -> SigA.R s u y yv+mix x y =+   mixVolume (DN.abs (SigA.amplitude x) + DN.abs (SigA.amplitude y)) x y++{-# INLINE mixVolume #-}+mixVolume ::+   (Real.C y, Field.C y, Module.C y yv, Dim.C u) =>+      DN.T u y+   -> SigA.R s u y yv+   -> SigA.R s u y yv+   -> SigA.R s u y yv+mixVolume v x y =+   let z = SigA.fromSamples v+              (toAmplitudeScalar z (SigA.amplitude x) *> SigA.samples x ++               toAmplitudeScalar z (SigA.amplitude y) *> SigA.samples y)+   in  z++{-| Mix one or more signals. -}+{-# INLINE mixMulti #-}+mixMulti ::+   (Real.C y, Field.C y, Module.C y yv, Dim.C u) =>+      [SigA.R s u y yv]+   ->  SigA.R s u y yv+mixMulti x =+   mixMultiVolume (sum (map (DN.abs . SigA.amplitude) x)) x++{-# INLINE mixMultiVolume #-}+mixMultiVolume ::+   (Real.C y, Field.C y, Module.C y yv, Dim.C u) =>+      DN.T u y+   -> [SigA.R s u y yv]+   ->  SigA.R s u y yv+mixMultiVolume v x =+   let z = SigA.fromSamples v+              (foldr (\y -> (toAmplitudeScalar z (SigA.amplitude y) *>+                             SigA.samples y +)) Sig.empty x)+   in  z++{-| Add a number to all of the signal values.+    This is useful for adjusting the center of a modulation. -}+{-# INLINE raise #-}+raise :: (Ind.C w, Field.C y, Module.C y yv, Dim.C u) =>+      DN.T u y+   -> yv+   -> w (SigA.S u y) yv+   -> w (SigA.S u y) yv+raise y' yv x =+   SigA.processSamples+      (Disp.raise (toAmplitudeScalar x y' *> yv)) x++{-# INLINE distort #-}+distort :: (Field.C y, Module.C y yv, Dim.C u) =>+      (yv -> yv)+   -> SigA.R s u y y+   -> SigA.R s u y yv+   -> SigA.R s u y yv+distort f cs xs =+   SigA.processSamples+      (Sig.zipWith+          (\c y -> c *> f (recip c *> y))+          (SigA.scalarSamples (toAmplitudeScalar xs) cs)) xs
+ src/Synthesizer/Dimensional/Amplitude/Filter.hs view
@@ -0,0 +1,102 @@+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes+-}+module Synthesizer.Dimensional.Amplitude.Filter (+   {- * Non-recursive -}++   {- ** Amplification -}+   amplify,+   amplifyDimension,+   negate,+   envelope,+   envelopeVector,+   envelopeVectorDimension,+ ) where+++import qualified Synthesizer.Dimensional.Abstraction.RateIndependent as Ind+import qualified Synthesizer.Dimensional.Abstraction.Homogeneous as Hom+import qualified Synthesizer.Dimensional.Abstraction.Flat as Flat++import qualified Synthesizer.Dimensional.RatePhantom as RP++-- import qualified Synthesizer.Dimensional.Straight.Signal      as SigS+import qualified Synthesizer.Dimensional.Amplitude.Signal as SigA+-- import Synthesizer.Dimensional.Amplitude.Signal (toAmplitudeScalar)++import qualified Number.DimensionTerm        as DN+import qualified Algebra.DimensionTerm       as Dim++import Number.DimensionTerm ((&*&))++-- import qualified Synthesizer.State.Signal              as Sig+import qualified Synthesizer.State.Filter.NonRecursive as FiltNR++-- 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 Algebra.Module         as Module++-- import NumericPrelude hiding (negate)+-- import PreludeBase as P+import Prelude (($))+++{- | The amplification factor must be positive. -}+{-# INLINE amplify #-}+amplify :: (Ind.C w, Ring.C y, Dim.C u) =>+      y+   -> w (SigA.S u y) yv+   -> w (SigA.S u y) yv+amplify volume x =+   SigA.replaceAmplitude (DN.scale volume $ SigA.amplitude x) x++{-# INLINE amplifyDimension #-}+amplifyDimension :: (Ind.C w, Ring.C y, Dim.C u, Dim.C v) =>+      DN.T v y+   -> w (SigA.S u y) yv+   -> w (SigA.S (Dim.Mul v u) y) yv+amplifyDimension volume x =+   SigA.replaceAmplitude (volume &*& SigA.amplitude x) x++-- FIXME: move to Dimensional.Straight+{-# INLINE negate #-}+negate :: (Ind.C w, Hom.C sig, Additive.C yv) =>+      w sig yv+   -> w sig yv+negate =+   Ind.processSignal (Hom.unwrappedProcessSamples Additive.negate)++-- FIXME: move to Dimensional.Straight+{-# INLINE envelope #-}+envelope :: (Hom.C sig, Flat.C flat y0, Ring.C y0) =>+      RP.T s flat y0   {- ^ the envelope -}+   -> RP.T s sig y0    {- ^ the signal to be enveloped -}+   -> RP.T s sig y0+envelope y =+   Hom.processSamples (FiltNR.envelope (Flat.toSamples y))++-- FIXME: move to Dimensional.Straight+{-# INLINE envelopeVector #-}+envelopeVector :: (Hom.C sig, Flat.C flat y0, Module.C y0 yv) =>+      RP.T s flat y0   {- ^ the envelope -}+   -> RP.T s sig yv    {- ^ the signal to be enveloped -}+   -> RP.T s sig yv+envelopeVector y =+   Hom.processSamples (FiltNR.envelopeVector (Flat.toSamples y))++{-# INLINE envelopeVectorDimension #-}+envelopeVectorDimension :: (Module.C y0 yv, Ring.C y, Dim.C u, Dim.C v) =>+      SigA.R s v y y0  {- ^ the envelope -}+   -> SigA.R s u y yv  {- ^ the signal to be enveloped -}+   -> SigA.R s (Dim.Mul v u) y yv+envelopeVectorDimension y x =+   SigA.fromSamples+      (SigA.amplitude y &*& SigA.amplitude x)+      (FiltNR.envelopeVector (SigA.samples y) (SigA.samples x))
+ src/Synthesizer/Dimensional/Amplitude/Signal.hs view
@@ -0,0 +1,219 @@+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++Signals equipped with a volume information that may carry a unit.+Is the approach with separated volume information still appropriate?+Actually it simplifies reusing code from "Synthesizer.State.Signal"+because we do not have to replace @(*)@ by @(&*&)@.+-}+module Synthesizer.Dimensional.Amplitude.Signal where++import qualified Synthesizer.Format as Format+import qualified Synthesizer.Dimensional.Abstraction.RateIndependent as Ind++import qualified Synthesizer.Dimensional.RatePhantom as RP+import qualified Synthesizer.Dimensional.Straight.Signal as SigS++import qualified Synthesizer.State.Filter.NonRecursive as Filt+import qualified Synthesizer.State.Signal as Sig++import qualified Synthesizer.Generic.Filter.NonRecursive as FiltG+import qualified Synthesizer.Generic.Signal as SigG+import qualified Synthesizer.Generic.SampledValue as Sample++import qualified Number.DimensionTerm        as DN+import qualified Algebra.DimensionTerm       as Dim++import qualified Algebra.Module         as Module+import qualified Algebra.Field          as Field+import qualified Algebra.Ring           as Ring++-- import Number.DimensionTerm ((&/&))+++import NumericPrelude+import PreludeBase as P+import Prelude ()+++data T v y sig yv =+   Cons {+        privateAmplitude :: DN.T v y   {-^ scaling of the values -}+      , signal           :: sig yv     {-^ the embedded signal -}+     }+--   deriving (Eq, Show)++instance (Dim.C v, Show y, Format.C sig) => Format.C (T v y sig) where+   format p (Cons amp sig) =+      showParen (p >= 10)+         (showString "amplitudeSignal " . showsPrec 11 amp .+          showString " " . Format.format 11 sig)++instance (Dim.C v, Show y, Show yv, Format.C sig) => Show (T v y sig yv) where+   showsPrec = Format.format++type R s v y yv = RP.T s (S v y) yv+type S v y = T v y (SigS.T Sig.T)  -- kind * -> *++{-+We removed that instance because 'fmap' is too dangerous for application code.+You may write functions that depend on the particular amplitude scaling.++instance Dim.C v => Functor (T v y s) where+   fmap f (Cons amp ss) = Cons amp (map f ss)+-}++{-# INLINE amplitude #-}+amplitude :: (Ind.C w, Dim.C v) =>+   w (T v y sig) yv -> DN.T v y+amplitude = privateAmplitude . Ind.toSignal++{-# INLINE samples #-}+samples :: (Ind.C w, Dim.C v) =>+   w (T v y (SigS.T sig)) yv -> sig yv+samples = privateSamples . Ind.toSignal++{-# INLINE privateSamples #-}+privateSamples :: (Dim.C v) =>+   T v y (SigS.T sig) yv -> sig yv+privateSamples = SigS.samples . signal++{-# INLINE phantomSignal #-}+phantomSignal ::+   RP.T s (T v y sig) yv -> RP.T s sig yv+phantomSignal =+   RP.fromSignal . signal . RP.toSignal+++{-# INLINE toAmplitudeScalar #-}+toAmplitudeScalar :: (Ind.C w, Field.C y, Dim.C v) =>+   w (T v y sig) yv -> DN.T v y -> y+toAmplitudeScalar sig y =+   DN.divToScalar y (amplitude sig)++{-# INLINE scalarSamples #-}+scalarSamples :: (Ind.C w, Ring.C y, Dim.C v) =>+   (DN.T v y -> y) -> w (S v y) y -> Sig.T y+scalarSamples toAmpScalar =+   scalarSamplesPrivate toAmpScalar . Ind.toSignal++{-# INLINE scalarSamplesGeneric #-}+scalarSamplesGeneric ::+   (Ind.C w, Ring.C y, Dim.C v, Sample.C y, SigG.C sig) =>+   (DN.T v y -> y) -> w (T v y (SigS.T sig)) y -> sig y+scalarSamplesGeneric toAmpScalar =+   scalarSamplesPrivateGeneric toAmpScalar . Ind.toSignal++{-# INLINE vectorSamples #-}+vectorSamples :: (Ind.C w, Module.C y yv, Dim.C v) =>+   (DN.T v y -> y) -> w (S v y) yv -> Sig.T yv+vectorSamples toAmpScalar =+   vectorSamplesPrivate toAmpScalar . Ind.toSignal+++{-# INLINE rewriteDimension #-}+rewriteDimension :: (Dim.C v0, Dim.C v1) =>+   (v0 -> v1) -> T v0 y sig yv -> T v1 y sig yv+rewriteDimension f (Cons amp ss) =+   Cons (DN.rewriteDimension f amp) ss+++{-# INLINE fromSignal #-}+fromSignal :: DN.T v y -> SigS.R s yv -> R s v y yv+fromSignal amp  =  RP.fromSignal . Cons amp . RP.toSignal+++{-# INLINE toScalarSignal #-}+toScalarSignal :: (Ind.C w, Field.C y, Dim.C v) =>+   DN.T v y -> w (S v y) y -> w (SigS.T Sig.T) y+toScalarSignal amp  =+   Ind.processSignal+      (SigS.Cons . scalarSamplesPrivate (flip DN.divToScalar amp))++{-# INLINE toVectorSignal #-}+toVectorSignal :: (Ind.C w, Field.C y, Module.C y yv, Dim.C v) =>+   DN.T v y -> w (S v y) yv -> w (SigS.T Sig.T) yv+toVectorSignal amp  =+   Ind.processSignal+      (SigS.Cons . vectorSamplesPrivate (flip DN.divToScalar amp))+++{-# INLINE scalarSamplesPrivate #-}+scalarSamplesPrivate :: (Ring.C y, Dim.C v) =>+   (DN.T v y -> y) -> S v y y -> Sig.T y+scalarSamplesPrivate toAmpScalar sig =+   let y = toAmpScalar (privateAmplitude sig)+   in  Filt.amplify y (privateSamples sig)++{-# INLINE scalarSamplesPrivateGeneric #-}+scalarSamplesPrivateGeneric ::+   (Ring.C y, Dim.C v, Sample.C y, SigG.C sig) =>+   (DN.T v y -> y) -> T v y (SigS.T sig) y -> sig y+scalarSamplesPrivateGeneric toAmpScalar sig =+   let y = toAmpScalar (privateAmplitude sig)+   in  FiltG.amplify y (privateSamples sig)++{-# INLINE vectorSamplesPrivate #-}+vectorSamplesPrivate :: (Module.C y yv, Dim.C v) =>+   (DN.T v y -> y) -> S v y yv -> Sig.T yv+vectorSamplesPrivate toAmpScalar sig =+   let y = toAmpScalar (privateAmplitude sig)+   in  y *> privateSamples sig+++{-# INLINE fromSamples #-}+fromSamples :: DN.T v y -> Sig.T yv -> R s v y yv+fromSamples amp  =  fromSignal amp . SigS.fromSamples++{-# INLINE fromScalarSamples #-}+fromScalarSamples :: DN.T v y -> Sig.T y -> R s v y y+fromScalarSamples  =  fromSamples++{-# INLINE fromVectorSamples #-}+fromVectorSamples :: DN.T v y -> Sig.T yv -> R s v y yv+fromVectorSamples  =  fromSamples++{-# INLINE replaceAmplitude #-}+replaceAmplitude :: (Ind.C w, Dim.C v0, Dim.C v1) =>+   DN.T v1 y -> w (T v0 y sig) yv -> w (T v1 y sig) yv+replaceAmplitude amp  =  Ind.processSignal (replaceAmplitudePrivate amp)++{-# INLINE replaceSamples #-}+replaceSamples :: (Ind.C w, Dim.C v) =>+   sig1 yv1 -> w (T v y sig0) yv0 -> w (T v y (SigS.T sig1)) yv1+replaceSamples ss  =  Ind.processSignal (replaceSamplesPrivate ss)++{-# INLINE replaceAmplitudePrivate #-}+replaceAmplitudePrivate :: (Dim.C v0, Dim.C v1) =>+   DN.T v1 y -> T v0 y sig yv -> T v1 y sig yv+replaceAmplitudePrivate amp  =  Cons amp . signal++{-# INLINE replaceSamplesPrivate #-}+replaceSamplesPrivate :: (Dim.C v) =>+   sig1 yv1 -> T v y sig0 yv0 -> T v y (SigS.T sig1) yv1+replaceSamplesPrivate ss x  =  Cons (privateAmplitude x) (SigS.Cons ss)+++{-# INLINE processSamples #-}+processSamples :: (Ind.C w, Dim.C v) =>+   (sig0 yv0 -> sig1 yv1) ->+   w (T v y (SigS.T sig0)) yv0 -> w (T v y (SigS.T sig1)) yv1+processSamples f =+   Ind.processSignal (processSamplesPrivate f)++{-# INLINE processSamplesPrivate #-}+processSamplesPrivate :: (Dim.C v) =>+   (sig0 yv0 -> sig1 yv1) ->+   T v y (SigS.T sig0) yv0 -> T v y (SigS.T sig1) yv1+processSamplesPrivate f (Cons amp sig) =+   Cons amp (SigS.processSamplesPrivate f sig)+++{-# INLINE asTypeOfAmplitude #-}+asTypeOfAmplitude :: y -> w (T v y sig) yv -> y+asTypeOfAmplitude = const
+ src/Synthesizer/Dimensional/Causal/Process.hs view
@@ -0,0 +1,176 @@+module Synthesizer.Dimensional.Causal.Process where++import qualified Synthesizer.Causal.Process as Causal++import qualified Synthesizer.Dimensional.Amplitude.Signal as SigA++import qualified Algebra.Module as Module+import qualified Algebra.Field  as Field+import Algebra.Module ((*>))++import qualified Number.DimensionTerm        as DN+import qualified Algebra.DimensionTerm       as Dim++import qualified Control.Arrow as Arrow++import Prelude hiding (map, )+++{-+TODO:+This differs from Rate.Process and Amplitude.Signal in the following way:+Here we expect, that @amp@ are types that contain physical units,+whereas Rate.Process.T has separate type variables for unit and values.+Thus Rate.Process.T is limited to DimensionalTerm numbers.+We need the additional flexibility here+because @amp@ can also be a pair of amplitudes+or a more complicated ensemble of amplitudes.+-}+newtype T amp0 amp1 yv0 yv1 =+   Cons (amp0 -> (amp1, Causal.T yv0 yv1))+++{-# INLINE apply #-}+apply :: (Dim.C v0) =>+   T (DN.T v0 y0) (DN.T v1 y1) yv0 yv1 ->+   SigA.R s v0 y0 yv0 -> SigA.R s v1 y1 yv1+apply (Cons f) x =+   let (yAmp, causal) = f (SigA.amplitude x)+   in  SigA.fromSamples yAmp (Causal.apply causal (SigA.samples x))+++{-# INLINE applyFst #-}+applyFst :: (Dim.C v0) =>+   T (DN.T v0 y0, restAmp) (DN.T v1 y1) (yv0, restSamp) yv1 ->+   SigA.R s v0 y0 yv0 ->+   T restAmp (DN.T v1 y1) restSamp yv1+applyFst (Cons f) x =+   Cons $ \yAmp ->+      let (zAmp, causal) = f (SigA.amplitude x, yAmp)+      in  (zAmp, Causal.applyFst causal (SigA.samples x))++{-# INLINE map #-}+map ::+   (amp0 -> amp1) ->+   (yv0 -> yv1) ->+   T amp0 amp1 yv0 yv1+map f g =+   Cons $ \ xAmp -> (f xAmp, Causal.map g)+++infixr 3 ***+infixr 3 &&&+infixr 1 >>>, ^>>, >>^+infixr 1 <<<, ^<<, <<^+++{-# INLINE compose #-}+{-# INLINE (>>>) #-}+compose, (>>>) ::+   T amp0 amp1 yv0 yv1 ->+   T amp1 amp2 yv1 yv2 ->+   T amp0 amp2 yv0 yv2+compose (Cons f) (Cons g) =+   Cons $ \ xAmp ->+      let (yAmp, causalXY) = f xAmp+          (zAmp, causalYZ) = g yAmp+      in  (zAmp, Causal.compose causalXY causalYZ)++(>>>) = compose++{-# INLINE (<<<) #-}+(<<<) ::+   T amp1 amp2 yv1 yv2 ->+   T amp0 amp1 yv0 yv1 ->+   T amp0 amp2 yv0 yv2+(<<<) = flip (>>>)+++{-# INLINE first #-}+first ::+   T amp0 amp1 yv0 yv1 ->+   T (amp0, amp) (amp1, amp) (yv0, yv) (yv1, yv)+first (Cons f) =+   Cons $ \ (xAmp, amp) ->+      let (yAmp, causal) = f xAmp+      in  ((yAmp, amp), Causal.first causal)++{-# INLINE second #-}+second ::+   T amp0 amp1 yv0 yv1 ->+   T (amp, amp0) (amp, amp1) (yv, yv0) (yv, yv1)+second (Cons f) =+   Cons $ \ (amp, xAmp) ->+      let (yAmp, causal) = f xAmp+      in  ((amp, yAmp), Causal.second causal)++{-# INLINE split #-}+{-# INLINE (***) #-}+split, (***) ::+   T amp0 amp1 yv0 yv1 ->+   T amp2 amp3 yv2 yv3 ->+   T (amp0, amp2) (amp1, amp3) (yv0, yv2) (yv1, yv3)+split f g =+   compose (first f) (second g)++(***) = split++{-# INLINE fanout #-}+{-# INLINE (&&&) #-}+fanout, (&&&) ::+   T amp amp0 yv yv0 ->+   T amp amp1 yv yv1 ->+   T amp (amp0, amp1) yv (yv0, yv1)+fanout f g =+   compose (map (\amp -> (amp,amp)) (\y -> (y,y))) (split f g)++(&&&) = fanout+++{-# INLINE (^>>) #-}+-- | Precomposition with a pure function.+(^>>) ::+   (amp0 -> amp1, yv0 -> yv1) ->+   T amp1 amp2 yv1 yv2 ->+   T amp0 amp2 yv0 yv2+f ^>> a = uncurry map f >>> a++{-# INLINE (>>^) #-}+-- | Postcomposition with a pure function.+(>>^) ::+   T amp0 amp1 yv0 yv1 ->+   (amp1 -> amp2, yv1 -> yv2) ->+   T amp0 amp2 yv0 yv2+a >>^ f = a >>> uncurry map f++{-# INLINE (<<^) #-}+-- | Precomposition with a pure function (right-to-left variant).+(<<^) ::+   T amp1 amp2 yv1 yv2 ->+   (amp0 -> amp1, yv0 -> yv1) ->+   T amp0 amp2 yv0 yv2+a <<^ f = a <<< uncurry map f++{-# INLINE (^<<) #-}+-- | Postcomposition with a pure function (right-to-left variant).+(^<<) ::+   (amp1 -> amp2, yv1 -> yv2) ->+   T amp0 amp1 yv0 yv1 ->+   T amp0 amp2 yv0 yv2+f ^<< a = uncurry map f <<< a++++{-# INLINE loop #-}+-- loop :: a (b, d) (c, d) -> a b c+loop ::+   (Field.C y, Module.C y yv, Dim.C v) =>+   DN.T v y ->+   T (restAmp0, DN.T v y) (restAmp1, DN.T v y) (restSamp0, yv) (restSamp1, yv) ->+   T restAmp0 restAmp1 restSamp0 restSamp1+loop ampIn (Cons f) =+   Cons $ \restAmp0 ->+      let ((restAmp1, ampOut), causal) = f (restAmp0, ampIn)+      in  (restAmp1,+           Causal.loop (causal Arrow.>>^+              Arrow.second (DN.divToScalar ampOut ampIn *>)))
+ src/Synthesizer/Dimensional/ControlledProcess.hs view
@@ -0,0 +1,154 @@+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes (OccasionallyScalar)+               and local universal quantification+++Basic definitions for signal processors+which are controlled by another signal.+If a control curve is expensive to compute,+or, what happens more frequently,+the conversion from natural control parameters+to internal control parameters is expensive,+then it can be more efficient to compute the control curve at a lower rate+and interpolate the internal control parameters of a particular process.+CSound and SuperCollider have a sample rate+that is common to all control curves+and they use constant interpolation exclusively.+-}+module Synthesizer.Dimensional.ControlledProcess where++import qualified Synthesizer.Dimensional.Process as Proc+import qualified Synthesizer.Dimensional.Rate as Rate+import qualified Synthesizer.Dimensional.RatePhantom as RP+import qualified Synthesizer.Dimensional.RateWrapper as SigP+-- import qualified Synthesizer.Dimensional.Straight.Signal as SigS+-- import qualified Synthesizer.Dimensional.Amplitude.Signal as SigA+import qualified Synthesizer.Causal.Process       as Causal+import qualified Synthesizer.Causal.Interpolation as Interpolation+import qualified Synthesizer.State.Signal as Sig+import qualified Number.DimensionTerm        as DN+import qualified Algebra.DimensionTerm       as Dim++-- import Synthesizer.Dimensional.Process (($:), ($#), )+-- import Synthesizer.Dimensional.RateAmplitude.Signal (($-))++-- import Number.DimensionTerm ((*&), ) -- ((&*&), (&/&))++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 qualified Control.Applicative as App+import Control.Applicative (Applicative)+-}++import NumericPrelude+{-+import PreludeBase as P+-}+++{- |+@ec@ is the type for the curve of external control parameters,+@ic@ for internal control parameters.+-}+newtype T s u t ec ic a = Cons {+      process :: Proc.T s u t (ec -> Sig.T ic, Sig.T ic -> a)+   }+++{-# INLINE runSynchronous #-}+runSynchronous ::+   T s u t ec ic a ->+   Proc.T s u t (ec -> a)+runSynchronous cp =+   do (convert, func) <- process cp+      return (func . convert)++{-# INLINE runSynchronous1 #-}+runSynchronous1 ::+   T s u t (RP.T s sig0 ec0) ic a ->+   Proc.T s u t (RP.T s sig0 ec0 -> a)+runSynchronous1 = runSynchronous++{-# INLINE runSynchronous2 #-}+runSynchronous2 ::+   T s u t (RP.T s sig0 ec0, RP.T s sig1 ec1) ic a ->+   Proc.T s u t (RP.T s sig0 ec0 -> RP.T s sig1 ec1 -> a)+runSynchronous2 = fmap curry . runSynchronous++{-# INLINE runSynchronous3 #-}+runSynchronous3 ::+   T s u t (RP.T s sig0 ec0, RP.T s sig1 ec1, RP.T s sig2 ec2) ic a ->+   Proc.T s u t (RP.T s sig0 ec0 -> RP.T s sig1 ec1 -> RP.T s sig2 ec2 -> a)+runSynchronous3 =+   fmap (\f x y z -> f (x,y,z)) . runSynchronous++++{-# INLINE runAsynchronous #-}+runAsynchronous ::+   (Dim.C u, Additive.C ic, RealField.C t) =>+   Interpolation.T t ic ->+   T s u t ec ic a ->+   Rate.T r u t ->+   ec ->+   Proc.T s u t a+runAsynchronous ip cp srcRate sig =+   do (convert, func) <- process cp+      k <- fmap+              (DN.divToScalar (Rate.toDimensionNumber srcRate))+              Proc.getSampleRate+      return+         (func (Causal.apply+                   (Interpolation.relativeConstantPad ip zero (convert sig))+                   (Sig.repeat k)))++{-# INLINE runAsynchronous1 #-}+runAsynchronous1 ::+   (Dim.C u, Additive.C ic, RealField.C t) =>+   Interpolation.T t ic ->+   T s u t (RP.T r sig0 ec0) ic a ->+   SigP.T u t sig0 ec0 ->+   Proc.T s u t a+runAsynchronous1 ip cp x =+   uncurry (runAsynchronous ip cp) (SigP.toSignal x)++{-# INLINE runAsynchronous2 #-}+runAsynchronous2 ::+   (Dim.C u, Additive.C ic, RealField.C t) =>+   Interpolation.T t ic ->+   T s u t (RP.T r sig0 ec0, RP.T r sig1 ec1) ic a ->+   SigP.T u t sig0 ec0 ->+   SigP.T u t sig1 ec1 ->+   Proc.T s u t a+runAsynchronous2 ip cp x y =+   let (srcRateX,sigX) = SigP.toSignal x+       (srcRateY,sigY) = SigP.toSignal y+       srcRate = Rate.common "ControlledProcess.runAsynchronous2" srcRateX srcRateY+   in  runAsynchronous ip cp srcRate (sigX,sigY)++{-# INLINE runAsynchronous3 #-}+runAsynchronous3 ::+   (Dim.C u, Additive.C ic, RealField.C t) =>+   Interpolation.T t ic ->+   T s u t (RP.T r sig0 ec0, RP.T r sig1 ec1, RP.T r sig2 ec2) ic a ->+   SigP.T u t sig0 ec0 ->+   SigP.T u t sig1 ec1 ->+   SigP.T u t sig2 ec2 ->+   Proc.T s u t a+runAsynchronous3 ip cp x y z =+   let (srcRateX,sigX) = SigP.toSignal x+       (srcRateY,sigY) = SigP.toSignal y+       (srcRateZ,sigZ) = SigP.toSignal z+       common = Rate.common "ControlledProcess.runAsynchronous3"+       srcRate = srcRateX `common` srcRateY `common` srcRateZ+   in  runAsynchronous ip cp srcRate (sigX,sigY,sigZ)
+ src/Synthesizer/Dimensional/Cyclic/Signal.hs view
@@ -0,0 +1,95 @@+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++Signals equipped with a phantom type parameter that reflects the sample rate.+-}+module Synthesizer.Dimensional.Cyclic.Signal where++import qualified Synthesizer.Format as Format+import qualified Synthesizer.Dimensional.RatePhantom as RP++import qualified Synthesizer.Dimensional.Straight.Signal as SigS+import qualified Synthesizer.State.Signal as Sig++-- import qualified Number.DimensionTerm        as DN+-- import qualified Algebra.DimensionTerm       as Dim++{-+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 Number.DimensionTerm ((&/&))+++import NumericPrelude+import PreludeBase+import Prelude ()+++newtype T seq yv =+   Cons {+       samples :: seq yv   {-^ the sampled values -}+     }+--   deriving (Eq, Show)++instance Functor seq => Functor (T seq) where+   fmap f = Cons . fmap f . samples++instance Format.C seq => Format.C (T seq) where+   format p = Format.format p . samples++instance (Format.C seq, Show y) => Show (T seq y) where+   showsPrec = Format.format+++type R s yv = RP.T s (T Sig.T) yv+++{-+replaceSamples :: Sig.T yv1 -> R s yv0 -> R s yv1+replaceSamples ss _  =  fromSamples ss+++processSamples ::+   (Sig.T yv0 -> Sig.T yv1) -> R s yv0 -> R s yv1+processSamples f x =+   replaceSamples (f $ samples $ RP.toSignal x) x+-}+++{-# INLINE fromPeriod #-}+fromPeriod :: Sig.T yv -> R s yv+fromPeriod  =  RP.fromSignal . Cons++{-# INLINE fromPeriodList #-}+fromPeriodList :: [yv] -> R s yv+fromPeriodList  =  fromPeriod . Sig.fromList++{-# INLINE toPeriod #-}+toPeriod :: R s yv -> Sig.T yv+toPeriod  =  samples . RP.toSignal+++{- |+Periodization of a straight signal.+-}+{-# INLINE fromSignal #-}+fromSignal :: Additive.C yv => Int -> SigS.R s yv -> R s yv+fromSignal n  =+   fromPeriod . sum . Sig.sliceVert n . SigS.toSamples++{- |+Convert a cyclic signal to a straight signal containing a loop.+-}+{-# INLINE toSignal #-}+toSignal :: Additive.C yv => R s yv -> SigS.R s yv+toSignal  =+   SigS.fromSamples . Sig.cycle . toPeriod
+ src/Synthesizer/Dimensional/Process.hs view
@@ -0,0 +1,162 @@+{-# OPTIONS -fglasgow-exts #-}+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes+               and local universal quantification+++Light-weight sample parameter inference which will fit most needs.+We only do \"poor man's inference\", only for sample rates.+The sample rate will be provided as an argument of a special type 'T'.+This argument will almost never be passed explicitly+but should be handled by operators analogous to '($)' and '(.)'.++In contrast to the run-time inference approach,+we have the static guarantee that the sample rate is fixed+before passing a signal to the outside world.+However we still need to make it safe that signals+that are rendered for one sample rate+are not processed with another sample rate.+-}+module Synthesizer.Dimensional.Process (+      T(..),+      run, {-share,-} withParam, getSampleRate,+      toTimeScalar,    toFrequencyScalar,+      toTimeDimension, toFrequencyDimension,+      loop, pure,+      ($:), ($::), ($^), ($#),+      (.:), (.^),+      liftP, liftP2, liftP3, liftP4,+   ) where++import qualified Synthesizer.Dimensional.Rate as Rate+import qualified Number.DimensionTerm        as DN+import qualified Algebra.DimensionTerm       as Dim++import Number.DimensionTerm ((*&), ) -- ((&*&), (&/&))++import qualified Algebra.Field          as Field+import qualified Algebra.Ring           as Ring++import Control.Monad.Fix (MonadFix(mfix), )+-- import Control.Monad.Reader ()+import Synthesizer.ApplicativeUtility+import qualified Control.Applicative as App+import Control.Applicative (Applicative)+++{-+import NumericPrelude+import PreludeBase as P+-}+++{- |+This wraps a function which computes a sample rate dependent result.+Sample rate tells how many values per unit are stored+for representation of a signal.++The process is labeled with a type variable @s@ which is part the signals.+This way we can ensure that signals are only used+with the sample rate they are created for.+-}+newtype T s u t a = Cons {process :: Rate.T s u t -> a}++instance Functor (T s u t) where+   fmap f (Cons g) = Cons (f . g)++instance Applicative (T s u t) where+   pure  = pure+   (<*>) = apply++instance Monad (T s u t) where+   return = pure+   (>>=)  = bind++instance MonadFix (T s u t) where+   mfix = loop . withParam+++{-# INLINE pure #-}+pure :: a -> T s u t a+pure = Cons . const++{-# INLINE apply #-}+apply :: T s u t (a -> b) -> T s u t a -> T s u t b+apply (Cons f) arg = Cons $ \sr -> f sr (process arg sr)+++{- |+Get results from the Process monad.+You can obtain only signals (or other values)+that do not implicitly depend on the sample rate,+that is value without the @s@ type parameter.+-}+{-# INLINE run #-}+run :: (Dim.C u) => DN.T (Dim.Recip u) t -> (forall s. T s u t a) -> a+run sampleRate f = process f (Rate.fromDimensionNumber sampleRate)++{-+{- |+You can write+@x >>= (\x0 -> Cut.zip $# x0 $# x0)@+or+@share x (\x0 -> Cut.zip $: x0 $: x0)@.+'share' allows for more consistent usage of @($:)@.+-}+share :: T s u t a -> (T s u t a -> T s u t b) -> T s u t b+share x y  =  y . return =<< x+-}++{-# INLINE bind #-}+bind :: T s u t a -> (a -> T s u t b) -> T s u t b+bind (Cons f) mg =+   Cons $ \ sr -> process (mg (f sr)) sr++-- same as Inference.Reader.Process.injectParam+{-# INLINE withParam #-}+withParam :: (a -> T s u t b) -> T s u t (a -> b)+withParam f = Cons (\sr a -> process (f a) sr)+++{-# INLINE getSampleRate #-}+getSampleRate :: Dim.C u => T s u t (DN.T (Dim.Recip u) t)+getSampleRate = Cons Rate.toDimensionNumber+++{-# INLINE toTimeScalar #-}+toTimeScalar {- , (~*&) -} :: (Ring.C t, Dim.C u) =>+   DN.T u t -> T s u t t+toTimeScalar time =+   fmap (DN.mulToScalar time) getSampleRate++{-# INLINE toFrequencyScalar #-}+toFrequencyScalar {- , (~/&) -} :: (Field.C t, Dim.C u) =>+   DN.T (Dim.Recip u) t -> T s u t t+toFrequencyScalar freq =+   fmap (DN.divToScalar freq) getSampleRate+++{-# INLINE toTimeDimension #-}+toTimeDimension :: (Field.C t, Dim.C u) =>+   t -> T s u t (DN.T u t)+toTimeDimension t =+   fmap (\sampleRate -> t *& DN.unrecip sampleRate) getSampleRate++{-# INLINE toFrequencyDimension #-}+toFrequencyDimension :: (Ring.C t, Dim.C u) =>+   t -> T s u t (DN.T (Dim.Recip u) t)+toFrequencyDimension f =+   fmap (\sampleRate -> f *& sampleRate) getSampleRate+++{-+infixl 7 ~*&, ~/&++(~*&) = toTimeScalar+(~/&) = toFrequencyScalar+-}
+ src/Synthesizer/Dimensional/Rate.hs view
@@ -0,0 +1,71 @@+{- |++Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++++Light-weight sample parameter inference which will fit most needs.+We only do \"poor man's inference\", only for sample rates.+The sample rate will be provided as an argument of a special type 'T'.+This argument will almost never be passed explicitly+but should be handled by operators analogous to '($)' and '(.)'.++In contrast to the run-time inference approach,+we have the static guarantee that the sample rate is fixed+before passing a signal to the outside world.+However we still need to make it safe that signals+that are rendered for one sample rate+are not processed with another sample rate.+We should wrap @T s u t -> a@ in a @Reader@ monad, but that's not all.+We must investigate a little more here.+Maybe we need another type parameter for the sample rate and the signals+in order to show that they belong together,+like it is done in the ST monad.+-}+module Synthesizer.Dimensional.Rate where++import qualified Number.DimensionTerm        as DN+import qualified Algebra.DimensionTerm       as Dim++import qualified Synthesizer.Utility as Util++{-+import NumericPrelude+import PreludeBase as P+-}+++{- |+This wraps a function which computes a sample rate dependent result.+Sample rate tells how many values per unit are stored+for representation of a signal.+-}+newtype T s u t = Cons {decons :: DN.T (Dim.Recip u) t}+   deriving (Eq, Ord, Show)+++{-# INLINE fromNumber #-}+fromNumber :: Dim.C u => Dim.Recip u -> t -> T s u t+fromNumber u = Cons . DN.fromNumberWithDimension u++{-# INLINE toNumber #-}+toNumber :: Dim.C u => Dim.Recip u -> T s u t -> t+toNumber u = DN.toNumberWithDimension u . decons++{-# INLINE fromDimensionNumber #-}+fromDimensionNumber :: Dim.C u => DN.T (Dim.Recip u) t -> T s u t+fromDimensionNumber = Cons++{-# INLINE toDimensionNumber #-}+toDimensionNumber :: Dim.C u => T s u t -> DN.T (Dim.Recip u) t+toDimensionNumber = decons++{-# INLINE common #-}+common :: Eq t => String -> T s u t -> T s u t -> T s u t+common funcName =+   Util.common ("Sample rates differ in " ++ funcName)
+ src/Synthesizer/Dimensional/Rate/Analysis.hs view
@@ -0,0 +1,79 @@+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes+-}+module Synthesizer.Dimensional.Rate.Analysis (+    centroid,+    length,++    centroidProc,+    lengthProc,+  ) where++import qualified Synthesizer.Dimensional.Straight.Signal as SigS+import qualified Synthesizer.Dimensional.RateWrapper     as SigP++import qualified Synthesizer.State.Analysis as Ana+import qualified Synthesizer.State.Signal   as Sig++import qualified Synthesizer.Dimensional.Process as Proc++import qualified Number.DimensionTerm        as DN+import qualified Algebra.DimensionTerm       as Dim++import Number.DimensionTerm ((*&))++import qualified Algebra.Field               as Field+-- import qualified Algebra.Real                as Real+-- import qualified Algebra.Ring                as Ring+++import PreludeBase ((.), ($), )+import NumericPrelude+import Prelude ()++++{-# INLINE centroid #-}+centroid :: (Field.C q, Dim.C u) =>+   SigP.T u q (SigS.T Sig.T) q -> DN.T u q+centroid = makePhysicalLength Ana.centroid++{-# INLINE length #-}+length :: (Field.C t, Dim.C u) =>+   SigP.T u t (SigS.T Sig.T) yv -> DN.T u t+length = makePhysicalLength (fromIntegral . Sig.length)++{-# INLINE makePhysicalLength #-}+makePhysicalLength :: (Field.C t, Dim.C u) =>+   (Sig.T y -> t) ->+   SigP.T u t (SigS.T Sig.T) y -> DN.T u t+makePhysicalLength f x =+   f (SigS.samples (SigP.signal x))  *&  DN.unrecip (SigP.sampleRate x)+++{-# DEPRECATED #-}+{-# INLINE centroidProc #-}+centroidProc :: (Field.C y, Dim.C u) =>+   Proc.T s u y (SigS.R s y -> DN.T u y)+centroidProc = makePhysicalLengthProc Ana.centroid++{-# DEPRECATED #-}+{-# INLINE lengthProc #-}+lengthProc :: (Field.C y, Dim.C u) =>+   Proc.T s u y (SigS.R s y -> DN.T u y)+lengthProc = makePhysicalLengthProc (fromIntegral . Sig.length)++{-# INLINE makePhysicalLengthProc #-}+makePhysicalLengthProc :: (Field.C t, Dim.C u) =>+   (Sig.T y -> t) ->+   Proc.T s u t (+     SigS.R s y ->+     DN.T u t)+makePhysicalLengthProc f =+   Proc.withParam $+      Proc.toTimeDimension . f . SigS.toSamples
+ src/Synthesizer/Dimensional/Rate/Control.hs view
@@ -0,0 +1,83 @@+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes+++Control curves which can be used+as envelopes, for controlling filter parameters and so on.+-}+module Synthesizer.Dimensional.Rate.Control+   ({- * Primitives -}+    constant, linear, exponential, exponential2, )+   where++import qualified Synthesizer.Dimensional.Straight.Signal as SigS++import qualified Synthesizer.State.Control as Ctrl+-- import qualified Synthesizer.State.Signal  as Sig++import qualified Synthesizer.Dimensional.Process as Proc++-- import Synthesizer.Dimensional.Process (($#), )++import qualified Number.DimensionTerm        as DN+import qualified Algebra.DimensionTerm       as Dim++-- import Number.DimensionTerm ((&*&))++import qualified Algebra.Transcendental     as Trans+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 PreludeBase+import Prelude ()+++{-# INLINE constant #-}+constant :: (Ring.C y, Dim.C u) =>+   Proc.T s u t (SigS.R s y)+constant = Proc.pure $ SigS.fromSamples $ Ctrl.constant one++{- |+Caution: This control curve can contain samples+with an absolute value greater than 1.+The linear curve starts with zero.+-}+{-# INLINE linear #-}+linear ::+   (Field.C q, Dim.C u) =>+      DN.T u q {-^ distance until curve reaches one -}+   -> Proc.T s u q (SigS.R s q)+linear dist =+   fmap+      (SigS.fromSamples . Ctrl.linearMultiscaleNeutral . recip)+      (Proc.toTimeScalar dist)++{-# INLINE exponential #-}+exponential :: (Trans.C q, Dim.C u) =>+      DN.T u q {-^ time where the function reaches 1\/e of the initial value -}+   -> Proc.T s u q (SigS.R s q)+exponential time =+   fmap+      (SigS.fromSamples . Ctrl.exponentialMultiscaleNeutral)+      (Proc.toTimeScalar time)++{-+  take 1000 $ show (run (fixSampleRate 100 (exponential 0.1 1)) :: SigDouble)+-}++{-# INLINE exponential2 #-}+exponential2 :: (Trans.C q, Dim.C u) =>+      DN.T u q {-^ half life, time where the function reaches 1\/2 of the initial value -}+   -> Proc.T s u q (SigS.R s q)+exponential2 time =+   fmap+      (SigS.fromSamples . Ctrl.exponential2MultiscaleNeutral)+      (Proc.toTimeScalar time)
+ src/Synthesizer/Dimensional/Rate/Cut.hs view
@@ -0,0 +1,55 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes+-}+module Synthesizer.Dimensional.Rate.Cut (+     take, drop,+   ) where++import qualified Synthesizer.Dimensional.Abstraction.Homogeneous as Hom++import qualified Synthesizer.Dimensional.RatePhantom as RP++import qualified Synthesizer.Dimensional.Process as Proc+-- import qualified Synthesizer.Dimensional.Rate as Rate++-- import Synthesizer.Dimensional.Process ((.:), (.^), )++import qualified Synthesizer.Dimensional.RateAmplitude.Signal as SigA+import qualified Synthesizer.State.Signal as Sig++import Synthesizer.Dimensional.RateAmplitude.Signal+   (toTimeScalar, )++import qualified Number.DimensionTerm        as DN+import qualified Algebra.DimensionTerm       as Dim++-- import qualified Number.NonNegative     as NonNeg++import qualified Algebra.RealField      as RealField+-- import qualified Algebra.Field          as Field+++import NumericPrelude hiding (negate)+-- import PreludeBase as P+import Prelude hiding (take, drop, )+++{-# INLINE take #-}+take :: (Hom.C sig, RealField.C t, Dim.C u) =>+   DN.T u t -> Proc.T s u t (RP.T s sig y -> RP.T s sig y)+take t' =+   do t <- toTimeScalar t'+      return $ Hom.processSamples (Sig.take (RealField.round t))++{-# INLINE drop #-}+drop :: (Hom.C sig, RealField.C t, Dim.C u) =>+   DN.T u t -> Proc.T s u t (RP.T s sig y -> RP.T s sig y)+drop t' =+   do t <- toTimeScalar t'+      return $ Hom.processSamples (Sig.drop (RealField.round t))
+ src/Synthesizer/Dimensional/Rate/Filter.hs view
@@ -0,0 +1,579 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes+-}+module Synthesizer.Dimensional.Rate.Filter (+   {- * Non-recursive -}++   {- ** Amplification -}+   negate,+   envelope,+   envelopeVector,+   convolveVector,++   {- ** Smooth -}+   mean,+   meanStatic,++   {- ** Delay -}+   delay,+   phaseModulation,+   phaser,+   phaserStereo,+   frequencyModulation,+   frequencyModulationDecoupled,+++   {- * Recursive -}++   {- ** Without resonance -}+   firstOrderLowpass,+   firstOrderHighpass,+   butterworthLowpass,+   butterworthHighpass,+   chebyshevALowpass,+   chebyshevAHighpass,+   chebyshevBLowpass,+   chebyshevBHighpass,+   {- ** With resonance -}+   universal,+   highpassFromUniversal,+   bandpassFromUniversal,+   lowpassFromUniversal,+   moogLowpass,++   {- ** Allpass -}+   allpassCascade,++   {- ** Reverb -}+   comb,++   {- * Helper functions -}+   interpolateMultiRelativeZeroPad,+) where++-- import qualified Synthesizer.Dimensional.Abstraction.Linear as Lin+import qualified Synthesizer.Dimensional.Abstraction.Homogeneous as Hom+-- import qualified Synthesizer.Dimensional.Abstraction.RateIndependent as Ind+import qualified Synthesizer.Dimensional.Abstraction.Flat as Flat++import qualified Synthesizer.Dimensional.RatePhantom as RP++import qualified Synthesizer.Dimensional.Amplitude.Filter       as FiltV+import qualified Synthesizer.Dimensional.Process as Proc+-- import qualified Synthesizer.Dimensional.Rate as Rate++-- import Synthesizer.Dimensional.Process ((.:), (.^), )++import qualified Synthesizer.Dimensional.Straight.Signal      as SigS+import qualified Synthesizer.Dimensional.RateAmplitude.Signal as SigA+import qualified Synthesizer.Dimensional.RateWrapper      as SigP+import qualified Synthesizer.State.Signal as Sig+import Synthesizer.Plain.Signal (Modifier)++import Synthesizer.Dimensional.RateAmplitude.Signal+   (toTimeScalar, toFrequencyScalar, )++import qualified Synthesizer.Causal.Process       as Causal+import qualified Synthesizer.Causal.Interpolation as Interpolation+import qualified Synthesizer.State.Displacement as Disp+import qualified Synthesizer.State.Filter.Delay as Delay+import qualified Synthesizer.State.Filter.Recursive.MovingAverage as MA+import qualified Synthesizer.State.Filter.NonRecursive as FiltNR++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.Butterworth as Butter+import qualified Synthesizer.Plain.Filter.Recursive.Chebyshev   as Cheby+import qualified Synthesizer.Plain.Filter.Recursive    as FiltR++import qualified Synthesizer.Storable.Signal as SigSt+import qualified Synthesizer.Storable.Filter.Recursive.Comb as Comb++-- import qualified Synthesizer.Generic.Interpolation as InterpolationG+import qualified Synthesizer.Generic.Filter.Recursive.MovingAverage as MAG+import qualified Synthesizer.Generic.Filter.NonRecursive as FiltG+import qualified Synthesizer.Generic.Filter.Delay as DelayG+import qualified Synthesizer.Generic.Signal as SigG+import qualified Synthesizer.Generic.SampledValue as Sample++import qualified Synthesizer.Frame.Stereo as Stereo++import qualified Number.DimensionTerm        as DN+import qualified Algebra.DimensionTerm       as Dim++import qualified Number.NonNegative     as NonNeg++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 Algebra.VectorSpace    as VectorSpace+import qualified Algebra.Module         as Module++-- import Synthesizer.Utility(clip)++-- import qualified Data.List as List++-- import Control.Monad(liftM2)++import NumericPrelude hiding (negate)+import PreludeBase as P+import Prelude ()+++{-# INLINE negate #-}+negate :: (Hom.C sig, Additive.C yv, Dim.C u) =>+      Proc.T s u t (+        RP.T s sig yv+     -> RP.T s sig yv)+negate = Proc.pure FiltV.negate+++{-# INLINE envelope #-}+envelope :: (Hom.C sig, Flat.C flat y0, Ring.C y0, Dim.C u) =>+      Proc.T s u t (+        RP.T s flat y0        {- v the envelope -}+     -> RP.T s sig y0         {- v the signal to be enveloped -}+     -> RP.T s sig y0)+envelope = Proc.pure FiltV.envelope++{-# INLINE envelopeVector #-}+envelopeVector ::+   (Hom.C sig, Flat.C flat y0, Module.C y0 yv, Dim.C u) =>+      Proc.T s u t (+        RP.T s flat y0        {- v the envelope -}+     -> RP.T s sig yv         {- v the signal to be enveloped -}+     -> RP.T s sig yv)+envelopeVector = Proc.pure FiltV.envelopeVector++{-# INLINE convolveVector #-}+convolveVector ::+   (Hom.C sig, Module.C q yv, Field.C q, Dim.C u, Sample.C q) =>+      Proc.T s u q (+        SigA.R s (Dim.Recip u) q q+                              {- v the filter window -}+     -> RP.T s sig yv         {- v the signal to be enveloped -}+     -> RP.T s sig yv)+convolveVector =+   do toFreq <- Proc.withParam toFrequencyScalar+      return $ \ window ->+         Hom.processSamples+            (FiltNR.generic (SigA.scalarSamples toFreq window))+++{- | needs a better handling of boundaries, yet -}+{-# INLINE meanStatic #-}+meanStatic :: (Hom.C sig, Additive.C yv, RealField.C q,+         Module.C q yv, Dim.C u) =>+      DN.T (Dim.Recip u) q    {- ^ cut-off freqeuncy -}+   -> Proc.T s u q (+        RP.T s sig yv+     -> RP.T s sig yv)+meanStatic freq =+   do f <- toFrequencyScalar freq+      return $+         let tInt  = round ((recip f - 1)/2)+             width = tInt*2+1+         in  Hom.processSamples+                ((asTypeOf (recip (fromIntegral width)) f *> ) .+                 Delay.staticNeg tInt .+                 MA.sumsStaticInt width)++{- | needs a better handling of boundaries, yet -}+{-# INLINE mean #-}+mean :: (Hom.C sig, Additive.C yv, RealField.C q,+         Module.C q yv, Dim.C u, Sample.C q, Sample.C yv) =>+      DN.T (Dim.Recip u) q    {- ^ minimum cut-off freqeuncy -}+   -> Proc.T s u q (+        SigA.R s (Dim.Recip u) q q+                              {- v cut-off freqeuncies -}+     -> RP.T s sig yv+     -> RP.T s sig yv)+mean minFreq =+   do mf <- toFrequencyScalar minFreq+      frequencyControl $ \ freqs ->+         let tMax   = ceiling (recip (2*mf))+             err    = error "Filter.mean: frequencies must be positive"+             widths = Sig.map (\f -> if f>0 then recip (2*f) else err) freqs+         in  Hom.processSamples+                (fromStorable .+--                 MAG.sumsStaticInt tMax .+                 MAG.modulatedFrac tMax (toStorable widths) .+                 toStorable)++{-# INLINE delay #-}+delay :: (Hom.C sig, Additive.C yv, RealField.C t, Dim.C u) =>+      DN.T u t+   -> Proc.T s u t (+        RP.T s sig yv+     -> RP.T s sig yv)+delay time =+   do t <- toTimeScalar time+      return $ Hom.processSamples (Delay.static (round t))+++{-# INLINE toStorable #-}+toStorable :: (Sample.C a) => Sig.T a -> SigSt.T a+toStorable = Sig.toStorableSignal SigSt.defaultChunkSize++{-# INLINE fromStorable #-}+fromStorable :: (Sample.C a) => SigSt.T a -> Sig.T a+fromStorable = Sig.fromStorableSignal++{-# INLINE phaseModulation #-}+phaseModulation ::+   (Hom.C sig, Additive.C yv, RealField.C q, Dim.C u,+    Sample.C q, Sample.C yv) =>+      Interpolation.T q yv+   -> DN.T u q+          {- ^ minimal deviation from current time, usually negative -}+   -> DN.T u q+          {- ^ maximal deviation, it must be @minDev <= maxDev@+               and the modulation must always be+               in the range [minDev,maxDev]. -}+   -> Proc.T s u q (+        SigA.R s u q q+          {- v deviation control,+               positive numbers meanStatic prefetch,+               negative numbers meanStatic delay -}+     -> RP.T s sig yv+     -> RP.T s sig yv)+phaseModulation ip minDev maxDev =+   fmap+      (\f devs ->+         Hom.processSamples+            (Sig.fromStorableSignal .+             f (SigA.processSamples toStorable devs) .+             toStorable))+      (phaseModulationGeneric ip minDev maxDev)++{-# INLINE phaseModulationGeneric #-}+phaseModulationGeneric ::+   (Additive.C yv, RealField.C q, Dim.C u,+    Sample.C q, Sample.C yv, SigG.C sig) =>+      Interpolation.T q yv+   -> DN.T u q+          {- ^ minimal deviation from current time, usually negative -}+   -> DN.T u q+          {- ^ maximal deviation, it must be @minDev <= maxDev@+               and the modulation must always be+               in the range [minDev,maxDev]. -}+   -> Proc.T s u q (+        RP.T s (SigA.T u q (SigS.T sig)) q+          {- v deviation control,+               positive numbers meanStatic prefetch,+               negative numbers meanStatic delay -}+     -> sig yv+     -> sig yv)+phaseModulationGeneric ip minDev _maxDev =+   fmap+      (\toTime devs ->+          let t0    = toTime minDev+              tInt0 = floor t0+          in  DelayG.modulated (Interpolation.toGeneric ip) tInt0+                 (SigG.map (max t0) (SigA.scalarSamplesGeneric toTime devs)))+      (Proc.withParam toTimeScalar)+++{-+FIXME: move to Dimensional.Straight+-}+{-# INLINE frequencyModulation #-}+frequencyModulation ::+   (Hom.C sig, Flat.C flat q, Additive.C yv, RealField.C q, Dim.C u) =>+      Interpolation.T q yv+   -> Proc.T s u q (+        RP.T s flat q    {- v frequency factors -}+     -> RP.T s sig yv+     -> RP.T s sig yv)+frequencyModulation ip =+   Proc.pure $+      \ factors ->+          Hom.processSamples+             (interpolateMultiRelativeZeroPad ip (Flat.toSamples factors))++{- |+Frequency modulation where the input signal can have a sample rate+different from the output.+(The sample rate values can differ, the unit must be the same.+We could lift that restriction,+but then the unit handling becomes more complicated,+and I didn't have a use for it so far.)++The function can be used for resampling.+-}+{-# INLINE frequencyModulationDecoupled #-}+frequencyModulationDecoupled ::+   (Additive.C yv, RealField.C q, Dim.C u) =>+      Interpolation.T q yv+   -> Proc.T s u q (+        SigS.R s q {- v frequency factors -}+     -> SigP.T u q (SigS.T Sig.T) yv+     -> SigS.R s yv)+frequencyModulationDecoupled ip =+   fmap+      (\toFreq factors y ->+         flip SigS.processSamples (RP.fromSignal (SigP.signal y)) $+            (interpolateMultiRelativeZeroPad ip+               (SigA.scalarSamples toFreq+                  (SigA.fromSignal (SigP.sampleRate y) factors))))+      (Proc.withParam Proc.toFrequencyScalar)++++{-# INLINE interpolateMultiRelativeZeroPad #-}+interpolateMultiRelativeZeroPad ::+    (RealField.C q, Additive.C yv) =>+    Interpolation.T q yv+    -> Sig.T q+    -> Sig.T yv+    -> Sig.T yv+interpolateMultiRelativeZeroPad ip k x =+    Causal.apply (Interpolation.relativeZeroPad zero ip zero x) k++{- | symmetric phaser -}+{-# INLINE phaser #-}+phaser ::+   (Hom.C sig, Additive.C yv, RealField.C q,+    Module.C q yv, Dim.C u,+    Sample.C q, Sample.C yv) =>+      Interpolation.T q yv+   -> DN.T u q  {- ^ maxDev, must be positive -}+   -> Proc.T s u q (+        SigA.R s u q q+                {- v delay control -}+     -> RP.T s sig yv+     -> RP.T s sig yv)+phaser ip maxDev =+   fmap+      (\p devs ->+         Hom.processSamples+            (FiltNR.amplifyVector (SigA.asTypeOfAmplitude 0.5 devs) .+             uncurry Disp.mix . p devs))+      (phaserCore ip maxDev)++{-# INLINE phaserStereo #-}+phaserStereo ::+   (Hom.C sig, Additive.C yv, RealField.C q,+    Module.C q yv, Dim.C u,+    Sample.C q, Sample.C yv) =>+      Interpolation.T q yv+   -> DN.T u q   {- ^ maxDev, must be positive -}+   -> Proc.T s u q (+        SigA.R s u q q+                 {- v delay control -}+     -> RP.T s sig yv+     -> RP.T s sig (Stereo.T yv))+phaserStereo ip maxDev =+   fmap+      (\p devs ->+            Hom.processSamples (uncurry (Sig.zipWith Stereo.cons) . p devs))+      (phaserCore ip maxDev)++{-# INLINE phaserCore #-}+phaserCore ::+   (Additive.C yv, RealField.C q,+    Module.C q yv, Dim.C u,+    Sample.C q, Sample.C yv) =>+      Interpolation.T q yv+   -> DN.T u q   {- ^ maxDev, must be positive -}+   -> Proc.T s u q (+        SigA.R s u q q+                 {- v delay control -}+     -> Sig.T yv+     -> (Sig.T yv, Sig.T yv))+phaserCore ip maxDev =+   do let minDev  = Additive.negate maxDev+      pm <- phaseModulationGeneric ip minDev maxDev+      return $ \ devs x ->+         let devsPos = SigA.processSamples toStorable devs+             devsNeg = SigA.processSamples FiltG.negate devsPos+             xst     = toStorable x+         in  (fromStorable (pm devsPos xst),+              fromStorable (pm devsNeg xst))+++{-# INLINE firstOrderLowpass #-}+{-# INLINE firstOrderHighpass #-}+firstOrderLowpass, firstOrderHighpass ::+   (Hom.C sig, Trans.C q, Module.C q yv, Dim.C u) =>+      Proc.T s u q (+        SigA.R s (Dim.Recip u) q q+                    {- v Control signal for the cut-off frequency. -}+     -> RP.T s sig yv+                    {- v Input signal -}+     -> RP.T s sig yv)+firstOrderLowpass  = firstOrderGen Filt1.lowpassModifier+firstOrderHighpass = firstOrderGen Filt1.highpassModifier++{-# INLINE firstOrderGen #-}+firstOrderGen ::+   (Hom.C sig, Trans.C q, Module.C q yv, Dim.C u) =>+      (Modifier yv (Filt1.Parameter q) yv yv)+   -> Proc.T s u q (+        SigA.R s (Dim.Recip u) q q+     -> RP.T s sig yv+     -> RP.T s sig yv)+firstOrderGen modif =+   frequencyControl $ \ freqs ->+      modifyModulated Filt1.parameter modif freqs+++{-# INLINE butterworthLowpass #-}+{-# INLINE butterworthHighpass #-}+{-# INLINE chebyshevALowpass #-}+{-# INLINE chebyshevAHighpass #-}+{-# INLINE chebyshevBLowpass #-}+{-# INLINE chebyshevBHighpass #-}++butterworthLowpass, butterworthHighpass,+   chebyshevALowpass, chebyshevAHighpass,+   chebyshevBLowpass, chebyshevBHighpass ::+      (Hom.C sig, Trans.C q, VectorSpace.C q yv, Dim.C u) =>+      NonNeg.Int   {- ^ Order of the filter, must be even,+                        the higher the order, the sharper is the separation of frequencies. -}+   -> q            {- ^ The attenuation at the cut-off frequency.+                        Should be between 0 and 1. -}+   -> Proc.T s u q (+        SigA.R s (Dim.Recip u) q q+                      {- v Control signal for the cut-off frequency. -}+     -> RP.T s sig yv {- v Input signal -}+     -> RP.T s sig yv)++butterworthLowpass  = higherOrderNoResoGen Butter.lowpass+butterworthHighpass = higherOrderNoResoGen Butter.highpass+chebyshevALowpass   = higherOrderNoResoGen Cheby.lowpassA+chebyshevAHighpass  = higherOrderNoResoGen Cheby.highpassA+chebyshevBLowpass   = higherOrderNoResoGen Cheby.lowpassB+chebyshevBHighpass  = higherOrderNoResoGen Cheby.highpassB+++{-# INLINE higherOrderNoResoGen #-}+higherOrderNoResoGen ::+   (Hom.C sig, Field.C q, Dim.C u) =>+      (Int -> q -> [q] -> [yv] -> [yv])+   -> NonNeg.Int+   -> q+   -> Proc.T s u q (+        SigA.R s (Dim.Recip u) q q+     -> RP.T s sig yv+     -> RP.T s sig yv)+higherOrderNoResoGen filt order ratio =+   frequencyControl $ \ freqs ->+      Hom.processSampleList (filt (NonNeg.toNumber order) ratio (Sig.toList freqs))++++highpassFromUniversal, bandpassFromUniversal, lowpassFromUniversal ::+   (Hom.C sig, Dim.C u) =>+      Proc.T s u q (+        RP.T s sig (UniFilter.Result yv)+     -> RP.T s sig yv)+highpassFromUniversal = return (Hom.processSamples (Sig.map UniFilter.highpass))+bandpassFromUniversal = return (Hom.processSamples (Sig.map UniFilter.bandpass))+lowpassFromUniversal  = return (Hom.processSamples (Sig.map UniFilter.lowpass))+++{-# INLINE universal #-}+universal ::+   (Hom.C sig, Flat.C flat q, Trans.C q, Module.C q yv, Dim.C u) =>+      Proc.T s u q (+        RP.T s flat q+                    {- v signal for resonance,+                         i.e. factor of amplification at the resonance frequency+                         relatively to the transition band. -}+     -> SigA.R s (Dim.Recip u) q q+                    {- v signal for cut off and band center frequency -}+     -> RP.T s sig yv+                    {- v input signal -}+     -> RP.T s sig (UniFilter.Result yv))+                    {- ^ highpass, bandpass, lowpass filter -}+universal =+   fmap flip $ frequencyControl $ \ freqs reso ->+      let resos = Flat.toSamples reso+      in  modifyModulated+             UniFilter.parameter+             UniFilter.modifier+             (Sig.zipWith FiltR.Pole resos freqs)++{-# INLINE moogLowpass #-}+moogLowpass :: (Hom.C sig, Flat.C flat q, Trans.C q, Module.C q yv, Dim.C u) =>+      NonNeg.Int+   -> Proc.T s u q (+        RP.T s flat q+                   {- v signal for resonance,+                        i.e. factor of amplification at the resonance frequency+                        relatively to the transition band. -}+     -> SigA.R s (Dim.Recip u) q q+                   {- v signal for cut off frequency -}+     -> RP.T s sig yv+     -> RP.T s sig yv)+moogLowpass order =+   fmap flip $ frequencyControl $ \ freqs reso ->+      let resos = Flat.toSamples reso+          orderInt = NonNeg.toNumber order+      in  modifyModulated+             (Moog.parameter orderInt)+             (Moog.lowpassModifier orderInt)+             (Sig.zipWith FiltR.Pole resos freqs)+++{-# INLINE allpassCascade #-}+allpassCascade :: (Hom.C sig, Trans.C q, Module.C q yv, Dim.C u) =>+      NonNeg.Int  {- ^ order, number of filters in the cascade -}+   -> q           {- ^ the phase shift to be achieved for the given frequency -}+   -> Proc.T s u q (+        SigA.R s (Dim.Recip u) q q {- v lowest comb frequency -}+     -> RP.T s sig yv+     -> RP.T s sig yv)+allpassCascade order phase =+   frequencyControl $ \ freqs ->+      let orderInt = NonNeg.toNumber order+      in  modifyModulated+             (Allpass.parameter orderInt phase)+             (Allpass.cascadeModifier orderInt)+             freqs+++{- | Infinitely many equi-delayed exponentially decaying echos. -}+{-# INLINE comb #-}+comb :: (Hom.C sig, RealField.C t, Module.C y yv, Dim.C u, Sample.C yv) =>+   DN.T u t -> y -> Proc.T s u t (RP.T s sig yv -> RP.T s sig yv)+comb time gain =+   do t <- toTimeScalar time+      return $ Hom.processSamples+         (fromStorable . Comb.run (round t) gain . toStorable)+++-- * auxiliary functions++{-# INLINE frequencyControl #-}+frequencyControl :: (Dim.C u, Field.C y) =>+      (Sig.T y -> t)+   -> Proc.T s u y (+        SigA.R s (Dim.Recip u) y y+     -> t)+frequencyControl f =+   do toFreq <- Proc.withParam toFrequencyScalar+      return $ \ freq -> f (SigA.scalarSamples toFreq freq)+++{-# INLINE modifyModulated #-}+modifyModulated :: Hom.C sig =>+   (param -> ctrl) ->+   Modifier state ctrl y0 y1 ->+   Sig.T param ->+   RP.T s sig y0 ->+   RP.T s sig y1+modifyModulated makeParam modif params =+   Hom.processSamples (Sig.modifyModulated modif (Sig.map makeParam params))
+ src/Synthesizer/Dimensional/Rate/Oscillator.hs view
@@ -0,0 +1,218 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++-}+module Synthesizer.Dimensional.Rate.Oscillator (+   {- * Oscillators with constant waveforms -}+   static,+   staticAntiAlias,+   freqMod,+   freqModAntiAlias,+   phaseMod,+   phaseFreqMod,+   shapeMod,+   shapeFreqMod,+   staticSample,+   freqModSample,+) where++import qualified Synthesizer.Dimensional.Abstraction.Flat as Flat++import qualified Synthesizer.Dimensional.RatePhantom as RP++import qualified Synthesizer.State.Oscillator as Osci+import qualified Synthesizer.State.Signal as Sig++import qualified Synthesizer.Basic.WaveSmoothed as WaveSmooth+import qualified Synthesizer.Basic.Wave         as Wave+import qualified Synthesizer.Basic.Phase        as Phase++import qualified Synthesizer.Dimensional.Straight.Signal as SigS+import qualified Synthesizer.Dimensional.Cyclic.Signal as SigC++import qualified Synthesizer.Dimensional.Amplitude.Signal as SigA+import qualified Synthesizer.Dimensional.Process as Proc+import Synthesizer.Dimensional.Process (toFrequencyScalar, )++import qualified Synthesizer.State.Interpolation as Interpolation++import qualified Number.DimensionTerm        as DN+import qualified Algebra.DimensionTerm       as Dim+-- import Number.DimensionTerm ((&*&))++import qualified Algebra.RealField          as RealField+import qualified Algebra.Field              as Field++-- import NumericPrelude+import PreludeBase as P+++{- * Oscillators with constant waveforms -}++{- | oscillator with a functional waveform with constant frequency -}+{-# INLINE static #-}+static :: (RealField.C t, Dim.C u) =>+      Wave.T t y   {- ^ waveform -}+   -> Phase.T t    {- ^ start phase from the range [0,1] -}+   -> DN.T (Dim.Recip u) t+                   {- ^ frequency -}+   -> Proc.T s u t (SigS.R s y)+static wave phase =+   staticAux (SigS.fromSamples . Osci.static wave phase)++{- | oscillator with a functional waveform with constant frequency -}+{-# INLINE staticAntiAlias #-}+staticAntiAlias :: (RealField.C t, Dim.C u) =>+      WaveSmooth.T t y+                   {- ^ waveform -}+   -> Phase.T t    {- ^ start phase from the range [0,1] -}+   -> DN.T (Dim.Recip u) t+                   {- ^ frequency -}+   -> Proc.T s u t (SigS.R s y)+staticAntiAlias wave phase =+   staticAux (SigS.fromSamples . Osci.staticAntiAlias wave phase)++{- | oscillator with a functional waveform with modulated frequency -}+{-# INLINE freqMod #-}+freqMod :: (RealField.C t, Dim.C u) =>+      Wave.T t y   {- ^ waveform -}+   -> Phase.T t    {- ^ start phase from the range [0,1] -}+   -> Proc.T s u t (+        SigA.R s (Dim.Recip u) t t+                   {- v frequency control -}+     -> SigS.R s y)+freqMod wave phase =+   freqModAux (SigS.fromSamples . Osci.freqMod wave phase)++{- | oscillator with a functional waveform with modulated frequency -}+{-# INLINE freqModAntiAlias #-}+freqModAntiAlias :: (RealField.C t, Dim.C u) =>+      WaveSmooth.T t y+                   {- ^ waveform -}+   -> Phase.T t    {- ^ start phase from the range [0,1] -}+   -> Proc.T s u t (+        SigA.R s (Dim.Recip u) t t+                   {- v frequency control -}+     -> SigS.R s y)+freqModAntiAlias wave phase =+   freqModAux (SigS.fromSamples . Osci.freqModAntiAlias wave phase)++{- | oscillator with modulated phase -}+{-# INLINE phaseMod #-}+phaseMod :: (Flat.C flat t, RealField.C t, Dim.C u) =>+      Wave.T t y   {- ^ waveform -}+   -> DN.T (Dim.Recip u) t+                   {- ^ frequency -}+   -> Proc.T s u t (+        RP.T s flat t+                   {- v phase modulation, phases must have no unit and+                        are from range [0,1] -}+     -> SigS.R s y)+phaseMod wave =+   staticAux (\freq -> SigS.fromSamples . Osci.phaseMod wave freq . Flat.toSamples)++{- | oscillator with modulated shape -}+{-# INLINE shapeMod #-}+shapeMod :: (Flat.C flat c, RealField.C t, Dim.C u) =>+      (c -> Wave.T t y)+                   {- ^ waveform -}+   -> Phase.T t    {- ^ phase -}+   -> DN.T (Dim.Recip u) t+                   {- ^ frequency -}+   -> Proc.T s u t (+        RP.T s flat c {- v shape control -}+     -> SigS.R s y)+shapeMod wave phase =+   staticAux (\freq -> SigS.fromSamples . Osci.shapeMod wave phase freq . Flat.toSamples)+++{- | oscillator with a functional waveform with modulated phase and frequency -}+{-# INLINE phaseFreqMod #-}+phaseFreqMod :: (Flat.C flat t, RealField.C t, Dim.C u) =>+      Wave.T t y   {- ^ waveform -}+   -> Proc.T s u t (+        RP.T s flat t+                     {- v phase control -}+     -> SigA.R s (Dim.Recip u) t t+                     {- v frequency control -}+     -> SigS.R s y)+phaseFreqMod wave =+   fmap flip $+      freqModAux+         (\ freqs phases ->+              SigS.fromSamples $ Osci.phaseFreqMod wave (Flat.toSamples phases) freqs)++{- | oscillator with both shape and frequency modulation -}+{-# INLINE shapeFreqMod #-}+shapeFreqMod :: (Flat.C flat c, RealField.C t, Dim.C u) =>+      (c -> Wave.T t y)+                   {- ^ waveform -}+   -> Phase.T t    {- ^ phase -}+   -> Proc.T s u t (+        RP.T s flat c+                     {- v shape control -}+     -> SigA.R s (Dim.Recip u) t t+                     {- v frequency control -}+     -> SigS.R s y)+shapeFreqMod wave phase =+   fmap flip $+      freqModAux+         (\ freqs parameters ->+              SigS.fromSamples $ Osci.shapeFreqMod wave phase (Flat.toSamples parameters) freqs)+++{- |+oscillator with a sampled waveform with constant frequency+This is essentially an interpolation with cyclic padding.+-}+{-# INLINE staticSample #-}+staticSample :: (RealField.C t, Dim.C u) =>+      Interpolation.T t y+   -> SigC.R r y   {- ^ waveform -}+   -> Phase.T t    {- ^ start phase from the range [0,1] -}+   -> DN.T (Dim.Recip u) t+                   {- ^ frequency -}+   -> Proc.T s u t (SigS.R s y)+staticSample ip wave phase =+   staticAux (SigS.fromSamples . Osci.staticSample ip (SigC.toPeriod wave) phase)++{- |+oscillator with a sampled waveform with modulated frequency+Should behave homogenously for different types of interpolation.+-}+{-# INLINE freqModSample #-}+freqModSample :: (RealField.C t, Dim.C u) =>+      Interpolation.T t y+   -> SigC.R r y   {- ^ waveform -}+   -> Phase.T t    {- ^ start phase from the range [0,1] -}+   -> Proc.T s u t (+        SigA.R s (Dim.Recip u) t t+                   {- v frequency control -}+     -> SigS.R s y)+freqModSample ip wave phase =+   freqModAux (SigS.fromSamples . Osci.freqModSample ip (SigC.toPeriod wave) phase)+++{-# INLINE freqModAux #-}+freqModAux :: (Field.C t, Dim.C u) =>+      (Sig.T t -> c)+   -> Proc.T s u t (+        SigA.R s (Dim.Recip u) t t+     -> c)+freqModAux f =+   do toFreq <- Proc.withParam toFrequencyScalar+      return $ f . SigA.scalarSamples toFreq++{-# INLINE staticAux #-}+staticAux :: (Dim.C u, Field.C t) =>+      (t -> c)+   -> DN.T (Dim.Recip u) t+   -> Proc.T s u t c+staticAux f freq =+   fmap f (toFrequencyScalar freq)
+ src/Synthesizer/Dimensional/RateAmplitude/Analysis.hs view
@@ -0,0 +1,359 @@+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes+-}+module Synthesizer.Dimensional.RateAmplitude.Analysis (+    centroid,+    length,++    normMaximum,      normVectorMaximum,+    normEuclideanSqr, normVectorEuclideanSqr,+    normSum,          normVectorSum,++    normMaximumProc,      normVectorMaximumProc,+    normEuclideanSqrProc, normVectorEuclideanSqrProc,+    normSumProc,          normVectorSumProc,++    histogram,+    zeros,++    toFrequencySpectrum, fromFrequencySpectrum,+  ) where++import qualified Synthesizer.State.Analysis as Ana+import qualified Synthesizer.State.Signal   as Sig++-- import qualified Synthesizer.Dimensional.Rate                 as Rate+import qualified Synthesizer.Dimensional.Process              as Proc+import qualified Synthesizer.Dimensional.Amplitude.Analysis   as AnaA+import qualified Synthesizer.Dimensional.Amplitude.Signal     as SigA+import qualified Synthesizer.Dimensional.RateAmplitude.Signal as SigRA+import qualified Synthesizer.Dimensional.Straight.Signal      as SigS+import qualified Synthesizer.Dimensional.Cyclic.Signal        as SigC+import qualified Synthesizer.Dimensional.RateWrapper          as SigP++import Synthesizer.Dimensional.RateAmplitude.Signal (DimensionGradient)++import qualified Number.DimensionTerm        as DN+import qualified Algebra.DimensionTerm       as Dim++import Number.DimensionTerm ((&*&), (*&), )++import qualified Number.Complex as Complex++import qualified Algebra.NormedSpace.Maximum   as NormedMax+import qualified Algebra.NormedSpace.Euclidean as NormedEuc+import qualified Algebra.NormedSpace.Sum       as NormedSum++import qualified Algebra.Transcendental      as Trans+import qualified Algebra.Algebraic           as Algebraic+import qualified Algebra.Field               as Field+import qualified Algebra.RealField           as RealField+import qualified Algebra.Ring                as Ring+import qualified Algebra.Real                as Real+++-- import qualified Data.List as List+-- import NumericPrelude.List (takeMatch)++import PreludeBase (Ord, ($), (.), return, fmap, id, )+import NumericPrelude ((+), negate, (/), sqr, abs, fromIntegral, pi, )+import Prelude (Int, )+++{- * Positions -}++{-# INLINE centroid #-}+centroid :: (Field.C q, Dim.C u, Dim.C v) =>+   SigP.T u q (SigA.S v y) q -> DN.T u q+centroid = makePhysicalLength Ana.centroid++{-# INLINE length #-}+length :: (Field.C t, Dim.C u, Dim.C v) =>+   SigP.T u t (SigA.S v y) yv -> DN.T u t+length = makePhysicalLength (fromIntegral . Sig.length)++{-# INLINE makePhysicalLength #-}+makePhysicalLength :: (Field.C t, Dim.C u, Dim.C v) =>+   (Sig.T yv -> t) ->+   SigP.T u t (SigA.S v y) yv -> DN.T u t+makePhysicalLength f x =+   f (SigA.samples x)  *&  DN.unrecip (SigP.sampleRate x)++{-# INLINE period #-}+period :: (Field.C t, Dim.C u, Dim.C v) =>+   SigP.T u t (SigA.T v y (SigC.T Sig.T)) yv -> DN.T u t+period = makePhysicalPeriod (fromIntegral . Sig.length)++{-# INLINE makePhysicalPeriod #-}+makePhysicalPeriod :: (Field.C t, Dim.C u, Dim.C v) =>+   (Sig.T yv -> t) ->+   SigP.T u t (SigA.T v y (SigC.T Sig.T)) yv -> DN.T u t+makePhysicalPeriod f x =+   f (SigC.samples (SigA.signal (SigP.signal x)))+       *&  DN.unrecip (SigP.sampleRate x)+++{- * Norms -}++{- |+Manhattan norm.+-}+{-# INLINE normMaximum #-}+normMaximum :: (Real.C y, Dim.C u, Dim.C v) =>+   SigP.T u t (SigA.S v y) y -> DN.T v y+normMaximum =+   AnaA.volumeMaximum++{- |+Square of energy norm.++Could also be called @variance@.+-}+{-# INLINE normEuclideanSqr #-}+normEuclideanSqr :: (Algebraic.C q, Dim.C u, Dim.C v) =>+   SigP.T u q (SigA.S v q) q ->+   DN.T (Dim.Mul u (Dim.Sqr v)) q+normEuclideanSqr =+   normAux DN.sqr (Sig.sum . Sig.map sqr)++{- |+Sum norm.+-}+{-# INLINE normSum #-}+normSum :: (Field.C q, Real.C q, Dim.C u, Dim.C v) =>+   SigP.T u q (SigA.S v q) q ->+   DN.T (Dim.Mul u v) q+normSum =+   normAux id (Sig.sum . Sig.map abs)++++{- |+Manhattan norm.+-}+{-# INLINE normVectorMaximum #-}+normVectorMaximum ::+   (NormedMax.C q yv, Ord q, Dim.C u, Dim.C v) =>+   SigP.T u q (SigA.S v q) yv ->+   DN.T v q+normVectorMaximum =+   AnaA.volumeVectorMaximum -- NormedMax.norm++{- |+Energy norm.+-}+{-# INLINE normVectorEuclideanSqr #-}+normVectorEuclideanSqr ::+   (NormedEuc.C q yv, Algebraic.C q, Dim.C u, Dim.C v) =>+   SigP.T u q (SigA.S v q) yv ->+   DN.T (Dim.Mul u (Dim.Sqr v)) q+normVectorEuclideanSqr =+   normAux DN.sqr (Sig.sum . Sig.map NormedEuc.normSqr)++{- |+Sum norm.+-}+{-# INLINE normVectorSum #-}+normVectorSum ::+   (NormedSum.C q yv, Field.C q, Dim.C u, Dim.C v) =>+   SigP.T u q (SigA.S v q) yv ->+   DN.T (Dim.Mul u v) q+normVectorSum =+   normAux id (Sig.sum . Sig.map NormedSum.norm)+++{-# INLINE normAux #-}+normAux :: (Dim.C v0, Dim.C v1, Dim.C u, Field.C t) =>+   (DN.T v0 y -> DN.T v1 t) ->+   (Sig.T yv -> t) ->+   SigP.T u t (SigA.T v0 y (SigS.T Sig.T)) yv ->+   DN.T (Dim.Mul u v1) t+normAux amp norm x =+   norm (SigA.samples x)+       *& DN.unrecip (SigP.sampleRate x)+      &*& amp (SigA.amplitude x)+++++{-# DEPRECATED #-}+{- |+Manhattan norm.+-}+{-# INLINE normMaximumProc #-}+normMaximumProc :: (Real.C y, Dim.C u, Dim.C v) =>+   Proc.T s u y (SigA.R s v y y -> DN.T v y)+normMaximumProc =+   Proc.pure AnaA.volumeMaximum++{-# DEPRECATED #-}+{- |+Square of energy norm.++Could also be called @variance@.+-}+{-# INLINE normEuclideanSqrProc #-}+normEuclideanSqrProc :: (Algebraic.C q, Dim.C u, Dim.C v) =>+   Proc.T s u q (+      SigA.R s v q q ->+      DN.T (Dim.Mul u (Dim.Sqr v)) q)+normEuclideanSqrProc =+   normAuxProc DN.sqr (Sig.sum . Sig.map sqr)++{-# DEPRECATED #-}+{- |+Sum norm.+-}+{-# INLINE normSumProc #-}+normSumProc :: (Field.C q, Real.C q, Dim.C u, Dim.C v) =>+   Proc.T s u q (+      SigA.R s v q q ->+      DN.T (Dim.Mul u v) q)+normSumProc =+   normAuxProc id (Sig.sum . Sig.map abs)++++{-# DEPRECATED #-}+{- |+Manhattan norm.+-}+{-# INLINE normVectorMaximumProc #-}+normVectorMaximumProc ::+   (NormedMax.C y yv, Ord y, Dim.C u, Dim.C v) =>+   Proc.T s u y (+      SigA.R s v y yv ->+      DN.T v y)+normVectorMaximumProc =+   Proc.pure AnaA.volumeVectorMaximum -- NormedMax.norm++{-# DEPRECATED #-}+{- |+Energy norm.+-}+{-# INLINE normVectorEuclideanSqrProc #-}+normVectorEuclideanSqrProc ::+   (NormedEuc.C y yv, Algebraic.C y, Dim.C u, Dim.C v) =>+   Proc.T s u y (+      SigA.R s v y yv ->+      DN.T (Dim.Mul u (Dim.Sqr v)) y)+normVectorEuclideanSqrProc =+   normAuxProc DN.sqr (Sig.sum . Sig.map NormedEuc.normSqr)++{-# DEPRECATED #-}+{- |+Sum norm.+-}+{-# INLINE normVectorSumProc #-}+normVectorSumProc ::+   (NormedSum.C y yv, Field.C y, Dim.C u, Dim.C v) =>+   Proc.T s u y (+      SigA.R s v y yv ->+      DN.T (Dim.Mul u v) y)+normVectorSumProc =+   normAuxProc id (Sig.sum . Sig.map NormedSum.norm)+++{-# INLINE normAuxProc #-}+normAuxProc :: (Dim.C v0, Dim.C v1, Dim.C u, Field.C t) =>+   (DN.T v0 y -> DN.T v1 t) ->+   (Sig.T yv -> t) ->+   Proc.T s u t (+      SigA.R s v0 y yv ->+      DN.T (Dim.Mul u v1) t)+normAuxProc amp norm =+   Proc.withParam $ \ x ->+   fmap+      (&*& amp (SigA.amplitude x))+      (Proc.toTimeDimension (norm (SigA.samples x)))++++++{- * Miscellaneous -}++{-# INLINE histogram #-}+histogram :: (RealField.C q, Dim.C u, Dim.C v) =>+   SigP.T u q (SigA.S v q) q ->+   Proc.T s v q (Int, SigA.R s (DimensionGradient v u) q q)+histogram xs =+   do rateY <- Proc.getSampleRate+      toTime <- Proc.withParam Proc.toTimeScalar+      return $+         let (offset, hist) =+                 Ana.histogramLinearIntMap+                    (SigA.scalarSamples toTime xs)+         in  (offset,+              SigA.fromSamples+                 (rateY &*& DN.unrecip (SigP.sampleRate xs))+                 hist)++{- |+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.+The result has a frequency as amplitude.+If you smooth it, you will get a curve that represents a frequency progress.+It ca be used as voiced\/unvoiced detector in a vocoder.++The result will be one value shorter than the input.+-}+{-# INLINE zeros #-}+zeros :: (Ord q, Ring.C q, Dim.C u, Dim.C v) =>+   Proc.T s u q (SigA.R s v q q -> SigA.R s (Dim.Recip u) q q)+zeros =+   do fp <- SigRA.fromPeaks+      return (fp . SigRA.Peaks . Ana.zeros . SigA.samples)++++{- |+Fourier analysis+-}+{-# INLINE toFrequencySpectrum #-}+toFrequencySpectrum :: (Trans.C q, Dim.C u, Dim.C v) =>+   SigP.T u q (SigA.T v q (SigC.T Sig.T)) (Complex.T q) ->+   SigP.T (Dim.Recip u) q (SigA.T (Dim.Mul u v) q (SigC.T Sig.T)) (Complex.T q)+toFrequencySpectrum x =+   let len = DN.rewriteDimension Dim.doubleRecip (period x)+       amp = SigA.amplitude x+       ss  = SigC.samples (SigA.signal (SigP.signal x))+       n   = Sig.length ss+       z = Complex.cis (negate (pi+pi) / fromIntegral n)+       newAmp = DN.unrecip (SigP.sampleRate x) &*& amp+   in  SigP.Cons len+          (SigA.Cons newAmp+              (SigC.Cons (Sig.take n (Ana.chirpTransform z ss))))+{-+toFrequencySpectrum $ SigP.Cons (DN.frequency (4::Prelude.Double)) (SigA.Cons (DN.voltage (1::Prelude.Double)) (SigC.Cons [1, 0 Number.Complex.+: (1::Prelude.Double), -1, 0 Number.Complex.+: (-1)]))+toFrequencySpectrum $ SigP.Cons (DN.frequency (4::Prelude.Double)) (SigA.Cons (DN.voltage (1::Prelude.Double)) (SigC.Cons [0 Number.Complex.+: (1::Prelude.Double), -1, 0 Number.Complex.+: (-1), 1]))+toFrequencySpectrum $ SigP.Cons (DN.frequency (4::Prelude.Double)) (SigA.Cons (DN.voltage (1::Prelude.Double)) (SigC.Cons [1, -1,1, (-1) Number.Complex.+: (0::Prelude.Double)]))+-}+++{- |+Fourier synthesis+-}+{-# INLINE fromFrequencySpectrum #-}+fromFrequencySpectrum :: (Trans.C q, Dim.C u, Dim.C v) =>+   SigP.T (Dim.Recip u) q (SigA.T (Dim.Mul u v) q (SigC.T Sig.T)) (Complex.T q) ->+   SigP.T u q (SigA.T v q (SigC.T Sig.T)) (Complex.T q)+fromFrequencySpectrum x =+   let len = period x+       amp = SigA.amplitude x+       ss  = SigC.samples (SigA.signal (SigP.signal x))+       n   = Sig.length ss+       z = Complex.cis ((pi+pi) / fromIntegral n)+       newAmp =+          DN.rewriteDimension+             (Dim.identityLeft . Dim.applyLeftMul Dim.cancelLeft . Dim.associateLeft)+             (DN.unrecip (SigP.sampleRate x) &*& amp)+   in  SigP.Cons len+          (SigA.Cons newAmp+              (SigC.Cons (Sig.take n (Ana.chirpTransform z ss))))
+ src/Synthesizer/Dimensional/RateAmplitude/Control.hs view
@@ -0,0 +1,332 @@+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes+++Control curves which can be used+as envelopes, for controlling filter parameters and so on.+-}+module Synthesizer.Dimensional.RateAmplitude.Control+   ({- * Primitives -}+    constant, constantVector,+    linear, line,+    exponential, exponential2, exponentialFromTo,+    cubicHermite,+    {- * Piecewise -}+    stepPiece, linearPiece, exponentialPiece, cosinePiece, cubicPiece,+    piecewise, piecewiseVolume, Piece, Piecewise,+    (-|#), ( #|-), (=|#), ( #|=), (|#), ( #|),  -- spaces before # for Haddock+    {- * Preparation -}+    mapLinearDimension, mapExponentialDimension, )+   where++import qualified Synthesizer.Dimensional.Amplitude.Control as CtrlA+import qualified Synthesizer.State.Control as Ctrl+import qualified Synthesizer.Dimensional.Straight.Signal as SigS++import qualified Synthesizer.Piecewise as Piecewise+import Synthesizer.Piecewise ((-|#), ( #|-), (=|#), ( #|=), (|#), ( #|), )++import qualified Synthesizer.Dimensional.RateAmplitude.Signal as SigA+import qualified Synthesizer.Dimensional.Process as Proc+-- import Synthesizer.Dimensional.Process (($:), ($#), )+import Synthesizer.Dimensional.RateAmplitude.Signal+          (toTimeScalar, toAmplitudeScalar, toGradientScalar, DimensionGradient)++import qualified Synthesizer.State.Signal as Sig++import qualified Number.DimensionTerm        as DN+import qualified Algebra.DimensionTerm       as Dim++-- import Number.DimensionTerm ((&*&))++-- 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 qualified Algebra.Ring               as Ring+import qualified Algebra.Additive           as Additive++-- import Control.Monad.Fix (mfix, )+import Control.Monad (liftM3, )++import NumericPrelude+import PreludeBase+import Prelude ()++++{-# INLINE constant #-}+constant :: (Real.C y, Dim.C u, Dim.C v) =>+      DN.T v y {-^ value -}+   -> Proc.T s u t (SigA.R s v y y)+constant y = Proc.pure $ CtrlA.constant y++{- |+The amplitude must be positive!+This is not checked.+-}+{-# INLINE constantVector #-}+constantVector :: -- (Field.C y', Real.C y', Dim.C v) =>+      DN.T v y {-^ amplitude -}+   -> yv       {-^ value -}+   -> Proc.T s u t (SigA.R s v y yv)+constantVector y yv = Proc.pure $ CtrlA.constantVector y yv++{- Using the 'Ctrl.linear' instead of 'Ctrl.linearStable'+   the type class constraints would be weaker.+linear :: (Additive.C y, Field.C y', Real.C y', Dim.C v) =>+-}++{- |+Caution: This control curve can contain samples+with an absolute value greater than 1.++Linear curves starting with zero are impossible.+Maybe you prefer using 'line'.+-}+{-# INLINE linear #-}+linear ::+   (Field.C q, Real.C q, Dim.C u, Dim.C v) =>+      DN.T (DimensionGradient u v) q+               {-^ slope of the curve -}+   -> DN.T v q {-^ initial value -}+   -> Proc.T s u q (SigA.R s v q q)+linear slope y0 =+   let (amp,sgn) = DN.absSignum y0+   in  do steep <- toGradientScalar amp slope+          return (SigA.fromSamples amp (Ctrl.linearMultiscale steep sgn))++{- |+Generates a finite ramp.+-}+{-# INLINE line #-}+line ::+   (RealField.C q, Dim.C u, Dim.C v) =>+      DN.T u q      {-^ duration of the ramp -}+   -> (DN.T v q, DN.T v q)+                    {-^ initial and final value -}+   -> Proc.T s u q (SigA.R s v q q)+line dur' (y0',y1') =+   (toTimeScalar dur') >>= \dur -> return $+      let amp = max (DN.abs y0') (DN.abs y1')+          y0  = toAmplitudeScalar z y0'+          y1  = toAmplitudeScalar z y1'+          z = SigA.fromSamples amp+                 (Sig.take (floor dur)+                    (Ctrl.linearMultiscale ((y1-y0)/dur) y0))+      in  z++{-# INLINE exponential #-}+exponential :: (Trans.C q, Real.C q, Dim.C u, Dim.C v) =>+      DN.T u q {-^ time where the function reaches 1\/e of the initial value -}+   -> DN.T v q {-^ initial value -}+   -> Proc.T s u q (SigA.R s v q q)+exponential time y0 =+   (toTimeScalar time) >>= \t -> return $+      let (amp,sgn) = DN.absSignum y0+      in  SigA.fromSamples amp (Ctrl.exponentialMultiscale t sgn)++{-+  take 1000 $ show (run (fixSampleRate 100 (exponential 0.1 1)) :: SigDouble)+-}++{-# INLINE exponential2 #-}+exponential2 :: (Trans.C q, Real.C q, Dim.C u, Dim.C v) =>+      DN.T u q {-^ half life, time where the function reaches 1\/2 of the initial value -}+   -> DN.T v q {-^ initial value -}+   -> Proc.T s u q (SigA.R s v q q)+exponential2 time y0 =+   (toTimeScalar time) >>= \t -> return $+      let (amp,sgn) = DN.absSignum y0+      in  SigA.fromSamples amp (Ctrl.exponential2Multiscale t sgn)++{- |+Generate an exponential curve through two nodes.+-}+{-# INLINE exponentialFromTo #-}+exponentialFromTo ::+   (Trans.C q, RealField.C q, Dim.C u, Dim.C v) =>+      DN.T u q      {-^ duration of the ramp -}+   -> (DN.T v q, DN.T v q)+                    {-^ initial and final value -}+   -> Proc.T s u q (SigA.R s v q q)+exponentialFromTo dur' (y0',y1') =+   (toTimeScalar dur') >>= \dur -> return $+      let amp = max (DN.abs y0') (DN.abs y1')+          y0  = toAmplitudeScalar z y0'+          y1  = toAmplitudeScalar z y1'+          z = SigA.fromSamples amp+                 (Sig.take (floor dur)+                    (Ctrl.exponentialFromTo dur y0 y1))+      in  z++++{-# INLINE cubicHermite #-}+cubicHermite ::+   (Field.C q, Real.C q, Dim.C u, Dim.C v) =>+      (DN.T u q, (DN.T v q, DN.T (DimensionGradient u v) q))+   -> (DN.T u q, (DN.T v q, DN.T (DimensionGradient u v) q))+   -> Proc.T s u q (SigA.R s v q q)+cubicHermite (t0', (y0',dy0')) (t1', (y1',dy1')) =+   let amp = max (DN.abs y0') (DN.abs y1')+   in  do t0  <- toTimeScalar t0'+          t1  <- toTimeScalar t1'+          dy0 <- toGradientScalar amp dy0'+          dy1 <- toGradientScalar amp dy1'+          return $+             let y0 = toAmplitudeScalar z y0'+                 y1 = toAmplitudeScalar z y1'+                 z = SigA.fromSamples amp (Ctrl.cubicHermite (t0, (y0,dy0)) (t1, (y1,dy1)))+              in z+++++-- * piecewise curves++type Piece s u v q =+   Piecewise.Piece+      (DN.T u q) (DN.T v q)+      (DN.T v q -> q -> Proc.T s u q (SigS.R s q))++type Piecewise s u v q =+   Piecewise.T+      (DN.T u q) (DN.T v q)+      (DN.T v q -> q -> Proc.T s u q (SigS.R s q))+++{- |+Since this function looks for the maximum node value,+and since the signal parameter inference phase must be completed before signal processing,+infinite descriptions cannot be used here.+-}+{-# INLINE piecewise #-}+piecewise :: (Trans.C q, RealField.C q, Dim.C u, Dim.C v) =>+      Piecewise s u v q+   -> Proc.T s u q (SigA.R s v q q)+piecewise cs =+   let amplitude = maximum+         (map (\c -> max (DN.abs (Piecewise.pieceY0 c))+                         (DN.abs (Piecewise.pieceY1 c))) cs)+   in  piecewiseVolume cs amplitude+++{-# INLINE piecewiseVolume #-}+piecewiseVolume ::+   (Trans.C q, RealField.C q, Dim.C u, Dim.C v) =>+      Piecewise s u v q+   -> DN.T v q+   -> Proc.T s u q (SigA.R s v q q)+piecewiseVolume cs amplitude =+   -- it would be nice if we could re-use Ctrl.piecewise+   do ts0 <- mapM (toTimeScalar . Piecewise.pieceDur) cs+      fmap (SigA.fromSamples amplitude . Sig.concat) $+         sequence $ zipWith+            (\(n,t) (Piecewise.PieceData c yi0 yi1 d) ->+                 fmap (Sig.take n . SigS.toSamples) $+                 Piecewise.computePiece c yi0 yi1 d amplitude t)+            (Ctrl.splitDurations ts0)+            cs+++{-# INLINE makePiece #-}+makePiece :: (Field.C q, Dim.C u, Dim.C v) =>+   Ctrl.Piece q -> Piece s u v q+makePiece piece =+   Piecewise.pieceFromFunction $ \ y0 y1 d amplitude t0 ->+      flip fmap (toTimeScalar d) (\d' ->+         let za = SigA.fromSignal amplitude z+             z  = SigS.fromSamples $+                  Piecewise.computePiece piece+                     (toAmplitudeScalar za y0)+                     (toAmplitudeScalar za y1)+                     d' t0+         in  z)++{-# INLINE stepPiece #-}+stepPiece :: (Field.C q, Dim.C u, Dim.C v) => Piece s u v q+stepPiece =+   makePiece Ctrl.stepPiece++{-# INLINE linearPiece #-}+linearPiece :: (Field.C q, Dim.C u, Dim.C v) => Piece s u v q+linearPiece =+   makePiece Ctrl.linearPiece++{-# INLINE exponentialPiece #-}+exponentialPiece :: (Trans.C q, Dim.C u, Dim.C v) =>+   DN.T v q -> Piece s u v q+exponentialPiece saturation =+   Piecewise.pieceFromFunction $ \ y0 y1 d amplitude t0 ->+      flip fmap (toTimeScalar d) (\d' ->+         let za = SigA.fromSignal amplitude z+             z  = SigS.fromSamples $+                  Piecewise.computePiece+                     (Ctrl.exponentialPiece (toAmplitudeScalar za saturation))+                     (toAmplitudeScalar za y0)+                     (toAmplitudeScalar za y1)+                     d' t0+         in  z)++{-# INLINE cosinePiece #-}+cosinePiece :: (Trans.C q, Dim.C u, Dim.C v) => Piece s u v q+cosinePiece =+   makePiece Ctrl.cosinePiece++{-# INLINE cubicPiece #-}+cubicPiece :: (Field.C q, Dim.C u, Dim.C v) =>+   DN.T (DimensionGradient u v) q ->+   DN.T (DimensionGradient u v) q ->+   Piece s u v q+cubicPiece yd0 yd1 =+   Piecewise.pieceFromFunction $ \ y0 y1 d amplitude t0 ->+      liftM3 (\d' yd0' yd1' ->+         let za = SigA.fromSignal amplitude z+             z  = SigS.fromSamples $+                  Piecewise.computePiece+                     (Ctrl.cubicPiece yd0' yd1')+                     (toAmplitudeScalar za y0)+                     (toAmplitudeScalar za y1)+                     d' t0+         in  z)+            (toTimeScalar d)+            (toGradientScalar amplitude yd0)+            (toGradientScalar amplitude yd1)+++-- * convert values to different graduations++{- |+Map a control curve without amplitude unit+by a linear (affine) function with a unit.+-}+{-# INLINE mapLinearDimension #-}+mapLinearDimension :: (Field.C y, Real.C y, Dim.C u, Dim.C v) =>+      DN.T v y              {- ^ range: one is mapped to @center + range * ampX@ -}+   -> DN.T (Dim.Mul v u) y  {- ^ center: zero is mapped to @center@ -}+   -> Proc.T s u t (+        SigA.R s u y y+     -> SigA.R s (Dim.Mul v u) y y)+mapLinearDimension range center =+   Proc.pure $ CtrlA.mapLinearDimension range center++{- |+Map a control curve without amplitude unit+exponentially to one with a unit.+-}+{-# INLINE mapExponentialDimension #-}+mapExponentialDimension :: (Trans.C y, Dim.C u) =>+      y         {- ^ range: one is mapped to @center*range@, must be positive -}+   -> DN.T u y  {- ^ center: zero is mapped to @center@ -}+   -> Proc.T s u t (+        SigA.R s Dim.Scalar y y+     -> SigA.R s u y y)+mapExponentialDimension range center =+   Proc.pure $ CtrlA.mapExponential range center
+ src/Synthesizer/Dimensional/RateAmplitude/Cut.hs view
@@ -0,0 +1,289 @@+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes+-}+module Synthesizer.Dimensional.RateAmplitude.Cut (+   {- * dissection -}+   splitAt,+   take,+   drop,+   takeUntilPause,+   unzip,+   unzip3,+   leftFromStereo, rightFromStereo,++   {- * glueing -}+   concat,      concatVolume,+   append,      appendVolume,+   zip,         zipVolume,+   zip3,        zip3Volume,+   mergeStereo, mergeStereoVolume,+   arrange,     arrangeVolume,+  ) where++import qualified Synthesizer.Dimensional.Amplitude.Cut as CutV+import qualified Synthesizer.Dimensional.Rate.Cut as CutR+import qualified Synthesizer.State.Cut as CutS+import qualified Synthesizer.State.Signal as Sig++import qualified Synthesizer.Frame.Stereo as Stereo+import qualified Synthesizer.Generic.SampledValue as Sample++import qualified Synthesizer.Dimensional.RateAmplitude.Signal as SigA+import qualified Synthesizer.Dimensional.Process as Proc+import Synthesizer.Dimensional.Process (($#))+import Synthesizer.Dimensional.RateAmplitude.Signal+   (toTimeScalar, toAmplitudeScalar)++import qualified Number.DimensionTerm        as DN+import qualified Algebra.DimensionTerm       as Dim++-- import Number.DimensionTerm ((&*&))++import qualified Data.EventList.Relative.TimeBody as EventList+import qualified Numeric.NonNegative.Class as NonNeg++import qualified Algebra.NormedSpace.Maximum as NormedMax+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 Data.List as List++import PreludeBase ((.), ($), Ord, (<=), map, return, )+-- import NumericPrelude+import Prelude (RealFrac)+++{- * dissection -}++{-# INLINE splitAt #-}+splitAt :: (RealField.C t, Dim.C u, Dim.C v, Sample.C yv) =>+   DN.T u t -> Proc.T s u t (SigA.R s v y yv -> (SigA.R s v y yv, SigA.R s v y yv))+splitAt t' =+   do t <- toTimeScalar t'+      return $ \x ->+         let (ss0,ss1) = Sig.splitAt (RealField.round t) (SigA.samples x)+         in  (SigA.replaceSamples ss0 x,+              SigA.replaceSamples ss1 x)++{-# INLINE take #-}+take :: (RealField.C t, Dim.C u, Dim.C v) =>+   DN.T u t -> Proc.T s u t (SigA.R s v y yv -> SigA.R s v y yv)+take t' =+   CutR.take t'+   -- fmap (fst.) $ splitAt t+   {-+   do t <- toTimeScalar t'+      return $ SigA.processSamples (Sig.take (RealField.round t))+   -}++{-# INLINE drop #-}+drop :: (RealField.C t, Dim.C u, Dim.C v) =>+   DN.T u t -> Proc.T s u t (SigA.R s v y yv -> SigA.R s v y yv)+drop t' =+   CutR.drop t'+   -- fmap (snd.) $ splitAt t+   {-+   do t <- toTimeScalar t'+      return $ SigA.processSamples (Sig.drop (RealField.round t))+   -}++{-# INLINE takeUntilPause #-}+takeUntilPause ::+  (RealField.C t, Dim.C u,+   Field.C y, NormedMax.C y yv, Dim.C v) =>+   DN.T v y -> DN.T u t -> Proc.T s u t (SigA.R s v y yv -> SigA.R s v y yv)+takeUntilPause y' t' =+   do t <- toTimeScalar t'+      return $ \x ->+         let y = toAmplitudeScalar x y'+         in  SigA.processSamples+                (CutS.takeUntilInterval ((<=y) . NormedMax.norm)+                    (RealField.ceiling t)) x+++{-# INLINE unzip #-}+unzip :: (Dim.C u, Dim.C v) =>+   Proc.T s u t+      (SigA.R s v y (yv0, yv1) ->+       (SigA.R s v y yv0, SigA.R s v y yv1))+unzip = Proc.pure CutV.unzip++{-# INLINE unzip3 #-}+unzip3 :: (Dim.C u, Dim.C v) =>+   Proc.T s u t+      (SigA.R s v y (yv0, yv1, yv2) ->+       (SigA.R s v y yv0, SigA.R s v y yv1, SigA.R s v y yv2))+unzip3 = Proc.pure CutV.unzip3+++{-# INLINE leftFromStereo #-}+leftFromStereo :: (Dim.C u) =>+   Proc.T s u t+      (SigA.R s u y (Stereo.T yv) -> SigA.R s u y yv)+leftFromStereo = Proc.pure CutV.leftFromStereo++{-# INLINE rightFromStereo #-}+rightFromStereo :: (Dim.C u) =>+   Proc.T s u t+      (SigA.R s u y (Stereo.T yv) -> SigA.R s u y yv)+rightFromStereo = Proc.pure CutV.rightFromStereo++++{- * glueing -}++{- |+Similar to @foldr1 append@ but more efficient and accurate,+because it reduces the number of amplifications.+Does not work for infinite lists,+because no maximum amplitude can be computed.+-}+{-# INLINE concat #-}+concat ::+   (Ord y, Field.C y, Dim.C v,+    Module.C y yv) =>+   Proc.T s u t ([SigA.R s v y yv] -> SigA.R s v y yv)+concat = Proc.pure $ CutV.concat++{- |+Give the output volume explicitly.+Does also work for infinite lists.+-}+{-# INLINE concatVolume #-}+concatVolume ::+   (Field.C y, Dim.C v,+    Module.C y yv) =>+   DN.T v y -> Proc.T s u t ([SigA.R s v y yv] -> SigA.R s v y yv)+concatVolume amp = Proc.pure $ CutV.concatVolume amp+++{-# INLINE append #-}+append ::+   (Ord y, Field.C y, Dim.C v,+    Module.C y yv) =>+   Proc.T s u t (SigA.R s v y yv -> SigA.R s v y yv -> SigA.R s v y yv)+append = Proc.pure $ CutV.append++{-# INLINE appendVolume #-}+appendVolume ::+   (Field.C y, Dim.C v,+    Module.C y yv) =>+   DN.T v y ->+   Proc.T s u t (SigA.R s v y yv -> SigA.R s v y yv -> SigA.R s v y yv)+appendVolume amp = Proc.pure $ CutV.appendVolume amp+++{-# INLINE zip #-}+zip ::+   (Ord y, Field.C y, Dim.C v,+    Module.C y yv0, Module.C y yv1) =>+   Proc.T s u t (SigA.R s v y yv0 -> SigA.R s v y yv1 -> SigA.R s v y (yv0,yv1))+zip = Proc.pure $ CutV.zip++{-# INLINE zipVolume #-}+zipVolume ::+   (Field.C y, Dim.C v,+    Module.C y yv0, Module.C y yv1) =>+   DN.T v y ->+   Proc.T s u t (SigA.R s v y yv0 -> SigA.R s v y yv1 -> SigA.R s v y (yv0,yv1))+zipVolume amp = Proc.pure $ CutV.zipVolume amp+++{-# INLINE mergeStereo #-}+mergeStereo ::+   (Ord y, Field.C y, Dim.C v,+    Module.C y yv) =>+   Proc.T s u t (SigA.R s v y yv -> SigA.R s v y yv -> SigA.R s v y (Stereo.T yv))+mergeStereo = Proc.pure $ CutV.mergeStereo++{-# INLINE mergeStereoVolume #-}+mergeStereoVolume ::+   (Field.C y, Dim.C v,+    Module.C y yv) =>+   DN.T v y ->+   Proc.T s u t (SigA.R s v y yv -> SigA.R s v y yv -> SigA.R s v y (Stereo.T yv))+mergeStereoVolume amp = Proc.pure $ CutV.mergeStereoVolume amp++++{-# INLINE zip3 #-}+zip3 ::+   (Ord y, Field.C y, Dim.C v,+    Module.C y yv0, Module.C y yv1, Module.C y yv2) =>+   Proc.T s u t (+      SigA.R s v y yv0 -> SigA.R s v y yv1 -> SigA.R s v y yv2 ->+      SigA.R s v y (yv0,yv1,yv2))+zip3 = Proc.pure $ CutV.zip3++{-# INLINE zip3Volume #-}+zip3Volume ::+   (Field.C y, Dim.C v,+    Module.C y yv0, Module.C y yv1, Module.C y yv2) =>+   DN.T v y ->+   Proc.T s u t (+      SigA.R s v y yv0 -> SigA.R s v y yv1 -> SigA.R s v y yv2 ->+      SigA.R s v y (yv0,yv1,yv2))+zip3Volume amp = Proc.pure $ CutV.zip3Volume amp+++{- |+Uses maximum input volume as output volume.+-}+{-# INLINE arrange #-}+arrange ::+   (Ring.C t, Dim.C u,+    RealFrac t, NonNeg.C t,+    Ord y, Field.C y, Dim.C v,+    Module.C y yv) =>+      DN.T u t  {-^ Dim of the time values in the time ordered list. -}+   -> Proc.T s u t (+         EventList.T t (SigA.R s v y yv)+               {- v A list of pairs: (relative start time, signal part),+                    The start time is relative+                    to the start time of the previous event. -}+      -> SigA.R s v y yv)+               {- ^ The mixed signal. -}+arrange unit' =+   Proc.withParam $ \sched ->+      let amp = List.maximum (map SigA.amplitude (EventList.getBodies sched))+      in  arrangeVolume amp unit' $# sched+++{- |+Given a list of signals with time stamps,+mix them into one signal as they occur in time.+Ideally for composing music.+Infinite schedules are not supported.+Does not work for infinite lists,+because no maximum amplitude can be computed.+-}+{-# INLINE arrangeVolume #-}+arrangeVolume ::+   (Ring.C t, Dim.C u,+    RealFrac t, NonNeg.C t,+    Field.C y, Dim.C v,+    Module.C y yv) =>+      DN.T v y  {- ^ Output volume. -}+   -> DN.T u t  {- ^ Dim of the time values in the time ordered list. -}+   -> Proc.T s u t (+         EventList.T t (SigA.R s v y yv)+            {- v A list of pairs: (relative start time, signal part),+                 The start time is relative+                 to the start time of the previous event. -}+      -> SigA.R s v y yv)+            {- ^ The mixed signal. -}+arrangeVolume amp unit' =+   do unit <- toTimeScalar unit'+      return $ \sched' ->+         let sched =+                EventList.mapBody (SigA.vectorSamples (toAmplitudeScalar z)) sched'+             z = SigA.fromSamples amp+                    (CutS.arrange (EventList.resample unit sched))+         in  z
+ src/Synthesizer/Dimensional/RateAmplitude/Demonstration.hs view
@@ -0,0 +1,554 @@+{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}+module Main (main) where+-- module Synthesizer.Dimensional.RateAmplitude.Demonstration where++import qualified Synthesizer.Dimensional.Rate.Oscillator as Osci+import qualified Synthesizer.Dimensional.Rate.Filter     as Filt+import qualified Synthesizer.Dimensional.RateAmplitude.Displacement as Disp+import qualified Synthesizer.Dimensional.RateAmplitude.Noise      as Noise+-- import qualified Synthesizer.SampleRateDimension.Filter.Recursive    as FiltR+-- import qualified Synthesizer.SampleRateDimension.Filter.NonRecursive as FiltNR+import qualified Synthesizer.Dimensional.RateAmplitude.Filter     as FiltA+import qualified Synthesizer.Dimensional.RateAmplitude.Cut        as Cut+import qualified Synthesizer.Dimensional.Amplitude.Cut            as CutA+import qualified Synthesizer.Dimensional.Rate.Cut                 as CutR++import qualified Synthesizer.Dimensional.RateAmplitude.Control    as Ctrl+import qualified Synthesizer.Dimensional.Rate.Control             as CtrlR++import qualified Synthesizer.Dimensional.Straight.Displacement as DispS++import qualified Synthesizer.Dimensional.Amplitude.Analysis       as Ana++import qualified Synthesizer.Dimensional.Process as Proc+import qualified Synthesizer.Dimensional.Cyclic.Signal   as SigC+import qualified Synthesizer.Dimensional.Straight.Signal as SigS+import qualified Synthesizer.Dimensional.RateAmplitude.Signal as SigA++import qualified Synthesizer.Dimensional.RateAmplitude.File as File+import qualified Synthesizer.Dimensional.RateAmplitude.Play as Play+import qualified Synthesizer.Dimensional.RateWrapper as SigP++import Synthesizer.Dimensional.RateAmplitude.Signal (($-), ($&), (&*^), (&*>^), )+import Synthesizer.Dimensional.Process (($:), ($::), (.:), ($^), (.^), ($#))+import Synthesizer.Dimensional.Amplitude.Control (mapLinear, mapExponential, )+import Synthesizer.Dimensional.RateAmplitude.Instrument (wasp, )++import qualified Synthesizer.Frame.Stereo as Stereo+import qualified Synthesizer.Generic.SampledValue as Sample++import qualified Synthesizer.State.Interpolation as Interpolation+import           Synthesizer.Plain.Instrument (choirWave)+import qualified Synthesizer.Basic.WaveSmoothed as WaveSmooth+import qualified Synthesizer.Basic.Wave         as Wave+import qualified Synthesizer.Basic.Phase        as Phase++import qualified Algebra.DimensionTerm as Dim+import qualified Number.DimensionTerm  as DN++import Number.DimensionTerm ((*&))++import qualified Number.NonNegative     as NonNeg++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 System.Random (Random, randomRs, mkStdGen)++import Synthesizer.Utility (snd3, thd3, )+import Data.List(zip4)++import PreludeBase+import NumericPrelude+++++{-# INLINE sineLow #-}+sineLow ::+   (RealField.C q, Trans.C q, Module.C q q, Sample.C q) =>+   Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q)+sineLow =+   DN.voltage 1 &*^+       Osci.static Wave.sine zero (DN.frequency 440)++{-# INLINE sineHigh #-}+sineHigh ::+   (RealField.C q, Trans.C q, Module.C q q, Sample.C q) =>+   Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q)+sineHigh =+   DN.voltage 1 &*^+       Osci.static Wave.sine zero (DN.frequency 660)++{-# INLINE sineMix #-}+sineMix ::+   (RealField.C q, Trans.C q, Module.C q q, Sample.C q) =>+   Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q)+sineMix =+   FiltA.amplify 0.5 $: (Disp.mix $: sineLow $: sineHigh)+++{-# INLINE exponential #-}+exponential ::+   (RealField.C q, Trans.C q, Module.C q q, Random q, Sample.C q) =>+   Proc.T s Dim.Time q (SigS.R s q)+exponential =+   CtrlR.exponential (DN.time 0.3)+++{-# INLINE ping #-}+ping ::+   (RealField.C q, Trans.C q, Module.C q q, Random q, Sample.C q) =>+   Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q)+ping =+   Filt.envelope+      $: exponential+      $: sineLow++++{-# INLINE sawWave #-}+sawWave :: (RealField.C a) => Wave.T a a+sawWave = Wave.triangleAsymmetric (-0.9)++{-+{-# INLINE saw #-}+saw ::+   (RealField.C q, Trans.C q, Module.C q q, Random q, Sample.C q) =>+   Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q)+saw =+   DN.voltage 1 &*^ Osci.static sawWave zero (DN.frequency 440)+-}++{-# INLINE sawVibrato #-}+sawVibrato ::+   (RealField.C q, Trans.C q, Module.C q q, Random q, Sample.C q) =>+   Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q)+sawVibrato =+   DN.voltage 1 &*^+      (Osci.freqMod sawWave zero+         $: (mapLinear 0.01 (DN.frequency 440) $^ Osci.static Wave.sine zero (DN.frequency 5)))++{-# INLINE sawChorus #-}+sawChorus ::+   (RealField.C q, Trans.C q, Module.C q q, Random q, Sample.C q) =>+   Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q)+sawChorus =+   let v = DN.voltage (1/4)+   in  Disp.mixMulti+         $:: (v &*^ Osci.static sawWave (Phase.fromRepresentative 0.00) (DN.frequency 442.0) :+              v &*^ Osci.static sawWave (Phase.fromRepresentative 0.25) (DN.frequency 441.2) :+              v &*^ Osci.static sawWave (Phase.fromRepresentative 0.50) (DN.frequency 438.7) :+              v &*^ Osci.static sawWave (Phase.fromRepresentative 0.75) (DN.frequency 438.1) :+              [])+++++{-# INLINE amplitudeModulationChirp #-}+amplitudeModulationChirp ::+   (RealField.C q, Trans.C q) =>+   Proc.T s Dim.Time q (SigS.R s q)+amplitudeModulationChirp =+   Filt.envelope+      $: (Osci.static Wave.sine zero (DN.frequency 440))+      $: (Osci.freqMod Wave.sine zero+             $: (Ctrl.exponentialFromTo+                   (DN.time 10)+                   (DN.frequency 1, DN.frequency 1000)))+++{-# INLINE airplane #-}+airplane ::+   (RealField.C q, Trans.C q, Module.C q q, Random q, Sample.C q) =>+   Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q)+airplane =+   SigA.share+      (Noise.white (DN.frequency 20000) (DN.voltage 0.2))+      (\noise ->+          Cut.take (DN.time 5) $: (Disp.mix+             $: noise+             $: (Filt.frequencyModulation Interpolation.linear+                    $- DN.scalar 1.001+                    $: noise)))++{-# INLINE airplaneFade #-}+airplaneFade ::+   Proc.T s Dim.Time Double (SigA.R s Dim.Voltage Double Double)+airplaneFade =+   Filt.envelope+      $: (DispS.map (\t -> recip (1 + 30*(t-1)^2)) $^ CtrlR.linear (DN.time 5))+--      $: Osci.static Wave.sine zero (DN.recip (DN.time 20))+      $: (Filt.phaser Interpolation.linear (DN.time 0.01)+            $: Ctrl.exponentialFromTo+                  (DN.time 10)+                  (DN.unrecip (DN.frequency 5000), DN.unrecip (DN.frequency 100))+            $: Noise.white (DN.frequency 20000) (DN.voltage 0.5))+++{-# INLINE wind #-}+wind ::+   (RealField.C q, Trans.C q, Module.C q q, Random q, Sample.C q) =>+   Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q)+wind =+   Filt.lowpassFromUniversal $:+      (Filt.universal+         $- DN.scalar 20+         $: (mapExponential 2 (DN.frequency 1000) $^+               (Disp.mix+                   $: DN.scalar 0.5 &*^ Osci.static Wave.sine zero (DN.frequency 0.2)+                   $: DN.scalar 1.0 &*^ Osci.static Wave.sine zero (DN.frequency (sqrt 0.2))))+         $: Noise.white (DN.frequency 20000) (DN.voltage 0.2))++{-# INLINE windStereo #-}+windStereo ::+   (RealField.C q, Trans.C q, Module.C q q, Random q, Sample.C q) =>+   Proc.T s Dim.Time q (SigA.R s Dim.Voltage q (Stereo.T q))+windStereo =+   SigA.share+      wind+      (\w -> Cut.mergeStereo $: w $: (Cut.drop (DN.time 0.5) $: w))+++{-# INLINE glissandoControl #-}+glissandoControl ::+   (RealField.C q, Trans.C q, Module.C q q, Random q) =>+   Proc.T s Dim.Time q (SigA.R s Dim.Scalar q q)+glissandoControl =+   Filt.firstOrderLowpass+      $- DN.frequency 4+      $: (Cut.concatVolume (DN.scalar 1) $:+          mapM (\p ->+             Cut.take (DN.time (1/6))+              $: Ctrl.constant (DN.scalar (fromInteger p / 12)))+              (randomRs (0,24) (mkStdGen 3141)))+++{-# INLINE bassFilter #-}+bassFilter ::+   (RealField.C q, Trans.C q, Module.C q q, Random q) =>+   Proc.T s Dim.Time q (SigA.R s Dim.Voltage q (Stereo.T q))+bassFilter =+   Filt.lowpassFromUniversal $:+      (Filt.universal+         $- DN.scalar 5+{-+         $- DN.frequency 440+-}+         $: (mapExponential 2 (DN.frequency 440) $^+               glissandoControl)+{-+         $: (mapExponential 10 (DN.frequency 440) $^+               Osci.static Wave.sine zero (DN.frequency 0.2))+-}+         $: (Cut.mergeStereo+               $: DN.voltage 1 &*^ Osci.static Wave.saw zero (DN.frequency 55.0)+               $: DN.voltage 1 &*^ Osci.static Wave.saw zero (DN.frequency 55.1)))++++{-# INLINE noiseLowpass #-}+noiseLowpass ::+   (RealField.C q, Trans.C q, Module.C q q, Random q) =>+   Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q)+noiseLowpass =+   let noise = Noise.white (DN.frequency 20000) (DN.voltage 0.1)+       control =+          Ctrl.exponentialFromTo+            (DN.time 5)+            (DN.frequency 10000, DN.frequency 10)+   in  Filt.firstOrderLowpass+          $: control+          $: noise+++{-# INLINE noiseHighpass #-}+noiseHighpass ::+   (RealField.C q, Trans.C q, Module.C q q, Random q) =>+   Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q)+noiseHighpass =+   let noise = Noise.white (DN.frequency 20000) (DN.voltage 0.1)+       control =+          Ctrl.exponentialFromTo+            (DN.time 5)+            (DN.frequency 10000, DN.frequency 10)+   in  Filt.firstOrderHighpass+          $: control+          $: noise+++{-# INLINE bubbles #-}+bubbles ::+   (RealField.C q, Trans.C q, Module.C q q, Random q, Sample.C q) =>+   Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q)+bubbles =+   let delay = 0.24+   in  Filt.comb (DN.time delay) (0.5 `asTypeOf` delay) $:+       (DN.voltage 0.5 &*^+        (Osci.freqMod Wave.sine zero $:+         (mapExponential 0.5 (DN.frequency 440) $^+            (Disp.mix+               $: DN.scalar 1.5 &*^ Osci.static Wave.saw zero (DN.frequency 0.5)+               $: DN.scalar 0.5 &*^ Osci.static Wave.saw zero (DN.frequency 10)))))+++{-# INLINE bubblesStereo #-}+bubblesStereo ::+   (RealField.C q, Trans.C q, Module.C q q, Random q, Sample.C q) =>+   Proc.T s Dim.Time q (SigA.R s Dim.Voltage q (Stereo.T q))+bubblesStereo =+   let delay = 0.24+       {-# INLINE channel #-}+       channel f =+          DN.voltage 0.5 &*^+           (Osci.freqMod Wave.sine zero $:+            (mapExponential 0.5 (DN.frequency 440) $^+               (Disp.mix+                  $: DN.scalar 1.5 &*^ Osci.static Wave.saw zero (DN.frequency 0.5)+                  $: DN.scalar 0.5 &*^ Osci.static Wave.saw zero f)))+   in  Filt.comb (DN.time delay) (0.5 `asTypeOf` delay) $:+          (Cut.mergeStereo+              $: channel (DN.frequency 10)+              $: channel (DN.frequency 9.23))+++{-# INLINE dampedEcho #-}+dampedEcho ::+   (RealField.C q, Trans.C q, Module.C q q, Random q, Sample.C q) =>+   Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q)+dampedEcho =+   FiltA.combProc (DN.time 0.2)+            (Filt.firstOrderLowpass $- DN.frequency 1000)+      $: (Filt.envelope+            $: CtrlR.exponential2 (DN.time 0.1)+            $: DN.voltage 1 &*^ Osci.static Wave.saw zero (DN.frequency 440))+++{-# INLINE trapezoid #-}+trapezoid ::+   (RealField.C q, Trans.C q, Module.C q q, Random q, Sample.C q) =>+   Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q)+trapezoid =+   Filt.mean (DN.frequency 500)+      $: (mapExponential 4 (DN.frequency 2000) $^ Osci.static Wave.sine zero (DN.frequency 1))+      $: DN.voltage 0.7 &*^ Osci.static (Wave.trapezoid 0.9) zero (DN.frequency 440)+{-+   Filt.meanStatic (DN.frequency 440)+      $: DN.voltage 1 &*^ Osci.static Wave.square zero (DN.frequency 440)+-}++++{-# INLINE staticSine #-}+staticSine ::+   (RealField.C q, Trans.C q) =>+   Proc.T s Dim.Time q (SigS.R s q)+staticSine =+   CutR.take (DN.time 10)+      $: (Osci.static Wave.sine zero (DN.frequency 440))+++{-# INLINE harmonicTone #-}+harmonicTone ::+   (RealField.C q, Trans.C q, Module.C q q) =>+   [(DN.Frequency q, q, Phase.T q)] ->+   Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q)+harmonicTone hs =+   let k = recip (sum (map (abs . snd3) hs))+   in  Disp.mixMulti $::+          map (\(f, amp, phase) ->+                  DN.voltage (amp*k) &*^+                  Osci.static Wave.sine phase f) hs++newtype Sound q v =+   Sound {fromSound :: forall s. Proc.T s Dim.Time q (SigA.R s Dim.Voltage q v)}++{-# INLINE harmonicExamples #-}+harmonicExamples ::+   (RealField.C q, Trans.C q, Module.C q q) =>+   [(FilePath, Sound q q)]+harmonicExamples =+   do expo <- [0,1,2]+      (harmName,harm::[Int])+           <- [("all", take 10 [1 ..]), ("odd", take 10 [1,3 ..])]+      (phaseName,phase)+           <- [("sin", Phase.fromRepresentative 0),+               ("cos", Phase.fromRepresentative (1/4))]+      return+         ("power" ++ show expo ++ harmName ++ "-" ++ phaseName,+          Sound+             (harmonicTone+                (map ((\n -> (n *& DN.frequency 440,+                             recip (n ^ expo),+                             phase))+                      . fromIntegral)+                     harm)))++{- |+Morphing shapes with constant sound.+By shifting the frequency of all harmonics up by an constant amount,+the periods of the harmonic do no longer match+and recombine only afte a period that depends on the frequency shift.+At the beginning we have the waveform of mixed sines,+after a quarter period of the shift frequency we have mixed cosines and so on.+-}+{-# INLINE harmonicMorph #-}+harmonicMorph ::+   (RealField.C q, Trans.C q, Module.C q q) =>+   [(FilePath, Sound q q)]+harmonicMorph =+   do expo <- [0,1,2]+      (harmName,harm::[Int])+           <- [("all", take 10 [1 ..]), ("odd", take 10 [1,3 ..])]+      return+         ("power" ++ show expo ++ harmName ++ "-shift",+          Sound+             (harmonicTone+                (map ((\n -> (n *& DN.frequency 440 + DN.frequency 1,+                             recip (n ^ expo),+                             zero))+                      . fromIntegral)+                     harm)))+++{-# INLINE waveforms #-}+waveforms ::+   (RealField.C q, Trans.C q, Module.C q q) =>+   [(FilePath, Sound q q)]+waveforms =+   do (name,wave)+           <- ("square",   Wave.trapezoid 0.9) :+              ("triangle", Wave.triangle) :+              ("saw",      sawWave) :+              []+      return+         (name,+          Sound+             (DN.voltage 1 &*^ Osci.static wave zero (DN.frequency 440)))+++{-# INLINE waveformsBandlimited #-}+waveformsBandlimited ::+   (RealField.C q, Trans.C q, Module.C q q) =>+   [(FilePath, Sound q q)]+waveformsBandlimited =+   do (name,wave)+           <- ("square",   WaveSmooth.square) :+              ("triangle", WaveSmooth.triangle) :+              ("saw",      WaveSmooth.saw) :+              ("sine",     WaveSmooth.sine) :+              ("harmonic", WaveSmooth.composedHarmonics $+                  let k = 0.5+                  in  [WaveSmooth.harmonic zero 0,+                       WaveSmooth.harmonic zero k,+                       WaveSmooth.harmonic zero (k/2),+                       WaveSmooth.harmonic zero (k/3),+                       WaveSmooth.harmonic zero (k/4)]) :+              []+      return+         (name++"-antialias-chirp",+          Sound+             (DN.voltage 1 &*^ (Osci.freqModAntiAlias wave zero $:+                 Ctrl.line (DN.time 10) (DN.frequency (-30000), DN.frequency 30000))))+++main :: IO ()+main =+   do+{-+      Play.timeVoltageMonoDoubleR (DN.frequency 44100) bubbles+-}+{-+      File.writeTimeVoltage "chirp"+         (SigP.runProcess+             (DN.frequency (44100::Double))+             (DN.voltage 1 &*^ amplitudeModulationChirp))+-}+      mapM_+         (\(name, sound) ->+             putStrLn name >>+             File.renderTimeVoltageStereoDouble+                (DN.frequency 44100) name (fromSound sound)) $++         ("bass-filter", Sound (Cut.take (DN.time 15) $: bassFilter)) :+         ("wind",        Sound (Cut.take (DN.time 10) $: windStereo)) :+         ("bubbles",     Sound (Cut.take (DN.time 10) $: bubblesStereo)) :+         []++      mapM_+         (\(name, sound) ->+             putStrLn name >>+             File.renderTimeVoltageMonoDouble+                (DN.frequency 44100) name (fromSound sound)) $++         ("sine-low",    Sound (Cut.take (DN.time 1) $: sineLow)) :+         ("sine-high",   Sound (Cut.take (DN.time 1) $: sineHigh)) :+         ("sine-mix",    Sound (Cut.take (DN.time 1) $: sineMix)) :+         ("exponential", Sound (Cut.take (DN.time 1) $: DN.voltage 1 &*^ exponential)) :+         ("ping",        Sound (Cut.take (DN.time 1) $: ping)) :++--         ("saw",         Sound (Cut.take (DN.time 2) $: saw)) :+         ("saw-vibrato", Sound (Cut.take (DN.time 2) $: sawVibrato)) :+         ("saw-chorus",  Sound (Cut.take (DN.time 2) $: sawChorus)) :++         ("wasp",        Sound (Cut.take (DN.time  5) $: wasp (DN.frequency 110))) :+         ("trapezoid",   Sound (Cut.take (DN.time  5) $: trapezoid)) :+         ("damped-echo", Sound (Cut.take (DN.time  4) $: dampedEcho)) :+         ("chirp",       Sound (DN.voltage 1 &*^ amplitudeModulationChirp)) :+         ("airplane",        Sound airplane) :+         {- This becomes considerably faster, if other effects are not rendered.+            This is obviously an optimizer bug. -}+         ("airplane-fade",   Sound airplaneFade) :++         ("noise-lowpass1",  Sound noiseLowpass) :+         ("noise-highpass1", Sound noiseHighpass) :+         []++      flip mapM_ waveformsBandlimited $+         \(fileName, tone) ->+            putStrLn fileName >>+            File.renderTimeVoltageMonoDouble+               (DN.frequency 44100) fileName+               (fromSound tone)++      flip mapM_ (harmonicExamples ++ harmonicMorph ++ waveforms) $+         \(fileName, tone) ->+            putStrLn fileName >>+            File.renderTimeVoltageMonoDouble+               (DN.frequency 44100) fileName+               (Cut.take (DN.time 1) $: fromSound tone)+++{-+import installed synthesizer package++ghc-core -f html -- -o dist/build/demonstration/demonstration -Wall -O2 -fexcess-precision -fvia-C -optc-O2 -package synthesizer src/Synthesizer/Dimensional/RateAmplitude/Demonstration.hs >dist/build/demonstration/demonstration.html++ghc -o dist/build/demonstration/demonstration -Wall -O2 -fexcess-precision -fvia-C -optc-O2 -ddump-simpl-stats -package synthesizer src/Synthesizer/Dimensional/RateAmplitude/Demonstration.hs++ghc -o dist/build/demonstration/demonstration -O -Wall -fexcess-precision -ddump-simpl-stats -package synthesizer src/Synthesizer/Dimensional/RateAmplitude/Demonstration.hs++ghc -o dist/build/demonstration/demonstration -O -Wall -fexcess-precision -ddump-simpl -package synthesizer src/Synthesizer/Dimensional/RateAmplitude/Demonstration.hs >dist/build/Demonstration.log+++with assembly output++ghc -o dist/build/fusiontest/fusiontest -O -Wall -fexcess-precision -ddump-simpl-stats -ddump-asm -package synthesizer speedtest/DemonstrationInlineMono.hs >dist/build/Demonstration.asm+++with make and no explicit package specification:++ghc -Idist/build -o dist/build/demonstration/demonstration --make -Wall -O -fexcess-precision -ddump-simpl-stats -i -idist/build/autogen -isrc -odir dist/build/demonstration/demonstration-tmp -hidir dist/build/demonstration/demonstration-tmp src/Synthesizer/Dimensional/RateAmplitude/Demonstration.hs+++with make and explicit package specification:++ghc --make -Idist/build -o dist/build/demonstration/demonstration -Wall -O -fexcess-precision -ddump-simpl-stats -ddump-simpl-iterations -i -idist/build/autogen -isrc -idist/build/demonstration/demonstration-tmp -odir dist/build/demonstration/demonstration-tmp -hidir dist/build/demonstration/demonstration-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 bytestring-0.9.0.5 -package binary-0.4.1 -package storablevector-0.1  src/Synthesizer/Dimensional/RateAmplitude/Demonstration.hs >src/Synthesizer/Dimensional/RateAmplitude/Demonstration.log++without make and with detailed simplifier report:++ghc -Idist/build -o dist/build/demonstration/demonstration -Wall -O -fexcess-precision -ddump-simpl-stats -ddump-simpl-iterations -i -idist/build/autogen -isrc -idist/build/demonstration/demonstration-tmp -odir dist/build/demonstration/demonstration-tmp -hidir dist/build/demonstration/demonstration-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 HTam-0.0 -package numeric-quest-0.1 -package bytestring-0.9.0.5 -package binary-0.4.1 -package storablevector-0.1 dist/build/HSsynthesizer*.o src/Synthesizer/Dimensional/RateAmplitude/Demonstration.hs  >src/Synthesizer/Dimensional/RateAmplitude/Demonstration.log+-}
+ src/Synthesizer/Dimensional/RateAmplitude/Displacement.hs view
@@ -0,0 +1,96 @@+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes+-}+module Synthesizer.Dimensional.RateAmplitude.Displacement (+   mix, mixVolume,+   mixMulti, mixMultiVolume,+   raise, distort,+   ) where++import qualified Synthesizer.Dimensional.Amplitude.Displacement as DispV++import qualified Synthesizer.Dimensional.RateAmplitude.Signal as SigA+import qualified Synthesizer.Dimensional.Process as Proc++import qualified Number.DimensionTerm        as DN+import qualified Algebra.DimensionTerm       as Dim++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 Algebra.Module ((*>))++import PreludeBase+-- import NumericPrelude+import Prelude ()+++{- * Mixing -}++{-| Mix two signals.+    In opposition to 'zipWith' the result has the length of the longer signal. -}+{-# INLINE mix #-}+mix :: (Real.C y, Field.C y, Module.C y yv, Dim.C v) =>+      Proc.T s u t (+        SigA.R s v y yv+     -> SigA.R s v y yv+     -> SigA.R s v y yv)+mix = Proc.pure DispV.mix++{-# INLINE mixVolume #-}+mixVolume ::+   (Real.C y, Field.C y, Module.C y yv, Dim.C v) =>+      DN.T v y+   -> Proc.T s u t (+        SigA.R s v y yv+     -> SigA.R s v y yv+     -> SigA.R s v y yv)+mixVolume v = Proc.pure $ DispV.mixVolume v++{-| Mix one or more signals. -}+{-# INLINE mixMulti #-}+mixMulti ::+   (Real.C y, Field.C y, Module.C y yv, Dim.C v) =>+      Proc.T s u t (+        [SigA.R s v y yv]+     ->  SigA.R s v y yv)+mixMulti = Proc.pure DispV.mixMulti++{-# INLINE mixMultiVolume #-}+mixMultiVolume ::+   (Real.C y, Field.C y, Module.C y yv, Dim.C v) =>+      DN.T v y+   -> Proc.T s u t (+        [SigA.R s v y yv]+     ->  SigA.R s v y yv)+mixMultiVolume v = Proc.pure $ DispV.mixMultiVolume v++{-| Add a number to all of the signal values.+    This is useful for adjusting the center of a modulation. -}+{-# INLINE raise #-}+raise :: (Field.C y, Module.C y yv, Dim.C v) =>+      DN.T v y+   -> yv+   -> Proc.T s u t (+        SigA.R s v y yv+     -> SigA.R s v y yv)+raise y' yv = Proc.pure $ DispV.raise y' yv++{-| Add a number to all of the signal values.+    This is useful for adjusting the center of a modulation. -}+{-# INLINE distort #-}+distort :: (Field.C y, Module.C y yv, Dim.C v) =>+      (yv -> yv)+   -> Proc.T s u t (+        SigA.R s v y y+     -> SigA.R s v y yv+     -> SigA.R s v y yv)+distort f = Proc.pure $ DispV.distort f
+ src/Synthesizer/Dimensional/RateAmplitude/File.hs view
@@ -0,0 +1,119 @@+{-# OPTIONS -fno-implicit-prelude -fglasgow-exts #-}+-- glasgow-exts for all quantifier+module Synthesizer.Dimensional.RateAmplitude.File (+   write,+   writeTimeVoltage,+   writeTimeVoltageMonoDouble,+   writeTimeVoltageStereoDouble,+   renderTimeVoltageMonoDouble,+   renderTimeVoltageStereoDouble,+  ) where++import qualified Sox.File+import qualified BinarySample as BinSmp++import qualified Synthesizer.Dimensional.Process as Proc++import qualified Synthesizer.Dimensional.Amplitude.Signal as SigA+import qualified Synthesizer.Dimensional.RateAmplitude.Signal as SigRA+import qualified Synthesizer.Dimensional.RateWrapper as SigP++import qualified Synthesizer.Frame.Stereo as Stereo++import qualified Synthesizer.Storable.Signal as SigSt++-- import qualified Synthesizer.Dimensional.Straight.Signal as SigS+import qualified Synthesizer.State.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.DimensionTerm as Dim+import qualified Number.DimensionTerm  as DN+++import System.Exit(ExitCode)++import NumericPrelude+import PreludeBase++++{-# INLINE write #-}+write ::+    (RealField.C t, BinSmp.C yv,+     Dim.C u, Field.C t,+     Dim.C v, Module.C y yv, Field.C y) =>+   DN.T (Dim.Recip u) t ->+   DN.T v y ->+   FilePath ->+   SigP.T u t (SigA.S v y) yv ->+--   SigP.T u t (SigA.T v y (SigS.T Sig.T)) yv ->+   IO ExitCode+write freqUnit amp name sig =+   Sox.File.write name+      (DN.divToScalar (SigP.sampleRate sig) freqUnit)+      (Sig.toList (SigA.vectorSamples (flip DN.divToScalar amp) sig))+++{-# INLINE writeTimeVoltage #-}+writeTimeVoltage ::+    (RealField.C t, BinSmp.C yv,+     Field.C t,+     Module.C y yv, Field.C y) =>+   FilePath ->+   SigP.T Dim.Time t (SigA.S Dim.Voltage y) yv ->+--   SigP.T Dim.Time t (SigA.T Dim.Voltage y (SigS.T Sig.T)) yv ->+   IO ExitCode+writeTimeVoltage =+   write (DN.frequency one) (DN.voltage one)++++{-# INLINE writeTimeVoltageMonoDouble #-}+writeTimeVoltageMonoDouble ::+   FilePath ->+   SigP.T Dim.Time Double (SigA.S Dim.Voltage Double) Double ->+--   SigP.T Dim.Time t (SigA.T Dim.Voltage y (SigS.T Sig.T)) yv ->+   IO ()+writeTimeVoltageMonoDouble name sig =+   let rate = DN.toNumberWithDimension Dim.frequency (SigP.sampleRate sig)+   in  do SigSt.writeFile (name ++ ".sw")+             (SigP.signal (SigRA.toStorableInt16Mono sig))+          Sox.File.rawToAIFF name [] rate 1+          return ()+++{-# INLINE writeTimeVoltageStereoDouble #-}+writeTimeVoltageStereoDouble ::+   FilePath ->+   SigP.T Dim.Time Double (SigA.S Dim.Voltage Double) (Stereo.T Double) ->+--   SigP.T Dim.Time t (SigA.T Dim.Voltage y (SigS.T Sig.T)) yv ->+   IO ()+writeTimeVoltageStereoDouble name sig =+   let rate = DN.toNumberWithDimension Dim.frequency (SigP.sampleRate sig)+   in  do SigSt.writeFile (name ++ ".sw")+             (SigP.signal (SigRA.toStorableInt16Stereo sig))+          Sox.File.rawToAIFF name [] rate 2+          return ()++{-# INLINE renderTimeVoltageMonoDouble #-}+renderTimeVoltageMonoDouble ::+   DN.T Dim.Frequency Double ->+   FilePath ->+   (forall s. Proc.T s Dim.Time Double (SigA.R s Dim.Voltage Double Double)) ->+   IO ()+renderTimeVoltageMonoDouble rate name sig =+   writeTimeVoltageMonoDouble name (SigP.runProcess rate sig)++{-# INLINE renderTimeVoltageStereoDouble #-}+renderTimeVoltageStereoDouble ::+   DN.T Dim.Frequency Double ->+   FilePath ->+   (forall s. Proc.T s Dim.Time Double (SigA.R s Dim.Voltage Double (Stereo.T Double))) ->+   IO ()+renderTimeVoltageStereoDouble rate name sig =+   writeTimeVoltageStereoDouble name (SigP.runProcess rate sig)
+ src/Synthesizer/Dimensional/RateAmplitude/Filter.hs view
@@ -0,0 +1,599 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes+-}+module Synthesizer.Dimensional.RateAmplitude.Filter (+   {- * Non-recursive -}++   {- ** Amplification -}+   amplify,+   amplifyDimension,+   negate,+   envelope,+   envelopeVector,+   envelopeVectorDimension,+   {- ** Filter operators from calculus -}+   differentiate,++   {- ** Smooth -}+   meanStatic,+   mean,++   {- ** Delay -}+   delay,+   phaseModulation,+   frequencyModulation,+   frequencyModulationDecoupled,+   phaser,+   phaserStereo,+++   {- * Recursive -}++   {- ** Without resonance -}+   firstOrderLowpass,+   firstOrderHighpass,+   butterworthLowpass,+   butterworthHighpass,+   chebyshevALowpass,+   chebyshevAHighpass,+   chebyshevBLowpass,+   chebyshevBHighpass,+   {- ** With resonance -}+   universal,+   FiltR.highpassFromUniversal,+   FiltR.bandpassFromUniversal,+   FiltR.lowpassFromUniversal,+   moogLowpass,++   {- ** Allpass -}+   allpassCascade,++   {- ** Reverb -}+   comb,+   combProc,++   {- ** Filter operators from calculus -}+   integrate,+) where++import qualified Synthesizer.Dimensional.Rate.Filter as FiltR+import qualified Synthesizer.Dimensional.Amplitude.Filter       as FiltV+-- import qualified Synthesizer.Dimensional.Amplitude.Displacement as MiscV+-- import qualified Synthesizer.Dimensional.Amplitude.Cut          as CutV+import qualified Synthesizer.Dimensional.ControlledProcess as CProc+import qualified Synthesizer.Dimensional.Process as Proc+-- import qualified Synthesizer.Dimensional.Rate as Rate++-- import Synthesizer.Dimensional.Process ((.:), (.^), )++import qualified Synthesizer.Dimensional.Abstraction.Flat as Flat+import qualified Synthesizer.Dimensional.Abstraction.Homogeneous as Hom++import qualified Synthesizer.Dimensional.RatePhantom as RP++import qualified Synthesizer.Dimensional.Straight.Signal      as SigS+import qualified Synthesizer.Dimensional.RateAmplitude.Signal as SigA+import qualified Synthesizer.Dimensional.RateWrapper      as SigP+-- import qualified Synthesizer.Dimensional.Amplitude.Signal as SigPA+import qualified Synthesizer.State.Signal as Sig+import Synthesizer.Plain.Signal (Modifier)++import Synthesizer.Dimensional.RateAmplitude.Signal+   (toTimeScalar, toFrequencyScalar, DimensionGradient, )++import qualified Synthesizer.Generic.SampledValue as Sample++import qualified Synthesizer.Frame.Stereo as Stereo++-- import qualified Synthesizer.State.Displacement as Disp+import qualified Synthesizer.State.Interpolation as Interpolation+import qualified Synthesizer.State.Filter.Delay as Delay+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.Butterworth as Butter+import qualified Synthesizer.Plain.Filter.Recursive.Chebyshev   as Cheby+import qualified Synthesizer.Plain.Filter.Recursive    as FiltR+import qualified Synthesizer.State.Filter.Recursive.Integration as Integrate+import qualified Synthesizer.State.Filter.Recursive.MovingAverage as MA+import qualified Synthesizer.State.Filter.NonRecursive as FiltNR++import qualified Synthesizer.Storable.Signal as SigSt+import qualified Synthesizer.Storable.Filter.Recursive.Comb as Comb++import qualified Number.DimensionTerm        as DN+import qualified Algebra.DimensionTerm       as Dim++import Number.DimensionTerm ((&*&), (&/&))++import qualified Number.NonNegative     as NonNeg++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 Algebra.VectorSpace    as VectorSpace+import qualified Algebra.Module         as Module++-- import Control.Monad(liftM2)++import NumericPrelude hiding (negate)+import PreludeBase as P+import Prelude ()+++{- | The amplification factor must be positive. -}+{-# INLINE amplify #-}+amplify :: (Ring.C y, Dim.C u, Dim.C v) =>+      y+   -> Proc.T s u t (+        SigA.R s v y yv+     -> SigA.R s v y yv)+amplify volume = Proc.pure $ FiltV.amplify volume++{-# INLINE amplifyDimension #-}+amplifyDimension :: (Ring.C y, Dim.C u, Dim.C v0, Dim.C v1) =>+      DN.T v0 y+   -> Proc.T s u t (+        SigA.R s v1 y yv+     -> SigA.R s (Dim.Mul v0 v1) y yv)+amplifyDimension volume = Proc.pure $ FiltV.amplifyDimension volume+++{-# INLINE negate #-}+negate :: (Additive.C yv, Dim.C u, Dim.C v) =>+      Proc.T s u t (+        SigA.R s v y yv+     -> SigA.R s v y yv)+negate = Proc.pure FiltV.negate+++{-# INLINE envelope #-}+envelope :: (Flat.C flat y0, Ring.C y0, Dim.C u, Dim.C v) =>+      Proc.T s u t (+        RP.T s flat y0   {- v the envelope -}+     -> SigA.R s v y y0  {- v the signal to be enveloped -}+     -> SigA.R s v y y0)+envelope = Proc.pure FiltV.envelope++{-# INLINE envelopeVector #-}+envelopeVector :: (Flat.C flat y0, Module.C y0 yv, Ring.C y, Dim.C u, Dim.C v) =>+      Proc.T s u t (+        RP.T s flat y0   {- v the envelope -}+     -> SigA.R s v y yv  {- v the signal to be enveloped -}+     -> SigA.R s v y yv)+envelopeVector = Proc.pure FiltV.envelopeVector++{-# INLINE envelopeVectorDimension #-}+envelopeVectorDimension ::+   (Module.C y0 yv, Ring.C y, Dim.C u, Dim.C v0, Dim.C v1) =>+      Proc.T s u t (+        SigA.R s v0 y y0  {-  the envelope -}+     -> SigA.R s v1 y yv  {-  the signal to be enveloped -}+     -> SigA.R s (Dim.Mul v0 v1) y yv)+envelopeVectorDimension = Proc.pure FiltV.envelopeVectorDimension+++{-# INLINE differentiate #-}+differentiate :: (Additive.C yv, Ring.C q, Dim.C u, Dim.C v) =>+      Proc.T s u q (+        SigA.R s v q yv+     -> SigA.R s (DimensionGradient u v) q yv)+differentiate =+   do rate <- Proc.getSampleRate+      return $ \ x ->+         SigA.fromSamples+            (rate &*& SigA.amplitude x)+            (FiltNR.differentiate (SigA.samples x))+++{- | needs a good handling of boundaries, yet -}+{-# INLINE meanStatic #-}+meanStatic ::+   (RealField.C q, Module.C q yv, Dim.C u, Dim.C v) =>+      DN.T (Dim.Recip u) q   {- ^ cut-off freqeuncy -}+   -> Proc.T s u q (+        SigA.R s v q yv+     -> SigA.R s v q yv)+meanStatic time =+   FiltR.meanStatic time++meanStaticSeparateTY :: (Additive.C yv, Field.C y, RealField.C t,+         Module.C y yv, Dim.C u, Dim.C v) =>+      DN.T (Dim.Recip u) t   {- ^ cut-off freqeuncy -}+   -> Proc.T s u t (+        SigA.R s v y yv+     -> SigA.R s v y yv)+meanStaticSeparateTY time =+   -- FiltR.meanStatic time, means that 't' = 'y'+   do f <- toFrequencyScalar time+      return $ \ x ->+         let tInt  = round ((recip f - 1)/2)+             width = tInt*2+1+         in  SigA.processSamples+                ((SigA.asTypeOfAmplitude (recip (fromIntegral width)) x *> ) .+                 Delay.staticNeg tInt .+                 MA.sumsStaticInt width) x+++{- | needs a better handling of boundaries, yet -}+{-# INLINE mean #-}+mean :: (Additive.C yv, RealField.C q,+         Module.C q yv, Dim.C u, Dim.C v, Sample.C q, Sample.C yv) =>+      DN.T (Dim.Recip u) q    {- ^ minimum cut-off freqeuncy -}+   -> Proc.T s u q (+        SigA.R s (Dim.Recip u) q q+                              {- v cut-off freqeuncies -}+     -> SigA.R s v q yv+     -> SigA.R s v q yv)+mean minFreq =+   FiltR.mean minFreq+++{-# INLINE delay #-}+delay :: (Additive.C yv, Field.C y, RealField.C t, Dim.C u, Dim.C v) =>+      DN.T u t+   -> Proc.T s u t (+        SigA.R s v y yv+     -> SigA.R s v y yv)+delay time =+   do t <- toTimeScalar time+      return $ SigA.processSamples (Delay.static (round t))+++{-# INLINE phaseModulation #-}+phaseModulation ::+   (Additive.C yv, RealField.C q, Dim.C u, Dim.C v,+    Sample.C q, Sample.C yv) =>+      Interpolation.T q yv+   -> DN.T u q+          {- ^ minDelay, minimal delay, may be negative -}+   -> DN.T u q+          {- ^ maxDelay, maximal delay, it must be @minDelay <= maxDelay@+               and the modulation must always be+               in the range [minDelay,maxDelay]. -}+   -> Proc.T s u q (+        SigA.R s u q q+          {- v delay control, positive numbers meanStatic delay,+               negative numbers meanStatic prefetch -}+     -> SigA.R s v q yv+     -> SigA.R s v q yv)+phaseModulation ip minDelay maxDelay =+   FiltR.phaseModulation ip minDelay maxDelay++{-# INLINE frequencyModulation #-}+frequencyModulation ::+   (Flat.C flat q, Additive.C yv, RealField.C q, Dim.C u, Dim.C v) =>+      Interpolation.T q yv+   -> Proc.T s u q (+        RP.T s flat q    {- v frequency factors -}+     -> SigA.R s v q yv+     -> SigA.R s v q yv)+frequencyModulation ip =+   Proc.pure $+      \ factors ->+          SigA.processSamples+             (FiltR.interpolateMultiRelativeZeroPad ip (Flat.toSamples factors))++{- |+Frequency modulation where the input signal can have a sample rate+different from the output.+(The sample rate values can differ, the unit must be the same.+We could lift that restriction,+but then the unit handling becomes more complicated,+and I didn't have a use for it so far.)++The function can be used for resampling.+-}+{-# INLINE frequencyModulationDecoupled #-}+frequencyModulationDecoupled ::+   (Flat.C flat q, Additive.C yv, RealField.C q, Dim.C u, Dim.C v) =>+      Interpolation.T q yv+   -> Proc.T s u q (+        RP.T s flat q    {- v frequency factors -}+     -> SigP.T u q (SigA.T v q (SigS.T Sig.T)) yv+     -> SigA.R s v q yv)+frequencyModulationDecoupled ip =+   fmap+      (\toFreq factors y ->+         flip SigA.processSamples (RP.fromSignal (SigP.signal y)) $+            FiltR.interpolateMultiRelativeZeroPad ip+               (SigA.scalarSamples toFreq+                  (SigA.fromSamples (SigP.sampleRate y) (Flat.toSamples factors))))+      (Proc.withParam Proc.toFrequencyScalar)+++{- | symmetric phaser -}+{-# INLINE phaser #-}+phaser ::+   (Additive.C yv, RealField.C q,+    Module.C q yv, Dim.C u, Dim.C v,+    Sample.C q, Sample.C yv) =>+      Interpolation.T q yv+   -> DN.T u q  {- ^ maxDelay, must be positive -}+   -> Proc.T s u q (+        SigA.R s u q q+                {- v delay control -}+     -> SigA.R s v q yv+     -> SigA.R s v q yv)+phaser = FiltR.phaser+{-+phaser ip maxDelay =+   do p <- phaserCore ip maxDelay+      return $ \ delays x ->+         FiltV.amplify 0.5 .+         uncurry MiscV.mix . p delays $ x+-}++{-# INLINE phaserStereo #-}+phaserStereo ::+   (Additive.C yv, RealField.C q,+    Module.C q yv, Dim.C u, Dim.C v,+    Sample.C q, Sample.C yv) =>+      Interpolation.T q yv+   -> DN.T u q   {- ^ maxDelay, must be positive -}+   -> Proc.T s u q (+        SigA.R s u q q+                 {- v delay control -}+     -> SigA.R s v q yv+     -> SigA.R s v q (Stereo.T yv))+phaserStereo = FiltR.phaserStereo+{-+phaserStereo ip maxDelay =+   do p <- phaserCore ip maxDelay+      return $ \ delays -> uncurry CutV.zip . p delays+-}++{-+{-# INLINE phaserCore #-}+phaserCore ::+   (Additive.C yv, RealField.C q,+    Module.C q yv, Dim.C u, Dim.C v,+    Sample.C q, Sample.C yv) =>+      Interpolation.T q yv+   -> DN.T u q   {- ^ maxDelay, must be positive -}+   -> Proc.T s u q (+        SigA.R s u q q+                 {- v delay control -}+     -> SigA.R s v q yv+     -> (SigA.R s v q yv, SigA.R s v q yv))+phaserCore ip maxDelay =+   do let minDelay  = Additive.negate maxDelay+      pm <- phaseModulation ip minDelay maxDelay+      return $ \ delays x ->+         let negDelays = FiltV.negate delays+         in  (pm delays x,+              pm negDelays x)+-}++++{-# INLINE firstOrderLowpass #-}+{-# INLINE firstOrderHighpass #-}+firstOrderLowpass, firstOrderHighpass ::+   (Trans.C q, Module.C q yv, Dim.C u, Dim.C v) =>+      CProc.T s u q+          (SigA.R s (Dim.Recip u) q q+                    {- v Control signal for the cut-off frequency. -} )+          (Filt1.Parameter q) (+        SigA.R s v q yv+                    {- v Input signal -}+     -> SigA.R s v q yv)+firstOrderLowpass  = firstOrderGen Filt1.lowpassModifier+firstOrderHighpass = firstOrderGen Filt1.highpassModifier++{-# INLINE firstOrderGen #-}+firstOrderGen ::+   (Trans.C q, Module.C q yv, Dim.C u, Dim.C v) =>+      (Modifier yv (Filt1.Parameter q) yv yv)+--      (Sig.T (Filt1.Parameter q) -> Sig.T yv -> Sig.T yv)+   -> CProc.T s u q (SigA.R s (Dim.Recip u) q q) (Filt1.Parameter q) (+        SigA.R s v q yv+     -> SigA.R s v q yv)+firstOrderGen modif =+   frequencyControl Filt1.parameter+      (Sig.modifyModulated modif)++++{-# INLINE butterworthLowpass #-}+{-# INLINE butterworthHighpass #-}+{-# INLINE chebyshevALowpass #-}+{-# INLINE chebyshevAHighpass #-}+{-# INLINE chebyshevBLowpass #-}+{-# INLINE chebyshevBHighpass #-}++butterworthLowpass, butterworthHighpass,+   chebyshevALowpass, chebyshevAHighpass,+   chebyshevBLowpass, chebyshevBHighpass ::+      (Trans.C q, VectorSpace.C q yv, Dim.C u, Dim.C v) =>+      NonNeg.Int   {- ^ Order of the filter, must be even,+                        the higher the order, the sharper is the separation of frequencies. -}+   -> q            {- ^ The attenuation at the cut-off frequency.+                        Should be between 0 and 1. -}+   -> CProc.T s u q+         (SigA.R s (Dim.Recip u) q q+                      {- v Control signal for the cut-off frequency. -}  )+         q (+        SigA.R s v q yv {- v Input signal -}+     -> SigA.R s v q yv)++butterworthLowpass  = higherOrderNoResoGen Butter.lowpass+butterworthHighpass = higherOrderNoResoGen Butter.highpass+chebyshevALowpass   = higherOrderNoResoGen Cheby.lowpassA+chebyshevAHighpass  = higherOrderNoResoGen Cheby.highpassA+chebyshevBLowpass   = higherOrderNoResoGen Cheby.lowpassB+chebyshevBHighpass  = higherOrderNoResoGen Cheby.highpassB++{- FIXME:+currently only frequencies can be interpolated not the filter parameters,+this is not very efficient+-}+{- TODO:+initial value+-}+{-# INLINE higherOrderNoResoGen #-}+higherOrderNoResoGen ::+   (Field.C q, Dim.C u, Dim.C v) =>+      (Int -> q -> [q] -> [yv] -> [yv])+   -> NonNeg.Int+   -> q+   -> CProc.T s u q (SigA.R s (Dim.Recip u) q q) q (+        SigA.R s v q yv+     -> SigA.R s v q yv)+higherOrderNoResoGen filt order ratio =+   frequencyControl id+      (\ cs xs ->+           Sig.fromList (filt (NonNeg.toNumber order) ratio+               (Sig.toList cs) (Sig.toList xs)))++++{-# INLINE universal #-}+universal ::+   (Flat.C flat q, Trans.C q, Module.C q yv, Dim.C u, Dim.C v) =>+      CProc.T s u q+         (RP.T s flat q+                   {- v signal for resonance,+                        i.e. factor of amplification at the resonance frequency+                        relatively to the transition band. -},+          SigA.R s (Dim.Recip u) q q+                   {- v signal for cut off and band center frequency -} )+         (UniFilter.Parameter q) (+        SigA.R s v q yv+                    {- v input signal -}+     -> SigA.R s v q (UniFilter.Result yv))+                    {- ^ highpass, bandpass, lowpass filter -}+universal =+   frequencyResonanceControl+      UniFilter.parameter+      (Sig.modifyModulated UniFilter.modifier)++{-# INLINE moogLowpass #-}+moogLowpass :: (Flat.C flat q, Trans.C q, Module.C q yv, Dim.C u, Dim.C v) =>+      NonNeg.Int+   -> CProc.T s u q+         (RP.T s flat q+                   {- v signal for resonance,+                        i.e. factor of amplification at the resonance frequency+                        relatively to the transition band. -},+          SigA.R s (Dim.Recip u) q q+                   {- v signal for cut off frequency -} )+         (Moog.Parameter q) (+        SigA.R s v q yv+     -> SigA.R s v q yv)+moogLowpass order =+   let orderInt = NonNeg.toNumber order+   in  frequencyResonanceControl+          (Moog.parameter orderInt)+          (Sig.modifyModulated (Moog.lowpassModifier orderInt))++{-# INLINE allpassCascade #-}+allpassCascade :: (Trans.C q, Module.C q yv, Dim.C u, Dim.C v) =>+      NonNeg.Int  {- ^ order, number of filters in the cascade -}+   -> q           {- ^ the phase shift to be achieved for the given frequency -}+   -> CProc.T s u q+         (SigA.R s (Dim.Recip u) q q {- v lowest comb frequency -})+         (Allpass.Parameter q) (+        SigA.R s v q yv+     -> SigA.R s v q yv)+allpassCascade order phase =+   let orderInt = NonNeg.toNumber order+   in  frequencyControl+          (Allpass.parameter orderInt phase)+          (Sig.modifyModulated (Allpass.cascadeModifier orderInt))+++{-# INLINE frequencyControl #-}+frequencyControl ::+   (Field.C y, Dim.C u, Dim.C v) =>+   (y -> ic) ->+   (Sig.T ic -> Sig.T yv0 -> Sig.T yv1) ->+   CProc.T s u y+      (SigA.R s (Dim.Recip u) y y) ic+      (SigA.R s v y1 yv0 -> SigA.R s v y1 yv1)++frequencyControl mkParam filt = CProc.Cons $+   do toFreq <- Proc.withParam toFrequencyScalar+      return+         (\ freqs -> Sig.map mkParam (SigA.scalarSamples toFreq freqs),+          \ params -> SigA.processSamples (filt params))+++{-# INLINE frequencyResonanceControl #-}+frequencyResonanceControl ::+   (Flat.C flat y, Field.C y, Dim.C u, Dim.C v) =>+   (FiltR.Pole y -> ic) ->+   (Sig.T ic -> Sig.T yv0 -> Sig.T yv1) ->+   CProc.T s u y+      (RP.T s flat y, SigA.R s (Dim.Recip u) y y) ic+      (SigA.R s v y1 yv0 -> SigA.R s v y1 yv1)++frequencyResonanceControl mkParam filt = CProc.Cons $+   do toFreq <- Proc.withParam toFrequencyScalar+      return+         (\ (resos, freqs) ->+               Sig.map mkParam $+               Sig.zipWith FiltR.Pole+                  (Flat.toSamples resos)+                  (SigA.scalarSamples toFreq freqs),+          \ params -> SigA.processSamples (filt params))+++{- | Infinitely many equi-delayed exponentially decaying echos. -}+{-# INLINE comb #-}+comb :: (RealField.C t, Module.C y yv, Dim.C u, Dim.C v, Sample.C yv) =>+   DN.T u t -> y -> Proc.T s u t (SigA.R s v y yv -> SigA.R s v y yv)+comb = FiltR.comb+++{- | Infinitely many equi-delayed echos processed by an arbitrary time-preserving signal processor. -}+{-# INLINE combProc #-}+combProc ::+   (RealField.C t, Real.C y, Field.C y, Module.C y yv, Sample.C yv,+    Dim.C u, Dim.C v) =>+   DN.T u t ->+   Proc.T s u t (SigA.R s v y yv -> SigA.R s v y yv) ->+   Proc.T s u t (SigA.R s v y yv -> SigA.R s v y yv)+combProc time proc =+   do f <- proc+      t <- fmap round $ toTimeScalar time+      let chunkSize = SigSt.chunkSize t+      return $ \x ->+         SigA.processSamples+            (Sig.fromStorableSignal .+             Comb.runProc t+                (Sig.toStorableSignal chunkSize .+                 SigA.vectorSamples (SigA.toAmplitudeScalar x) .+                 f .+                 SigA.fromSamples (SigA.amplitude x) .+                 Sig.fromStorableSignal) .+             Sig.toStorableSignal chunkSize) x++{-+combProc time proc sr x =+   Rate.loop (\sr' y -> MiscV.mixVolume (SigA.amplitude x) x (delay time sr' (proc sr' y))) sr+-}+++{-# INLINE integrate #-}+integrate :: (Additive.C yv, Field.C q, Dim.C u, Dim.C v) =>+      Proc.T s u q (+        SigA.R s v q yv+     -> SigA.R s (Dim.Mul u v) q yv)+integrate =+   do rate <- Proc.getSampleRate+      return $ \ x ->+         SigA.replaceAmplitude+            (DN.rewriteDimension (Dim.commute . Dim.applyRightMul Dim.invertRecip) $+             SigA.amplitude x &/& rate)+            (Hom.processSamples Integrate.run x)
+ src/Synthesizer/Dimensional/RateAmplitude/Instrument.hs view
@@ -0,0 +1,540 @@+{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}+module Synthesizer.Dimensional.RateAmplitude.Instrument where++import qualified Synthesizer.Dimensional.Rate.Oscillator as Osci+import qualified Synthesizer.Dimensional.Rate.Filter     as Filt+import qualified Synthesizer.Dimensional.RateAmplitude.Displacement as Disp+import qualified Synthesizer.Dimensional.RateAmplitude.Noise      as Noise+-- import qualified Synthesizer.SampleRateDimension.Filter.Recursive    as FiltR+-- import qualified Synthesizer.SampleRateDimension.Filter.NonRecursive as FiltNR+import qualified Synthesizer.Dimensional.RateAmplitude.Filter     as FiltA+import qualified Synthesizer.Dimensional.RateAmplitude.Cut        as Cut+import qualified Synthesizer.Dimensional.Amplitude.Cut            as CutA++import qualified Synthesizer.Dimensional.RateAmplitude.Control    as Ctrl+import qualified Synthesizer.Dimensional.Rate.Control             as CtrlR++import qualified Synthesizer.Dimensional.Straight.Displacement    as DispS++import qualified Synthesizer.Dimensional.Amplitude.Analysis       as Ana++import qualified Synthesizer.Dimensional.Process as Proc+import qualified Synthesizer.Dimensional.Cyclic.Signal   as SigC+import qualified Synthesizer.Dimensional.Straight.Signal as SigS+import qualified Synthesizer.Dimensional.RateAmplitude.Signal as SigA++import Synthesizer.Dimensional.RateAmplitude.Signal (($-), ($&), (&*^), (&*>^), )+import Synthesizer.Dimensional.RateAmplitude.Control ((-|#), ( #|-), (|#), ( #|), )++import Synthesizer.Dimensional.Process (($:), ($::), (.:), ($^), ($#))+import Synthesizer.Dimensional.Amplitude.Control (mapLinear, mapExponential, )++import qualified Synthesizer.Generic.SampledValue as Sample++import qualified Algebra.DimensionTerm as Dim+import qualified Number.DimensionTerm  as DN++import Number.DimensionTerm ((*&), (&*&), )++import qualified Synthesizer.State.Interpolation as Interpolation+import           Synthesizer.Plain.Instrument (choirWave)+import qualified Synthesizer.Basic.Wave       as Wave+import qualified Synthesizer.Basic.Phase      as Phase++import qualified Number.NonNegative     as NonNeg++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 System.Random (Random, randoms, randomRs, mkStdGen, )+import Synthesizer.Utility (randomRsBalanced, balanceLevel, )++import Data.List(zip4)++import PreludeBase+import NumericPrelude++++{-| Create a sound of a slightly changed frequency+    just as needed for a simple stereo sound. -}+{-# INLINE stereoPhaser #-}+stereoPhaser :: Ring.C a =>+      (DN.T Dim.Frequency a ->+       Proc.T s Dim.Time a (SigA.R s u b b))+           {- ^ A function mapping a frequency to a signal. -}+   -> a    {- ^ The factor to the frequency, should be close to 1. -}+   -> DN.T Dim.Frequency a+           {- ^ The base (undeviated) frequency of the sound. -}+   -> Proc.T s Dim.Time a (SigA.R s u b b)+stereoPhaser sound dif freq =+   sound (dif *& freq)++++{-+allpassPlain :: (RealField.C a, Trans.C a, Module.C a a) =>+                   a -> a -> a -> a -> [a]+allpassPlain sampleRate halfLife k freq =+    Filt.allpassCascade 10+        (map Filt.AllpassParam (exponential2 (halfLife*sampleRate) k))+        (simpleSaw sampleRate freq)+-}++{-# INLINE allpassDown #-}+allpassDown ::+   (RealField.C a, Trans.C a, Module.C a a) =>+      NonNeg.Int -> DN.T Dim.Time a ->+      DN.T Dim.Frequency a -> DN.T Dim.Frequency a ->+      Proc.T s Dim.Time a (SigA.R s Dim.Voltage a a)+allpassDown order halfLife filterfreq freq =+   do x <- simpleSaw freq+      FiltA.amplify 0.3 $:+         (Disp.mix+             $# x+             $: (Filt.allpassCascade order (-2*pi)+                    $: filterfreq &*^ CtrlR.exponential2 halfLife+                    $# x))+++{-# INLINE moogDown #-}+{-# INLINE moogReso #-}+moogDown, moogReso ::+   (RealField.C a, Trans.C a, Module.C a a) =>+      NonNeg.Int -> DN.T Dim.Time a ->+      DN.T Dim.Frequency a -> DN.T Dim.Frequency a ->+      Proc.T s Dim.Time a (SigA.R s Dim.Voltage a a)+moogDown order halfLife filterfreq freq =+   Filt.moogLowpass order+      $- DN.fromNumber 10+      $: filterfreq &*^ CtrlR.exponential2 halfLife+      $: simpleSaw freq++moogReso order halfLife filterfreq freq =+   Filt.moogLowpass order+      $: DN.fromNumber 100 &*^ CtrlR.exponential2 halfLife+      $- filterfreq+      $: simpleSaw freq+++{-# INLINE bell #-}+bell :: (Trans.C a, RealField.C a, Module.C a a) =>+   DN.T Dim.Frequency a ->+   Proc.T s Dim.Time a (SigA.R s Dim.Voltage a a)+bell freq =+   let halfLife = DN.time 0.5+   in  FiltA.amplify (1/3) $:+       (Disp.mixMulti $::+          (bellHarmonic 1 halfLife freq :+           bellHarmonic 4 halfLife freq :+           bellHarmonic 7 halfLife freq :+           []))++++{-# INLINE bellHarmonic #-}+bellHarmonic :: (Trans.C a, RealField.C a, Module.C a a) =>+   a -> DN.T Dim.Time a -> DN.T Dim.Frequency a ->+   Proc.T s Dim.Time a (SigA.R s Dim.Voltage a a)+bellHarmonic n halfLife freq =+   Filt.envelope+      $: CtrlR.exponential2 (recip n *& halfLife)+      $: (DN.voltage 1+             &*^ (Osci.freqMod Wave.sine zero+                  $: (mapLinear 0.005 (DN.frequency 5)+                        $^ Osci.static Wave.sine zero (n *& freq))))+++{-# INLINE fastBell #-}+{-# INLINE squareBell #-}+{-# INLINE moogGuitar #-}+{-# INLINE moogGuitarSoft #-}+{-# INLINE fatSaw #-}++fastBell, squareBell, moogGuitar, moogGuitarSoft, fatSaw ::+   (RealField.C a, Trans.C a, Module.C a a) =>+   DN.T Dim.Frequency a -> Proc.T s Dim.Time a (SigA.R s Dim.Voltage a a)+fastBell freq =+   Filt.envelope+      $: CtrlR.exponential2 (DN.time 0.2)+      $: (DN.voltage 1  &*^  Osci.static Wave.sine zero freq)++{-# INLINE filterSaw #-}+filterSaw :: (Module.C a a, Trans.C a, RealField.C a) =>+   DN.T Dim.Frequency a -> DN.T Dim.Frequency a ->+   Proc.T s Dim.Time a (SigA.R s Dim.Voltage a a)+filterSaw filterFreq freq =+   FiltA.amplify 0.1 $:+   (Filt.lowpassFromUniversal $:+     (Filt.universal+         $- DN.fromNumber 10+         $: filterFreq &*^ CtrlR.exponential2 (DN.time 0.1)+         $: (DN.voltage 1  &*^  Osci.static Wave.saw zero freq)))+++squareBell freq =+   Filt.firstOrderLowpass+      $: DN.frequency 4000 &*^ CtrlR.exponential2 (DN.time (1/10))+--       (Osci.freqModSample Interpolation.cubic [0, 0.7, -0.3, 0.7, 0, -0.7, 0.3, -0.7] zero+      $: (DN.voltage 1  &*^+           (Osci.freqModSample Interpolation.linear+               (SigC.fromPeriodList [0, 0.5, 0.6, 0.8, 0, -0.5, -0.6, -0.8]) zero+               $: (mapLinear 0.01 freq+                      $^ (Osci.static Wave.sine zero (DN.frequency 5.0)))))+++{-# INLINE fmBell #-}+fmBell :: (RealField.C a, Trans.C a, Module.C a a) =>+   a -> a -> DN.T Dim.Frequency a ->+   Proc.T s Dim.Time a (SigA.R s Dim.Voltage a a)+fmBell depth freqRatio freq =+   let modul =+          Filt.envelope+             $: CtrlR.exponential2 (DN.time 0.2)+             $: DN.fromNumber depth &*^ Osci.static Wave.sine zero (freqRatio *& freq)+   in  Filt.envelope+          $: CtrlR.exponential2 (DN.time 0.5)+          $: (DN.voltage 1 &*^ (Osci.phaseMod Wave.sine freq $& modul))+++moogGuitar freq =+   let filterControl =+          DN.frequency 4000 &*^ CtrlR.exponential2 (DN.time 0.5)+       tone =+          DN.voltage 1  &*^+          (Osci.freqMod Wave.saw zero+              $: (mapLinear 0.005 freq $^+                     Osci.static Wave.sine zero (DN.frequency 5)))+   in  Filt.moogLowpass 4 $- DN.fromNumber 10 $: filterControl $: tone++moogGuitarSoft freq =+   Filt.envelope+      $: (fmap (1-) $^ CtrlR.exponential2 (DN.time 0.003))+      $: moogGuitar freq+++{- |+Phase modulation using a ring modulated signal.+May be used as some kind of e-guitar.+-}+fmRing ::+   (RealField.C a, Trans.C a, Module.C a a) =>+   DN.T Dim.Frequency a -> Proc.T s Dim.Time a (SigA.R s Dim.Voltage a a)+fmRing freq =+   DN.voltage 1 &*^+   (Osci.phaseMod (Wave.sineSawSmooth 1) freq+     $: (DN.fromNumber 1 &*^   -- 0.2 for no distortion+            (Filt.envelope+                $: CtrlR.exponential2 (DN.time 0.2)+                $: (Filt.envelope+                       $: Osci.static (Wave.raise one Wave.sine) (Phase.fromRepresentative 0.75) freq+                       $: Osci.static Wave.sine zero (5.001 *& freq)))))++fatPad ::+   (RealField.C a, Trans.C a, Module.C a a, Random a) =>+   DN.T Dim.Frequency a -> Proc.T s Dim.Time a (SigA.R s Dim.Voltage a a)+fatPad freq =+   let env =+          Cut.append+             $: (Cut.take (DN.time 0.7) $:+                  Ctrl.cubicHermite+                   (DN.time 0,   (DN.fromNumber 0,   DN.frequency 1 &*& DN.fromNumber 5))+                   (DN.time 0.7, (DN.fromNumber 0.5, DN.frequency 1 &*& DN.fromNumber 0)))+             $: Ctrl.constant (DN.fromNumber 0.5)+       osci f =+          DN.voltage 0.3 &*^+          (Osci.phaseMod Wave.sine f+            $: (DN.fromNumber 2 &*^+                   (Filt.envelope+                       $: env+                       $: Osci.static (Wave.sineSawSmooth 1) zero f)))+       freqs = randomRsBalanced (mkStdGen 384) 3 1 0.03+   in  Disp.mixMulti $:: map (\k -> osci (k *& freq)) freqs+{-+renderTimeVoltageMonoDouble (DN.frequency 44100) "fat-pad" (Cut.take (DN.time 1.5) $: fatPad (DN.frequency 220))+-}+++brass ::+   (RealField.C a, Trans.C a, Module.C a a, Random a) =>+   DN.T Dim.Frequency a -> Proc.T s Dim.Time a (SigA.R s Dim.Voltage a a)+brass freq =+   let blobEnv = Ctrl.piecewise+          (DN.fromNumber 0  |# (DN.time 0.05, Ctrl.cosinePiece) #|-+           DN.fromNumber 1 -|# (DN.time 0.05, Ctrl.cosinePiece) #|+           DN.fromNumber 0)+       adsr = Ctrl.piecewise+          (DN.fromNumber 0 |# (DN.time 0.1, Ctrl.cubicPiece (DN.frequency 1 &*& DN.fromNumber 10) (DN.frequency 1 &*& DN.fromNumber 0)) #|-+           DN.fromNumber 0.5 -|# (DN.time 1, Ctrl.stepPiece) #|-+           DN.fromNumber 0.5 -|# (DN.time 0.3, Ctrl.exponentialPiece (DN.fromNumber 0)) #|+           DN.fromNumber 0.01)+       osci b f =+          DN.voltage 0.5 &*^+          (Osci.freqMod Wave.saw zero $:+             (Disp.mix+                 $: (mapLinear 0.01 f $^ Osci.static Wave.sine zero (DN.frequency 2))+                 $: ((b *& f) &*^ blobEnv)))+       n = 4+       freqs = randomRsBalanced (mkStdGen 295) n 1 0.03+       blobAmps = balanceLevel 0 (take n (iterate (0.1+) 0))+   in  Filt.envelope+          $: adsr+          $: (Disp.mixMulti $:: zipWith (\b k -> osci b (k *& freq)) blobAmps freqs)+{-+Synthesizer.Dimensional.RateAmplitude.File.renderTimeVoltageMonoDouble (DN.frequency 44100) "brass" (brass (DN.frequency 440))+-}+++{-| low pass with resonance -}+{-# INLINE filterSweep #-}+filterSweep :: (Module.C a v, Trans.C a, RealField.C a) =>+   Phase.T a ->+   Proc.T s Dim.Time a (+      SigA.R s Dim.Voltage a v ->+      SigA.R s Dim.Voltage a v)+filterSweep phase =+   Filt.lowpassFromUniversal .:+    (Filt.universal+       $- DN.fromNumber 10+       $: (mapExponential 2 (DN.frequency 1800) $^+              Osci.static Wave.sine phase (DN.frequency (1/16))))+++{-# INLINE fatSawChordFilter #-}+{-# INLINE fatSawChord #-}+fatSawChordFilter, fatSawChord ::+   (RealField.C a, Trans.C a, Module.C a a) =>+   DN.T Dim.Frequency a -> Proc.T s Dim.Time a (SigA.R s Dim.Voltage a a)++fatSawChordFilter freq =+   FiltA.amplify (1/2) $:+   (Filt.lowpassFromUniversal $:+     (Filt.universal+         $- DN.fromNumber 10+         $: filterDown+         $: fatSawChord freq))++fatSawChord freq =+   FiltA.amplify (1/3) $:+   (Disp.mixMulti $::+       [fatSaw ( 1    *& freq),+        fatSaw ((5/4) *& freq),+        fatSaw ((3/2) *& freq)])++{-# INLINE filterDown #-}+filterDown :: (RealField.C a, Trans.C a) =>+   Proc.T s Dim.Time a (SigA.R s Dim.Frequency a a)+filterDown =+   DN.frequency 4000 &*^ CtrlR.exponential2 (DN.time (1/3))++{-# INLINE simpleSaw #-}+simpleSaw :: (Ring.C a, Dim.C u, RealField.C v) =>+   DN.T (Dim.Recip u) v ->+   Proc.T s u v (SigA.R s Dim.Voltage a v)+simpleSaw freq =+   DN.voltage 1 &*>^ Osci.static Wave.saw zero freq+++{-| accumulate multiple similar saw sounds and observe the increase of volume+    The oscillator @osc@ must accept relative frequencies. -}+{-# INLINE modulatedWave #-}+modulatedWave :: (Trans.C a, RealField.C a, Dim.C u) =>+   Proc.T s u a (SigA.R s (Dim.Recip u) a a -> SigA.R s Dim.Voltage a a) ->+   DN.T (Dim.Recip u) a ->+   a -> Phase.T a ->+   DN.T (Dim.Recip u) a ->+   Proc.T s u a (SigA.R s Dim.Voltage a a)+modulatedWave osc freq depth phase speed =+   osc $: (mapLinear depth freq $^+              Osci.static Wave.sine phase speed)+++{-# INLINE accumulationParameters #-}+accumulationParameters :: (Random a, Trans.C a, RealField.C a, Module.C a a) =>+   [(Phase.T a, a, Phase.T a, DN.T Dim.Frequency a)]+accumulationParameters =+   let starts = randoms           (mkStdGen 48251)+       depths = randomRs (0,0.02) (mkStdGen 12354)+       phases = randoms           (mkStdGen 74389)+       speeds = randomRs (DN.frequency 0.1, DN.frequency 0.3)+                                  (mkStdGen 03445)+   in  zip4 starts depths phases speeds++{-# INLINE accumulatedSaws #-}+{-# INLINE choir #-}+accumulatedSaws, choir ::+   (Random a, Trans.C a, RealField.C a, Module.C a a) =>+   DN.T Dim.Frequency a ->+   Proc.T s Dim.Time a (SigA.R s Dim.Voltage a a)+accumulatedSaws freq =+    Disp.mixMulti $::+       (map+          (\(start, depth, phase, speed) ->+               modulatedWave+                  (ampVolt (Osci.freqMod Wave.saw start))+                  freq depth phase speed)+          accumulationParameters)++choir freq =+   FiltA.amplify 0.2 $: (Disp.mixMulti $::+      take 10+         (map+            (\(start, depth, phase, speed) ->+                modulatedWave+                  (ampVolt (Osci.freqModSample Interpolation.constant+                      (SigC.fromPeriodList choirWave) start))+                  freq depth phase speed)+            accumulationParameters))+++fatSaw freq =+    {- a simplified version of modulatedWave -}+    let partial depth modPhase modFreq =+           osciDoubleSaw $:+              (mapLinear depth freq $^+                  Osci.static Wave.sine (Phase.fromRepresentative modPhase) modFreq)+    in  Disp.mixMulti $::+            [partial 0.00311 0.0 (DN.frequency 20),+             partial 0.00532 0.3 (DN.frequency 17),+             partial 0.00981 0.9 (DN.frequency  6)]+++{-# INLINE wasp #-}+{- |+A good choice is @freq = DN.frequency 110@+-}+wasp ::+   (RealField.C q, Trans.C q, Module.C q q, Random q, Sample.C q, Dim.C u) =>+   DN.T (Dim.Recip u) q ->+   Proc.T s u q (SigA.R s Dim.Voltage q q)+wasp freq =+   Filt.envelope+      $: (mapLinear 1 (DN.scalar 0.5) $^ Osci.static Wave.saw zero (recip 2.01 *& freq))+      $: DN.voltage 0.7 &*^ Osci.static Wave.saw zero freq+++{-# INLINE osciDoubleSaw #-}+osciDoubleSaw :: (RealField.C a, Module.C a a, Dim.C u) =>+   Proc.T s u a (+      SigA.R s (Dim.Recip u) a a ->+      SigA.R s Dim.Voltage a a)+osciDoubleSaw =+   ampVolt $+   Osci.freqModSample Interpolation.linear+      (SigC.fromPeriodList [-1, -0.2, 0.5, -0.5, 0.2, 1.0]) zero++{-# INLINE ampVolt #-}+ampVolt :: (Ring.C y, Dim.C u) =>+   Proc.T s u y (a -> SigS.R s y) ->+   Proc.T s u y (a -> SigA.R s Dim.Voltage y y)+ampVolt p =+   Proc.withParam $ \x ->+      DN.voltage 1 &*^ (p $# x)++{-|+A tone with a waveform with roughly the dependency @x -> x^?p@,+where the waveform is normalized to constant quadratic norm+-}+{-# INLINE osciSharp #-}+osciSharp :: (RealField.C a, Trans.C a) =>+   DN.T Dim.Frequency a ->+   Proc.T s Dim.Time a (SigA.R s Dim.Voltage a a)+osciSharp freq =+   let control = DN.fromNumber 10 &*^ CtrlR.exponential2 (DN.time 0.01)+   in  DN.voltage 1 &*^+          (Osci.shapeMod Wave.powerNormed zero freq $& 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.+-}+{-# INLINE osciAbsModSaw #-}+osciAbsModSaw :: (RealField.C a, Trans.C a, Module.C a a) =>+   DN.T Dim.Frequency a ->+   Proc.T s Dim.Time a (SigA.R s Dim.Voltage a a)+osciAbsModSaw freq =+   let harmonic n =+          DN.voltage (0.25 / fromInteger n)+              &*^ (Osci.freqMod Wave.sine zero+                $: (mapLinear 0.03 freq $^+                      (Osci.static Wave.sine zero (DN.frequency 1))))+   in  Disp.mixMulti $:: map harmonic [1..20]++{-|+Short pulsed Noise.white,+i.e. Noise.white amplified with pulses of varying H\/L ratio.+-}+{-# INLINE pulsedNoise #-}+pulsedNoise :: (Random a, RealField.C a, Trans.C a, Module.C a a) =>+   DN.T Dim.Frequency a   {-^ frequency of the pulses, interesting ones are around 100 Hz and below -} ->+   Proc.T s Dim.Time a (SigA.R s Dim.Voltage a a)+pulsedNoise freq =+   let raisedSine = Wave.raise one Wave.sine+       c = Proc.pure Ana.lessOrEqual+              $: (DN.voltage 1.0 &*^ Osci.static raisedSine zero freq)+              $: (DN.voltage 0.2 &*^ Osci.static raisedSine zero (DN.frequency 0.1))+   in  Proc.pure CutA.selectBool+          $- DN.voltage 0+          $: Noise.white (DN.frequency 20000) (DN.voltage 1.0)+          $: c+++{-# INLINE noisePerc #-}+noisePerc :: (Random a, RealField.C a, Trans.C a) =>+   Proc.T s Dim.Time a (SigA.R s Dim.Voltage a a)+noisePerc =+   Filt.envelope+      $: CtrlR.exponential2 (DN.time 0.1)+      $: Noise.white (DN.frequency 20000) (DN.voltage 1.0)++{-# INLINE noiseBass #-}+noiseBass :: (Random a, RealField.C a, Trans.C a, Module.C a a, Sample.C a) =>+   DN.T Dim.Frequency a ->+   Proc.T s Dim.Time a (SigA.R s Dim.Voltage a a)+noiseBass freq =+   FiltA.combProc (DN.unrecip freq)+      (Filt.firstOrderLowpass $- DN.frequency 2000)+      $: noisePerc++{-|+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.+-}+{-# INLINE electroTom #-}+electroTom :: (Ring.C a, Random a, RealField.C a, Trans.C a, Module.C a a, Sample.C a) =>+   Proc.T s Dim.Time a (SigA.R s Dim.Voltage a a)+electroTom =+   let ks =+         FiltA.combProc (DN.time (1/30))+            (Filt.firstOrderLowpass $- (DN.frequency 1000))+            $: noisePerc+   in  Filt.frequencyModulation Interpolation.linear+          $: CtrlR.exponential2 (DN.time 0.3)+          $: ks++{-# INLINE bassDrum #-}+bassDrum ::+   (RealField.C q, Trans.C q, Module.C q q, Random q) =>+   Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q)+bassDrum =+   Cut.take (DN.time 0.15) $:+   (Disp.mix+    $: (Filt.firstOrderLowpass+          $- (DN.frequency 5000)+          $: (Filt.envelope+                $: (DispS.raise 0.03 $^ CtrlR.exponential2 (DN.time 0.002))+                $: (Noise.white (DN.frequency 20000) (DN.voltage 1))))+    $: (DN.voltage 0.5 &*^+         (Filt.envelope+            $: (CtrlR.exponential2 (DN.time 0.05))+            $: (Osci.freqMod Wave.sine zero+                   $: (Ctrl.exponential2+                         (DN.time 0.15) (DN.frequency 100))))))
+ src/Synthesizer/Dimensional/RateAmplitude/Noise.hs view
@@ -0,0 +1,143 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++-}+module Synthesizer.Dimensional.RateAmplitude.Noise+  (white,    whiteBandEnergy,    randomPeeks,+   whiteGen, whiteBandEnergyGen, randomPeeksGen,+   ) where+++import qualified Synthesizer.State.NoiseCustom as Noise+import qualified Synthesizer.State.Signal as Sig++import qualified Synthesizer.RandomKnuth as Knuth++import qualified Synthesizer.Dimensional.RateAmplitude.Signal as SigA+import qualified Synthesizer.Dimensional.Process as Proc++import Synthesizer.Dimensional.Process (($#), )++import qualified Number.DimensionTerm        as DN+import qualified Algebra.DimensionTerm       as Dim+import Number.DimensionTerm ((&*&))++import qualified Algebra.Algebraic          as Algebraic+import qualified Algebra.Field              as Field+import qualified Algebra.Ring               as Ring++import System.Random (Random, RandomGen, mkStdGen)++import NumericPrelude+import PreludeBase as P++++{-# INLINE white #-}+{- The Field.C constraint could be replaced by Ring.C+   if Noise instead of faster NoiseCustom would be used -}+white :: (Field.C yv, Random yv, Algebraic.C q, Dim.C u, Dim.C v) =>+      DN.T (Dim.Recip u) q+          {-^ width of the frequency band -}+   -> DN.T v q+          {-^ volume caused by the given frequency band -}+   -> Proc.T s u q (SigA.R s v q yv)+          {-^ noise -}+white =+   -- FIXME: there was a bug in GHC-6.4's standard random generator where genRange returned minBound::Int as lower bound but actually generated numbers were always positive+   -- this is fixed in GHC-6.6 and thus the standard generator can be used+   whiteGen (Knuth.cons 6746)+--   whiteGen (mkStdGen 6746)++{-# INLINE whiteGen #-}+whiteGen ::+   (Field.C yv, Random yv, RandomGen g, Algebraic.C q, Dim.C u, Dim.C v) =>+      g   {-^ random generator, can be used to choose a seed -}+   -> DN.T (Dim.Recip u) q+          {-^ width of the frequency band -}+   -> DN.T v q+          {-^ volume caused by the given frequency band -}+   -> Proc.T s u q (SigA.R s v q yv)+          {-^ noise -}+whiteGen gen bandWidth volume =+   do bw <- SigA.toFrequencyScalar bandWidth+      return $+         SigA.fromSamples+            (DN.scale (sqrt $ 3 / bw) volume)+            (Noise.whiteGen gen)+++{-# INLINE whiteBandEnergy #-}+whiteBandEnergy :: (Field.C yv, Random yv, Algebraic.C q, Dim.C u, Dim.C v) =>+      DN.T (Dim.Mul u (Dim.Sqr v)) q+          {-^ energy per frequency band -}+   -> Proc.T s u q (SigA.R s v q yv)+          {-^ noise -}+whiteBandEnergy = whiteBandEnergyGen (mkStdGen 6746)++{-# INLINE whiteBandEnergyGen #-}+whiteBandEnergyGen ::+   (Field.C yv, Random yv, RandomGen g, Algebraic.C q, Dim.C u, Dim.C v) =>+      g   {-^ random generator, can be used to choose a seed -}+   -> DN.T (Dim.Mul u (Dim.Sqr v)) q+          {-^ energy per frequency band -}+   -> Proc.T s u q (SigA.R s v q yv)+          {-^ noise -}+whiteBandEnergyGen gen energy =+   do rate <- Proc.getSampleRate+      return $+         SigA.fromSamples+            (DN.sqrt $ DN.scale 3 $+             DN.rewriteDimension+                (Dim.identityLeft . Dim.applyLeftMul Dim.cancelLeft .+                 Dim.associateLeft) $+             rate &*& energy)+            (Noise.whiteGen gen)+++{-+The Field.C q constraint could be lifted to Ring.C+if we would use direct division instead of toFrequencyScalar.+-}+{-# INLINE randomPeeks #-}+randomPeeks ::+   (Field.C q, Random q, Ord q, Dim.C u) =>+    Proc.T s u q (+       SigA.R s (Dim.Recip u) q q+          {- v momentary densities (frequency),+               @p@ means that there is about one peak+               in the time range of @1\/p@. -}+    -> SigA.R s (Dim.Recip u) q q)+          {- ^ Every occurence is represented by a peak of area 1.+               If you smooth the input and the output signal to the same degree+               they should be rather similar. -}+randomPeeks =+   randomPeeksGen (mkStdGen 876)+++{-# INLINE randomPeeksGen #-}+randomPeeksGen ::+   (Field.C q, Random q, Ord q, Dim.C u,+    RandomGen g) =>+       g  {- ^ random generator, can be used to choose a seed -}+    -> Proc.T s u q (+         SigA.R s (Dim.Recip u) q q+          {- v momentary densities (frequency),+               @p@ means that there is about one peak+               in the time range of @1\/p@. -}+      -> SigA.R s (Dim.Recip u) q q)+          {- ^ Every occurence is represented by a peak of area 1. -}+randomPeeksGen g =+   Proc.withParam $ \ dens ->+      do freq <- SigA.toFrequencyScalar (SigA.amplitude dens)+         SigA.fromPeaks $#+            (SigA.Peaks $+             Sig.zipWith (<)+                (Noise.randomRs (0, recip freq) g)+                (SigA.samples dens))
+ src/Synthesizer/Dimensional/RateAmplitude/Play.hs view
@@ -0,0 +1,101 @@+{-# OPTIONS -fno-implicit-prelude -fglasgow-exts #-}+-- glasgow-exts for all quantifier+module Synthesizer.Dimensional.RateAmplitude.Play (+   timeVoltageMonoDouble,+   timeVoltageStereoDouble,+   timeVoltageMonoDoubleR,+   timeVoltageStereoDoubleR,+  ) where++import qualified Sox+-- import qualified Sox.File+import qualified Sox.Play+-- import qualified BinarySample as BinSmp++import qualified Synthesizer.Dimensional.Process as Proc++import qualified Synthesizer.Dimensional.Amplitude.Signal as SigA+import qualified Synthesizer.Dimensional.RateAmplitude.Signal as SigRA+import qualified Synthesizer.Dimensional.RateWrapper as SigP++import qualified Synthesizer.Storable.Signal as SigSt++-- import qualified Synthesizer.Dimensional.Straight.Signal as SigS+-- import qualified Synthesizer.State.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.DimensionTerm as Dim+import qualified Number.DimensionTerm  as DN++import qualified Synthesizer.Frame.Stereo as Stereo++-- import System.Exit(ExitCode)+import Control.Exception(bracket)+import Foreign.Storable (Storable)++import qualified System.IO as IO+import qualified System.Process as Proc++import NumericPrelude+import PreludeBase+++raw :: (RealField.C a, Storable y) =>+   [String] -> a -> Int -> SigSt.T y -> IO ()+raw args sampleRate numChannels stream =+   bracket+      (Proc.runInteractiveProcess "play"+          (args +++           Sox.sampleRateOption sampleRate +++           Sox.channelOption numChannels +++           ["-t","sw","-"])+          Nothing Nothing)+      (\(input,output,err,proc) -> do+          mapM IO.hClose [input, output, err]+          -- wait for end of replay+          Proc.waitForProcess proc)+      (\(input,_,_,_) ->+         Sox.Play.catchCtrlC >>+         SigSt.hPut input stream)+++{-# INLINE timeVoltageMonoDouble #-}+timeVoltageMonoDouble ::+   SigP.T Dim.Time Double (SigA.S Dim.Voltage Double) Double ->+   IO ()+timeVoltageMonoDouble sig =+   let rate = DN.toNumberWithDimension Dim.frequency (SigP.sampleRate sig)+   in  raw [] rate 1+          (SigP.signal (SigRA.toStorableInt16Mono sig))+++{-# INLINE timeVoltageStereoDouble #-}+timeVoltageStereoDouble ::+   SigP.T Dim.Time Double (SigA.S Dim.Voltage Double) (Stereo.T Double) ->+--   SigP.T Dim.Time t (SigA.T Dim.Voltage y (SigS.T Sig.T)) yv ->+   IO ()+timeVoltageStereoDouble sig =+   let rate = DN.toNumberWithDimension Dim.frequency (SigP.sampleRate sig)+   in  raw [] rate 2+          (SigP.signal (SigRA.toStorableInt16Stereo sig))++{-# INLINE timeVoltageMonoDoubleR #-}+timeVoltageMonoDoubleR ::+   DN.T Dim.Frequency Double ->+   (forall s. Proc.T s Dim.Time Double (SigA.R s Dim.Voltage Double Double)) ->+   IO ()+timeVoltageMonoDoubleR rate sig =+   timeVoltageMonoDouble (SigP.runProcess rate sig)++{-# INLINE timeVoltageStereoDoubleR #-}+timeVoltageStereoDoubleR ::+   DN.T Dim.Frequency Double ->+   (forall s. Proc.T s Dim.Time Double (SigA.R s Dim.Voltage Double (Stereo.T Double))) ->+   IO ()+timeVoltageStereoDoubleR rate sig =+   timeVoltageStereoDouble (SigP.runProcess rate sig)
+ src/Synthesizer/Dimensional/RateAmplitude/Signal.hs view
@@ -0,0 +1,216 @@+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++For a description see "Synthesizer.Dimensional.Process".+-}+module Synthesizer.Dimensional.RateAmplitude.Signal (+   T, R,+   Proc.toTimeScalar,+   Proc.toFrequencyScalar,+   toAmplitudeScalar,+   toGradientScalar,+   DimensionGradient,+   amplitude, samples,+   fromSignal, fromSamples,+   scalarSamples, fromScalarSamples, scalarSamplesGeneric,+   vectorSamples, fromVectorSamples,+   replaceAmplitude,+   replaceSamples,+   processSamples,+   asTypeOfAmplitude,+   ($-),  ($&),+   (&*^), (&*>^),+   Peaks(Peaks), fromPeaks,+   cache, bindCached, share,++   toStorableInt16Mono,+   toStorableInt16Stereo,+   ) where++import Synthesizer.Dimensional.Process (($:), ($^), ($#), )+import qualified Synthesizer.Dimensional.Process as Proc++import qualified Synthesizer.Dimensional.Abstraction.Flat as Flat+import qualified Synthesizer.Dimensional.Abstraction.RateIndependent as Ind+import qualified Synthesizer.Dimensional.RatePhantom as RP++import Synthesizer.Dimensional.Amplitude.Signal as SigA+import qualified Synthesizer.Dimensional.Amplitude.Control as CtrlV+import qualified Synthesizer.Dimensional.Straight.Signal   as SigS+import qualified Synthesizer.State.Signal as Sig+import qualified Synthesizer.Storable.Signal as SigSt+import qualified Synthesizer.Generic.SampledValue as Sample+import qualified Synthesizer.Frame.Stereo as Stereo++import qualified BinarySample as BinSmp+import Data.Int (Int16)++import qualified Number.DimensionTerm        as DN+import qualified Algebra.DimensionTerm       as Dim+import Number.DimensionTerm ((&/&))++import qualified Algebra.Module         as Module+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 Data.List as List++import NumericPrelude (zero, one, )+-- import PreludeBase+import Prelude (($), (.), Bool, Ord, fmap, return, (=<<), )++++type DimensionGradient u v = Dim.Mul (Dim.Recip u) v++{-# INLINE toGradientScalar #-}+toGradientScalar :: (Field.C q, Dim.C u, Dim.C v) =>+   DN.T v q -> DN.T (DimensionGradient u v) q -> Proc.T s u q q+toGradientScalar amp steepness =+   Proc.toFrequencyScalar+   (DN.rewriteDimension (Dim.identityRight . Dim.applyRightMul Dim.cancelRight . Dim.associateRight) $+    steepness &/& amp)+++{- |+We want to represent streams of discrete events+in a manner that is more safe than plain @[Bool]@.+Each peak can be imagined as a Dirac impulse.++A @[Bool]@ could be used accidentally for 'Synthesizer.Dimensional.Amplitude.Cut.selectBool',+where @selectBool@ is intended for piecewise constant control curves.++You may think that a type like @Peak = Peak Bool@ as sample type+in @T s Peak@ would also do the job.+Actually, this wouldn't be a good idea+since you can apply constant interpolation on it,+which obviously fools the idea of a peak.+-}+newtype Peaks s = Peaks {getPeaks :: Sig.T Bool}++{- |+This is the most frequently needed transformation (if not the only one)+of a stream of peaks.+It converts to a signal of peaks with area 1.+This convention is especially useful for smoothing filters+that eventually produce frequency progress curves.+-}+{-# INLINE fromPeaks #-}+fromPeaks ::+   (Ord q, Ring.C q, Dim.C u) =>+   Proc.T s u q (Peaks s -> R s (Dim.Recip u) q q)+fromPeaks =+   do rate <- Proc.getSampleRate+      return $+         fromScalarSamples rate .+         Sig.map (\c -> if c then one else zero) .+         getPeaks+++infixl 0 $-, $&++{- |+Take a scalar argument where a process expects a signal.+Only possible for non-negative values so far.+-}+{-# INLINE ($-) #-}+($-) :: (Field.C y, Real.C y, Dim.C u, Dim.C v) =>+    Proc.T s u t (R s v y y -> a) -> DN.T v y -> Proc.T s u t a+($-) f x = f $: Proc.pure (CtrlV.constant x)++{- |+Take a signal with 'DN.Scalar' unit in amplitude+where the process expects a plain 'Sig.T'.+-}+{-# INLINE ($&) #-}+($&) :: (Ring.C y) =>+   Proc.T s u t (SigS.R s y -> a) ->+   Proc.T s u t (R s Dim.Scalar y y) ->+   Proc.T s u t a+($&) f arg =+   do x <- arg+      f $# SigS.fromSamples (scalarSamples DN.toNumber x)+--      f $# toScalarSignal one x+++infix 7 &*^, &*>^++{-# INLINE (&*^) #-}+(&*^) :: (Flat.C flat y) =>+   DN.T v y ->+   Proc.T s u t (RP.T s flat y) ->+   Proc.T s u t (R s v y y)+(&*^) v x = fromSamples v . Flat.toSamples $^ x++{-+{-# INLINE (&*^) #-}+(&*^) :: (Flat.C flat y) =>+   DN.T v y ->+   Proc.T s u t (SigS.R s y) ->+   Proc.T s u t (R s v y y)+(&*^) v x = fromSignal v $^ x+-}++{-# INLINE (&*>^) #-}+(&*>^) ::+   DN.T v y ->+   Proc.T s u t (SigS.R s yv) ->+   Proc.T s u t (R s v y yv)+(&*>^) v x = fromSignal v $^ x++{-# INLINE cache #-}+cache ::+   (Dim.C v, Ind.C w, Sample.C yv0) =>+   Proc.T s u t (w (T v y (SigS.T Sig.T)) yv0) ->+   Proc.T s u t (w (T v y (SigS.T Sig.T)) yv0)+cache =+   fmap (processSamples+      (Sig.fromStorableSignal . Sig.toStorableSignal SigSt.defaultChunkSize))++{-# INLINE bindCached #-}+bindCached ::+   (Dim.C v, Ind.C w, Sample.C yv0) =>+   Proc.T s u t (w (T v y (SigS.T Sig.T)) yv0) ->+   (w (T v y (SigS.T Sig.T)) yv0 -> Proc.T s u t b) ->+   Proc.T s u t b+bindCached x y =+   y =<< cache x++{-# INLINE share #-}+share ::+   (Dim.C v, Ind.C w, Sample.C yv0) =>+   Proc.T s u t (w (T v y (SigS.T Sig.T)) yv0) ->+   (Proc.T s u t (w (T v y (SigS.T Sig.T)) yv0) -> Proc.T s u t b) ->+   Proc.T s u t b+share x y = bindCached x (y . return)++++{-# INLINE toStorableInt16Mono #-}+toStorableInt16Mono ::+   (Ind.C w, RealField.C a, BinSmp.C a) =>+   w (SigA.S Dim.Voltage a) a ->+   w SigSt.T Int16+toStorableInt16Mono =+   Ind.processSignal+      (Sig.toStorableSignal SigSt.defaultChunkSize .+       Sig.map BinSmp.numToInt16Packed .+       SigA.scalarSamplesPrivate (DN.toNumberWithDimension Dim.voltage))++{-# INLINE toStorableInt16Stereo #-}+toStorableInt16Stereo ::+   (Ind.C w, Module.C a a, RealField.C a, BinSmp.C a) =>+   w (SigA.S Dim.Voltage a) (Stereo.T a) ->+   w SigSt.T (Stereo.T Int16)+toStorableInt16Stereo =+   Ind.processSignal+      (Sig.toStorableSignal SigSt.defaultChunkSize .+       Sig.map (Stereo.map BinSmp.numToInt16Packed) .+       SigA.vectorSamplesPrivate (DN.toNumberWithDimension Dim.voltage))
+ src/Synthesizer/Dimensional/RateAmplitude/Traumzauberbaum.hs view
@@ -0,0 +1,465 @@+{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}+module Main (main) where+-- module Synthesizer.Dimensional.RateAmplitude.Traumzauberbaum where++-- import qualified Synthesizer.Dimensional.RateAmplitude.Instrument as Instr++import qualified Synthesizer.Dimensional.Rate.Oscillator as Osci+import qualified Synthesizer.Dimensional.Rate.Filter     as Filt+import qualified Synthesizer.Dimensional.RateAmplitude.Displacement as Disp+import qualified Synthesizer.Dimensional.RateAmplitude.Noise      as Noise+-- import qualified Synthesizer.SampleRateDimension.Filter.Recursive    as FiltR+-- import qualified Synthesizer.SampleRateDimension.Filter.NonRecursive as FiltNR+import qualified Synthesizer.Dimensional.RateAmplitude.Filter     as FiltA+import qualified Synthesizer.Dimensional.RateAmplitude.Cut        as Cut+-- import qualified Synthesizer.Dimensional.Amplitude.Cut            as CutA++import qualified Synthesizer.Dimensional.RateAmplitude.Control    as Ctrl+-- import qualified Synthesizer.Dimensional.Rate.Control             as CtrlR++-- import qualified Synthesizer.Dimensional.Straight.Displacement    as DispS++import qualified Synthesizer.Dimensional.Process as Proc+import qualified Synthesizer.Dimensional.Straight.Signal as SigS+import qualified Synthesizer.Dimensional.RateAmplitude.Signal as SigA++import qualified Synthesizer.Dimensional.RateAmplitude.File as File+import qualified Synthesizer.Dimensional.RateAmplitude.Play as Play+import qualified Synthesizer.Dimensional.RateWrapper as SigP++import Synthesizer.Dimensional.RateAmplitude.Signal (($-), (&*^), )+import Synthesizer.Dimensional.Process (($:), ($::), ($^), ($#))+import Synthesizer.Dimensional.Amplitude.Control (mapExponential, )++import qualified Synthesizer.Generic.SampledValue as Sample++import qualified Synthesizer.Frame.Stereo as Stereo++-- import qualified Synthesizer.State.Interpolation as Interpolation+import qualified Synthesizer.Basic.Wave as Wave++import qualified Algebra.DimensionTerm as Dim+import qualified Number.DimensionTerm  as DN++import Number.DimensionTerm ((*&))++-- import qualified Number.NonNegative     as NonNeg++-- 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 System.Random (Random, randomRs, mkStdGen)++import PreludeBase+import NumericPrelude+++type PitchClass = Int++type Pitch = (PitchClass, Int)++c, d, e, f, g, a, h :: PitchClass+c =  0+d =  2+e =  4+f =  5+g =  7+a =  9+h = 11++melody :: [(Pitch, Int)]+melody =+   ((g,4),4) : ((g,4),2) : ((c,4),4) : ((d,4),2) : ((e,4),12) :+   ((g,4),4) : ((g,4),2) : ((c,4),4) : ((d,4),2) : ((e,4),12) :+   ((c,4),4) : ((c,4),2) : ((d,4),4) : ((d,4),2) : ((e,4),12) :+   ((c,4),4) : ((c,4),2) : ((d,4),4) : ((d,4),2) : ((e,4),12) :+   ((a,4),4) : ((a,4),2) : ((f,4),4) : ((f,4),2) : ((d,4),12) :+   ((g,4),4) : ((g,4),2) : ((c,4),4) : ((d,4),2) : ((e,4),12) :+   ((a,4),4) : ((a,4),2) : ((g,4),4) : ((g,4),2) : ((f,4),12) :+   ((g,4),4) : ((g,4),2) : ((c,4),4) : ((d,4),2) : ((c,4),12) :+   []+++type Chord = [Pitch]++chords :: [(Chord, Int)]+chords =+   ([(c,4),(e,4),(g,4)],  6) :+   ([(a,3),(c,4),(f,4)],  4) :+   ([(g,3),(h,3),(d,4)],  2) :+   ([(g,3),(c,4),(e,4)], 12) :++   ([(c,4),(e,4),(g,4)],  6) :+   ([(a,3),(c,4),(f,4)],  4) :+   ([(g,3),(h,3),(d,4)],  2) :+   ([(g,3),(c,4),(e,4)], 12) :++   ([(a,3),(c,4),(e,4)],  6) :+   ([(g,3),(h,3),(d,4)],  6) :+   ([(g,3),(c,4),(e,4)], 12) :++   ([(a,3),(c,4),(e,4)],  6) :+   ([(g,3),(h,3),(d,4)],  6) :+   ([(g,3),(c,4),(e,4)], 12) :++   ([(a,3),(c,4),(f,4)],  6) :+   ([(a,3),(d,4),(f,4)],  6) :+   ([(g,3),(h,3),(d,4)], 12) :++   ([(c,4),(e,4),(g,4)],  6) :+   ([(a,3),(c,4),(f,4)],  4) :+   ([(g,3),(h,3),(d,4)],  2) :+   ([(g,3),(c,4),(e,4)], 12) :++   ([(a,3),(c,4),(f,4)],  6) :+   ([(g,3),(h,3),(e,4)],  6) :+   ([(f,3),(a,3),(d,4)], 12) :++   ([(c,4),(e,4),(g,4)],  6) :+   ([(a,3),(c,4),(f,4)],  4) :+   ([(g,3),(h,3),(d,4)],  2) :+   ([(e,3),(g,3),(c,4)], 12) :++   []+++bass :: [(Pitch, Int)]+bass =+   ((c,5), 6) : ((f,4), 4) : ((g,4), 2) : ((c,5), 12) :+   ((c,5), 6) : ((f,4), 4) : ((g,4), 2) : ((c,5), 12) :+   ((a,4), 4) : ((a,4), 2) : ((g,4), 4) : ((g,4),  2) : ((c,5), 12) :+   ((a,4), 4) : ((a,4), 2) : ((g,4), 4) : ((g,4),  2) : ((c,5), 12) :+   ((f,4), 4) : ((f,4), 2) : ((d,4), 4) : ((d,4),  2) : ((g,4), 12) :+   ((c,5), 6) : ((f,4), 4) : ((g,4), 2) : ((c,5), 12) :+   ((f,5), 6) : ((e,5), 6) : ((d,5), 12) :+   ((c,5), 6) : ((f,4), 4) : ((g,4), 2) : ((c,4), 12) :+   []+++harmony :: [Pitch]+harmony =+   (c,4) : (g,4) : (c,5) : (f,3) : (c,4) : (g,3) :+   (c,4) : (g,4) : (c,5) : (c,4) : (g,4) : (c,5) :+   (c,4) : (g,4) : (c,5) : (f,3) : (c,4) : (g,3) :+   (c,4) : (g,4) : (c,5) : (c,4) : (g,4) : (c,5) :++   (a,3) : (e,4) : (a,4) : (g,3) : (d,4) : (g,4) :+   (c,4) : (g,4) : (c,5) : (c,4) : (g,4) : (c,5) :+   (a,3) : (e,4) : (a,4) : (g,3) : (d,4) : (g,4) :+   (c,4) : (g,4) : (c,5) : (c,4) : (g,4) : (c,5) :++   (f,3) : (c,4) : (f,4) : (a,3) : (d,4) : (a,4) :+   (g,3) : (d,4) : (g,4) : (g,3) : (d,4) : (g,4) :+   (c,4) : (g,4) : (c,5) : (f,3) : (c,4) : (g,3) :+   (c,4) : (g,4) : (c,5) : (c,4) : (g,4) : (c,5) :++   (f,3) : (c,4) : (f,4) : (e,3) : (h,3) : (e,4) :+   (d,3) : (a,3) : (d,4) : (a,3) : (d,4) : (a,4) :+   (c,4) : (g,4) : (c,5) : (f,3) : (c,4) : (g,3) :+   (c,4) : (g,4) : (c,5) : (c,4) : (c,4) : (c,4) :+--   (c,4) : (g,4) : (c,5) : (c,4) : (g,4) : (c,5) :++   []++++{-# INLINE assemblePitch #-}+assemblePitch :: Pitch -> Double+assemblePitch (pc, oct) =+   fromIntegral pc / 12 + fromIntegral oct - 4+++{-# INLINE timeUnit #-}+timeUnit :: DN.T Dim.Time Double+timeUnit = DN.time 0.2++{-# INLINE pitchControl #-}+pitchControl ::+   Proc.T s Dim.Time Double (SigA.R s Dim.Scalar Double Double)+--   Proc.T s Dim.Time Double (SigS.R s Double)+pitchControl =+   Cut.concatVolume (DN.scalar 1) $:+   (mapM (\(p,dur) ->+      Cut.take (fromIntegral dur *& timeUnit)+       $: Ctrl.constant (DN.scalar (assemblePitch p))) melody)+++{-# INLINE simpleMusic #-}+simpleMusic ::+   Proc.T s Dim.Time Double (SigA.R s Dim.Voltage Double Double)+simpleMusic =+   DN.voltage 1 &*^+   (Osci.freqMod (Wave.trapezoid 0.9) zero+      $: (mapExponential 2 (DN.frequency 440) $^ pitchControl))+++{-# INLINE filteredPitchControl #-}+filteredPitchControl ::+   Proc.T s Dim.Time Double (SigA.R s Dim.Scalar Double Double)+filteredPitchControl =+   Filt.lowpassFromUniversal $:+      (Filt.universal+         $- DN.scalar 3+         $- DN.frequency 4+         $: pitchControl)+++{-# INLINE envelope #-}+envelope ::+   Proc.T s Dim.Time Double (SigA.R s Dim.Scalar Double Double)+envelope =+   Filt.firstOrderLowpass+      $- DN.frequency 10+      $: (Filt.firstOrderHighpass+             $- DN.frequency 0.3+             $: pitchControl)+++{-# INLINE envelopedMelody #-}+envelopedMelody ::+   Proc.T s Dim.Time Double (SigA.R s Dim.Voltage Double Double)+envelopedMelody =+   DN.voltage 1 &*^+   (Filt.envelope $: envelope $:+    (Osci.freqMod (Wave.trapezoid 0.9) zero+       $: (mapExponential 2 (DN.frequency 440) $^ filteredPitchControl)))+++{-# INLINE filteredMusic #-}+filteredMusic ::+   Proc.T s Dim.Time Double (SigA.R s Dim.Voltage Double Double)+filteredMusic =+   Filt.lowpassFromUniversal $:+      (Filt.universal+         $- DN.scalar 10+         $: (mapExponential 20 (DN.frequency 100) $^ envelope)+         $: DN.voltage 1 &*^ (Osci.freqMod (Wave.trapezoid 0.9) zero+               $: (mapExponential 2 (DN.frequency 440) $^ pitchControl)))++++{-# INLINE makeChordPhaser #-}+makeChordPhaser ::+   Chord ->+   Proc.T s Dim.Time Double (SigA.R s Dim.Voltage Double (Stereo.T Double))+makeChordPhaser chord =+   Disp.mixMulti $::+   (map (\p ->+       Cut.mergeStereo+          $: (DN.voltage 1 &*^+              Osci.static (Wave.triangleAsymmetric 0.9) zero+                 (2 ** assemblePitch p *& DN.frequency 439))+          $: (DN.voltage 1 &*^+              Osci.static (Wave.triangleAsymmetric 0.9) zero+                 (2 ** assemblePitch p *& DN.frequency 441)))+       chord)++{-# INLINE makeChord #-}+makeChord ::+   Chord ->+   Proc.T s Dim.Time Double (SigA.R s Dim.Voltage Double (Stereo.T Double))+makeChord chord =+   Disp.mixMulti $::+   (map (\p ->+       let {-# INLINE tone #-}+           tone noise =+              DN.voltage 1 &*^+                 (Osci.freqMod (Wave.triangleAsymmetric 0.9) zero $:+--                 (Osci.freqMod (Wave.saw) zero $:+                    (mapExponential 2 (DN.frequency 440) $^+                        (Disp.raise (DN.scalar (assemblePitch p)) 1 $:+                           (Filt.firstOrderLowpass+                               $- DN.frequency 2+                               $: noise))))+{-+       in Cut.mergeStereo+             $: (tone (Ctrl.constant (DN.scalar 0.01)))+             $: (tone (Ctrl.constant (DN.scalar (-0.01)))))+-}+{-+       in Cut.mergeStereo+             $: (tone                (Noise.white (DN.frequency 10000) (DN.scalar 0.5)))+             $: (tone (Filt.negate $: Noise.white (DN.frequency 10000) (DN.scalar 0.5))))+-}+       in SigA.share+             (Noise.white (DN.frequency 10000) (DN.scalar 0.5))+             (\ns ->+                Cut.mergeStereo+                   $: (tone ns)+                   $: (tone (Filt.negate $: ns))))+{-+       in Cut.mergeStereo+             $: (tone (Noise.white (DN.frequency 10000) (DN.scalar 0.5)))+             $: (tone (Ctrl.constant (DN.scalar (-0.02)))))+-}+{-+       in Cut.mergeStereo+             $: (tone (DN.scalar   1  &*^ Osci.static Wave.sine zero (DN.frequency 3)))+             $: (tone (DN.scalar (-1) &*^ Osci.static Wave.sine zero (DN.frequency 3))))+-}+       chord)++{-# INLINE chordAccompaniment #-}+chordAccompaniment ::+   Proc.T s Dim.Time Double (SigA.R s Dim.Voltage Double (Stereo.T Double))+chordAccompaniment =+   Cut.concat $::+   (map (\(chd,dur) -> Cut.take (fromIntegral dur *& timeUnit) $: makeChord chd) chords)++++{-# INLINE bassControl #-}+bassControl ::+   Proc.T s Dim.Time Double (SigA.R s Dim.Scalar Double Double)+--   Proc.T s Dim.Time Double (SigS.R s Double)+bassControl =+   Cut.concatVolume (DN.scalar 1) $::+   (map (\(p,dur) ->+      Cut.take (fromIntegral dur *& timeUnit)+       $: Ctrl.constant (DN.scalar (assemblePitch p))) bass)+{-+   Cut.concatVolume (DN.scalar 1) $:+   (mapM (\(p,dur) ->+      Cut.take (fromIntegral dur *& timeUnit)+       $: Ctrl.constant (DN.scalar (assemblePitch p))) bass)+-}++{-# INLINE bassPhaserSignal #-}+bassPhaserSignal ::+   Proc.T s Dim.Time Double (SigA.R s Dim.Voltage Double (Stereo.T Double))+bassPhaserSignal =+   Cut.mergeStereo+      $: DN.voltage 1 &*^+            (Osci.freqMod (Wave.triangleAsymmetric 0.8) zero $:+               (mapExponential 2 (DN.frequency 54.7) $^ bassControl))+      $: DN.voltage 1 &*^+            (Osci.freqMod (Wave.triangleAsymmetric 0.8) zero $:+               (mapExponential 2 (DN.frequency 55.3) $^ bassControl))++{-# INLINE bassSignal #-}+bassSignal ::+   Proc.T s Dim.Time Double (SigA.R s Dim.Voltage Double (Stereo.T Double))+bassSignal =+{-+   SigA.share+      (DN.voltage 1 &*^+          (Osci.freqMod (Wave.triangleAsymmetric 0.9) zero $:+             (mapExponential 2 (DN.frequency 110) $^ bassControl)))+      (\b -> Cut.mergeStereo $: b $: b)+-}+{-+   SigA.share+      bassControl+      (\b ->+          let {-# INLINE channel #-}+              channel p =+                 DN.voltage 1 &*^+                    (Osci.freqMod (Wave.triangleAsymmetric 0.9) zero $: p)+          in  Cut.mergeStereo+                 $: channel (mapExponential 2 (DN.frequency 109.7) $^ b)+                 $: channel (mapExponential 2 (DN.frequency 110.3) $^ b))+-}+{-+   SigA.share+      bassControl+      (\b ->+         Filt.envelopeVector+            $: (Osci.freqMod ((1+) . Wave.triangleAsymmetric 0.9) zero $:+                  (mapExponential 2 (DN.frequency 27.5) $^ b))+            $: (Cut.mergeStereo+                  $: DN.voltage 1 &*^+                        (Osci.freqMod (Wave.triangleAsymmetric 0.9) zero $:+                           (mapExponential 2 (DN.frequency 109.7) $^ b))+                  $: DN.voltage 1 &*^+                        (Osci.freqMod (Wave.triangleAsymmetric 0.9) zero $:+                           (mapExponential 2 (DN.frequency 110.3) $^ b))))+-}+   SigA.share+      (Filt.firstOrderLowpass $- DN.frequency 2 $: bassControl)+      (\b ->+         Filt.envelopeVector+            $: (Osci.freqMod (Wave.raise one $ Wave.triangleAsymmetric 0.9) zero $:+                  (mapExponential 2 (DN.frequency 27.5) $^ b))+            $: (let {-# INLINE channel #-}+                    channel p =+                       DN.voltage 1 &*^+                          (Osci.freqMod (Wave.triangleAsymmetric 0.9) zero $: p)+                in  Cut.mergeStereo+                       $: channel (mapExponential 2 (DN.frequency 109.7) $^ b)+                       $: channel (mapExponential 2 (DN.frequency 110.3) $^ b)))+++{-# INLINE accompaniment #-}+accompaniment ::+   Proc.T s Dim.Time Double (SigA.R s Dim.Voltage Double (Stereo.T Double))+accompaniment =+   Disp.mix+      $: (FiltA.amplify 0.3 $: bassSignal)+      $: (FiltA.amplify 0.1 $: chordAccompaniment)+{-+   FiltA.amplify 0.1 $: chordAccompaniment+-}+{-+   FiltA.amplify 0.3 $: bassSignal+-}+++{-# INLINE filteredAccompaniment #-}+filteredAccompaniment ::+   Proc.T s Dim.Time Double (SigA.R s Dim.Voltage Double (Stereo.T Double))+filteredAccompaniment =+   Filt.lowpassFromUniversal $:+      (Filt.universal+         $- DN.scalar 5+         $: (mapExponential 2 (DN.frequency 440) $^+               (Cut.concatVolume (DN.scalar 1) $:+                   (mapM (\p ->+                      Cut.take (2 *& timeUnit)+                         $: Ctrl.constant (DN.scalar (assemblePitch p))) harmony)))+         $: accompaniment)+++++{-# INLINE songSignal #-}+songSignal ::+   Proc.T s Dim.Time Double (SigA.R s Dim.Voltage Double (Stereo.T Double))+songSignal =+   Disp.mixMulti $::+      (SigA.share envelopedMelody (\m -> Cut.mergeStereo $: m $: m)) :+      (FiltA.amplify 0.6 $: filteredAccompaniment) :+      []++++main :: IO ()+main =+   Play.timeVoltageStereoDoubleR+      (DN.frequency (44100::Double))+--      (Cut.take (DN.time 2) $: songSignal)+      songSignal+--      accompaniment+--      bassSignal++{-+   File.writeTimeVoltage "traumzauberbaum"+      (SigP.runProcess+          (DN.frequency (44100::Double))+          songSignal)+     >> return ()+-}++{-+import installed synthesizer package++ghc -o dist/build/traumzauberbaum/traumzauberbaum -O -Wall -fexcess-precision -ddump-simpl-stats -package synthesizer src/Synthesizer/Dimensional/RateAmplitude/Traumzauberbaum.hs++ghc -o dist/build/traumzauberbaum/traumzauberbaum-prof -prof -auto-all -O -Wall -fexcess-precision -ddump-simpl-stats -package synthesizer src/Synthesizer/Dimensional/RateAmplitude/Traumzauberbaum.hs++ghc -o dist/build/traumzauberbaum/traumzauberbaum -O -Wall -fexcess-precision -ddump-simpl-iterations -package synthesizer src/Synthesizer/Dimensional/RateAmplitude/Traumzauberbaum.hs >dist/build/Traumzauberbaum.log++ghc-core -f html -- -o dist/build/traumzauberbaum/traumzauberbaum -O -Wall -fexcess-precision -fvia-C -optc-O2 -package synthesizer src/Synthesizer/Dimensional/RateAmplitude/Traumzauberbaum.hs >dist/build/traumzauberbaum/traumzauberbaum.html+-}
+ src/Synthesizer/Dimensional/RatePhantom.hs view
@@ -0,0 +1,62 @@+{- |++Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes+++-}+module Synthesizer.Dimensional.RatePhantom where++import qualified Synthesizer.Format as Format+import qualified Synthesizer.Dimensional.Abstraction.RateIndependent as Ind++-- import qualified Number.DimensionTerm        as DN+-- import qualified Algebra.DimensionTerm       as Dim++{-+import NumericPrelude+import PreludeBase as P+-}+++{- |+Wraps a signal and adds a phantom type+that identifies signals of the same sample rate.+We provide the phantom type this way+in order to flexibly replace it by a material sample rate.+-}+newtype T s sig y = Cons {signal :: sig y}+--   deriving (Eq, Ord, Show)++instance Functor sig => Functor (T s sig) where+   fmap f = fromSignal . fmap f . toSignal++instance (Format.C sig) => Format.C (T s sig) where+   format p (Cons sig) =+      showParen (p >= 10)+         (showString "ratePhantom " . Format.format 11 sig)++instance (Format.C sig, Show y) => Show (T s sig y) where+   showsPrec = Format.format+++{-# INLINE fromSignal #-}+fromSignal :: sig y -> T s sig y+fromSignal = Cons++{-# INLINE toSignal #-}+toSignal :: T s sig y -> sig y+toSignal = signal++{-# INLINE processSignal #-}+processSignal :: (sig0 y0 -> sig1 y1) -> (T s sig0 y0 -> T s sig1 y1)+processSignal f = fromSignal . f . toSignal+++instance Ind.C (T s) where+   toSignal = signal+   processSignal = processSignal
+ src/Synthesizer/Dimensional/RateWrapper.hs view
@@ -0,0 +1,186 @@+{-# OPTIONS -fglasgow-exts #-}+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++Signals equipped with a sample rate information that carry a physical dimension.+-}+module Synthesizer.Dimensional.RateWrapper where++import qualified Synthesizer.Format as Format+import qualified Synthesizer.Dimensional.Abstraction.RateIndependent as Ind++import qualified Synthesizer.Dimensional.RatePhantom as RP+-- import qualified Synthesizer.Dimensional.Straight.Signal  as SigS+-- import qualified Synthesizer.Dimensional.Amplitude.Signal as SigA+import qualified Synthesizer.Dimensional.Process as Proc+import qualified Synthesizer.Dimensional.Rate as Rate+-- import qualified Synthesizer.State.Signal as Sig++import Synthesizer.Dimensional.Process (($:), ($#), )++-- import qualified Synthesizer.State.Filter.NonRecursive as Filt++import qualified Number.DimensionTerm        as DN+import qualified Algebra.DimensionTerm       as Dim++-- import Number.DimensionTerm ((&/&))++{-+import qualified Algebra.Module         as Module+import qualified Algebra.Field          as Field+import qualified Algebra.Ring           as Ring+-}++-- import NumericPrelude+import PreludeBase+import Prelude ()+++data T u t sig y =+   Cons {+        sampleRate :: DN.T (Dim.Recip u) t+                                 {-^ number of samples per unit -}+      , signal     :: sig y      {-^ the embedded signal -}+     }+--   deriving (Eq, Show)++instance Functor sig => Functor (T u t sig) where+   fmap f = processSignal (fmap f)++instance (Dim.C u, Show t, Format.C sig) => Format.C (T u t sig) where+   format p (Cons rate sig) =+      showParen (p >= 10)+         (showString "rateWrapper " . showsPrec 11 rate .+          showString " " . Format.format 11 sig)++instance (Dim.C u, Show t, Format.C sig, Show y) => Show (T u t sig y) where+   showsPrec = Format.format+++{-# INLINE fromProcess #-}+fromProcess :: (Dim.C u) =>+   Proc.T s u t (RP.T s sig yv -> T u t sig yv)+fromProcess =+   fmap+      (\rate -> Cons rate . RP.toSignal)+      Proc.getSampleRate+++{-# INLINE runProcess #-}+runProcess :: (Dim.C u) =>+   DN.T (Dim.Recip u) t ->+   (forall s. Proc.T s u t (RP.T s sig yv)) ->+   T u t sig yv+runProcess rate p =+   Proc.run rate (fromProcess $: p)+++{-# INLINE runProcessOn #-}+runProcessOn :: (Dim.C u) =>+   (forall s. Proc.T s u t (RP.T s sig0 yv0 -> RP.T s sig1 yv1)) ->+   T u t sig0 yv0 -> T u t sig1 yv1+runProcessOn p x =+   runProcess+      (sampleRate x)+      (p $# RP.fromSignal (signal x))+++{-# INLINE toProcess #-}+toProcess :: (Dim.C u) =>+   (T u t sig yv -> a) ->+   Proc.T s u t (RP.T s sig yv -> a)+toProcess f =+   fmap (f.) fromProcess++{-+infixl 0 $%++Apply a process that depends on (at least) two physical signals.+It is checked dynamically whether the sample rates of both signals are equal.+If the sample rates differ, this is an runtime error.+For more than one physical signal as input you can apply this operator repeatedly.+Try to avoid it due to the dynamic check.++($%) ::+   Proc.T s u t (SigA.R s v0 y0 yv0 -> SigA.R s v1 y1 yv1 -> a) ->+   T u t v0 y0 yv0 ->+   Proc.T s u t (SigA.R s v1 y1 yv1 -> a)+($%)+-}+++{- |+internal function+-}++{-# INLINE fromSignal #-}+fromSignal :: (Dim.C u) =>+   Rate.T s u t -> RP.T s sig yv -> T u t sig yv+fromSignal rate x =+   Cons (Rate.toDimensionNumber rate) (RP.toSignal x)++{-# INLINE toSignal #-}+toSignal :: (Dim.C u) =>+   T u t sig yv -> (Rate.T s u t, RP.T s sig yv)+toSignal x =+   (Rate.fromDimensionNumber (sampleRate x),+    RP.fromSignal (signal x))+++{-+rewriteDimension :: (Dim.C v0, Dim.C v1) =>+   (v0 -> v1) -> T u t v0 y yv -> T u t v1 y yv+rewriteDimension f (Cons amp ss) =+   Cons (DN.rewriteDimension f amp) ss+++toScalarSignal :: (Field.C y, Dim.C v) =>+   DN.T v y -> T u t y y -> RP.T s sig y+toScalarSignal amp  =  SigS.cons . scalarSamples (flip DN.divToScalar amp)++toVectorSignal :: (Field.C y, Module.C y yv, Dim.C v) =>+   DN.T v y -> T u t y yv -> RP.T s sig yv+toVectorSignal amp  =  SigS.cons . vectorSamples (flip DN.divToScalar amp)+++cons :: DN.T v y -> Sig.T yv -> T u t y yv+cons  =  Cons++consScalar :: DN.T v y -> Sig.T y -> T u t y y+consScalar  =  cons++consVector :: DN.T v y -> Sig.T yv -> T u t y yv+consVector  =  cons++replaceAmplitude :: DN.T v1 y -> T u t v0 y yv -> T u t v1 y yv+replaceAmplitude amp (Cons _ ss)  =  Cons amp ss++replaceSamples :: Sig.T yv1 -> T u t y yv0 -> T u t y yv1+replaceSamples ss (Cons amp _)  =  Cons amp ss+++processSamples :: (Dim.C v) =>+   (Sig.T yv0 -> Sig.T yv1) -> T u t y yv0 -> T u t y yv1+processSamples f x =+   replaceSamples (f $ samples x) x+++asTypeOfAmplitude :: y -> T u t y yv -> y+asTypeOfAmplitude = const+-}++{-# INLINE processSignal #-}+processSignal ::+   (sig0 yv0 -> sig1 yv1) -> T u t sig0 yv0 -> T u t sig1 yv1+processSignal f x =+   Cons (sampleRate x) (f $ signal x)+++instance (Dim.C u) => Ind.C (T u t) where+   toSignal = signal+   processSignal = processSignal
+ src/Synthesizer/Dimensional/Straight/Displacement.hs view
@@ -0,0 +1,65 @@+module Synthesizer.Dimensional.Straight.Displacement where++import qualified Synthesizer.Dimensional.Abstraction.RateIndependent as Ind+import qualified Synthesizer.Dimensional.Abstraction.Flat as Flat++import qualified Synthesizer.Dimensional.Straight.Signal as SigS+import qualified Synthesizer.State.Displacement as Disp+import qualified Synthesizer.State.Signal as Sig++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) => SigS.R s v -> SigS.R s v -> SigS.R s v+{- we can't assert equal sample rates of mixer inputs if 'w = RateWrapper'+mix :: (Ind.C w, Additive.C v) =>+   w (SigS.T Sig.T) v -> w (SigS.T Sig.T) v -> w (SigS.T Sig.T) v+-}+mix x = SigS.processSamples (SigS.toSamples x Additive.+)++{-| Add a number to all of the signal values.+    This is useful for adjusting the center of a modulation. -}+{-# INLINE raise #-}+raise :: (Ind.C w, Additive.C v) =>+    v -> w (SigS.T Sig.T) v -> w (SigS.T Sig.T) v+raise x = SigS.processSamples (Disp.raise x)+++{- * Distortion -}++{-# INLINE map #-}+map :: (Ind.C w, Flat.C flat y0) =>+    (y0 -> y1) ->+    w flat y0 ->+    w (SigS.T Sig.T) y1+map f =+   Ind.processSignal+      (SigS.Cons .+       Sig.map f .+       Flat.unwrappedToSamples)++{- |+In "Synthesizer.State.Distortion" you find a collection+of appropriate distortion functions.+-}+{-# INLINE distort #-}+distort :: (c -> a -> a) -> SigS.R s c -> SigS.R s a -> SigS.R s a+{- we can't assert equal sample rates of inputs if 'w = RateWrapper'+distort :: (Ind.C w) =>+   (c -> a -> a) ->+   w (SigS.T Sig.T) c ->+   w (SigS.T Sig.T) a ->+   w (SigS.T Sig.T) a+-}+distort f c = SigS.processSamples (Disp.distort f (SigS.toSamples c))
+ src/Synthesizer/Dimensional/Straight/Signal.hs view
@@ -0,0 +1,89 @@+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++Signals equipped with a phantom type parameter that reflects the sample rate.+-}+module Synthesizer.Dimensional.Straight.Signal where++import qualified Synthesizer.Dimensional.Abstraction.RateIndependent as Ind++import qualified Synthesizer.Format as Format+import qualified Synthesizer.Dimensional.RatePhantom as RP++import qualified Synthesizer.State.Signal as Sig++-- import qualified Number.DimensionTerm        as DN+-- import qualified Algebra.DimensionTerm       as Dim++{-+import qualified Algebra.Module         as Module+import qualified Algebra.Field          as Field+import qualified Algebra.Ring           as Ring+-}++-- import Number.DimensionTerm ((&/&))+++-- import NumericPrelude+import PreludeBase+-- import Prelude ()+++newtype T seq yv =+   Cons {+       samples :: seq yv   {-^ the sampled values -}+     }+--   deriving (Eq, Show)++instance Functor seq => Functor (T seq) where+   fmap f = Cons . fmap f . samples++instance Format.C seq => Format.C (T seq) where+   format p = Format.format p . samples++instance (Format.C seq, Show y) => Show (T seq y) where+   showsPrec = Format.format+++type R s yv = RP.T s (T Sig.T) yv++{- |+In contrast to 'Synthesizer.Dimensional.RateAmplitude.Peaks'+where only booleans are possible (peak or not peak)+we can also have signals of booleans or other enumerations.+In this case we consider the signal as piecewise constant.+-}+type Binary s = R s Bool++++{-# INLINE replaceSamples #-}+replaceSamples :: Sig.T yv1 -> R s yv0 -> R s yv1+replaceSamples ss _  =  fromSamples ss+++{-# INLINE processSamples #-}+processSamples :: Ind.C w =>+   (seq0 yv0 -> seq1 yv1) -> w (T seq0) yv0 -> w (T seq1) yv1+processSamples f =+   Ind.processSignal (processSamplesPrivate f)++{-# INLINE processSamplesPrivate #-}+processSamplesPrivate ::+   (seq0 yv0 -> seq1 yv1) -> T seq0 yv0 -> T seq1 yv1+processSamplesPrivate f =+   Cons . f . samples+++{-# INLINE fromSamples #-}+fromSamples :: Sig.T yv -> R s yv+fromSamples  =  RP.fromSignal . Cons++{-# INLINE toSamples #-}+toSamples :: Ind.C w => w (T seq) yv -> seq yv+toSamples  =  samples . Ind.toSignal
+ 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,66 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+{-+This data type can be used as sample type for stereo signals.+-}+module Synthesizer.Frame.Stereo (T, left, right, cons, map, ) where++import qualified Synthesizer.Generic.SampledValue as Sample++import qualified Algebra.Module   as Module+import qualified Algebra.Additive as Additive++import Foreign.Storable (Storable (..), )++import NumericPrelude+import PreludeBase hiding (map)+import Prelude ()+++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)+++{-# INLINE roundUp #-}+roundUp :: Int -> Int -> Int+roundUp m x = x + mod (-x) m++-- cf. StorableInstances+instance (Storable a) => Storable (T a) where+   sizeOf ~(Cons l r) =+      roundUp (alignment r) (sizeOf l) + sizeOf r+   alignment x = alignment (left x)+   peek ptr =+      do l <- peekByteOff ptr 0+         let peekSecond :: Storable b => b -> IO b+             peekSecond ru =+                peekByteOff ptr (roundUp (alignment ru) (sizeOf l))+         r <- peekSecond undefined+         return (Cons l r)+   poke ptr (Cons l r) =+      pokeByteOff ptr 0 l >>+      pokeByteOff ptr (roundUp (alignment r) (sizeOf l)) r+++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 (Sample.C a) => Sample.C (T a) -- where
+ src/Synthesizer/FusionList/Control.hs view
@@ -0,0 +1,252 @@+{-# OPTIONS_GHC -O2 -fglasgow-exts -fno-implicit-prelude #-}+{- |+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 Data.List (zipWith4, tails)+-- import NumericPrelude.List (iterateAssoc)++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.iterateAssoc op d))++{-# INLINE curveMultiscaleNeutral #-}+curveMultiscaleNeutral :: (y -> y -> y) -> y -> y -> Sig.T y+curveMultiscaleNeutral op d neutral =+   Sig.cons neutral (Sig.iterateAssoc op d)
+ src/Synthesizer/FusionList/Filter/NonRecursive.hs view
@@ -0,0 +1,315 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+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 Synthesizer.Generic.SampledValue as Sample++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 Synthesizer.Utility (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, Sample.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, Sample.C a) =>+   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 @@+{-# OPTIONS_GHC -O2 -fno-implicit-prelude #-}+{- |+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 (Phase.toRepresentative $ Phase.multiply len 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,733 @@+{-# OPTIONS_GHC -O -fglasgow-exts -fno-implicit-prelude #-}+{- glasgow-exts are for the rules -}+module Synthesizer.FusionList.Signal where++import qualified Synthesizer.Generic.Signal as SigG++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.State (State, runState, )++import Synthesizer.Utility+   (viewListL, viewListR, mapFst, mapSnd, mapPair, fst3, snd3, thd3)++import NumericPrelude.Condition (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 SigG.C T where+   empty = empty+   null = null+   cons = cons+   fromList = fromList+   toList = toList+   repeat = repeat+   cycle = cycle+   replicate = replicate+   iterate = iterate+   iterateAssoc op x = iterate (op x) x -- should be optimized+   unfoldR = generate+   map = map+   mix = mix+   zipWith = zipWith+   scanL = scanL+   viewL = viewL+   viewR = viewR+   foldL = foldL+   length = length+   take = take+   drop = drop+   splitAt = splitAt+   dropMarginRem = dropMarginRem+   takeWhile = takeWhile+   dropWhile = dropWhile+   span = span+   append = append+   concat = concat+   reverse = reverse+{-+   mapAccumL = mapAccumL+   mapAccumR = mapAccumR+-}+   crochetL = crochetL++++{- * 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 viewListL++{-# 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 iterateAssoc #-}+iterateAssoc :: (a -> a -> a) -> a -> T a+iterateAssoc 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+          (recurse (\(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) . viewListL . decons++viewR :: T a -> Maybe (T a, a)+viewR =+   fmap (mapFst Cons) . viewListR . 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)))++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++recurse :: (acc -> Maybe acc) -> acc -> acc+recurse f =+   let aux x = maybe x aux (f x)+   in  aux+
+ src/Synthesizer/Generic/Analysis.hs view
@@ -0,0 +1,334 @@+{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}+module Synthesizer.Generic.Analysis where++import qualified Synthesizer.Generic.Signal as SigG+import qualified Synthesizer.Generic.SampledValue as Sample++-- 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, Sample.C y, SigG.C sig) => sig y -> y+volumeMaximum =+   SigG.foldL max zero . rectify+--   maximum . rectify++{- |+Volume based on Energy norm.+-}+volumeEuclidean :: (Algebraic.C y, Sample.C y, SigG.C sig) => sig y -> y+volumeEuclidean =+   Algebraic.sqrt . volumeEuclideanSqr++volumeEuclideanSqr :: (Field.C y, Sample.C y, SigG.C sig) => sig y -> y+volumeEuclideanSqr =+   average . SigG.map sqr++{- |+Volume based on Sum norm.+-}+volumeSum :: (Field.C y, Real.C y, Sample.C y, SigG.C sig) => sig y -> y+volumeSum = average . rectify++++{- |+Volume based on Manhattan norm.+-}+volumeVectorMaximum ::+   (NormedMax.C y yv, Ord y, Sample.C y, Sample.C yv, SigG.C sig) =>+   sig yv -> y+volumeVectorMaximum =+   SigG.foldL max zero . SigG.map NormedMax.norm+--   NormedMax.norm+--   maximum . SigG.map NormedMax.norm++{- |+Volume based on Energy norm.+-}+volumeVectorEuclidean ::+   (Algebraic.C y, NormedEuc.C y yv, Sample.C y, Sample.C yv, SigG.C sig) =>+   sig yv -> y+volumeVectorEuclidean =+   Algebraic.sqrt . volumeVectorEuclideanSqr++volumeVectorEuclideanSqr ::+   (Field.C y, NormedEuc.Sqr y yv, Sample.C y, Sample.C yv, SigG.C sig) =>+   sig yv -> y+volumeVectorEuclideanSqr =+   average . SigG.map NormedEuc.normSqr++{- |+Volume based on Sum norm.+-}+volumeVectorSum ::+   (NormedSum.C y yv, Field.C y, Sample.C y, Sample.C yv, SigG.C sig) =>+   sig yv -> y+volumeVectorSum =+   average . SigG.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, Sample.C y, SigG.C sig) => sig y -> (y,y)+bounds =+   maybe+      (error "Analysis.bounds: List must contain at least one element.")+      (\(x,xs) ->+          SigG.foldL (\(minX,maxX) y -> (min y minX, max y maxX)) (x,x) xs)+   . SigG.viewL+++++{- * 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, Sample.C y, SigG.C sig) =>+   y -> sig y -> (Int, sig Int)+histogramIntMap binsPerUnit =+   histogramDiscreteIntMap . quantize binsPerUnit++quantize :: (RealField.C y, Sample.C y, SigG.C sig) =>+   y -> sig y -> sig Int+quantize binsPerUnit = SigG.map (floor . (binsPerUnit*))++attachOne :: (Sample.C i, SigG.C sig) => sig i -> sig (i,Int)+attachOne = SigG.map (\i -> (i,one))++meanValues ::+   (RealField.C y, Sample.C y, SigG.C sig) => sig y -> [(Int,y)]+meanValues x = concatMap spread (zip x (tail x))++spread ::+   (RealField.C y, Sample.C y, SigG.C sig) => (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, Sample.C y, SigG.C sig) => sig y -> y+directCurrentOffset = average+++scalarProduct ::+   (Ring.C y, Sample.C y, SigG.C sig) => sig y -> sig y -> y+scalarProduct xs ys =+   SigG.sum (SigG.zipWith (*) xs ys)++{- |+'directCurrentOffset' must be non-zero.+-}+centroid :: (Field.C y, Sample.C y, SigG.C sig) => sig y -> y+centroid xs =+   scalarProduct (SigG.iterate (one+) zero) xs / SigG.sum xs++{-+centroidAlt :: (Field.C y, Sample.C y, SigG.C sig) => sig y -> y+centroidAlt xs =+   SigG.sum (scanr (+) zero (tail xs)) / sum xs+-}++average :: (Field.C y, Sample.C y, SigG.C sig) => sig y -> y+average x =+   SigG.sum x / fromIntegral (SigG.length x)++rectify :: (Real.C y, Sample.C y, SigG.C sig) => 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, Sample.C y, SigG.C sig) =>+   sig y -> sig Bool+zeros =+   SigG.zapWith (/=) . SigG.map (>=zero)++++{- |+Detect thresholds with a hysteresis.+-}+flipFlopHysteresis :: (Ord y, Sample.C y, SigG.C sig) =>+   (y,y) -> Bool -> sig y -> sig Bool+flipFlopHysteresis (lower,upper) =+   SigG.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,294 @@+{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}+module Synthesizer.Generic.Control where++import qualified Synthesizer.Generic.Signal as SigG+import qualified Synthesizer.Generic.SampledValue as Sample++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 Data.List (zipWith4, tails)+-- import NumericPrelude.List (iterateAssoc)++import qualified Prelude as P+import PreludeBase+import NumericPrelude+++{- * Control curve generation -}++constant :: (Sample.C y, SigG.C sig) => y -> sig y+constant = SigG.repeat+++linear :: (Additive.C y, Sample.C y, SigG.C sig) =>+      y   {-^ steepness -}+   -> y   {-^ initial value -}+   -> sig y {-^ linear progression -}+linear d y0 = SigG.iterate (d+) y0++{- |+Minimize rounding errors by reducing number of operations per element+to a logarithmuc number.+-}+linearMultiscale :: (Additive.C y, Sample.C y, SigG.C sig) =>+      y+   -> y+   -> sig y+linearMultiscale = curveMultiscale (+)++{- |+Linear curve starting at zero.+-}+linearMultiscaleNeutral :: (Additive.C y, Sample.C y, SigG.C sig) =>+      y+   -> sig y+linearMultiscaleNeutral slope =+   curveMultiscaleNeutral (+) slope zero+++exponential, exponentialMultiscale :: (Trans.C y, Sample.C y, SigG.C sig) =>+      y   {-^ time where the function reaches 1\/e of the initial value -}+   -> y   {-^ initial value -}+   -> sig y {-^ exponential decay -}+exponential time = SigG.iterate (* exp (- recip time))+exponentialMultiscale time = curveMultiscale (*) (exp (- recip time))++exponentialMultiscaleNeutral :: (Trans.C y, Sample.C y, SigG.C sig) =>+      y   {-^ time where the function reaches 1\/e of the initial value -}+   -> sig y {-^ exponential decay -}+exponentialMultiscaleNeutral time =+   curveMultiscaleNeutral (*) (exp (- recip time)) one++exponential2, exponential2Multiscale :: (Trans.C y, Sample.C y, SigG.C sig) =>+      y   {-^ half life -}+   -> y   {-^ initial value -}+   -> sig y {-^ exponential decay -}+exponential2 halfLife = SigG.iterate (*  0.5 ** recip halfLife)+exponential2Multiscale halfLife = curveMultiscale (*) (0.5 ** recip halfLife)++exponential2MultiscaleNeutral :: (Trans.C y, Sample.C y, SigG.C sig) =>+      y   {-^ half life -}+   -> sig y {-^ exponential decay -}+exponential2MultiscaleNeutral halfLife =+   curveMultiscaleNeutral (*) (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, Sample.C v, SigG.C sig) =>+       y  {-^ time where the function reaches 1\/e of the initial value -}+   ->  v  {-^ initial value -}+   -> sig v {-^ exponential decay -}+vectorExponential time y0 = SigG.iterate (exp (-1/time) *>) y0++vectorExponential2 ::+   (Trans.C y, Module.C y v, Sample.C v, SigG.C sig) =>+       y  {-^ half life -}+   ->  v  {-^ initial value -}+   -> sig v {-^ exponential decay -}+vectorExponential2 halfLife y0 = SigG.iterate (0.5**(1/halfLife) *>) y0++++cosine, cosineMultiscale :: (Trans.C y, Sample.C y, SigG.C sig) =>+       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 = cosineWithSlope $+   \d x -> SigG.map cos (linear d x)++cosineMultiscale = cosineWithSlope $+   \d x -> SigG.map real (curveMultiscale (*) (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, Sample.C y, SigG.C sig) =>+   (y, (y,y)) -> (y, (y,y)) -> sig y+cubicHermite node0 node1 =+   SigG.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+-}++++{- |+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, Sample.C y, SigG.C sig) =>+   [ControlPiece y] -> sig y+piecewise 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 yi0 yi1 t d n c)+          (map fst (tail ts)) (map (subtract 1 . snd) ts)+          xs)+++piecewisePart :: (Trans.C y, Sample.C y, SigG.C sig) =>+   y -> y -> y -> y -> Int -> Control y -> sig y+piecewisePart y0 y1 t0 d n ctrl =+   SigG.take n+      (case ctrl of+         CtrlStep  -> constant y0+         CtrlLin   -> let s = (y1-y0)/d in linearMultiscale s (y0-t0*s)+         CtrlExp s -> let y0' = y0-s; y1' = y1-s; yd = y0'/y1'+                      in  raise s (exponentialMultiscale (d / log yd)+                                           (y0' * yd**(t0/d)))+         CtrlCos   -> SigG.map+                          (\y -> (1+y)*(y0/2)+(1-y)*(y1/2))+                          (cosineMultiscale t0 (t0+d))+         CtrlCubic yd0 yd1 ->+            cubicHermite (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 :: (Sample.C y, SigG.C sig) =>+   (y -> y -> y) -> y -> y -> sig y+curveMultiscale op d y0 =+   SigG.cons y0 (SigG.map (op y0) (SigG.iterateAssoc op d))+++curveMultiscaleNeutral :: (Sample.C y, SigG.C sig) =>+   (y -> y -> y) -> y -> y -> sig y+curveMultiscaleNeutral op d neutral =+   SigG.cons neutral (SigG.iterateAssoc op d)
+ src/Synthesizer/Generic/Displacement.hs view
@@ -0,0 +1,52 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+<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 Synthesizer.Generic.SampledValue as Sample++-- 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, Sample.C v, SigG.C sig) =>+   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 an arbitrary number of signals. -}+mixMulti :: (Additive.C v, Sample.C v, SigG.C sig) =>+   [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, Sample.C v, SigG.C sig) =>+   v -> sig v -> sig v+raise x = SigG.map ((+) x)+++{- * Distortion -}+{- |+In "Synthesizer.Basic.Distortion" you find a collection+of appropriate distortion functions.+-}+distort :: (Sample.C c, Sample.C v, SigG.C sig) =>+   (c -> v -> v) -> sig c -> sig v -> sig v+distort = SigG.zipWith
+ src/Synthesizer/Generic/Filter/Delay.hs view
@@ -0,0 +1,63 @@+{-# OPTIONS -fno-implicit-prelude #-}+module Synthesizer.Generic.Filter.Delay where++import qualified Synthesizer.Generic.Interpolation as Interpolation+import qualified Synthesizer.Generic.SampledValue  as Sample+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, Sample.C y, SigG.C sig) => Int -> sig y -> sig y+static = staticPad zero++{-# INLINE staticPad #-}+staticPad :: (Sample.C y, SigG.C sig) => y -> Int -> sig y -> sig y+staticPad = Interpolation.delayPad++{-# INLINE staticPos #-}+staticPos :: (Additive.C y, Sample.C y, SigG.C sig) => Int -> sig y -> sig y+staticPos n = SigG.append (SigG.replicate n zero)++{-# INLINE staticNeg #-}+staticNeg :: (Sample.C y, SigG.C sig) => Int -> sig y -> sig y+staticNeg = SigG.drop+++++{-# INLINE modulatedCore #-}+modulatedCore ::+   (RealField.C a, Additive.C v, Sample.C a, Sample.C v, SigG.C sig) =>+   Interpolation.T sig a v -> Int -> sig a -> sig v -> sig v+modulatedCore ip size =+   SigG.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 a, Additive.C v, Sample.C a, Sample.C v, SigG.C sig) =>+   Interpolation.T sig a v -> Int -> sig a -> sig v -> sig 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/Generic/Filter/NonRecursive.hs view
@@ -0,0 +1,297 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+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.SampledValue as Sample++import qualified Synthesizer.Generic.Filter.Delay as Delay+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 Synthesizer.Utility (nest)++import PreludeBase+import NumericPrelude++++{- * Envelope application -}++{-# INLINE negate #-}+negate ::+   (Additive.C a, Sample.C a, SigG.C sig) =>+   sig a -> sig a+negate = SigG.map Additive.negate++{-# INLINE amplify #-}+amplify ::+   (Ring.C a, Sample.C a, SigG.C sig) =>+   a -> sig a -> sig a+amplify v = SigG.map (v*)++{-# INLINE amplifyVector #-}+amplifyVector ::+   (Module.C a v, Sample.C v, SigG.C sig) =>+   a -> sig v -> sig v+amplifyVector v = SigG.map (v*>)++{-# INLINE envelope #-}+envelope ::+   (Ring.C a, Sample.C a, SigG.C sig) =>+      sig a  {-^ the envelope -}+   -> sig a  {-^ the signal to be enveloped -}+   -> sig a+envelope = SigG.zipWith (*)++{-# INLINE envelopeVector #-}+envelopeVector ::+   (Module.C a v, Sample.C a, Sample.C v, SigG.C sig) =>+      sig a  {-^ the envelope -}+   -> sig v  {-^ the signal to be enveloped -}+   -> sig v+envelopeVector = SigG.zipWith (*>)++++{-# INLINE fadeInOut #-}+fadeInOut ::+   (Field.C a, Sample.C a, SigG.C sig) =>+   Int -> Int -> Int -> sig a -> sig a+fadeInOut tIn tHold tOut xs =+   let slopeIn  =                  recip (fromIntegral tIn)+       slopeOut = Additive.negate (recip (fromIntegral tOut))+       leadIn  = SigG.take tIn  $ Ctrl.linear slopeIn  0+       leadOut = SigG.take tOut $ Ctrl.linear 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 -}+++{-| Unmodulated non-recursive filter -}+{-# INLINE generic #-}+generic ::+   (Module.C a v, Sample.C a, Sample.C v, SigG.C sig) =>+   sig a -> sig v -> sig v+generic m x =+   let mr = SigG.reverse m+       xp = Delay.staticPos (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, Sample.C v, SigG.C sig) =>+   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, Sample.C v, SigG.C sig) => sig v -> sig v+binomial1 = SigG.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, Sample.C v, SigG.C sig) =>+   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, Sample.C v, SigG.C sig) =>+   sig v -> sig v+differentiate x = SigG.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, Sample.C v, SigG.C sig) =>+   sig v -> sig v+differentiateCenter =+   SigG.zapWith (\(x0,_) (_,x1) -> (x1 - x0) * (1/2)) .+   SigG.zapWith (,)++{- |+Second derivative.+It is @differentiate2 == differentiate . differentiate@+but 'differentiate2' should be faster.+-}+{-# INLINE differentiate2 #-}+differentiate2 ::+   (Additive.C v, Sample.C v, SigG.C sig) =>+   sig v -> sig v+differentiate2 = differentiate . differentiate
+ src/Synthesizer/Generic/Filter/Recursive/Integration.hs view
@@ -0,0 +1,48 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+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 Synthesizer.Generic.SampledValue as Sample++-- 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, Sample.C v, SigG.C sig) =>+   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, Sample.C v, SigG.C sig) =>+   v -> sig v -> sig v+runInit = SigG.scanL (+)++{- other quadrature methods may follow -}
+ src/Synthesizer/Generic/Filter/Recursive/MovingAverage.hs view
@@ -0,0 +1,169 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+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.SampledValue as Sample++import qualified Synthesizer.Generic.Filter.Recursive.Integration as Integration+import qualified Synthesizer.Generic.Filter.Delay as Delay++import Synthesizer.Utility (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, Sample.C v, SigG.C sig) =>+   Int -> sig v -> sig v+sumsStaticInt n xs =+   Integration.run (sub xs (Delay.staticPos n xs))+++{-# INLINE sub #-}+sub :: (Additive.C v, Sample.C v, SigG.C sig) =>+   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, Sample.C v, SigG.C sig) =>+   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.C sig, Sample.C y) =>+   y -> Int -> sig y -> y+index deflt n =+   maybe deflt fst . SigG.viewL . SigG.drop n+++{-# INLINE addNext #-}+addNext ::+   (Additive.C v, Sample.C a, SigG.C sig) =>+   (a -> v) -> (v -> sig a -> v) -> v -> sig a -> v+addNext f next s xs =+   maybe s+      (\(y,ys) -> next (s + f y) ys)+      (SigG.viewL xs)+++{- |+@sig a@ must contain only non-negative elements.+-}+{-# INLINE sumDiffsModulated #-}+sumDiffsModulated ::+   (RealField.C a, Module.C a v, Sample.C a, Sample.C v, SigG.C sig) =>+   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+   SigG.zipWithTails (uncurry sumFromToFrac)+       (SigG.zip (SigG.cons (d+1) ds) (SigG.map (1+) ds)) .+   SigG.cons zero++{-+   SigG.zipWithTails (uncurry sumFromToFrac)+      (SigG.zip (SigG.cons d (SigG.map (subtract 1) ds)) ds)+-}++{-+{-# 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, Sample.C a, Sample.C v, SigG.C sig) =>+   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, Sample.C a, Sample.C v, SigG.C sig) =>+   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,348 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+ToDo:+use AffineSpace instead of Module for the particular interpolation types,+since affine combinations assert reconstruction of constant functions.+They are more natural for interpolation of internal control parameters.+However, how can cubic interpolation expressed by affine combinations+without divisions?+-}+module Synthesizer.Generic.Interpolation where++import qualified Synthesizer.Generic.Control      as Ctrl+import qualified Synthesizer.Generic.SampledValue as Sample+import qualified Synthesizer.Generic.Signal       as SigG++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 Algebra.Module((*>))+import Data.Maybe (fromMaybe)++import Control.Monad.State (StateT(StateT), evalStateT, ap, )+import Control.Applicative (Applicative(pure, (<*>)), (<$>), liftA2, )+import Synthesizer.ApplicativeUtility (liftA4, )+import Synthesizer.Utility (affineComb, )++import PreludeBase+import NumericPrelude+++{- | interpolation as needed for resampling -}+data T sig t y =+  Cons {+    number :: Int,  -- interpolation requires a total number of 'number'+    offset :: Int,  -- interpolation requires 'offset' values before the current+    func   :: t -> sig y -> y+  }+++{-* Interpolation with various padding methods -}++{-# INLINE zeroPad #-}+zeroPad :: (RealField.C t, Sample.C y, SigG.C sig) =>+   (T sig t y -> t -> sig y -> a) ->+   y -> T sig t y -> t -> sig y -> a+zeroPad interpolate z ip phase x =+   let (phInt, phFrac) = splitFraction phase+   in  interpolate ip phFrac+          (delayPad z (offset ip - phInt) (SigG.append x (SigG.repeat z)))++{-# INLINE constantPad #-}+constantPad :: (RealField.C t, Sample.C y, SigG.C sig) =>+   (T sig t y -> t -> sig y -> a) ->+   T sig t y -> t -> sig y -> a+constantPad interpolate ip phase x =+   let (phInt, phFrac) = splitFraction phase+       xPad =+          do (xFirst,_) <- SigG.viewL x+             return (delayPad xFirst (offset ip - phInt) (SigG.extendConstant x))+   in  interpolate ip phFrac+          (fromMaybe SigG.empty xPad)+++{- |+Only for finite input signals.+-}+{-# INLINE cyclicPad #-}+cyclicPad :: (RealField.C t, Sample.C y, SigG.C sig) =>+   (T sig t y -> t -> sig y -> a) ->+   T sig 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, Sample.C y, SigG.C sig) =>+   (T sig t y -> t -> sig y -> a) ->+   T sig 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 -}++{-# INLINE skip #-}+skip :: (RealField.C t, Sample.C y, SigG.C sig) =>+   T sig 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, Sample.C y, SigG.C sig) =>+   T sig 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, Sample.C t, Sample.C y, SigG.C sig) =>+   T sig t y -> t -> sig y -> sig t -> sig y+multiRelative ip phase0 x0 =+   SigG.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, Sample.C t, Sample.C y, SigG.C sig) =>+   y -> T sig 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, Sample.C t, Sample.C y, SigG.C sig) =>+   T sig 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, Sample.C t, Sample.C y, SigG.C sig) =>+   T sig 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, Sample.C t, Sample.C y, SigG.C sig) =>+   T sig 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, Sample.C t, Sample.C y, SigG.C sig) =>+   t -> sig t -> sig y -> sig y+multiRelativeZeroPadConstant = multiRelativeZeroPad zero constant++{-# INLINE multiRelativeZeroPadLinear #-}+multiRelativeZeroPadLinear ::+   (RealField.C t, Module.C t y, Sample.C t, Sample.C y, SigG.C sig) =>+   t -> sig t -> sig y -> sig y+multiRelativeZeroPadLinear = multiRelativeZeroPad zero linear++{-# INLINE multiRelativeZeroPadCubic #-}+multiRelativeZeroPadCubic ::+   (RealField.C t, Module.C t y, Sample.C t, Sample.C y, SigG.C sig) =>+   t -> sig t -> sig y -> sig y+multiRelativeZeroPadCubic = multiRelativeZeroPad zero cubic+++{-* Different kinds of interpolation -}++{-** Hard-wired interpolations -}++data PrefixReader sig a =+   PrefixReader Int (StateT sig Maybe a)++instance Functor (PrefixReader sig) where+   fmap f (PrefixReader count parser) =+      PrefixReader count (fmap f parser)++instance Applicative (PrefixReader sig) where+   pure = PrefixReader 0 . return+   (PrefixReader count0 parser0) <*> (PrefixReader count1 parser1) =+       PrefixReader (count0+count1) (parser0 `ap` parser1)++{-# INLINE getNode #-}+getNode :: (Sample.C y, SigG.C sig) =>+   PrefixReader (sig y) y+getNode = PrefixReader 1 (StateT SigG.viewL)++{-# INLINE fromPrefixReader #-}+fromPrefixReader :: (Sample.C y, SigG.C sig) =>+   String -> Int -> PrefixReader (sig y) (t -> y) -> T sig t y+fromPrefixReader name off (PrefixReader count parser) =+   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 :: (Sample.C y, SigG.C sig) => T sig t y+constant =+   fromPrefixReader "constant" 0 (const <$> getNode)++{-| Consider the signal to be piecewise linear. -}+{-# INLINE linear #-}+linear :: (Module.C t y, Sample.C y, SigG.C sig) => T sig 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, Sample.C y, SigG.C sig) => T sig 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)++{-# INLINE cubicAlt #-}+cubicAlt :: (Field.C t, Module.C t y, Sample.C y, SigG.C sig) => T sig 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 steepness 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, Sample.C t, Sample.C y, SigG.C sig) =>+   Int -> [t -> t] -> T sig t y+piecewise center ps =+   Cons (length ps) (center-1)+      (\t -> linearComb (SigG.reverse (SigG.fromList (map ($t) ps))))++{-# INLINE piecewiseConstant #-}+piecewiseConstant ::+   (Module.C t y, Sample.C t, Sample.C y, SigG.C sig) => T sig t y+piecewiseConstant =+   piecewise 1 [const 1]++{-# INLINE piecewiseLinear #-}+piecewiseLinear ::+   (Module.C t y, Sample.C t, Sample.C y, SigG.C sig) => T sig t y+piecewiseLinear =+   piecewise 1 [id, (1-)]++{-# INLINE piecewiseCubic #-}+piecewiseCubic ::+   (Field.C t, Module.C t y, Sample.C t, Sample.C y, SigG.C sig) => T sig 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, Sample.C t, Sample.C y, SigG.C sig) =>+      (Int,Int)   {- ^ @(left extent, right extent)@, e.g. @(1,1)@ for linear hat -}+   -> (t -> t)+   -> T sig t y+function (left,right) f =+   let len = left+right+   in  Cons len left+          (\t -> linearComb $ SigG.reverse $+               SigG.map+                  (\x -> f (t + fromIntegral x))+                  (SigG.take len (SigG.iterate succ (-left))))+{-+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]+-}+++-- cf. Module.linearComb+{-# INLINE linearComb #-}+linearComb ::+   (SigG.C sig, Sample.C t, Sample.C y, Module.C t y) =>+   sig t -> sig y -> y+linearComb ts ys =+   SigG.sum $ SigG.zipWith (*>) ts ys++++{-* Helper functions -}++{-# INLINE delayPad #-}+delayPad :: (Sample.C y, SigG.C sig) => y -> Int -> sig y -> sig y+delayPad z n =+   if n<0 then SigG.drop (negate n) else SigG.append (SigG.replicate n z)
+ src/Synthesizer/Generic/Noise.hs view
@@ -0,0 +1,64 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- | Noise and random processes. -}+module Synthesizer.Generic.Noise where++import qualified Synthesizer.Generic.Signal as SigG+import qualified Synthesizer.Generic.SampledValue as Sample++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, Sample.C y, SigG.C sig) =>+   sig y+white = whiteGen (mkStdGen 12354)++whiteGen ::+   (Ring.C y, Random y, RandomGen g, Sample.C y, SigG.C sig) =>+   g -> sig y+whiteGen =+   SigG.unfoldR (Just . randomR (-1,1))+++{- |+Approximates normal distribution with variance 1+by a quadratic B-spline distribution.+-}+whiteQuadraticBSplineGen ::+   (Ring.C y, Random y, RandomGen g, Sample.C y, SigG.C sig) =>+   g -> sig y+whiteQuadraticBSplineGen g =+   let (g0,gr) = Rnd.split g+       (g1,g2) = Rnd.split gr+   in  whiteGen g0 `SigG.mix`+       whiteGen g1 `SigG.mix`+       whiteGen g2+++randomPeeks ::+   (Real.C y, Random y, Sample.C y, SigG.C sig) =>+      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, Sample.C y, SigG.C sig) =>+      g+   -> sig y+   -> sig Bool+randomPeeksGen =+   SigG.zipWith (<) . SigG.unfoldR (Just . randomR (0,1))
+ src/Synthesizer/Generic/Oscillator.hs view
@@ -0,0 +1,214 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+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.Plain.ToneModulation as ToneMod+import qualified Synthesizer.Basic.Wave       as Wave+import qualified Synthesizer.Basic.Phase      as Phase++import qualified Synthesizer.Generic.Interpolation as Interpolation++import qualified Synthesizer.Generic.Signal as SigG+import qualified Synthesizer.Generic.SampledValue as Sample++{-+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 -}++freqToPhase :: (RealField.C a, Sample.C a, SigG.C sig) =>+    Phase.T a -> sig a -> sig (Phase.T a)+freqToPhase phase freq =+    SigG.scanL (flip Phase.increment) phase freq+++{- | oscillator with constant frequency -}+static :: (RealField.C a, Sample.C a, Sample.C b, SigG.C sig) =>+   Wave.T a b -> (Phase.T a -> a -> sig b)+static wave phase freq =+    SigG.map (Wave.apply wave) (SigG.iterate (Phase.increment freq) phase)++{- | oscillator with modulated frequency -}+freqMod :: (RealField.C a, Sample.C a, Sample.C b, SigG.C sig) =>+   Wave.T a b -> Phase.T a -> sig a -> sig b+freqMod wave phase freqs =+    SigG.map (Wave.apply wave) (freqToPhase phase freqs)++{- | oscillator with modulated phase -}+phaseMod :: (RealField.C a, Sample.C a, Sample.C b, SigG.C sig) =>+   Wave.T a b -> a -> sig a -> sig b+phaseMod wave = shapeMod (Wave.phaseOffset wave) zero++{- | oscillator with modulated shape -}+shapeMod :: (RealField.C a, Sample.C a, Sample.C b, Sample.C c, SigG.C sig) =>+   (c -> Wave.T a b) -> Phase.T a -> a -> sig c -> sig b+shapeMod wave phase freq parameters =+    SigG.zipWith (Wave.apply . wave) parameters (SigG.iterate (Phase.increment freq) phase)++{- | oscillator with both phase and frequency modulation -}+phaseFreqMod :: (RealField.C a, Sample.C a, Sample.C b, SigG.C sig) =>+   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, Sample.C a, Sample.C b, Sample.C c, SigG.C sig) =>+   (c -> Wave.T a b) -> Phase.T a -> sig c -> sig a -> sig b+shapeFreqMod wave phase parameters freqs =+    SigG.zipWith (Wave.apply . wave) parameters (freqToPhase phase freqs)+++{- | oscillator with a sampled waveform with constant frequency+     This is essentially an interpolation with cyclic padding. -}+staticSample :: (RealField.C a, Sample.C a, Sample.C b, SigG.C sig) =>+   Interpolation.T sig a b -> [b] -> Phase.T a -> a -> sig b+staticSample ip wave phase freq =+    freqModSample ip wave phase (SigG.repeat freq)++{- | oscillator with a sampled waveform with modulated frequency+     Should behave homogenously for different types of interpolation. -}+freqModSample :: (RealField.C a, Sample.C a, Sample.C b, SigG.C sig) =>+   Interpolation.T sig a b -> [b] -> Phase.T a -> sig a -> sig b+freqModSample ip wave phase freqs =+    let len = length wave+    in  Interpolation.multiRelativeCyclicPad+           ip (Phase.toRepresentative $ Phase.multiply len phase)+           (SigG.map (* fromIntegral len) freqs)+           (SigG.fromList 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, Sample.C a, SigG.C sig) =>+    Interpolation.T c (b -> a) -> [b -> a] -> c -> b -> sig c -> sig b -> sig a+shapeFreqModSample ip waves shape0 phase shapes freqs =+    SigG.zipWith ($)+       (Interpolation.multiRelativeConstantPad ip shape0 shapes waves)+       (freqToPhase phase freqs)+{-+GNUPlot.plotList [] $ take 500 $ shapeFreqModSample Interpolation.cubic (SigG.map Wave.truncOddCosine [0..3]) (0.1::Double) (0::Double) (repeat 0.005) (repeat 0.02)+-}++{- |+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.++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, Sample.C a, SigG.C sig) =>+    Interpolation.T t y ->+    Interpolation.T t y ->+    t -> sig y -> t -> t -> sig t -> sig t -> sig y+shapeFreqModFromSampledTone+      ipLeap ipStep period sampledTone+      shape0 phase shapes freqs =+   SigG.map+      (uncurry (ToneMod.interpolateCell ipLeap ipStep))+      (ToneMod.oscillatorCells+          ipLeap ipStep period sampledTone+          (shape0, shapes) (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) (SigG.iterate (*(1-2e-3)) 0.01)+GNUPlot.plotList [] $ take 101 $ shapeFreqModFromSampledTone Interpolation.linear Interpolation.linear (1/0.07::Double) (SigG.iterate (1+) (0::Double)) 0 0 (repeat 1) (repeat 0.7)+-}+-}+++{- * Oscillators with specific waveforms -}++{- | sine oscillator with static frequency -}+staticSine :: (Trans.C a, RealField.C a, Sample.C a, SigG.C sig) =>+   Phase.T a -> a -> sig a+staticSine = static Wave.sine++{- | sine oscillator with modulated frequency -}+freqModSine :: (Trans.C a, RealField.C a, Sample.C a, SigG.C sig) =>+   Phase.T a -> sig a -> sig a+freqModSine = freqMod Wave.sine++{- | sine oscillator with modulated phase, useful for FM synthesis -}+phaseModSine :: (Trans.C a, RealField.C a, Sample.C a, SigG.C sig) =>+   a -> sig a -> sig a+phaseModSine = phaseMod Wave.sine++{- | saw tooth oscillator with modulated frequency -}+staticSaw :: (RealField.C a, Sample.C a, SigG.C sig) =>+   Phase.T a -> a -> sig a+staticSaw = static Wave.saw++{- | saw tooth oscillator with modulated frequency -}+freqModSaw :: (RealField.C a, Sample.C a, SigG.C sig) =>+   Phase.T a -> sig a -> sig a+freqModSaw = freqMod Wave.saw
+ src/Synthesizer/Generic/SampledValue.hs view
@@ -0,0 +1,20 @@+module Synthesizer.Generic.SampledValue where++import Foreign.Storable (Storable)+import StorableInstance ()++import qualified Number.Complex as Complex+import qualified Number.Ratio   as Ratio+import qualified Algebra.PrincipalIdealDomain as PID+++class Storable a => C a -- where++instance C Bool -- where+instance C Int -- where+instance C Float -- where+instance C Double -- where+instance (C a, C b) => C (a,b) -- where+instance (C a, C b, C c) => C (a,b,c) -- where+instance (C a) => C (Complex.T a) -- where+instance (C a, PID.C a) => C (Ratio.T a) -- where
+ src/Synthesizer/Generic/Signal.hs view
@@ -0,0 +1,197 @@+{- OPTIONS_GHC -fglasgow-exts -}+{-+Unfortunately we have to use the SampledValue constraint also for lists,+which means that we can only use Storable values for signals.+Maybe we can improve this situation using associated types.+-}+module Synthesizer.Generic.Signal where++import qualified Algebra.Module   as Module+import qualified Algebra.Additive as Additive++import qualified Synthesizer.Generic.SampledValue as Sample++import qualified Synthesizer.Plain.Modifier as Modifier++import Control.Monad.State (State, runState, )++import qualified Data.List as List++import Synthesizer.Utility (fst3, snd3, thd3)+import Prelude+   (Bool, Int, Maybe(Just), maybe,+    fst, snd, flip, uncurry, (.), not, )+++class C sig where+   empty :: (Sample.C y) => sig y+   null :: (Sample.C y) => sig y -> Bool+   cons :: (Sample.C y) => y -> sig y -> sig y+   fromList :: (Sample.C y) => [y] -> sig y+   toList :: (Sample.C y) => sig y -> [y]+   repeat :: (Sample.C y) => y -> sig y+   cycle :: (Sample.C y) => sig y -> sig y+   replicate :: (Sample.C y) => Int -> y -> sig y+   iterate :: (Sample.C y) => (y -> y) -> y -> sig y+   iterateAssoc :: (Sample.C y) => (y -> y -> y) -> y -> sig y+   unfoldR :: (Sample.C b) => (a -> Maybe (b,a)) -> a -> sig b+   map :: (Sample.C a, Sample.C b) => (a -> b) -> (sig a -> sig b)+   mix :: (Sample.C y, Additive.C y) => sig y -> sig y -> sig y+   zipWith :: (Sample.C a, Sample.C b, Sample.C c) =>+      (a -> b -> c) -> (sig a -> sig b -> sig c)+{-+   zipWithTails :: (Sample.C a, Sample.C b, Sample.C c) =>+      (a -> T b -> c) -> T a -> T b -> T c+-}+   scanL :: (Sample.C a, Sample.C b) =>+      (a -> b -> a) -> a -> sig b -> sig a+   foldL :: (Sample.C b) => (a -> b -> a) -> a -> sig b -> a+   viewL :: (Sample.C a) => sig a -> Maybe (a, sig a)+   viewR :: (Sample.C a) => sig a -> Maybe (sig a, a)+   length :: (Sample.C y) => sig y -> Int+   take :: (Sample.C y) => Int -> sig y -> sig y+   drop :: (Sample.C y) => Int -> sig y -> sig y+   dropMarginRem :: (Sample.C y) => Int -> Int -> sig y -> (Int, sig y)+   splitAt :: (Sample.C y) => Int -> sig y -> (sig y, sig y)+   takeWhile :: (Sample.C y) => (y -> Bool) -> sig y -> sig y+   dropWhile :: (Sample.C y) => (y -> Bool) -> sig y -> sig y+   span :: (Sample.C y) => (y -> Bool) -> sig y -> (sig y, sig y)+   append :: (Sample.C y) => sig y -> sig y -> sig y+   concat :: (Sample.C y) => [sig y] -> sig y+   reverse :: (Sample.C y) => sig y -> sig y+{-+   mapAccumL :: (Sample.C x, Sample.C y) =>+      (acc -> x -> (acc, y)) -> acc -> sig x -> (acc, sig y)+   mapAccumR :: (Sample.C x, Sample.C y) =>+      (acc -> x -> (acc, y)) -> acc -> sig x -> (acc, sig y)+-}+   crochetL :: (Sample.C x, Sample.C y) =>+      (x -> acc -> Maybe (y, acc)) -> acc -> sig x -> sig y+++{-# INLINE sum #-}+sum :: (Additive.C a, Sample.C a, C sig) => sig a -> a+sum = foldL (Additive.+) Additive.zero++{-+{-# INLINE tails #-}+tails :: (Sample.C y, C sig) => sig y -> [sig y]+tails =+   List.unfoldr (fmap (\x -> (x, fmap snd (viewL x)))) . Just+-}++{-# INLINE zapWith #-}+zapWith :: (Sample.C a, Sample.C b, C sig) =>+   (a -> a -> b) -> sig a -> sig b+zapWith f xs0 =+   let xs1 = maybe empty snd (viewL xs0)+   in  zipWith f xs0 xs1++{-# INLINE zip #-}+zip :: (Sample.C a, Sample.C b, C sig) =>+   sig a -> sig b -> sig (a,b)+zip = zipWith (,)+++{-# INLINE unzip #-}+unzip :: (Sample.C a, Sample.C b, C sig) =>+   sig (a,b) -> (sig a, sig b)+unzip xs =+   (map fst xs, map snd xs)++{-# INLINE unzip3 #-}+unzip3 :: (Sample.C a, Sample.C b, Sample.C c, C sig) =>+   sig (a,b,c) -> (sig a, sig b, sig c)+unzip3 xs =+   (map fst3 xs, map snd3 xs, map thd3 xs)+++{-# INLINE modifyStatic #-}+modifyStatic :: (Sample.C a, Sample.C b, C sig) =>+   Modifier.Simple s ctrl a b -> ctrl -> sig a -> sig b+modifyStatic (Modifier.Simple state proc) control x =+   crochetL (\a acc -> Just (runState (proc control a) acc)) state x++{-| Here the control may vary over the time. -}+{-# INLINE modifyModulated #-}+modifyModulated :: (Sample.C a, Sample.C b, Sample.C ctrl, C sig) =>+   Modifier.Simple s ctrl a b -> sig ctrl -> sig a -> sig b+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, Sample.C t, Sample.C y, C sig) =>+   sig t -> sig y -> y+linearComb ts ys =+   sum (zipWith (Module.*>) ts ys)+++{-# INLINE sliceVert #-}+sliceVert :: (Sample.C y, C sig) =>+   Int -> sig y -> [sig y]+sliceVert n =+   List.map (take n) . List.takeWhile (not . null) . List.iterate (drop n)+++{-# INLINE extendConstant #-}+extendConstant :: (Sample.C y, C sig) =>+   sig y -> sig y+extendConstant xt =+   maybe empty+      (append xt . repeat . snd)+      (viewR xt)+++-- comonadic 'bind'+-- only non-empty suffixes are processed+{-# INLINE mapTails #-}+mapTails :: (Sample.C a, Sample.C b, C sig) =>+   (sig a -> b) -> sig a -> sig b+mapTails f =+   unfoldR (\xs ->+      do (_,ys) <- viewL xs+         Just (f xs, ys))++-- only non-empty suffixes are processed+{-# INLINE zipWithTails #-}+zipWithTails :: (Sample.C a, Sample.C b, Sample.C c, C sig) =>+   (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)))+++{-+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/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/Synthesizer/Inference/DesignStudy/Arrow.hs view
@@ -0,0 +1,45 @@+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.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 Arrow Processor where+  arr f = P Any (const f)+  (P r0 f0) >>> (P r1 f1) =+     P (intersectRates r0 r1) (\r -> f1 r . f0 r)+  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/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.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/Inference/Func/Cut.hs view
@@ -0,0 +1,276 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+Copyright   :  (c) Henning Thielemann 2006, 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes+-}+module Synthesizer.Inference.Func.Cut (+   {- * dissection -}+   -- splitAt,+   -- take,+   -- drop,+   takeUntilPause,+   -- unzip,+   -- unzip3,++   {- * glueing -}+   concat,+   concatVolume,+   append,+   zip,+   -- zip3,+   arrange,+   arrangeVolume,+  ) where++import qualified Synthesizer.Physical.Signal      as SigP+import qualified Synthesizer.Physical.Cut         as CutP+import qualified Synthesizer.Inference.Func.Signal as SigF++import qualified Synthesizer.SampleRateContext.Signal as SigC+import qualified Synthesizer.SampleRateContext.Rate as Rate+import qualified Synthesizer.SampleRateContext.Cut as CutC++import qualified Data.EventList.Relative.TimeBody as EventList+import qualified Numeric.NonNegative.Class as NonNeg++import qualified Algebra.NormedSpace.Maximum as NormedMax+import qualified Algebra.OccasionallyScalar  as OccScalar+import qualified Algebra.Module              as Module+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 Data.List as List++-- import Control.Monad.Fix(mfix)++import PreludeBase hiding (zip, zip3, concat, )+-- import NumericPrelude+import Prelude (RealFrac)++{-+{- * dissection -}++splitAt :: (RealField.C a, Field.C q, OccScalar.C a q) =>+   q -> SigI.T a q v -> Process.T q (SigI.T a q v, SigI.T a q v)+splitAt t0 x@(Cons sr amp ss) =+   do t <- SigI.toTimeScalar x (Expr.constant t0)+      let (ss0,ss1) = List.splitAt (round t) ss+      return (Cons sr amp ss0, Cons sr amp ss1)++take :: (RealField.C a, Field.C q, OccScalar.C a q) =>+   q -> SigI.T a q v -> SigI.Process a q v+take t = fmap fst . splitAt t++drop :: (RealField.C a, Field.C q, OccScalar.C a q) =>+   q -> SigI.T a q v -> SigI.Process a q v+drop t = fmap snd . splitAt t+-}++takeUntilPause :: (RealField.C t, Ring.C t', OccScalar.C t t',+                   Field.C y', NormedMax.C y yv, OccScalar.C y y') =>+   y' -> t' -> SigF.T t t' y y' yv -> SigF.T t t' y y' yv+takeUntilPause y' t' x =+   SigF.cons $ \infered@(isr,iamp) ->+      let x' = SigF.eval x infered+          xp = SigP.replaceParameters isr iamp x'+          zp = CutP.takeUntilPause y' t' xp+      in  SigP.replaceParameters+             (SigP.sampleRate x') (SigP.amplitude x') zp+++{-+How can we assert sharing of the input signal+with the output signals?++unzip ::+       SigF.T t t' y y' (yv0, yv1)+   -> (SigF.T t t' y y' yv0, SigF.T t t' y y' yv1)+unzip x =+   (SigF.cons $ \inferedY@(isrY,iampY) -> ,+    SigF.cons $ \inferedZ@(isrZ,iampZ) -> )+++unzip3 ::+       SigF.T t t' y y' (yv0, yv1, yv2)+   -> (SigF.T t t' y y' yv0, SigF.T t t' y y' yv1, SigF.T t t' y y' yv2)+unzip3 = return . CutC.unzip3+-}+++{- * glueing -}++{- |+  Similar to @foldr1 append@ but more efficient and accurate,+  because it reduces the number of amplifications.+  Does not work for infinite lists,+  because in this case a maximum amplitude cannot be computed.+-}+concat ::+   (Eq t', Real.C y', Field.C y', Module.C y yv, OccScalar.C y y') =>+      [SigF.T t t' y y' yv]+   ->  SigF.T t t' y y' yv+concat xs =+   SigF.cons $ \(isr,iamp) ->+      let xs' = zipWith (\x amp -> SigF.eval x (isr, amp)) xs amps+          amps = map SigF.guessAmplitude xs'+          xps = zipWith SigF.contextFixAmplitude amps xs'+          sampleRate = SigF.mergeSampleRates xs'+      in  SigF.fromContextCheckAmplitude sampleRate iamp+             (CutC.concat (Rate.fromNumber isr) xps)++{- |+  Like 'concat' but it expects a fixed output amplitude.+  This way it can also handle infinitely many inputs+  if one input or the output has a fixed sample rate.++  'concatVolume' is one reason for the complicated handling+  of sampling rates by lists of @Maybe@s.++  The problem of finding an apropriate sampling rate is that+  we must have an order of processing parallel signal processors+  which guarantees termination if termination is possible.+  Say @mix (concat infinitelist0) (concat infinitelist1)@.+  Either infinite list can have signal with fixed sample rate or not.+  There is no way to determine this a priori.+  The only safe way is to process them in parallel.+  That's why we must have a @[Maybe t']@ instead of @Maybe t'@.+  Also @[t']@ is not enough,+  because e.g. a concatenation of infinitely many sounds+  with undetermined sampling rate+  would have an empty list representing the sampling rate,+  but computing the empty list needs infinite time.+-}+concatVolume ::+   (Eq t', Real.C y', Field.C y', Module.C y yv, OccScalar.C y y') =>+      [SigF.T t t' y y' yv]+   ->  SigF.T t t' y y' yv+concatVolume xs =+   SigF.cons $ \(isr,iamp) ->+      let xs' = zipWith (\x amp -> SigF.eval x (isr, amp)) xs amps+          amps = map SigF.guessAmplitude xs'+          xps = zipWith SigF.contextFixAmplitude amps xs'+          sampleRate = SigF.mergeSampleRates xs'+      in  SigF.fromContextFreeAmplitude sampleRate+             (CutC.concatVolume iamp (Rate.fromNumber isr) xps)+++merge :: (Eq t', Real.C y', Field.C y', OccScalar.C y y',+          Module.C y v0, Module.C y v1) =>+      (Rate.T t t' -> SigC.T y y' v0 -> SigC.T y y' v1 -> SigC.T y y' v2)+   -> SigF.T t t' y y' v0+   -> SigF.T t t' y y' v1+   -> SigF.T t t' y y' v2+merge f x y =+   SigF.cons $ \(isr,iamp) ->+      let x' = SigF.eval x (isr, ampX)+          y' = SigF.eval y (isr, ampY)+          ampX = SigF.guessAmplitude x'+          ampY = SigF.guessAmplitude y'+          xp = SigF.contextFixAmplitude ampX x'+          yp = SigF.contextFixAmplitude ampY y'+          sampleRate = SigF.mergeSampleRate x' y'+      in  SigF.fromContextCheckAmplitude sampleRate iamp+             (f (Rate.fromNumber isr) xp yp)+++append :: (Eq t', Real.C y', Field.C y', OccScalar.C y y',+         Module.C y yv) =>+      SigF.T t t' y y' yv+   -> SigF.T t t' y y' yv+   -> SigF.T t t' y y' yv+append = merge CutC.append+++zip :: (Eq t', Real.C y', Field.C y', OccScalar.C y y',+        Module.C y v0, Module.C y v1) =>+      SigF.T t t' y y' v0+   -> SigF.T t t' y y' v1+   -> SigF.T t t' y y' (v0,v1)+zip = merge CutC.zip++{-+zip3 :: (Real.C q, Field.C q, Ord q, OccScalar.C a q,+         Module.C a v0, Module.C a v1, Module.C a v2)+   => SigI.T a q v0+   -> SigI.T a q v1+   -> SigI.T a q v2+   -> SigI.Process a q (v0, v1, v2)+zip3 x0 x1 x2 =+   mfix (\z ->+      do sampleRate <- Process.equalValues+            [SigP.sampleRate x0, SigP.sampleRate x1, SigP.sampleRate x2]+         amplitude  <- Process.fromExpr+            (Expr.maximum [amplitudeExpr x0, amplitudeExpr x1, amplitudeExpr x2])+         samp0 <- SigI.vectorSamples (toAmplitudeScalar z) x0+         samp1 <- SigI.vectorSamples (toAmplitudeScalar z) x1+         samp2 <- SigI.vectorSamples (toAmplitudeScalar z) x2+         SigI.returnCons sampleRate amplitude+            (List.zip3 samp0 samp1 samp2))+-}++++scheduleToContext ::+      t'+   -> EventList.T time (SigF.T t t' y y' yv)+   -> (SigF.Parameter t',+       EventList.T time (SigC.T y y' yv))+scheduleToContext isr sched =+   let xps =+          EventList.mapBody+             (\x ->+                 let y = SigF.eval x (isr, amp)+                     amp = SigF.guessAmplitude y+                     z = SigF.contextFixAmplitude amp y+                 in  (y,z)) sched+       schedp = EventList.mapBody snd xps+       sampleRate = SigF.mergeSampleRates (map fst (EventList.getBodies xps))+   in  (sampleRate, schedp)+++{- |+  Given a list of signals with time stamps,+  mix them into one signal as they occur in time.+  Ideally for composing music.+  Infinite schedules are not supported,+  because no maximum amplitude can be computed.+-}+arrange ::+   (RealFrac t, NonNeg.C t, Eq t', Ring.C t, Ring.C t', OccScalar.C t t',+    Ord y', Field.C y', OccScalar.C y y',+    Module.C y yv) =>+      t'+   -> EventList.T t (SigF.T t t' y y' yv)+          {-^ A list of pairs: (relative start time, signal part),+              The start time is relative+              to the start time of the previous event. -}+   -> SigF.T t t' y y' yv+          {-^ The mixed signal. -}+arrange unit sched =+   SigF.cons $ \(isr,iamp) ->+      let (sampleRate, schedp) = scheduleToContext isr sched+      in  SigF.fromContextCheckAmplitude sampleRate iamp+             (CutC.arrange unit (Rate.fromNumber isr) schedp)++arrangeVolume ::+   (RealFrac t, NonNeg.C t, Eq t', Ring.C t, Ring.C t', OccScalar.C t t',+    Field.C y', OccScalar.C y y',+    Module.C y yv) =>+      t'+   -> EventList.T t (SigF.T t t' y y' yv)+          {-^ A list of pairs: (relative start time, signal part),+              The start time is relative+              to the start time of the previous event. -}+   -> SigF.T t t' y y' yv+          {-^ The mixed signal. -}+arrangeVolume unit sched =+   SigF.cons $ \(isr,iamp) ->+      let (sampleRate, schedp) = scheduleToContext isr sched+      in  SigF.fromContextFreeAmplitude sampleRate+             (CutC.arrangeVolume iamp unit (Rate.fromNumber isr) schedp)
+ src/Synthesizer/Inference/Func/Signal.hs view
@@ -0,0 +1,297 @@+{-# OPTIONS -fno-implicit-prelude -fglasgow-exts #-}+{- |++Copyright   :  (c) Henning Thielemann 2006, 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++-}+module Synthesizer.Inference.Func.Signal where++import qualified Synthesizer.Physical.Signal as SigP+import qualified Synthesizer.SampleRateContext.Signal as SigC++-- import qualified Algebra.OccasionallyScalar as OccScalar+-- import qualified Algebra.Module         as Module+-- import qualified Algebra.Field          as Field+-- import qualified Algebra.Ring           as Ring++-- import Algebra.OccasionallyScalar (toScalar)++import Control.Monad.Fix (fix)+import Data.Maybe (catMaybes, isJust)+import Data.List  (transpose)+import NumericPrelude.List (shearTranspose)++-- import NumericPrelude+import PreludeBase as P++{- |+Each process must work the following way:+If the signal processor has a fixed sample rate or amplitude+either implied by its parameters or its inputs+then this parameter should be set as @Just@+in the corresponding fields of @SigP.T@.+These fields must be computed+independently from the function argument of type @(t',y')@.+This function argument is the pair of eventually used signal parameters+sample rate and amplitude.+If you set signal parameters to @Just@ with a value,+then you can expect that the corresponding pair member has the same value.+-}+newtype T t t' y y' yv =+   Cons {eval :: (t',y') -> Evaluated t t' y y' yv}++type Evaluated t t' y y' yv = SigP.T t (Parameter t') y (Parameter y') yv+{- |+Since all 'Just' values must contain the same value,+we could also use the data structure '(Peano, a)'+just like in the @unique-logic@ package.+-}+newtype Parameter a = Parameter {parameterDesc :: [Maybe a]}++liftParam2 ::+   ([Maybe a] -> [Maybe b] -> [Maybe c]) ->+   Parameter a -> Parameter b -> Parameter c+liftParam2 f (Parameter x) (Parameter y) = Parameter (f x y)++cons :: ((t',y') -> SigP.T t (Parameter t') y (Parameter y') yv) -> T t t' y y' yv+cons = Cons+++contextFixAmplitude ::+      y'+   -> Evaluated t t' y y' yv+   -> SigC.T y y' yv+contextFixAmplitude amp =+   SigC.replaceAmplitude amp . SigP.content++fromContextFreeAmplitude ::+      Parameter t'+   -> SigC.T y y' yv+   -> Evaluated t t' y y' yv+fromContextFreeAmplitude sr (SigC.Cons _amp ss) =+   SigP.cons sr anyParameter ss++fromContextCheckAmplitude :: (Eq y') =>+      Parameter t'+   -> y'+   -> SigC.T y y' yv+   -> Evaluated t t' y y' yv+fromContextCheckAmplitude sr iamp (SigC.Cons amp ss) =+   SigP.cons sr (justParameter amp)+      (if iamp==amp then ss else error "fromContextCheckAmplitude: amplitudes differ")+++anyParameter :: Parameter q+anyParameter = Parameter []++justParameter :: q -> Parameter q+justParameter x = Parameter [Just x]++inSampleRate :: (t',y') -> t'+inSampleRate = fst++inAmplitude :: (t',y') -> y'+inAmplitude = snd++++{-+vectorSamples :: (Eq t', Module.C y yv) =>+   (y' -> y) -> T t t' y y' yv -> (t' -> [yv])+vectorSamples toAmpScalar sig =+   \inferedSampleRate ->+      let x'   = eval sig (inferedSampleRate, amp')+          amp' = guessParameter+                    "vectorSamples: input amplitude"+                    (SigP.amplitude x')+          amp = toAmpScalar amp' `SigP.asTypeOfAmplitude` x'+      in  amp *> SigP.samples x'++scalarSamples :: (Eq t', Ring.C y) =>+   (y' -> y) -> T t t' y y' y -> (t' -> [y])+scalarSamples toAmpScalar sig =+   \inferedSampleRate ->+      let x'  = sig (inferParameter inferedSampleRate (SigP.sampleRate x'),+                     amp')+          amp' = fromMaybe (error "scalarSamples: undetermined input amplitude")+                           (SigP.amplitude x')+          amp = toAmpScalar amp' `SigP.asTypeOfAmplitude` x'+      in  map (amp*) (SigP.samples x')++++inferParameter :: Eq q => q -> Maybe q -> q+inferParameter infered =+   maybe infered+      (\x -> if x == infered+               then x+               else error ("inferParameter:" +++                           " requested value and infered one differ"))+-}++equalParameter :: Eq q => String -> Maybe q -> Maybe q -> Maybe q+equalParameter name x y =+   case (x,y) of+      (Nothing,_) -> y+      (_,Nothing) -> x+      (Just xv, Just yv) ->+         if xv == yv+           then Just xv+           else error ("equalParameter: " ++ name ++ " differ")++equalSampleRate :: Eq t' => Maybe t' -> Maybe t' -> Maybe t'+equalSampleRate = equalParameter "sample rate"+++zipJut :: (a -> a -> a) -> [a] -> [a] -> [a]+zipJut f =+   let aux (x:xs) (y:ys) = f x y : aux xs ys+       aux []     ys     = ys+       aux xs     []     = xs+   in  aux++{-|+  Merge the @Just@s of two lists.+  It does not check for validity of the data.+-}+mergeParameter :: Parameter q -> Parameter q -> Parameter q+mergeParameter =+   liftParam2 (zipJut (\x y -> if isJust x then x else y))++mergeSampleRate ::+   Evaluated t t' y0 y0' yv0 -> Evaluated t t' y1 y1' yv1 -> Parameter t'+mergeSampleRate x y =+   mergeParameter (SigP.sampleRate x) (SigP.sampleRate y)+++mergeParameterEq :: Eq q => String -> Parameter q -> Parameter q -> Parameter q+mergeParameterEq name =+   liftParam2 (zipJut (equalParameter name))++mergeSampleRateEq :: Eq t' => Parameter t' -> Parameter t' -> Parameter t'+mergeSampleRateEq = mergeParameterEq "sample rate"++-- cf. Examples.merge+merge :: [a] -> [a] -> [a]+merge (x:xs) ys = x : merge ys xs+merge []     ys = ys++propMerge :: Eq a => [a] -> [a] -> Bool+propMerge xs ys  =  merge xs ys == concat (transpose [xs,ys])++mergeParameter' :: Parameter t' -> Parameter t' -> Parameter t'+mergeParameter' = liftParam2 merge++checkParameter :: Eq q => String -> q -> Maybe q -> q+checkParameter name x =+   maybe x (\y -> if x == y+                    then x+                    else error ("checkParameter: deviation from common " ++ name))++checkSampleRate :: Eq t' => t' -> Maybe t' -> t'+checkSampleRate = checkParameter "sample rate"++checkAmplitude :: Eq y' => y' -> Maybe y' -> y'+checkAmplitude = checkParameter "amplitude"+++{-|+  This routine is prepared for infinite lists.+  In order to handle them we employ a Cantor diagonalization scheme.+  It does not check for validity of the data+  (i.e. equal @Just@ values)+  but it does only keep some @Just@s,+  and thus allows for a quick search of a guess of a parameter value.+-}+mergeParameters :: [Parameter q] -> Parameter q+mergeParameters =+   Parameter . map (head . (++[Nothing]) . filter isJust)+      . shearTranspose . map parameterDesc++mergeSampleRates :: [Evaluated t t' y y' yv] -> Parameter t'+mergeSampleRates =+   mergeParameters . map SigP.sampleRate++mergeParametersEq :: Eq q => String -> [Parameter q] -> Parameter q+mergeParametersEq name =+   Parameter . map (foldl (equalParameter name) Nothing)+      . shearTranspose . map parameterDesc++mergeSampleRatesEq :: Eq t' => [Parameter t'] -> Parameter t'+mergeSampleRatesEq = mergeParametersEq "sample rate"++{- |+This is a simple working version of 'mergeParameters',+which does not need @Eq@ constraint.+However, flattening a three-dimensional list+does handle different dimensions differently,+that is slower than the others.+-}+mergeParameters' :: [Parameter q] -> Parameter q+mergeParameters' =+   Parameter . concat . shearTranspose . map parameterDesc+++{-+equalParameters :: Eq q => String -> [Parameter q] -> Parameter q+equalParameters name xs =+   let cxs = catMaybes xs+   in  if and (zipWith (==) cxs (tail cxs))+         then listToMaybe cxs+         else error ("equalParameters: " ++ name ++ " differ")++equalSampleRates :: Eq t' => [Maybe t'] -> Maybe t'+equalSampleRates = equalParameters "sample rates"+-}++guessParameter :: String -> Parameter q -> q+guessParameter context =+   head . (++ error (context ++ " undetermined")) . catMaybes . parameterDesc++guessSampleRate :: Evaluated t t' y y' yv -> t'+guessSampleRate = guessParameter "sample rate" . SigP.sampleRate++guessAmplitude :: Evaluated t t' y y' yv -> y'+guessAmplitude = guessParameter "amplitude" . SigP.amplitude++++{- |+  A complex signal graph can be built without ever mentioning a sampling rate.+  However when it comes to playing or writing a file,+  we must determine the sampling rate eventually.+  This function simply passes a signal through+  while forcing it to the given sampling rate.+-}+fixSampleRate :: (Eq t') =>+      t'                {-^ sample rate -}+   -> T t t' y y' yv    {-^ passed through signal -}+   -> T t t' y y' yv+fixSampleRate forcedSampleRate input =+   Cons $ \infered ->+      let inputSig = eval input infered+      in  SigP.cons+             (justParameter forcedSampleRate)+             (SigP.amplitude inputSig)+             (if inSampleRate infered == forcedSampleRate+                then SigP.samples inputSig+                else error "fixSampleRate: sampleRates differ")++-- ***** Is this one correct? Has the usage of 'infered' a cycle?+{- | Create a loop (feedback) from one node to another one.+     That is, compute the fix point of a process iteration. -}+loop :: (Eq t') =>+      (T t t' y y' yv -> T t t' y y' yv)+                        {-^ process chain that shall be looped -}+   ->  T t t' y y' yv+loop f =+   fix (\x -> f (Cons $ \infered ->+          SigP.cons anyParameter anyParameter+                    (SigP.samples (eval x infered))))++-- example: loop (\y -> x + delay y)
+ src/Synthesizer/Inference/Reader/Control.hs view
@@ -0,0 +1,167 @@+{-# OPTIONS -fno-implicit-prelude -fglasgow-exts #-}+{- |+Copyright   :  (c) Henning Thielemann 2007+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes+++Control curves which can be used+as envelopes, for controlling filter parameters and so on.+-}+module Synthesizer.Inference.Reader.Control+   ({- * Primitives -}+    constant, constantVector, linear, line, exponential, exponential2,+    {- * Piecewise -}+    piecewise, piecewiseVolume, Control(..), ControlPiece(..),+    (-|#), ( #|-), (=|#), ( #|=), (|#), ( #|),  -- spaces before # for Haddock+    {- * Preparation -}+    mapLinear, mapExponential, )+   where+++import Synthesizer.Plain.Control+   (Control(..), ControlPiece(..), (-|#), ( #|-), (=|#), ( #|=), (|#), ( #|))++import qualified Synthesizer.SampleRateContext.Control as CtrlC++{-+if we import that, then GHC-6.4.1 will no longer complain,+that Synthesizer.Plain.Control is unnecessarily imported+import qualified Synthesizer.Plain.Control as Ctrl+-}++import qualified Synthesizer.Inference.Reader.Signal as SigR+import qualified Synthesizer.Inference.Reader.Process as Proc++import qualified Algebra.OccasionallyScalar as OccScalar+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 qualified Algebra.Ring               as Ring++-- import NumericPrelude+-- import PreludeBase as P+++constant :: (Field.C y', Real.C y', OccScalar.C y y') =>+      y' {-^ value -}+   -> Proc.T t t' (SigR.T y y' y)+constant y =+   SigR.lift (CtrlC.constant y)++{- |+The amplitude must be positive!+This is not checked.+-}+constantVector :: -- (Field.C y', Real.C y', OccScalar.C y y') =>+      y' {-^ amplitude -}+   -> yv {-^ value -}+   -> Proc.T t t' (SigR.T y y' yv)+constantVector y yv =+   SigR.lift (CtrlC.constantVector y yv)++{- Using the 'Ctrl.linear' instead of 'Ctrl.linearStable'+   the type class constraints would be weaker.+linear :: (Additive.C y, Field.C y', Real.C y', OccScalar.C y y') =>+-}++{- |+Caution: This control curve can contain samples+with an absolute value greater than 1.++Linear curves starting with zero are impossible.+Maybe you prefer using 'line'.+-}+linear ::+   (Field.C q, Field.C q',+    Real.C q', OccScalar.C q q') =>+      q' {-^ slope of the curve -}+   -> q' {-^ initial value -}+   -> Proc.T q q' (SigR.T q q' q)+linear slope y0 =+   SigR.lift (CtrlC.linear slope y0)++{- |+Generates a finite ramp.+-}+line ::+   (RealField.C q, Field.C q',+    Real.C q', OccScalar.C q q') =>+      q'      {-^ duration of the ramp -}+   -> (q',q') {-^ initial and final value -}+   -> Proc.T q q' (SigR.T q q' q)+line dur (y0,y1) =+   SigR.lift (CtrlC.line dur (y0,y1))++exponential :: (Trans.C q, Field.C q', Real.C q', OccScalar.C q q') =>+      q' {-^ time where the function reaches 1\/e of the initial value -}+   -> q' {-^ initial value -}+   -> Proc.T q q' (SigR.T q q' q)+exponential time y0 =+   SigR.lift (CtrlC.exponential time y0)++{-+  take 1000 $ show (run (fixSampleRate 100 (exponential 0.1 1)) :: SigDouble)+-}++exponential2 :: (Trans.C q, Field.C q', Real.C q', OccScalar.C q q') =>+      q' {-^ half life, time where the function reaches 1\/2 of the initial value -}+   -> q' {-^ initial value -}+   -> Proc.T q q' (SigR.T q q' q)+exponential2 time y0 =+   SigR.lift (CtrlC.exponential2 time y0)++++{- |+Since this function looks for the maximum node value,+and since the signal parameter inference phase must be completed before signal processing,+infinite descriptions cannot be used here.+-}+piecewise :: (Trans.C q, RealField.C q,+              Real.C q', Field.C q', OccScalar.C q q') =>+      [ControlPiece q']+   -> Proc.T q q' (SigR.T q q' q)+piecewise cs =+   SigR.lift (CtrlC.piecewise cs)++piecewiseVolume ::+   (Trans.C q, RealField.C q,+    Real.C q', Field.C q', OccScalar.C q q') =>+      [ControlPiece q']+   -> q'+   -> Proc.T q q' (SigR.T q q' q)+piecewiseVolume cs amplitude =+   SigR.lift (CtrlC.piecewiseVolume cs amplitude)+++{- |+Map a control curve without amplitude unit+by a linear (affine) function with a unit.+-}+mapLinear :: (Ring.C y, Field.C y', Real.C y', OccScalar.C y y') =>+      y'  {- ^ range: one is mapped to @center+range@ -}+   -> y'  {- ^ center: zero is mapped to @center@ -}+   -> Proc.T t t'+       (SigR.T y y' y+     -> SigR.T y y' y)+mapLinear range center =+   SigR.lift (CtrlC.mapLinear range center)++{- |+Map a control curve without amplitude unit+exponentially to one with a unit.+-}+mapExponential :: (Field.C y', Trans.C y, Module.C y y') =>+      y   {- ^ range: one is mapped to @center*range@, must be positive -}+   -> y'  {- ^ center: zero is mapped to @center@ -}+   -> Proc.T t t'+       (SigR.T y y  y+     -> SigR.T y y' y)+mapExponential range center =+   SigR.lift (CtrlC.mapExponential range center)
+ src/Synthesizer/Inference/Reader/Cut.hs view
@@ -0,0 +1,194 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+Copyright   :  (c) Henning Thielemann 2006+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes+-}+module Synthesizer.Inference.Reader.Cut (+   {- * dissection -}+   splitAt,+   take,+   drop,+   takeUntilPause,+   unzip,+   unzip3,++   {- * glueing -}+   concat,   concatVolume,+   append,   appendVolume,+   zip,      zipVolume,+   zip3,     zip3Volume,+   arrange,  arrangeVolume,+  ) where++import qualified Synthesizer.SampleRateContext.Cut as CutC++import qualified Synthesizer.Inference.Reader.Signal as SigR+import qualified Synthesizer.Inference.Reader.Process as Proc++import qualified Data.EventList.Relative.TimeBody as EventList+import qualified Numeric.NonNegative.Class as NonNeg++import qualified Algebra.NormedSpace.Maximum as NormedMax+import qualified Algebra.OccasionallyScalar  as OccScalar+import qualified Algebra.Module              as Module+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 Data.List as List++import PreludeBase ((.), Ord)+-- import NumericPrelude+import Prelude (RealFrac)+++{- * dissection -}++splitAt :: (RealField.C t, Field.C t', OccScalar.C t t') =>+   t' -> Proc.T t t' (SigR.T y y' yv -> (SigR.T y y' yv, SigR.T y y' yv))+splitAt t = SigR.lift (CutC.splitAt t)++take :: (RealField.C t, Field.C t', OccScalar.C t t') =>+   t' -> Proc.T t t' (SigR.T y y' yv -> SigR.T y y' yv)+take t = SigR.lift (CutC.take t)++drop :: (RealField.C t, Field.C t', OccScalar.C t t') =>+   t' -> Proc.T t t' (SigR.T y y' yv -> SigR.T y y' yv)+drop t = SigR.lift (CutC.drop t)++takeUntilPause ::+  (RealField.C t, Ring.C t', OccScalar.C t t',+   Field.C y', NormedMax.C y yv, OccScalar.C y y') =>+   y' -> t' -> Proc.T t t' (SigR.T y y' yv -> SigR.T y y' yv)+takeUntilPause y' t' = SigR.lift (CutC.takeUntilPause y' t')+++unzip ::+   Proc.T t t'+      (SigR.T y y' (yv0, yv1) ->+         (SigR.T y y' yv0, SigR.T y y' yv1))+unzip = SigR.lift CutC.unzip++unzip3 ::+   Proc.T t t'+      (SigR.T y y' (yv0, yv1, yv2) ->+         (SigR.T y y' yv0, SigR.T y y' yv1, SigR.T y y' yv2))+unzip3 = SigR.lift CutC.unzip3+++{- * glueing -}++{- |+Similar to @foldr1 append@ but more efficient and accurate,+because it reduces the number of amplifications.+Does not work for infinite lists,+because no maximum amplitude can be computed.+-}+concat ::+   (Real.C y, Ord y', Field.C y', OccScalar.C y y',+    Module.C y yv) =>+   Proc.T t t' ([SigR.T y y' yv] -> SigR.T y y' yv)+concat = SigR.lift CutC.concat++{- |+Give the output volume explicitly.+Does also work for infinite lists.+-}+concatVolume ::+   (Field.C y', OccScalar.C y y',+    Module.C y yv) =>+   y' -> Proc.T t t' ([SigR.T y y' yv] -> SigR.T y y' yv)+concatVolume = SigR.lift . CutC.concatVolume+++append ::+   (Real.C y, Ord y', Field.C y', OccScalar.C y y',+    Module.C y yv) =>+   Proc.T t t' (SigR.T y y' yv -> SigR.T y y' yv -> SigR.T y y' yv)+append = SigR.lift CutC.append++appendVolume ::+   (Field.C y', OccScalar.C y y',+    Module.C y yv) =>+   y' ->+   Proc.T t t' (SigR.T y y' yv -> SigR.T y y' yv -> SigR.T y y' yv)+appendVolume = SigR.lift . CutC.appendVolume+++zip ::+   (Real.C y, Ord y', Field.C y', OccScalar.C y y',+    Module.C y yv0, Module.C y yv1) =>+   Proc.T t t' (SigR.T y y' yv0 -> SigR.T y y' yv1 -> SigR.T y y' (yv0,yv1))+zip = SigR.lift CutC.zip++zipVolume ::+   (Field.C y', OccScalar.C y y',+    Module.C y yv0, Module.C y yv1) =>+   y' ->+   Proc.T t t' (SigR.T y y' yv0 -> SigR.T y y' yv1 -> SigR.T y y' (yv0,yv1))+zipVolume = SigR.lift . CutC.zipVolume+++zip3 ::+   (Real.C y, Ord y', Field.C y', OccScalar.C y y',+    Module.C y yv0, Module.C y yv1, Module.C y yv2) =>+   Proc.T t t' (SigR.T y y' yv0 -> SigR.T y y' yv1 -> SigR.T y y' yv2 ->+                 SigR.T y y' (yv0,yv1,yv2))+zip3 = SigR.lift CutC.zip3++zip3Volume ::+   (Field.C y', OccScalar.C y y',+    Module.C y yv0, Module.C y yv1, Module.C y yv2) =>+   y' ->+   Proc.T t t' (SigR.T y y' yv0 -> SigR.T y y' yv1 -> SigR.T y y' yv2 ->+                 SigR.T y y' (yv0,yv1,yv2))+zip3Volume = SigR.lift . CutC.zip3Volume+++{- |+Uses maximum input volume as output volume.+-}+arrange ::+   (Ring.C t', OccScalar.C t t',+    RealFrac t, NonNeg.C t,+    Ord y', Field.C y', OccScalar.C y y',+    Module.C y yv) =>+      t'  {-^ Unit of the time values in the time ordered list. -}+   -> Proc.T t t'+        (EventList.T t (SigR.T y y' yv)+             {-  A list of pairs: (relative start time, signal part),+                 The start time is relative+                 to the start time of the previous event. -}+         -> SigR.T y y' yv+             {-  The mixed signal. -} )+arrange = SigR.lift . CutC.arrange+++{- |+Given a list of signals with time stamps,+mix them into one signal as they occur in time.+Ideally for composing music.+Infinite schedules are not supported.+Does not work for infinite lists,+because no maximum amplitude can be computed.+-}+arrangeVolume ::+   (Ring.C t', OccScalar.C t t',+    RealFrac t, NonNeg.C t,+    Field.C y', OccScalar.C y y',+    Module.C y yv) =>+      y'  {-^ Output volume. -}+   -> t'  {-^ Unit of the time values in the time ordered list. -}+   -> Proc.T t t'+        (EventList.T t (SigR.T y y' yv)+             {-  A list of pairs: (relative start time, signal part),+                 The start time is relative+                 to the start time of the previous event. -}+         -> SigR.T y y' yv+             {-  The mixed signal. -} )+arrangeVolume amp = SigR.lift . CutC.arrangeVolume amp
+ src/Synthesizer/Inference/Reader/Filter.hs view
@@ -0,0 +1,340 @@+{-# OPTIONS -fno-implicit-prelude -fglasgow-exts #-}+{- |+Copyright   :  (c) Henning Thielemann 2007+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes+-}+module Synthesizer.Inference.Reader.Filter (+   {- * Non-recursive -}++   {- ** Amplification -}+   amplify,+   negate,+   envelope,+   {- ** Filter operators from calculus -}+   differentiate,++{-+   {- ** Smooth -}+   mean,++   {- ** Delay -}+   delay,+   phaseModulation,+   phaser,+   phaserStereo,+++   {- * Recursive -}++   {- ** Without resonance -}+   firstOrderLowpass,+   firstOrderHighpass,+   butterworthLowpass,+   butterworthHighpass,+   chebyshevALowpass,+   chebyshevAHighpass,+   chebyshevBLowpass,+   chebyshevBHighpass,+   {- ** With resonance -}+   universal,+   moogLowpass,+   {- ** Allpass -}+   allpassCascade,+-}+   {- ** Reverb -}+   comb,++   {- ** Filter operators from calculus -}+   integrate,+) where+++import qualified Synthesizer.SampleRateContext.Filter as FiltC++import qualified Synthesizer.Inference.Reader.Signal as SigR+import qualified Synthesizer.Inference.Reader.Process as Proc++{-+import Synthesizer.Inference.Reader.Signal+   (toTimeScalar, toFrequencyScalar)++import qualified Synthesizer.Physical.Signal as SigP+import qualified Synthesizer.Plain.Displacement as Syn+import qualified Synthesizer.Plain.Interpolation as Interpolation+import qualified Synthesizer.Plain.Filter.Delay.Block as Delay+import qualified Synthesizer.Plain.Filter.NonRecursive as Filt+import qualified Synthesizer.Inference.Monad.Signal.Displacement as SynI+import qualified Synthesizer.Inference.Monad.Signal.Cut         as CutI+-}++import qualified Algebra.OccasionallyScalar as OccScalar+-- 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 Algebra.Module         as Module+-- import qualified Algebra.VectorSpace    as VectorSpace++{-+import Synthesizer.Utility(clip)++import Control.Monad(liftM2)++import NumericPrelude hiding (negate)+import PreludeBase as P+-}+++{- | The amplification factor must be positive. -}+amplify :: (Field.C y') =>+      y'+   -> Proc.T t t'+        (SigR.T y y' yv+      -> SigR.T y y' yv)+amplify volume = SigR.lift (FiltC.amplify volume)++negate :: (Additive.C yv) =>+   Proc.T t t'+       (SigR.T y y' yv+     -> SigR.T y y' yv)+negate = SigR.lift FiltC.negate+++envelope :: (Module.C y yv, Field.C y') =>+   Proc.T t t' (+      SigR.T y y' y   {-  the envelope -}+   -> SigR.T y y' yv  {-  the signal to be enveloped -}+   -> SigR.T y y' yv)+envelope = SigR.lift FiltC.envelope+++differentiate :: (Additive.C v, Field.C q') =>+   Proc.T q q' (+        SigR.T q q' v+     -> SigR.T q q' v)+differentiate = SigR.lift FiltC.differentiate+++{-+{- | needs a good handling of boundaries, yet -}+mean :: (Additive.C yv, Field.C y', RealField.C a,+         Module.C a v, OccScalar.C a q) =>+      q            {- ^ time length of the window -}+   -> SigR.T y y' yv+   -> Proc.T t t' (SigR.T y y' yv)+mean time x =+   do t <- toTimeScalar x (Expr.constant time)+      let tInt  = round ((t-1)/2)+      let width = tInt*2+1+      returnModified []+         ((SigP.asTypeOfAmplitude (recip (fromIntegral width)) x *> ) .+          Filt.sums width . FiltNR.delay tInt) x+++delay :: (Additive.C yv, Field.C y', RealField.C a, OccScalar.C a q) =>+      q+   -> SigR.T y y' yv+   -> Proc.T t t' (SigR.T y y' yv)+delay time x =+   do t <- toTimeScalar x (Expr.constant time)+      returnModified [] (FiltNR.delay (round t)) x+++phaseModulation ::+         (Additive.C yv, Field.C y', RealField.C a, OccScalar.C a q) =>+      Interpolation.T a v+   -> q   {- ^ minDelay, minimal delay, may be negative -}+   -> q   {- ^ maxDelay, maximal delay, it must be @minDelay <= maxDelay@+               and the modulation must always be+               in the range [minDelay,maxDelay]. -}+   -> SigI.T a q a+          {- ^ delay control, positive numbers mean delay,+               negative numbers mean prefetch -}+   -> SigR.T y y' yv+   -> Proc.T t t' (SigR.T y y' yv)+phaseModulation ip minDelay maxDelay delays x =+   do t0 <- toTimeScalar x (Expr.constant minDelay)+      t1 <- toTimeScalar x (Expr.constant maxDelay)+      let tInt0 = floor   t0+      let tInt1 = ceiling t1+      let tInt0Neg = Additive.negate tInt0+      ds <- SigI.scalarSamples (toTimeScalar delays) delays+      returnModified [SigP.sampleRate delays]+         (FiltNR.delay tInt0 .+             Delay.modulated ip (tInt1-tInt0+1)+               (FiltNR.delay tInt0Neg+                  (Syn.raise (fromIntegral tInt0Neg)+                     (map (clip t0 t1) ds)))) x+++{- | symmetric phaser -}+phaser :: (Additive.C yv, Field.C y', RealField.C a,+           Module.C a v, OccScalar.C a q) =>+      Interpolation.T a v+   -> q   {- ^ maxDelay, must be positive -}+   -> SigI.T a q a+          {- ^ delay control -}+   -> SigR.T y y' yv+   -> Proc.T t t' (SigR.T y y' yv)+phaser ip maxDelay delays x =+   amplify (asTypeOf 0.5 maxDelay) =<<+      uncurry SynI.mix =<< phaserCore ip maxDelay delays x++phaserStereo :: (Additive.C yv, Field.C y', Real.C q, RealField.C a,+                 Module.C a v, OccScalar.C a q) =>+      Interpolation.T a v+   -> q   {- ^ maxDelay, must be positive -}+   -> SigI.T a q a+          {- ^ delay control -}+   -> SigR.T y y' yv+   -> SigI.Process a q (v,v)+phaserStereo ip maxDelay delays x =+   uncurry CutI.zip =<< phaserCore ip maxDelay delays x++phaserCore :: (Additive.C yv, Field.C y', RealField.C a,+               Module.C a v, OccScalar.C a q) =>+      Interpolation.T a v+   -> q   {- ^ maxDelay, must be positive -}+   -> SigI.T a q a+          {- ^ delay control -}+   -> SigR.T y y' yv+   -> Process.T q (SigR.T y y' yv, SigR.T y y' yv)+phaserCore ip maxDelay delays x =+   do let minDelay = Additive.negate maxDelay+      negDelays <- Inference.Signal.Filter.negate delays+      liftM2 (,)+         (phaseModulation ip minDelay maxDelay delays x)+         (phaseModulation ip minDelay maxDelay negDelays x)++++firstOrderLowpass, firstOrderHighpass ::+   (Trans.C a, Trans.C q, Module.C a v, OccScalar.C a q) =>+      SigI.T a q a {- ^ Control signal for the cut-off frequency. -}+   -> SigR.T y y' yv {- ^ Input signal -}+   -> Proc.T t t' (SigR.T y y' yv)+firstOrderLowpass  = firstOrderGen Syn.lowpass1stOrder+firstOrderHighpass = firstOrderGen Syn.highpass1stOrder++firstOrderGen :: (Trans.C a, Trans.C q, Module.C a v, OccScalar.C a q) =>+      ([a] -> [v] -> [v])+   -> SigI.T a q a+   -> SigR.T y y' yv+   -> Proc.T t t' (SigR.T y y' yv)+firstOrderGen filt freq x =+   do freqs <- SigI.scalarSamples (toFrequencyScalar x) freq+      returnModified [SigP.sampleRate freq]+         (filt (map Syn.lowpass1stOrderParam freqs)) x+++butterworthLowpass, butterworthHighpass,+   chebyshevALowpass, chebyshevAHighpass,+   chebyshevBLowpass, chebyshevBHighpass ::+      (Field.C y', Trans.C a, VectorSpace.C a v, OccScalar.C a q) =>+      Int          {- ^ Order of the filter, must be even,+                        the higher the order, the sharper is the separation of frequencies. -}+   -> a            {- ^ The attenuation at the cut-off frequency.+                        Should be between 0 and 1. -}+   -> SigI.T a q a {- ^ Control signal for the cut-off frequency. -}+   -> SigR.T y y' yv {- ^ Input signal -}+   -> Proc.T t t' (SigR.T y y' yv)++butterworthLowpass  = higherOrderNoResoGen Syn.butterworthLowpass+butterworthHighpass = higherOrderNoResoGen Syn.butterworthHighpass+chebyshevALowpass   = higherOrderNoResoGen Syn.chebyshevALowpass+chebyshevAHighpass  = higherOrderNoResoGen Syn.chebyshevAHighpass+chebyshevBLowpass   = higherOrderNoResoGen Syn.chebyshevBLowpass+chebyshevBHighpass  = higherOrderNoResoGen Syn.chebyshevBHighpass++higherOrderNoResoGen ::+   (Field.C y', Ring.C a, OccScalar.C a q) =>+      (Int -> a -> [a] -> [v] -> [v])+   -> Int+   -> a+   -> SigI.T a q a+   -> SigR.T y y' yv+   -> Proc.T t t' (SigR.T y y' yv)+higherOrderNoResoGen filt order ratio freq x =+   do freqs <- SigI.scalarSamples (toFrequencyScalar x) freq+      returnModified [SigP.sampleRate freq]+         (filt order ratio freqs) x++++universal :: (Trans.C a, Module.C a v, Field.C y', OccScalar.C a q) =>+      SigI.T a q a {- ^ signal for resonance,+                        i.e. factor of amplification at the resonance frequency+                        relatively to the transition band. -}+   -> SigI.T a q a {- ^ signal for cut off and band center frequency -}+   -> SigR.T y y' yv {- ^ input signal -}+   -> SigI.Process a q (v,v,v) {- ^ highpass, bandpass, lowpass filter -}+universal reso freq x =+   do resos <- SigI.scalarSamples (Process.exprToScalar) reso+      freqs <- SigI.scalarSamples (toFrequencyScalar x) freq+      let params =+             map UniFilter.parameter+                 (zipWith Syn.Pole resos freqs)+      returnModified [SigP.sampleRate reso, SigP.sampleRate freq]+         (UniFilter.run params) x++moogLowpass :: (Trans.C a, Module.C a v, Field.C y', OccScalar.C a q) =>+      Int+   -> SigI.T a q a {- ^ signal for resonance,+                        i.e. factor of amplification at the resonance frequency+                        relatively to the transition band. -}+   -> SigI.T a q a {- ^ signal for cut off and band center frequency -}+   -> SigR.T y y' yv+   -> Proc.T t t' (SigR.T y y' yv)+moogLowpass order reso freq x =+   do resos <- SigI.scalarSamples (Process.exprToScalar) reso+      freqs <- SigI.scalarSamples (toFrequencyScalar x) freq+      let params =+             map (Moog.parameter order)+                 (zipWith Syn.Pole resos freqs)+      returnModified [SigP.sampleRate reso, SigP.sampleRate freq]+         (Moog.lowpass order params) x++allpassCascade :: (Trans.C a, Module.C a v, Field.C y', OccScalar.C a q) =>+      Int          {- ^ order, number of filters in the cascade -}+   -> a            {- ^ the phase shift to be achieved for the given frequency -}+   -> SigI.T a q a {- ^ lowest comb frequency -}+   -> SigR.T y y' yv+   -> Proc.T t t' (SigR.T y y' yv)+allpassCascade order phase freq x =+   do freqs <- SigI.scalarSamples (toFrequencyScalar x) freq+      let params = map (Syn.allpassCascadeParam order phase) freqs+      returnModified [SigP.sampleRate freq]+         (Syn.allpassCascade order params) x+-}++++{- | Infinitely many equi-delayed exponentially decaying echos. -}+comb :: (RealField.C t, Ring.C t', OccScalar.C t t', Module.C y yv) =>+   t' -> y -> Proc.T t t' (SigR.T y y' yv -> SigR.T y y' yv)+comb time gain = SigR.lift (FiltC.comb time gain)+++integrate :: (Additive.C v, Field.C q') =>+   Proc.T q q'+       (SigR.T q q' v+     -> SigR.T q q' v)+integrate = SigR.lift FiltC.integrate+++{-+returnModified :: (Eq q) =>+   [Process.Value q] -> ([v] -> [w]) -> SigR.T y y' yv -> SigI.Process a q w+returnModified sampleRates proc x =+   do let sampleRate = SigP.sampleRate x+      mapM_ (Process.equalValue sampleRate) sampleRates+      SigI.returnCons+         sampleRate (SigP.amplitude x)+         (proc (SigP.samples x))+-}
+ src/Synthesizer/Inference/Reader/Noise.hs view
@@ -0,0 +1,62 @@+{-# OPTIONS -fno-implicit-prelude -fglasgow-exts #-}+{- |+Copyright   :  (c) Henning Thielemann 2006+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++-}+module Synthesizer.Inference.Reader.Noise+  (white,+   whiteGen,+   randomPeeks) where+++import qualified Synthesizer.SampleRateContext.Noise as NoiseC++import qualified Synthesizer.Inference.Reader.Signal as SigR+import qualified Synthesizer.Inference.Reader.Process as Proc++import qualified Algebra.OccasionallyScalar as OccScalar+import qualified Algebra.Algebraic          as Algebraic+import qualified Algebra.Field              as Field+import qualified Algebra.Ring               as Ring++import System.Random (Random, RandomGen)++-- import NumericPrelude+import PreludeBase as P++++white :: (Ring.C yv, Random yv, Algebraic.C q') =>+      q'  {-^ width of the frequency band -}+   -> q'  {-^ volume caused by the given frequency band -}+   -> Proc.T t q' (SigR.T y q' yv)+          {-^ noise -}+white bandWidth volume = SigR.lift $ NoiseC.white bandWidth volume++whiteGen :: (Ring.C yv, Random yv, RandomGen g, Algebraic.C q') =>+      g   {-^ random generator, can be used to choose a seed -}+   -> q'  {-^ width of the frequency band -}+   -> q'  {-^ volume caused by the given frequency band -}+   -> Proc.T t q' (SigR.T y q' yv)+          {-^ noise -}+whiteGen gen bandWidth volume = SigR.lift (NoiseC.whiteGen gen bandWidth volume)++{-+The Field.C q constraint could be lifted to Ring.C+if we would use direct division instead of toFrequencyScalar.+-}+randomPeeks ::+   (Field.C q, Random q, Ord q,+    Field.C q', OccScalar.C q q') =>+   Proc.T q q'+      (   SigR.T q q' q  {-   momentary densities (frequency),+                              @p@ means that there is about one peak+                              in the time range of @1\/p@. -}+       -> [Bool])+                         {-   Every occurence of 'True' represents a peak. -}+randomPeeks = SigR.lift NoiseC.randomPeeks
+ src/Synthesizer/Inference/Reader/Oscillator.hs view
@@ -0,0 +1,79 @@+{-# OPTIONS -fno-implicit-prelude -fglasgow-exts #-}+{- |+Copyright   :  (c) Henning Thielemann 2006, 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++-}+module Synthesizer.Inference.Reader.Oscillator (+   {- * Oscillators with constant waveforms -}+   static,+   freqMod,+   phaseMod,+   phaseFreqMod,+) where++import qualified Synthesizer.SampleRateContext.Oscillator as OsciC++-- import qualified Synthesizer.Plain.Oscillator as Osci+import qualified Synthesizer.Basic.Wave       as Wave++import qualified Synthesizer.Inference.Reader.Signal as SigR+import qualified Synthesizer.Inference.Reader.Process as Proc++import qualified Algebra.OccasionallyScalar as OccScalar+import qualified Algebra.RealField          as RealField+import qualified Algebra.Field              as Field++-- import NumericPrelude+-- import PreludeBase as P+++{- * Oscillators with constant waveforms -}++{- | oscillator with a functional waveform with constant frequency -}+static :: (RealField.C t, Field.C t', OccScalar.C t t') =>+      Wave.T t yv  {- ^ waveform -}+   -> y'           {- ^ amplitude -}+   -> t            {- ^ start phase from the range [0,1] -}+   -> t'           {- ^ frequency -}+   -> Proc.T t t' (SigR.T y y' yv)+static wave amplitude phase freq =+   SigR.lift (OsciC.static wave amplitude phase freq)++{- | oscillator with a functional waveform with modulated frequency -}+freqMod :: (RealField.C t, Field.C t', OccScalar.C t t') =>+      Wave.T t yv  {- ^ waveform -}+   -> y'           {- ^ amplitude -}+   -> t            {- ^ start phase from the range [0,1] -}+   -> Proc.T t t' (+          SigR.T t t' t  {-   frequency control -}+       -> SigR.T y y' yv)+freqMod wave amplitude phase =+   SigR.lift (OsciC.freqMod wave amplitude phase)++{- | oscillator with modulated phase -}+phaseMod :: (RealField.C t, Field.C t', OccScalar.C t t') =>+      Wave.T t yv  {- ^ waveform -}+   -> y'           {- ^ amplitude -}+   -> t'           {- ^ frequency control -}+   -> Proc.T t t' (+          SigR.T t t  t  {-   phase modulation, phases must have no unit and+                              are from range [0,1] -}+       -> SigR.T y y' yv)+phaseMod wave amplitude freq =+   SigR.lift (OsciC.phaseMod wave amplitude freq)++{- | oscillator with a functional waveform with modulated phase and frequency -}+phaseFreqMod :: (RealField.C t, Field.C t', OccScalar.C t t') =>+      Wave.T t yv  {- ^ waveform -}+   -> y'           {- ^ amplitude -}+   -> Proc.T t t' (+          SigR.T t t  t  {-   phase control -}+       -> SigR.T t t' t  {-   frequency control -}+       -> SigR.T y y' yv)+phaseFreqMod wave amplitude =+   SigR.lift (OsciC.phaseFreqMod wave amplitude)
+ src/Synthesizer/Inference/Reader/Play.hs view
@@ -0,0 +1,21 @@+module Synthesizer.Inference.Reader.Play where++import qualified BinarySample as BinSmp++import qualified Synthesizer.Inference.Reader.Signal  as SigR+import qualified Synthesizer.Inference.Reader.Process as ProcR+import qualified Synthesizer.Physical.Play           as PlayP++import qualified Algebra.OccasionallyScalar as OccScalar+import qualified Algebra.VectorSpace        as VectorSpace+import qualified Algebra.RealField          as RealField+import qualified Algebra.Field              as Field+++auto :: (RealField.C t, BinSmp.C yv,+         Field.C t', OccScalar.C t t',+         Field.C y', OccScalar.C y y',+         VectorSpace.C y yv) =>+   t' -> y' -> t' -> ProcR.T t t' (SigR.T y y' yv) -> IO ()+auto freqUnit amp sampleRate proc =+   PlayP.auto freqUnit amp (SigR.run sampleRate proc)
+ src/Synthesizer/Inference/Reader/Process.hs view
@@ -0,0 +1,110 @@+{- |++Copyright   :  (c) Henning Thielemann 2007+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes (OccasionallyScalar)++++Light-weight sample parameter inference which will fit most needs.+We only do \"poor man's inference\", only for sample rates.+The sample rate will be provided in a Reader monad.+We almost do not need monad functionality+but only "Control.Applicative" functionality.++In contrast to the run-time inference approach,+we have the static guarantee that the sample rate is fixed+before passing a signal to the outside world.+-}+module Synthesizer.Inference.Reader.Process (+      T(..),+      run, share,+      injectParam, extractParam, convertTimeParam,+      loop, pure,+      ($:), ($::), ($^), ($#),+      (.:), (.^),+      liftP, liftP2, liftP3, liftP4,+   ) where++import Control.Monad.Fix (MonadFix(mfix), )+import Synthesizer.ApplicativeUtility+import qualified Control.Applicative as App+import Control.Applicative (Applicative)++{-+import NumericPrelude+import PreludeBase as P+-}+++{- |+This wraps a function which computes a sample rate dependent result.+Sample rate tells how many values per unit are stored+for representation of a signal.+-}+newtype T t t' a = Cons {process :: t' -> a}+++instance Functor (T t t') where+   fmap f x = Cons (f . process x)++instance Applicative (T t t') where+   pure  = pure+   (<*>) = apply++instance Monad (T t t') where+   return = pure+   (>>=)  = share++instance MonadFix (T t t') where+   mfix = loop . injectParam++++run ::+   t' -> T t t' a -> (t', a)+run sr (Cons p) = (sr, p sr)+++{- |+Re-use a result several times without recomputing.+With a simple @let@ you can re-use a result+but it must be recomputed due to the dependency on the sample rate.+-}+share ::+      T t t' a        {-^ process that provides a result -}+   -> (a -> T t t' b) {-^ function that can re-use that result as much as it wants -}+   -> T t t' b+share p f = Cons $ \sr ->+   process (f (process p sr)) sr++++{- |+This corresponds to 'Control.Applicative.pure'+-}+pure :: a -> T t t' a+pure x = Cons $ const x++apply :: T t t' (a -> b) -> T t t' a -> T t t' b+apply f proc = Cons $ \sr ->+   process f sr (process proc sr)++extractParam :: T t t' (a -> b) -> (a -> T t t' b)+extractParam = ($#)++injectParam :: (a -> T t t' b) -> T t t' (a -> b)+injectParam f = Cons $ \sr x ->+   process (f x) sr++{- |+The first argument will be a function like 'InferenceReader.Signal.toTimeScalar'.+If you use this function instead of 'InferenceReader.Signal.toTimeScalar' directly,+the type @t@ can be automatically infered.+-}+convertTimeParam :: (t' -> t' -> t) -> t' -> (t -> a) -> T t t' a+convertTimeParam convert t' f = Cons $ \sr ->+   f (convert sr t')
+ src/Synthesizer/Inference/Reader/Signal.hs view
@@ -0,0 +1,136 @@+{-# OPTIONS -fno-implicit-prelude -fglasgow-exts #-}+{- |++Copyright   :  (c) Henning Thielemann 2007+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes (OccasionallyScalar)+-}+module Synthesizer.Inference.Reader.Signal (+    T(..),+    run,+    addSampleRate,+    apply,+    lift,+    returnCons,++    toTimeScalar,+    toFrequencyScalar,+    toAmplitudeScalar,+    toGradientScalar,++    scalarSamples,+    vectorSamples,++    ($-),+    constant,+   ) where++import Synthesizer.Inference.Reader.Process (($:))+import qualified Synthesizer.Inference.Reader.Process as Proc++import qualified Synthesizer.SampleRateContext.Rate   as Rate+import qualified Synthesizer.SampleRateContext.Signal as SigC+import qualified Synthesizer.Physical.Signal as SigP++import Synthesizer.SampleRateContext.Signal (T(Cons, samples, amplitude))++import qualified Algebra.OccasionallyScalar as OccScalar+import qualified Algebra.Module         as Module+import qualified Algebra.Field          as Field+import qualified Algebra.Ring           as Ring++import Algebra.OccasionallyScalar (toScalar)++import NumericPrelude+import PreludeBase as P++++run ::+   t' -> Proc.T t t' (T y y' yv) -> SigP.T t t' y y' yv+run sr proc =+   uncurry addSampleRate (Proc.run sr proc)++{-+run ::+   Rate.T t t' -> Proc.T t t' (T y y' yv) -> SigP.T t t' y y' yv+run sr proc =+   uncurry addSampleRate (Proc.run (Rate.toNumber sr) proc)+-}++addSampleRate ::+   t' -> T y y' yv -> SigP.T t t' y y' yv+addSampleRate = SigP.addPlainSampleRate++apply ::+   (Proc.T t t' (T y0 y0' y0v -> T y1 y1' y1v))+    -> SigP.T t t' y0 y0' y0v+    -> SigP.T t t' y1 y1' y1v+apply proc (SigP.Cons sr sig) =+   let (sr', f) = Proc.run (Rate.toNumber sr) proc+   in  addSampleRate sr' (f sig)+++lift :: (Rate.T t t' -> a) -> Proc.T t t' a+lift f = Proc.Cons $ f . Rate.fromNumber+++returnCons ::+   y' -> [yv] -> Proc.T t t' (T y y' yv)+returnCons amp sig = Proc.pure (Cons amp sig)++{-+sampleRateExpr :: SigP.T t (Value t') y (Value y') yv -> Expr t'+sampleRateExpr x = Expr.fromValue (SigP.sampleRate x)++amplitudeExpr :: SigP.T t (Value t') y (Value y') yv -> Expr y'+amplitudeExpr x = Expr.fromValue (SigP.amplitude x)+-}++toTimeScalar :: (Ring.C t', OccScalar.C t t') =>+   t' -> t' -> t+toTimeScalar sampleRate t = toScalar (t * sampleRate)++toFrequencyScalar :: (Field.C t', OccScalar.C t t') =>+   t' -> t' -> t+toFrequencyScalar sampleRate f = toScalar (f / sampleRate)++toAmplitudeScalar :: (Field.C y', OccScalar.C y y') =>+   T y y' yv -> y' -> y+toAmplitudeScalar sig y =+   toScalar (y / amplitude sig)++toGradientScalar :: (Field.C q', OccScalar.C q q') =>+   q' -> q' -> q' -> q+toGradientScalar amp sampleRate steepness =+   toFrequencyScalar sampleRate (steepness / amp)+++scalarSamples :: (Ring.C y) =>+   (y' -> y) -> T y y' y -> [y]+scalarSamples toAmpScalar sig =+   let y = toAmpScalar (amplitude sig)+   in  map (y*) (samples sig)++vectorSamples :: (Module.C y yv) =>+   (y' -> y) -> T y y' yv -> [yv]+vectorSamples toAmpScalar sig =+   let y = toAmpScalar (amplitude sig)+   in  y *> samples sig+++{- |+Take a scalar argument where a process expects a signal.+-}+($-) :: Ring.C yv =>+    Proc.T t t' (T y y' yv -> a) -> y' -> Proc.T t t' a+($-) f x = f $: Proc.pure (constant x)++{-+Should be in Control module.+-}+constant :: Ring.C yv => y' -> T y y' yv+constant x = Cons x (repeat 1)
+ src/Synthesizer/Physical.hs view
@@ -0,0 +1,25 @@+{- |++Copyright   :  (c) Henning Thielemann 2006+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++++This module is for documentation purposes.+But the modules below are exported+in order to let you easily navigate to them.+-}+++module Synthesizer.Physical+   (module Synthesizer.Physical.Signal,+    module Synthesizer.Physical.Cut,+    module Synthesizer.Physical.Displacement) where++import Synthesizer.Physical.Signal+import Synthesizer.Physical.Cut+import Synthesizer.Physical.Displacement
+ src/Synthesizer/Physical/Control.hs view
@@ -0,0 +1,72 @@+{-# OPTIONS -fno-implicit-prelude #-}+{-|+Control curve generation+-}++module Synthesizer.Physical.Control where++import qualified Synthesizer.SampleRateContext.Control as CtrlC+import qualified Synthesizer.Plain.Control as Ctrl+import qualified Synthesizer.Physical.Signal as SigP+import Synthesizer.Physical.Signal(toTimeScalar)++import qualified Algebra.OccasionallyScalar as OccScalar+import qualified Algebra.Module         as Module+import qualified Algebra.Transcendental as Trans+import qualified Algebra.Real           as Real+import qualified Algebra.Ring           as Ring++-- import PreludeBase+-- import NumericPrelude+++exponential :: (Trans.C a, Ring.C a', Real.C a', OccScalar.C a a') =>+      a' {-^ sample rate -}+   -> a' {-^ time where the function reaches 1\/e of the initial value -}+   -> a' {-^ initial value -}+   -> SigP.T a a' a a' a+         {-^ exponential decay -}+exponential sampleRate time y0 =+   SigP.lift0 (CtrlC.exponential time y0) sampleRate+++exponential2 :: (Trans.C a, Ring.C a', Real.C a', OccScalar.C a a') =>+      a' {-^ sample rate -}+   -> a' {-^ half life -}+   -> a' {-^ initial value -}+   -> SigP.T a a' a a' a+         {-^ exponential decay -}+exponential2 sampleRate halfLife y0 =+   SigP.lift0 (CtrlC.exponential2 halfLife y0) sampleRate+++vectorExponential ::+   (Trans.C t, Ring.C t',+    OccScalar.C t t', Module.C t yv) =>+      t' {-^ sample rate -}+   -> t' {-^ time where the function reaches 1\/e of the initial value -}+   -> y' {-^ amplitude unit -}+   -> yv {-^ initial value -}+   -> SigP.T t t' y y' yv+         {-^ exponential decay -}+vectorExponential sampleRate time amplitude y0 =+   let z = SigP.cons sampleRate amplitude+              (Ctrl.vectorExponential+                 (toTimeScalar z time) y0)+   in  z+++vectorExponential2 ::+   (Trans.C t, Ring.C t',+    OccScalar.C t t', Module.C t yv) =>+      t' {-^ sample rate -}+   -> t' {-^ half life -}+   -> y' {-^ amplitude unit -}+   -> yv {-^ initial value -}+   -> SigP.T t t' y y' yv+         {-^ exponential decay -}+vectorExponential2 sampleRate halfLife amplitude y0 =+   let z = SigP.cons sampleRate amplitude+              (Ctrl.vectorExponential2+                 (toTimeScalar z halfLife) y0)+   in  z
+ src/Synthesizer/Physical/Cut.hs view
@@ -0,0 +1,224 @@+{- |+Copyright   :  (c) Henning Thielemann 2006, 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++Cut signals++-}+module Synthesizer.Physical.Cut where++import qualified Synthesizer.SampleRateContext.Cut as CutC+import qualified Synthesizer.SampleRateContext.Signal as SigC+import qualified Synthesizer.SampleRateContext.Rate   as Rate++import qualified Synthesizer.Physical.Signal as SigP++import qualified Data.EventList.Relative.TimeBody as EventList+import qualified Numeric.NonNegative.Class as NonNeg++import qualified Algebra.NormedSpace.Maximum as NormedMax+import qualified Algebra.OccasionallyScalar as OccScalar+import qualified Algebra.Module             as Module+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 Data.List as List++import Synthesizer.Utility (mapSnd)++import PreludeBase (Eq, Ord, Bool, uncurry, (.), (==), flip, fst, error)+-- import NumericPrelude++import Prelude (RealFrac)+++{- * Dissection -}++splitAt :: (RealField.C t, Ring.C t', OccScalar.C t t') =>+   t' -> SigP.T t t' y y' yv -> (SigP.T t t' y y' yv, SigP.T t t' y y' yv)+splitAt t = SigP.liftR2 (CutC.splitAt t)++take :: (RealField.C t, Ring.C t', OccScalar.C t t') =>+   t' -> SigP.T t t' y y' yv -> SigP.T t t' y y' yv+take t = SigP.lift1 (CutC.take t)++drop :: (RealField.C t, Ring.C t', OccScalar.C t t') =>+   t' -> SigP.T t t' y y' yv -> SigP.T t t' y y' yv+drop t = SigP.lift1 (CutC.drop t)+++propSplit :: (Eq t', Eq y', Eq yv,+              OccScalar.C t t', Ring.C t', RealField.C t) =>+   t' -> SigP.T t t' y y' yv -> Bool+propSplit t x =  splitAt t x == (take t x, drop t x)+++takeUntilPause :: (RealField.C t, Ring.C t', OccScalar.C t t',+                   Field.C y', NormedMax.C y yv, OccScalar.C y y') =>+   y' -> t' -> SigP.T t t' y y' yv -> SigP.T t t' y y' yv+takeUntilPause y' t' =+   SigP.lift1 (CutC.takeUntilPause y' t')+++unzip ::+   SigP.T t t' y y' (yv0, yv1) -> (SigP.T t t' y y' yv0, SigP.T t t' y y' yv1)+unzip = SigP.liftR2 CutC.unzip++unzip3 ::+      SigP.T t t' y y' (yv0, yv1, yv2)+   -> (SigP.T t t' y y' yv0, SigP.T t t' y y' yv1, SigP.T t t' y y' yv2)+unzip3 = SigP.liftR3 CutC.unzip3+++{- * Glueing -}+++{- |+  Similar to @foldr1 append@ but more efficient and accurate,+  because it reduces the number of amplifications.+  Does not work for infinite lists,+  because in this case a maximum amplitude cannot be computed.+-}+concat :: (Real.C y', Field.C y', Eq t', OccScalar.C y y',+           Module.C y yv) =>+      [SigP.T t t' y y' yv]+   ->  SigP.T t t' y y' yv+concat = SigP.liftList CutC.concat++{- |+  Like 'concat', but you have to specify the amplitude of the resulting signal.+  This way we can process infinite lists, too.+  The list must contain at least one element for getting a sample rate.+-}+concatVolume :: (Field.C y', Eq t', OccScalar.C y y',+              Module.C y yv) =>+       y'+   -> [SigP.T t t' y y' yv]+   ->  SigP.T t t' y y' yv+concatVolume amp = SigP.liftList (CutC.concatVolume amp)++append :: (Eq t', Real.C y', Field.C y', OccScalar.C y y',+         Module.C y yv) =>+   SigP.T t t' y y' yv -> SigP.T t t' y y' yv -> SigP.T t t' y y' yv+append = SigP.lift2 CutC.append+++propConcatAppend :: (Eq t', Eq y', Eq yv,+                   Module.C y yv, OccScalar.C y y',+                   Ring.C t', RealField.C y') =>+      SigP.T t t' y y' yv+   -> SigP.T t t' y y' yv+   -> Bool+propConcatAppend x y =  append x y == concat [x,y]+++propAppendSplit :: (Eq t', Eq y', Eq yv,+                    Module.C y yv, OccScalar.C y y',+                    RealField.C y', OccScalar.C t t',+                    Ring.C t', RealField.C t) =>+   t' -> SigP.T t t' y y' yv -> Bool+propAppendSplit t x =  uncurry append (splitAt t x) == x+++++zip :: (Eq t', Real.C y', Field.C y', OccScalar.C y y',+        Module.C y yv0, Module.C y yv1)+   => SigP.T t t' y y' yv0+   -> SigP.T t t' y y' yv1+   -> SigP.T t t' y y' (yv0, yv1)+zip = SigP.lift2 CutC.zip+++zip3 :: (Eq t', Real.C y', Field.C y', OccScalar.C y y',+         Module.C y yv0, Module.C y yv1, Module.C y yv2)+   => SigP.T t t' y y' yv0+   -> SigP.T t t' y y' yv1+   -> SigP.T t t' y y' yv2+   -> SigP.T t t' y y' (yv0, yv1, yv2)+zip3 = SigP.lift3 CutC.zip3+++propZip :: (Eq t', Eq y', Field.C y', Real.C y',+            Eq yv0, Eq yv1,+            Module.C y yv1, Module.C y yv0,+            OccScalar.C y y') =>+   SigP.T t t' y y' (yv0, yv1) -> Bool+propZip x =  uncurry zip (unzip x) == x++propZip3 :: (Eq t', Eq y', Field.C y', Real.C y',+             Eq yv0, Eq yv1, Eq yv2,+             Module.C y yv2, Module.C y yv1, Module.C y yv0,+             OccScalar.C y y') =>+   SigP.T t t' y y' (yv0, yv1, yv2) -> Bool+propZip3 x =  (\(a,b,c) -> zip3 a b c) (unzip3 x) == x+++splitSampleRateEventList :: (Eq t') =>+      EventList.T time (SigP.T t t' y y' yv)+   -> (Rate.T t t', EventList.T time (SigC.T y y' yv))+splitSampleRateEventList xs =+   case EventList.getBodies xs of+      [] -> error "splitSampleRateEventList: empty list"+      (x:_) ->+         let sr = fst (SigP.splitSampleRate x)+         in  (sr, EventList.mapBody (SigP.checkSampleRate "splitSampleRateEventList" sr) xs)+++{- |+  Given a list of signals with time stamps,+  mix them into one signal as they occur in time.+  Ideally for composing music.+  The amplitude of the output is designed for the worst case+  (all signals coincide).+  This is usually too pessimistic.+  Maybe you prefer 'arrangeVolume'.++  Infinite schedules are not supported,+  because no maximum amplitude can be computed.+  If you want infinite schedules,+  then 'arrangeVolume' is your friend, again.+-}+arrange ::+   (RealFrac t, NonNeg.C t, Eq t', Ring.C t, Ring.C t', OccScalar.C t t',+    Ord y', Field.C y', OccScalar.C y y',+    Module.C y yv) =>+      t'  {-^ Unit of the time values in the time ordered list. -}+   -> EventList.T t (SigP.T t t' y y' yv)+          {-^ A list of pairs: (relative start time, signal part),+              The start time is relative+              to the start time of the previous event. -}+   -> SigP.T t t' y y' yv+          {-^ The mixed signal. -}+arrange unit =+   uncurry SigP.run .+   mapSnd (flip (CutC.arrange unit)) .+   splitSampleRateEventList+++{- |+  Similar to 'arrange' but allows for infinite schedules.+  To this end it needs the amplitude of the resulting signal.+-}+arrangeVolume ::+   (RealFrac t, NonNeg.C t, Eq t', Ring.C t, Ring.C t', OccScalar.C t t',+    Field.C y', OccScalar.C y y',+    Module.C y yv) =>+      y'  {-^ Amplitude of output. -}+   -> t'  {-^ Unit of the time values in the time ordered list. -}+   -> EventList.T t (SigP.T t t' y y' yv)+          {-^ A list of pairs: (relative start time, signal part),+              The start time is relative+              to the start time of the previous event. -}+   -> SigP.T t t' y y' yv+          {-^ The mixed signal. -}+arrangeVolume amp unit =+   uncurry SigP.run .+   mapSnd (flip (CutC.arrangeVolume amp unit)) .+   splitSampleRateEventList
+ src/Synthesizer/Physical/Displacement.hs view
@@ -0,0 +1,45 @@+module Synthesizer.Physical.Displacement where++import qualified Synthesizer.SampleRateContext.Displacement as MiscC++import qualified Synthesizer.Physical.Signal as SigP++import qualified Algebra.OccasionallyScalar as OccScalar+import qualified Algebra.Module         as Module+-- import qualified Algebra.Transcendental as Trans+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 Algebra.Module ((*>))++import PreludeBase+-- import NumericPrelude+import Prelude ()+++{- * Mixing -}++{-| Mix two signals.+    In opposition to 'zipWith' the result has the length of the longer signal. -}+mix :: (Eq t', Real.C y', Field.C y', Module.C y yv, OccScalar.C y y') =>+      SigP.T t t' y y' yv+   -> SigP.T t t' y y' yv+   -> SigP.T t t' y y' yv+mix = SigP.lift2 MiscC.mix++{-| Mix one or more signals. -}+mixMulti :: (Eq t', Real.C y', Field.C y', Module.C y yv, OccScalar.C y y') =>+      [SigP.T t t' y y' yv]+   ->  SigP.T t t' y y' yv+mixMulti = SigP.liftList MiscC.mixMulti++{-| Add a number to all of the signal values.+    This is useful for adjusting the center of a modulation. -}+raise :: (Eq t', Field.C y', Module.C y yv, OccScalar.C y y') =>+      y'+   -> yv+   -> SigP.T t t' y y' yv+   -> SigP.T t t' y y' yv+raise y' yv = SigP.lift1 (MiscC.raise y' yv)
+ src/Synthesizer/Physical/File.hs view
@@ -0,0 +1,27 @@+{-# OPTIONS -fno-implicit-prelude #-}+module Synthesizer.Physical.File where++import qualified Sox.File+import qualified BinarySample as BinSmp++import qualified Synthesizer.Physical.Signal as SigP++import qualified Algebra.OccasionallyScalar as OccScalar+import qualified Algebra.VectorSpace        as VectorSpace+import qualified Algebra.RealField          as RealField+import qualified Algebra.Field              as Field++import System.Exit(ExitCode)++-- import NumericPrelude+import PreludeBase++++write :: (RealField.C t, BinSmp.C yv,+          Field.C t', OccScalar.C t t',+          Field.C y', OccScalar.C y y',+          VectorSpace.C y yv) =>+   t' -> y' -> FilePath -> SigP.T t t' y y' yv -> IO ExitCode+write freqUnit amp name sig =+   uncurry (Sox.File.write name) (SigP.pureData freqUnit amp sig)
+ src/Synthesizer/Physical/Filter.hs view
@@ -0,0 +1,51 @@+{-# OPTIONS -fno-implicit-prelude #-}+module Synthesizer.Physical.Filter where++import qualified Synthesizer.SampleRateContext.Filter as FiltC+import qualified Synthesizer.Physical.Signal as SigP++import qualified Algebra.OccasionallyScalar as OccScalar+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 PreludeBase+-- import NumericPrelude+++{- * Amplification -}++amplify :: (Ring.C y') =>+      y'+   -> SigP.T t t' y y' yv+   -> SigP.T t t' y y' yv+amplify volume = SigP.lift1 (FiltC.amplify volume)++envelope :: (Eq t', Module.C y0 yv, Ring.C y') =>+      SigP.T t t' y y' y0  {-^ the envelope -}+   -> SigP.T t t' y y' yv  {-^ the signal to be enveloped -}+   -> SigP.T t t' y y' yv+envelope = SigP.lift2 FiltC.envelope++++{- * Filter operators from calculus -}++differentiate :: (Additive.C yv, Ring.C a')+   => SigP.T t a' y a' yv -> SigP.T t a' y a' yv+differentiate = SigP.lift1 FiltC.differentiate++integrate :: (Additive.C yv, Field.C a')+   => SigP.T t a' y a' yv -> SigP.T t a' y a' yv+integrate = SigP.lift1 FiltC.integrate+++{- * Echo -}++{- | Infinitely many equi-delayed exponentially decaying echos. -}+comb :: (RealField.C t, Ring.C t', OccScalar.C t t', Module.C y yv) =>+   t' -> y -> SigP.T t t' y y' yv -> SigP.T t t' y y' yv+comb time gain = SigP.lift1 (FiltC.comb time gain)
+ src/Synthesizer/Physical/Noise.hs view
@@ -0,0 +1,27 @@+{-# OPTIONS -fno-implicit-prelude #-}+module Synthesizer.Physical.Noise where++import qualified Synthesizer.SampleRateContext.Noise as NoiseC+-- import qualified Synthesizer.SampleRateContext.Signal as SigC++import qualified Synthesizer.Physical.Signal as SigP++import System.Random (Random)++import qualified Algebra.Algebraic      as Algebraic+import qualified Algebra.Ring           as Ring++-- import PreludeBase+-- import NumericPrelude+++{- * Noise -}++white :: (Ring.C yv, Random yv, Algebraic.C q') =>+      q' {-^ sample rate -}+   -> q'  {-^ width of the frequency band -}+   -> q'  {-^ volume caused by the given frequency band -}+   -> SigP.T t q' y q' yv+         {-^ noise -}+white sampleRate bandWidth volume =+   SigP.lift0 (NoiseC.white bandWidth volume) sampleRate
+ src/Synthesizer/Physical/Oscillator.hs view
@@ -0,0 +1,66 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+Copyright   :  (c) Henning Thielemann 2006, 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++Tone generators++-}+module Synthesizer.Physical.Oscillator where++import qualified Synthesizer.SampleRateContext.Oscillator as OsciC+-- import qualified Synthesizer.Plain.Oscillator as Osci+import qualified Synthesizer.Basic.Wave       as Wave+import qualified Synthesizer.Physical.Signal as SigP++import qualified Algebra.OccasionallyScalar as OccScalar+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 PreludeBase+-- import NumericPrelude++++{- * Oscillators with constant waveforms -}++{- | oscillator with a functional waveform with constant frequency -}+static :: (RealField.C t, Field.C t', OccScalar.C t t')+   => Wave.T t yv+   -> (t' -> y' -> t -> t' -> SigP.T t t' y y' yv)+static wave sampleRate amplitude phase freq =+   SigP.lift0 (OsciC.static wave amplitude phase freq) sampleRate++{- | oscillator with a functional waveform with modulated frequency -}+freqMod :: (RealField.C t, Field.C t', OccScalar.C t t')+   => Wave.T t yv+   -> (y' -> t -> SigP.T t t' t t' t -> SigP.T t t' y y' yv)+freqMod wave amplitude phase =+   SigP.lift1 (OsciC.freqMod wave amplitude phase)++{- | sine oscillator with static frequency -}+staticSine :: (RealField.C a, Trans.C a, Field.C t', OccScalar.C a t')+   => t' -> y' -> a -> t' -> SigP.T a t' a y' a+staticSine = static Wave.sine++{- | sine oscillator with modulated frequency -}+freqModSine :: (RealField.C a, Trans.C a, Module.C a a, Field.C t', OccScalar.C a t')+   => y' -> a -> SigP.T a t' a t' a -> SigP.T a t' a y' a+freqModSine = freqMod Wave.sine++{- | saw tooth oscillator with modulated frequency -}+staticSaw :: (RealField.C a, Field.C t', OccScalar.C a t')+   => t' -> y' -> a -> t' -> SigP.T a t' a y' a+staticSaw = static Wave.saw++{- | saw tooth oscillator with modulated frequency -}+freqModSaw :: (RealField.C a, Field.C t', Module.C a a, OccScalar.C a t')+   => y' -> a -> SigP.T a t' a t' a -> SigP.T a t' a y' a+freqModSaw = freqMod Wave.saw
+ src/Synthesizer/Physical/Play.hs view
@@ -0,0 +1,25 @@+{-# OPTIONS -fno-implicit-prelude #-}+module Synthesizer.Physical.Play where++import qualified Sox.Play+import qualified BinarySample as BinSmp++import qualified Synthesizer.Physical.Signal as SigP++import qualified Algebra.OccasionallyScalar as OccScalar+import qualified Algebra.VectorSpace        as VectorSpace+import qualified Algebra.RealField          as RealField+import qualified Algebra.Field              as Field++-- import NumericPrelude+import PreludeBase++++auto :: (RealField.C t, BinSmp.C yv,+         Field.C t', OccScalar.C t t',+         Field.C y', OccScalar.C y y',+         VectorSpace.C y yv) =>+   t' -> y' -> SigP.T t t' y y' yv -> IO ()+auto freqUnit amp sig =+   uncurry Sox.Play.auto (SigP.pureData freqUnit amp sig)
+ src/Synthesizer/Physical/Signal.hs view
@@ -0,0 +1,336 @@+{-# OPTIONS -fno-implicit-prelude #-}+{-|+Copyright   :  (c) Henning Thielemann 2006, 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++  This module equips a list of values+  with a sampling rate and an amplitude.+  Since sampling rate and amplitude need not to be of the same type+  and need not to be of the type of the values+  one can choose physical quantities for sampling rate and amplitude+  but low level types like Double and Float for the values.+  The only thing we need is the conversion to scalar types+  provided by the 'Algebra.OccasionallyScalar.C' type class.+  This conversion may fail in which case we encountered a unit error.+  We can also use this module with plain number types.+  Then toScalar cannot fail.++  The conversion to scalars is very general+  and might support applications I can currently not imagine.+-}++module Synthesizer.Physical.Signal where++import qualified Synthesizer.SampleRateContext.Signal as SigC+import qualified Synthesizer.SampleRateContext.Rate   as Rate++import qualified Algebra.OccasionallyScalar as OccScalar+import qualified Algebra.VectorSpace as VectorSpace+import qualified Algebra.Module      as Module+import qualified Algebra.Field       as Field+import qualified Algebra.Ring        as Ring++import Algebra.OccasionallyScalar(toScalar)+import Algebra.Module((*>))++import Synthesizer.Utility (mapSnd, common, )++import PreludeBase+import NumericPrelude++{-| t and y are plain number types,+    t' and y' may be physical quantities.+    yv may be a vector type.+    It should hold:+      @(OccScalar.C t t',+        OccScalar.C y y',+        Module.C y yv)@+    There are no values of type t and type y in T+    but they are essential to computation of intermediate results.+-}+data T t t' y y' yv =+   Cons {+        fullSampleRate :: Rate.T t t'+           {-^ how many values per unit are stored -}+      , content :: SigC.T y y' yv+           {-^ the signal with a unit-equipped volume -}+     }+   deriving (Eq, Show)++{- | Construct a signal. -}+cons ::+      t'    {- ^ sampling rate, must be positive (unchecked) -}+   -> y'    {- ^ amplitude, must be positive (unchecked) -}+   -> [yv]  {- ^ samples, values should be between -1 and 1 (unchecked) -}+   -> T t t' y y' yv+cons sr amp ss =+   Cons (Rate.fromNumber sr) (SigC.Cons amp ss)++sampleRate :: T t t' y y' yv -> t'+sampleRate = Rate.toNumber . fullSampleRate++amplitude :: T t t' y y' yv -> y'+amplitude = SigC.amplitude . content++samples :: T t t' y y' yv -> [yv]+samples = SigC.samples . content++{- |+Replace sample rate and amplitude+with different representations of their values.+This is needed for internal purposes,+especially for preserving the phantom types.+Do not use it for arbitrary changes of sample rate or amplitude!+-}+replaceParameters :: t1' -> y1' -> T t t0' y y0' yv -> T t t1' y y1' yv+replaceParameters sr amp (Cons _ (SigC.Cons _ ss))  =  cons sr amp ss++replaceSampleRate :: t1' -> T t t0' y y' yv -> T t t1' y y' yv+replaceSampleRate sr (Cons _ sig)  =  Cons (Rate.fromNumber sr) sig++replaceAmplitude :: y1' -> T t t' y y0' yv -> T t t' y y1' yv+replaceAmplitude amp (Cons sr sig)  =+   Cons sr (SigC.replaceAmplitude amp sig)++replaceSamples :: [yv1] -> T t t' y y' yv0 -> T t t' y y' yv1+replaceSamples ss (Cons sr sig)  =+   Cons sr (SigC.replaceSamples ss sig)+++{- |+Assert a condition before shipping the first sample.+-}+assert :: String -> Bool -> T t t' y y' yv -> T t t' y y' yv+assert msg cond x =+   replaceSamples (if cond then samples x else error msg) x++{- |+Assert that the amplitude of the signal matches the given one.+Otherwise give an error when the first sample is fetched.+-}+assertAmplitude :: Eq y' => y' -> T t t' y y' yv -> T t t' y y' yv+assertAmplitude amp x =+   replaceSamples+      (if amp == amplitude x+         then samples x+         else error "assertAmplitude: amplitudes differ") x++{- |+Assert that the sample rate of the signal matches the given one.+-}+assertSampleRate :: Eq t' => t' -> T t t' y y' yv -> T t t' y y' yv+assertSampleRate sr0 (Cons sr sig) =+   Cons sr $+   if sr0 == Rate.toNumber sr+     then sig+     else error "assertSampleRate: sample rates differ"++{- | Fix the type of a value to the scalar time type of a signal. -}+asTypeOfTime ::+      t     {- ^ time value, of with a type to be fixed -}+   -> T t t' y y' yv+            {- ^ signal, whose time type shall be matched -}+   -> t     {- ^ the time value, again -}+asTypeOfTime = const++{- | Fix the type of a value to the scalar amplitude type of a signal. -}+asTypeOfAmplitude :: y -> T t t' y y' yv -> y+asTypeOfAmplitude = const++{- | Express a time value as a multiple of the sampling period.+     The multiplicity is returned.+     It is a checked error,+     if the units of time value and sampling period mismatch. -}+toTimeScalar :: (Ring.C t', OccScalar.C t t') =>+   T t t' y y' yv -> t' -> t+toTimeScalar x t =+   toScalar (t * sampleRate x) `asTypeOfTime` x++{- | Express a frequency value as a multiple of the sampling frequency.+     The multiplicity is returned.+     In many applications the multiplicity is below 1.+     It is a checked error,+     if the units of frequency value and sampling frequency mismatch. -}+toFrequencyScalar :: (Field.C t', OccScalar.C t t') =>+   T t t' y y' yv -> t' -> t+toFrequencyScalar x f =+   toScalar (f / sampleRate x) `asTypeOfTime` x++{- | Express an amplitude value as a multiple of the signal amplitude.+     The multiplicity is returned.+     It is a checked error,+     if the units of amplitude value and signal amplitude mismatch. -}+toAmplitudeScalar :: (Field.C y', OccScalar.C y y') =>+   T t t' y y' yv -> y' -> y+toAmplitudeScalar x y =+   toScalar (y / amplitude x) `asTypeOfAmplitude` x++{-| If all signals share the same sampleRate, then return it,+    otherwise raise an error. -}+commonSampleRate :: (Eq t') =>+   T t t' y0 y'0 yv0 -> T t t' y1 y'1 yv1 -> t'+commonSampleRate x y =+   commonSampleRate' (sampleRate x) (sampleRate y)+   -- "The sample rates "++show sr0++" and "++show sr1++" differ."++commonSampleRate' :: (Eq a) => a -> a -> a+commonSampleRate' x y =+   common "The sample rates differ." x y++{- | Extract data for further processing that is not aware of physical units,+     such as playing and creating files. -}+pureData :: (Field.C t', OccScalar.C t t',+             Field.C y', OccScalar.C y y',+             VectorSpace.C y yv) =>+      t'  {- ^ The unit of the sampling frequency, say 'Number.SI.hertz' -}+   -> y'  {- ^ The maximum expected value.+               The data is normalized to this value,+               in order to preserve that all output samples+               are at most 1 in magnitude. -}+   -> T t t' y y' yv+          {- ^ The input signal. -}+   -> (t, [yv])+          {- ^ The sampling frequency without unit and+               the list of normalized samples.+               This information should suffice for playback+               or writing the signal to a file. -}+pureData freqUnit amp sig =+   (toTimeScalar sig (recip freqUnit),+    recip (toAmplitudeScalar sig amp) *> samples sig)+++instance Functor (T t t' y y') where+   fmap f (Cons sr sig) = Cons sr (fmap f sig)++++{- * Conversion from and to signals with sample rate context -}+++runPlain ::+   t' -> (Rate.T t t' -> SigC.T y y' yv) -> T t t' y y' yv+runPlain sr f =+   addPlainSampleRate sr (f (Rate.fromNumber sr))++addPlainSampleRate ::+   t' -> SigC.T y y' yv -> T t t' y y' yv+addPlainSampleRate sr = Cons (Rate.fromNumber sr)++run ::+   Rate.T t t' -> (Rate.T t t' -> SigC.T y y' yv) -> T t t' y y' yv+run sr f =+   addSampleRate sr (f sr)++addSampleRate ::+   Rate.T t t' -> SigC.T y y' yv -> T t t' y y' yv+addSampleRate = Cons++splitSampleRate ::+   T t t' y y' yv -> (Rate.T t t', SigC.T y y' yv)+splitSampleRate (Cons sr sig) = (sr, sig)++{- |+If the given sample rate matches the one of the signal,+then return the core signal, otherwise 'undefined'.+-}+checkSampleRate :: (Eq t') =>+   String ->+   Rate.T t t' ->+   T t t' y y' yv -> SigC.T y y' yv+checkSampleRate funcName sr0 (Cons sr sig) =+   if sr0 == sr+     then sig+     else error ("checkSampleRate for " ++ funcName ++ ": sample rates differ")++splitSampleRateList :: (Eq t') =>+   [T t t' y y' yv] -> (Rate.T t t', [SigC.T y y' yv])+splitSampleRateList [] = error "splitSampleRateList: empty list"+splitSampleRateList xt@(x:_) =+   let sr = fst (splitSampleRate x)+   in  (sr, map (checkSampleRate "splitSampleRateList" sr) xt)+++apply ::+   (Rate.T t t' -> SigC.T y0 y'0 y0v -> SigC.T y1 y'1 y1v)+    -> T t t' y0 y'0 y0v+    -> T t t' y1 y'1 y1v+apply f (Cons sr sig) =+   run sr (flip f sig)+++{-+commonSampleRate :: (Eq t') =>+   T t t' y0 y'0 yv0 -> T t t' y1 y'1 yv1 -> Rate.T t t'+commonSampleRate x0 x1 = Rate.fromNumber (SigP.commonSampleRate x0 x1)+-}+++lift0 ::+      (Rate.T t t' -> SigC.T y y' yv)+   -> t' -> T t t' y y' yv+lift0 = flip runPlain++lift1 ::+      (Rate.T t t' -> SigC.T y0 y0' yv0 -> SigC.T y1 y1' yv1)+   -> (T t t' y0 y0' yv0 -> T t t' y1 y1' yv1)+lift1 = apply++lift2 :: (Eq t') =>+      (Rate.T t t' -> SigC.T y0 y'0 yv0 -> SigC.T y1 y'1 yv1 -> SigC.T y2 y'2 yv2)+   -> (T t t' y0 y'0 yv0 -> T t t' y1 y'1 yv1 -> T t t' y2 y'2 yv2)+lift2 f x0 x1 =+   let (_, y0) = splitSampleRate x0+       (_, y1) = splitSampleRate x1+   in  runPlain (commonSampleRate x0 x1) (\sr -> f sr y0 y1)+{-+   let (sr0, y0) = splitSampleRate x0+       (sr1, y1) = splitSampleRate x1+       sr = SigP.commonSampleRate' sr0 sr1+   in  addSampleRate sr (f sr y0 y1)+-}++lift3 :: (Eq t') =>+      (Rate.T t t' -> SigC.T y0 y'0 yv0 -> SigC.T y1 y'1 yv1 -> SigC.T y2 y'2 yv2 -> SigC.T y3 y'3 yv3)+   -> (T t t' y0 y'0 yv0 -> T t t' y1 y'1 yv1 -> T t t' y2 y'2 yv2 -> T t t' y3 y'3 yv3)+lift3 f x0 x1 x2 =+   let (sr0, y0) = splitSampleRate x0+       (sr1, y1) = splitSampleRate x1+       (sr2, y2) = splitSampleRate x2+   in  run+          (sr0 `commonSampleRate'` sr1 `commonSampleRate'` sr2)+          (\sr -> f sr y0 y1 y2)+++liftList :: Eq t' =>+      (Rate.T t t' -> [SigC.T y1 y'1 yv1] -> SigC.T y y' yv)+   -> ([T t t' y1 y'1 yv1] -> T t t' y y' yv)+liftList f =+   uncurry run .+   mapSnd (flip f) .+   splitSampleRateList++++liftR2 ::+      (Rate.T t t' -> SigC.T y y' yv -> (SigC.T y0 y'0 yv0, SigC.T y1 y'1 yv1))+   -> T t t' y y' yv+   -> (T t t' y0 y'0 yv0, T t t' y1 y'1 yv1)+liftR2 f x0 =+   let (sr,x1) = splitSampleRate x0+       (y0,y1) = f sr x1+   in  (addSampleRate sr y0, addSampleRate sr y1)++liftR3 ::+      (Rate.T t t' -> SigC.T y y' yv -> (SigC.T y0 y'0 yv0, SigC.T y1 y'1 yv1, SigC.T y2 y'2 yv2))+   -> T t t' y y' yv+   -> (T t t' y0 y'0 yv0, T t t' y1 y'1 yv1, T t t' y2 y'2 yv2)+liftR3 f x0 =+   let (sr,x1) = splitSampleRate x0+       (y0,y1,y2) = f sr x1+   in  (addSampleRate sr y0, addSampleRate sr y1, addSampleRate sr y2)++
+ 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,336 @@+{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}+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 =+   scalarProduct (iterate (one+) zero) xs / sum xs++centroidAlt :: Field.C y => Sig.T y -> y+centroidAlt xs =+   sum (scanr (+) zero (tail xs)) / sum xs+++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/Control.hs view
@@ -0,0 +1,476 @@+{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}+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 NumericPrelude.List (iterateAssoc)++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)++++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) (iterateAssoc op d)+++curveMultiscaleNeutral :: (y -> y -> y) -> y -> y -> Sig.T y+curveMultiscaleNeutral op d neutral =+   neutral : iterateAssoc op d
+ src/Synthesizer/Plain/Cut.hs view
@@ -0,0 +1,93 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+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 NumericPrelude.List (zipWithMatch)++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++++selectBool :: (Sig.T a, Sig.T a) -> Sig.T Bool -> Sig.T a+selectBool =+   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 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+<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,122 @@+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 Sox+import qualified Sox.File+import 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 {- Sox.File.writeMono "test" rate+                (take (round (3*rate)) (soundD rate)) -}+          Sox.File.renderMono "test" rate soundE+          rawSystem "sox" (Sox.sampleRateOption rate ++ ["test.sw", "test.aiff"])+          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.lowpass 8 (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.lowpassB+   --  Cheby.highpassB+   --  Cheby.lowpassA+   --  Cheby.highpassA+   in  Cheby.lowpassB 8 (0.3::Double) filterFreqs (Noise.white::[Double])++sound7 sampleRate =+   let filterFreqs = exponential2 (-0.5*sampleRate) (100/sampleRate)+   --  butterworthHighpass+   in  Butter.lowpass 8 (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 @@+{-# OPTIONS -fno-implicit-prelude #-}+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 Sox.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 =+   Sox.File.writeStereo "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 @@+{-# OPTIONS -fno-implicit-prelude #-}+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/Filter/Delay.hs view
@@ -0,0 +1,67 @@+{-# OPTIONS -fno-implicit-prelude #-}+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 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+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 @@+{-# OPTIONS -fno-implicit-prelude #-}+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 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+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 NumericPrelude.List (takeMatch, dropMatch, )+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 (takeMatch mask0) (List.tails xs)+       targets = dropMatch 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 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+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 Synthesizer.Utility (nest, )+import Data.List (tails)++-- import Control.Monad.State (StateT)+-- import Control.Monad.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,54 @@+{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}+{- |+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,162 @@+{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}+{- |+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 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 Synthesizer.Utility (nest, mapSnd, )++import Control.Monad.State (State(..), evalState, )++import qualified Prelude as P+import PreludeBase+import NumericPrelude++++newtype Parameter a = Parameter a  {- ^ Feedback factor. -}+   deriving Show+++{-# 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 flangerParameter #-}+flangerParameter :: Trans.C a => Int -> a -> Parameter a+flangerParameter order frequency =+    parameter order (-2*pi) 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 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 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,91 @@+{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}+{- |+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,85 @@+{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}+{- |+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))+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 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 Control.Monad.State (State(..), evalState)++import qualified Prelude as P+import PreludeBase+import NumericPrelude++++sineListSlow, sineListFast :: (Trans.C a) => a -> [a]+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++parameterInstable, parameter :: (Trans.C a) =>+   a -> a -> a -> Filt2.Parameter a++{- must handle infinite values when 'freq' approaches 0.5 -}+parameterInstable ratio sinw freq =+   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+parameter ratio sinw freq =+   let phi     = pi*freq+       sinsin  = sin (2*phi) * sinw+       sinphi2 = (sin phi)^2+       ratsin  = 1 + (ratio^2-1) * sinphi2+       denom   = ratsin + ratio*sinsin+       c0      = ratio^2 * sinphi2 / denom+   in  Filt2.Parameter c0 (2*c0) c0+          (2*(1-(ratio^2+1)*sinphi2)/denom) ((ratio*sinsin-ratsin)/denom)++run :: (Trans.C a, Module.C a v) =>+   Passband -> Int -> a -> Sig.T a -> Sig.T v -> Sig.T v+run kind order ratio freqs =+   let orderFloat = fromIntegral (2*order)+       sines = take (div order 2) (sineListFast (pi/orderFloat))+       -- the filter amplifies frequency 0 with factor 1+       -- and frequency 'freq' with factor 'ratio'+       wcoef = (1/ratio^2-1)**(-1/orderFloat)+       makePartialFilter s =+          Filt2.run (map (Filt2.adjustPassband kind . parameter wcoef s) freqs)+   in  foldl (.) id (map makePartialFilter sines)++lowpass, highpass :: (Trans.C a, Module.C a v) =>+   Int -> a -> Sig.T a -> Sig.T v -> Sig.T v+lowpass = run Lowpass+highpass order ratio freqs =+   run Highpass order ratio (map (0.5-) freqs)
+ src/Synthesizer/Plain/Filter/Recursive/Chebyshev.hs view
@@ -0,0 +1,119 @@+{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}+{- |+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))+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 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)+import qualified Number.Complex as Complex++-- import Control.Monad.State (State(..), evalState)++import qualified Prelude as P+import PreludeBase+import NumericPrelude++-- 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.+-}+parameterA, parameterB :: (Trans.C a) =>+   a -> Complex.T a -> a -> Filt2.Parameter a+parameterA 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)++runA :: (Trans.C a, Module.C a v) =>+   Passband -> Int -> a -> Sig.T a -> Sig.T v -> Sig.T v+runA kind order ratio freqs =+   let orderFloat = fromIntegral (2*order)+       bn = asinh (ratio/sqrt(1-ratio^2)) / orderFloat+       pikn  = take order (map (pi/(2*orderFloat)*) (iterate (2+) 1))+       zeros = map (\angle -> cos angle * cosh bn +: (- sin angle * sinh bn)) pikn+       {- if ratio == (sqrt 2) then the product of the normalization factors is+          2^(1-2*order) -}+       makePartialFilter z =+          Filt2.run+             (map (Filt2.adjustPassband kind .+                   parameterA (sqrt+                      ((1-real z^2-imag z^2)^2 + 4*imag z^2)) z)+                  freqs)+   in  foldl (.) (ratio *>) (map makePartialFilter zeros)+++parameterB 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)++runB :: (Trans.C a, Module.C a v) =>+   Passband -> Int -> a -> Sig.T a -> Sig.T v -> Sig.T v+runB kind order ratio freqs =+   let orderFloat = fromIntegral (2*order)+       bn = (asinh (sqrt(1-ratio^2)/ratio)) / orderFloat+       pikn  = take order (map (pi/(2*orderFloat)*) (iterate (2+) 1))+       zeros = map (\angle -> (cos angle * cosh bn +: (- sin angle * sinh bn))) pikn+       a0s   = map cos pikn+       makePartialFilter a0 z =+          Filt2.run+             (map (Filt2.adjustPassband kind .+                   parameterB a0 z) freqs)+   in  foldl (.) id (zipWith makePartialFilter a0s zeros)++lowpassA, highpassA, lowpassB, highpassB ::+   (Trans.C a, VectorSpace.C a v) =>+   Int -> a -> Sig.T a -> Sig.T v -> Sig.T v+lowpassA = runA Lowpass+highpassA order ratio freqs =+   runA Highpass order ratio (map (0.5-) freqs)++lowpassB = runB Lowpass+highpassB order ratio freqs =+   runB Highpass order ratio (map (0.5-) freqs)
+ src/Synthesizer/Plain/Filter/Recursive/Comb.hs view
@@ -0,0 +1,67 @@+{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}+{- |+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,105 @@+{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}+{- |+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 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.State (State(..), )++import PreludeBase+import NumericPrelude++++newtype Parameter a = Parameter a+   deriving Show++{-| 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 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
+ src/Synthesizer/Plain/Filter/Recursive/Integration.hs view
@@ -0,0 +1,44 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+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,106 @@+{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}+{- |+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 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 Synthesizer.Utility (nest)++import Control.Monad.State (State(..), evalState, gets)++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++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+++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++lowpassTest :: [Double]+lowpassTest =+   lowpass 10+      (repeat (parameter 10 (Pole 10 (0.05::Double))))+      (1:repeat 0)
+ src/Synthesizer/Plain/Filter/Recursive/MovingAverage.hs view
@@ -0,0 +1,141 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+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,85 @@+{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}+{- |+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 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.State (State(..), )++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++{- | Given the filter parameters of a lowpass filter,+     turn them into highpass parameters, if requested filter type is Highpass -}+{-# INLINE adjustPassband #-}+adjustPassband :: (Ring.C a) =>+   Passband -> Parameter a -> Parameter a+adjustPassband kind p =+   case kind of+      Lowpass  -> p+      Highpass -> 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 ((v,v),(v,v)) v+step c u0 = State $ \((u1,u2),(y1,y2)) ->+   let y0 =+          c0 c *> u0 ++          c1 c *> u1 + d1 c *> y1 ++          c2 c *> u2 + d2 c *> y2+   in  (y0, ((u0,u1),(y0,y1)))+++{-# INLINE runInit #-}+runInit :: (Ring.C a, Module.C a v) =>+   ((v,v),(v,v)) -> Sig.T (Parameter a) -> Sig.T v -> Sig.T v+runInit ((u0init,u1init),(y0init,y1init)) control input =+   let u0s = input+       u1s = u0init:u0s+       u2s = u1init:u1s+       y1s = y0init:y0s+       y2s = y1init: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 zero
+ src/Synthesizer/Plain/Filter/Recursive/Test.hs view
@@ -0,0 +1,69 @@+{-# OPTIONS -fno-implicit-prelude #-}+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 Number.Complex((+:))++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.lowpass 2 0.2 (repeat (0.1::Double)) (repeat 1))++butterworthLowpassTest1 :: Double+butterworthLowpassTest1 =+   maximum (take 300 (drop 500+         (Butter.lowpass 6 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.lowpass 20 0.1 (repeat (0.1::Double)) (chirp len))+++chebyshevALowpassTest0 :: Filt2.Parameter Double+chebyshevALowpassTest0 =+   let beta = (asinh 1) / 4+   in  Cheby.parameterA 1 (12/13 * cosh beta +: (-5/13 * sinh beta)) 0.1++chebyshevBLowpassTest0 :: Filt2.Parameter Double+chebyshevBLowpassTest0 =+   let beta = (asinh 1) / 4+   in  Cheby.parameterB (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))++chebyshevLowpassTest2 :: [Double]+chebyshevLowpassTest2 =+   let len = 1*sampleRate+   in  take (round len) (Cheby.lowpassA 10 0.25 (repeat (0.1::Double)) (chirp len))+
+ src/Synthesizer/Plain/Filter/Recursive/Universal.hs view
@@ -0,0 +1,107 @@+{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}+{- |+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 at once.++ToDo: band limit filter as sum of input and band pass+-}+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 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.State (State(..), )++import qualified Prelude as P+import PreludeBase+import NumericPrelude+++data Parameter a =+        Parameter {k1, k2, ampIn, ampI1, ampI2 :: !a}++data Result a =+        Result {highpass, bandpass, lowpass :: !a}++instance Additive.C v => Additive.C (Result v) where+   {-# INLINE zero #-}+   {-# INLINE (+) #-}+   {-# INLINE (-) #-}+   {-# INLINE negate #-}+   zero = Result zero zero zero+   (+) (Result xhp xbp xlp) (Result yhp ybp ylp) = Result (xhp + yhp) (xbp + ybp) (xlp + ylp)+   (-) (Result xhp xbp xlp) (Result yhp ybp ylp) = Result (xhp - yhp) (xbp - ybp) (xlp - ylp)+   negate                   (Result xhp xbp xlp) = Result (negate xhp) (negate xbp) (negate xlp)+++instance Module.C a v => Module.C a (Result v) where+   {-# INLINE (*>) #-}+   s *> (Result hp bp lp) = Result (s *> hp) (s *> bp) (s *> lp)+++{-| Universal filter: Computes high pass, band pass, low pass in one go -}+{-# 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)++{-# 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+      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 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/Instrument.hs view
@@ -0,0 +1,302 @@+{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}+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,313 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+ToDo:+use AffineSpace instead of Module for the particular interpolation types,+since affine combinations assert reconstruction of constant functions.+They are more natural for interpolation of internal control parameters.+However, how can cubic interpolation expressed by affine combinations+without divisions?+-}+module Synthesizer.Plain.Interpolation where++import qualified Synthesizer.Plain.Control as Ctrl+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.Field     as Field+import qualified Algebra.Ring      as Ring+import qualified Algebra.Additive  as Additive++import Algebra.Additive(zero)+import Algebra.Module((*>))+import Data.Maybe (fromMaybe)+import Synthesizer.Utility (viewListL, viewListR, affineComb, )+import Synthesizer.ApplicativeUtility (liftA4, )++import Control.Monad.State (StateT(StateT), evalStateT, replicateM_, ap, guard, )+import Control.Applicative (Applicative(pure, (<*>)), (<$>), liftA2, )++import PreludeBase+import NumericPrelude+++{- | interpolation as needed for resampling -}+data T t y =+  Cons {+    number :: Int,  -- interpolation requires a total number of 'number'+    offset :: Int,  -- interpolation requires 'offset' values before the current+    func   :: t -> Sig.T y -> y+  }+++{-* 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,_) <- viewListL x+             (xBody,xLast) <- viewListR 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 -}++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) <- viewListL x+          guard (phase >= 1 && minLength (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+++{-* Different kinds of interpolation -}++{-** Hard-wired interpolations -}++data PrefixReader y a =+   PrefixReader Int (StateT (Sig.T y) Maybe a)++instance Functor (PrefixReader y) where+   fmap f (PrefixReader count parser) =+      PrefixReader count (fmap f parser)++-- this is a MonadWriter with Sum monoid+instance Applicative (PrefixReader y) where+   pure = PrefixReader 0 . return+   (PrefixReader count0 parser0) <*> (PrefixReader count1 parser1) =+       PrefixReader (count0+count1) (parser0 `ap` parser1)++getNode :: PrefixReader y y+getNode = PrefixReader 1 (StateT viewListL)++fromPrefixReader :: String -> Int -> PrefixReader y (t -> y) -> T t y+fromPrefixReader name off (PrefixReader count parser) =+   Cons count off+      (\t xs ->+          maybe+             (error (name ++ " interpolation: not enough nodes"))+             ($t)+             (evalStateT parser xs))++{-| Consider the signal to be piecewise constant. -}+constant :: T t y+constant =+   fromPrefixReader "constant" 0 (const <$> getNode)++{-| Consider the signal to be piecewise 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. -}+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)++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 steepness x' -}+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 -}++piecewise :: (Module.C t y) =>+   Int -> [t -> t] -> T t y+piecewise center ps =+   Cons (length ps) (center-1)+      (\t -> Module.linearComb (reverse (map ($t) ps)))++piecewiseConstant :: (Module.C t y) => T t y+piecewiseConstant =+   piecewise 1 [const 1]++piecewiseLinear :: (Module.C t y) => T t y+piecewiseLinear =+   piecewise 1 [id, (1-)]++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 -}+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+   in  Cons len left+          (\t -> Module.linearComb (reverse+              (map (\x -> f (t + fromIntegral x)) (take len [(-left)..]))))+{-+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]+-}++++{-* Helper functions -}+++{-| Test if a list has at least @n@ elements+    make sure that @n@ is non-negative -}+minLength :: Int -> Sig.T y -> Bool+minLength n xs =+   maybe False (const True) (evalStateT (replicateM_ n (StateT viewListL)) xs)
+ src/Synthesizer/Plain/LorenzAttractor.hs view
@@ -0,0 +1,37 @@+{-# OPTIONS_GHC -fno-implicit-prelude #-}+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 @@+{-# OPTIONS -fno-implicit-prelude #-}+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,80 @@+{- |+Support for stateful modifiers like controlled filters.+-}+module Synthesizer.Plain.Modifier where++import Control.Monad.State (State(..), zipWithM, evalState)++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)
+ src/Synthesizer/Plain/Noise.hs view
@@ -0,0 +1,53 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- | 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 NumericPrelude.List (sliceVert)++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 . sliceVert 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,200 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+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 (freqToPhase, )++{-+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+++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)+        (freqToPhase (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 (freqToPhase 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 $+    freqToPhase (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)+       (freqToPhase (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)+-}++{- |+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.++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 =+   map+      (uncurry (ToneMod.interpolateCell ipLeap ipStep))+      (ToneMod.oscillatorCells+          ipLeap ipStep 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)+-}+++{- * 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/Signal.hs view
@@ -0,0 +1,209 @@+{-# OPTIONS_GHC -O -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 Synthesizer.Generic.Signal as SigG+import qualified Sound.Signal as Signal++import qualified Algebra.Additive              as Additive++import qualified Synthesizer.Plain.Modifier as Modifier+import Synthesizer.Utility (viewListL, viewListR, )++import qualified NumericPrelude.List as NPList+import qualified Data.List as List+++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++++instance Signal.C [] where+   singleton = (:[])+   unfoldR   = unfoldR+   reduceL   = reduceL+   mapAccumL = mapAccumL+   (++)      = (List.++)+   zipWith   = List.zipWith++unfoldR :: (acc -> Maybe (y, acc)) -> acc -> (acc, T y)+unfoldR f =+   let recurse acc0 =+          maybe+             (acc0,[])+             (\(y,acc1) ->+                let (accEnd, signal) = recurse acc1+                in  (accEnd, y : signal))+             (f acc0)+   in  recurse++reduceL :: (x -> acc -> Maybe acc) -> acc -> T x -> acc+reduceL f =+   let recurse a xt =+          case xt of+             [] -> a+             (x:xs) ->+                maybe a+                   (\ a' -> seq a' (recurse a' xs))+                   (f x a)+   in  recurse++mapAccumL :: (x -> acc -> Maybe (y, acc)) -> acc -> T x -> (acc, T y)+mapAccumL f =+   let recurse acc0 xt =+          case xt of+             [] -> (acc0,[])+             (x:xs) ->+                 maybe+                    (acc0,[])+                    (\(y,acc1) ->+                       let (accEnd, signal) = recurse acc1 xs+                       in  (accEnd, y : signal))+                    (f x acc0)+   in  recurse++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 (Signal.crochetL f b) =+        Signal.generate (\(a0,b0) ->+            do yb1@(y0,_) <- f a0 b0+               return (y0, yb1)) (a,b) ;+  #-}+++instance SigG.C [] where+   empty = []+   null = List.null+   cons = (:)+   fromList = id+   toList = id+   repeat = List.repeat+   cycle = List.cycle+   replicate = List.replicate+   iterate = List.iterate+   iterateAssoc = NPList.iterateAssoc+   unfoldR = List.unfoldr+   map = List.map+   mix = (Additive.+)+   zipWith = List.zipWith+   scanL = List.scanl+   viewL = viewListL+   viewR = viewListR+   foldL = List.foldl+   length = List.length+   take = List.take+   drop = List.drop+   splitAt = List.splitAt+   dropMarginRem = dropMarginRem+   takeWhile = List.takeWhile+   dropWhile = List.dropWhile+   span = List.span+   append = (List.++)+   concat = List.concat+   reverse = List.reverse+{-+   mapAccumL = List.mapAccumL+   mapAccumR = List.mapAccumR+-}+   crochetL = crochetL++{-+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 =+   NPList.dropMatch (take m (drop n xs)) 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
+ src/Synthesizer/Plain/ToneModulation.hs view
@@ -0,0 +1,459 @@+{-# OPTIONS -O2 -fno-implicit-prelude #-}+{- |+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.Phase as Phase++import qualified Synthesizer.Plain.Interpolation as Interpolation+-- 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 Synthesizer.Utility (viewListL, viewListR, clip, mapPair, )+import Control.Monad (guard)++import qualified Data.List as List++import NumericPrelude.List (replicateMatch, takeMatch, )+import NumericPrelude++-- import qualified Prelude as P+import PreludeBase++++-- * general helpers++interpolateCell ::+   Interpolation.T a y ->+   Interpolation.T b y ->+   (a, b) ->+   [[y]] -> y+interpolateCell ipLeap ipStep (qLeap,qStep) =+   Interpolation.func ipStep qStep .+   map (Interpolation.func ipLeap qLeap)+++{- |+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.+-}+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 :: RealField.C a =>+      Int+   -> a+   -> (a, Phase.T a)+   -> (Int, (a, a))+flattenShapePhase periodInt period (shape,phase) =+   let (xShape,xWave) =+          untangleShapePhase periodInt period (shape, Phase.toRepresentative phase)+       (nLeap,qLeap) = splitFraction xShape+       (nStep,qStep) = splitFraction xWave+       {- 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 =>+      Interpolation.T a v+   -> Interpolation.T a v+   -> Int+   -> t+   -> (t, t)+shapeLimits ipLeap ipStep periodInt len =+   let minShape =+          fromIntegral $+          interpolationOffset ipLeap ipStep periodInt ++          periodInt+       maxShape =+          minShape + len -+             fromIntegral+                (Interpolation.number ipStep ++                 Interpolation.number ipLeap * periodInt)+   in  (minShape, maxShape)+++interpolationOffset ::+      Interpolation.T a v+   -> Interpolation.T a v+   -> Int+   -> Int+interpolationOffset ipLeap ipStep periodInt =+   Interpolation.offset ipStep ++   Interpolation.offset ipLeap * periodInt+++++-- * array based shape variable wave++data Prototype a v =+   Prototype {+      protoIpLeap,+      protoIpStep      :: Interpolation.T a v,+      protoIpOffset    :: Int,+      protoPeriod      :: a,+      protoPeriodInt   :: Int,+      protoShapeLimits :: (a,a),+      protoArray       :: Array Int v+   }+++makePrototype :: (RealField.C a) =>+   Interpolation.T a v ->+   Interpolation.T a v ->+   a -> [v] -> Prototype a v+makePrototype ipLeap ipStep period tone =+   let periodInt = round period+       ipOffset =+          interpolationOffset ipLeap ipStep periodInt+       len = length tone+       (lower,upper) =+          shapeLimits ipLeap ipStep periodInt len+       limits =+          if lower > upper+            then error "min>max"+            else+              (fromIntegral lower, fromIntegral upper)++       arr = listArray (0, pred len) tone++   in  Prototype {+          protoIpLeap      = ipLeap,+          protoIpStep      = ipStep,+          protoIpOffset    = ipOffset,+          protoPeriod      = period,+          protoPeriodInt   = periodInt,+          protoShapeLimits = limits,+          protoArray       = arr+       }++sampledToneCell :: (RealField.C a) =>+   Prototype a v -> a -> Phase.T a -> ((a,a),[[v]])+sampledToneCell p shape phase =+   let (n, q) =+          flattenShapePhase (protoPeriodInt p) (protoPeriod p)+             (uncurry clip (protoShapeLimits p) shape, phase)+   in  (q,+        map (map (protoArray p ! ) . iterate (protoPeriodInt p +)) $+        enumFrom (n - protoIpOffset p))++sampledToneAltCell :: (RealField.C a) =>+   Prototype a v -> a -> Phase.T a -> ((a,a),[[v]])+sampledToneAltCell p shape phase =+   let (n, q) =+          flattenShapePhase (protoPeriodInt p) (protoPeriod p)+             (uncurry clip (protoShapeLimits p) shape, phase)+   in  (q,+        iterate (drop (protoPeriodInt p)) $+        map (protoArray 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) =>+    Interpolation.T t y ->+    Interpolation.T t y ->+    t -> [y] -> (t,[t]) -> (Phase.T t,[t]) -> [((t,t),[[y]])]+oscillatorCells+       ipLeap ipStep period sampledTone shapes freqs =+    let periodInt = round period+        ptrs =+           List.transpose $+           takeWhile (not . null) $+           iterate (drop periodInt) sampledTone+        ipOffset =+           interpolationOffset ipLeap ipStep periodInt+        (skip:skips,coords) =+           unzip $+           oscillatorCoords periodInt period+              (limitRelativeShapes ipLeap ipStep periodInt sampledTone shapes)+              freqs+    in  zipWith+           -- n will be zero within the data, it's only needed for extrapolation+           (\(k,q) (n,ptr) ->+             if n>0+               then error "ToneModulation.oscillatorCells: limit of shape parameter is buggy"+               else+                 (q, drop (periodInt+k) ptr))+           coords $+        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 - periodInt) : skips)++dropFrac :: RealField.C i => i -> [a] -> (Int, i, [a])+dropFrac =+   let recurse acc n xt =+          if n>=1+            then+               case xt of+                  _:xs -> recurse (succ acc) (n-1) xs+                  [] -> (acc, n, [])+            else (acc,n,xt)+   in  recurse 0++dropFrac' :: RealField.C i => i -> [a] -> (Int, i, [a])+dropFrac' =+   let recurse acc n xt =+          maybe+             (acc,n,xt)+             (recurse (succ acc) (n-1) . snd)+             (guard (n>=1) >> viewListL xt)+   in  recurse 0++propDropFrac :: (RealField.C i, Eq a) => i -> [a] -> Bool+propDropFrac n xs =+   dropFrac n xs == dropFrac' n xs++++dropRem :: Int -> [a] -> (Int, [a])+dropRem =+   let recurse n xt =+          if n>0+            then+               case xt of+                  _:xs -> recurse (pred n) xs+                  [] -> (n, [])+            else (n,xt)+   in  recurse++dropRem' :: Int -> [a] -> (Int, [a])+dropRem' =+   let recurse n xt =+          maybe+             (n,xt)+             (recurse (pred n) . snd)+             (guard (n>0) >> viewListL xt)+   in  recurse++propDropRem :: (Eq a) => Int -> [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,[t]) -> (Phase.T t, [t]) -> [(Int,(Int,(t,t)))]+oscillatorCoords periodInt 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  freqToPhase+                  (Phase.increment (-s) phase)  -- phase - s+                  (zipWith (-) freqs ss)+    in  zipWith+--           (\(d,s) p -> (d, (s,p)))+           (\(d,s) p -> (d, flattenShapePhase periodInt period (s,p)))+           shapeOffsets+           phases+{-+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)+-}+++-- 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+-}+freqToPhase :: RealField.C a => Phase.T a -> [a] -> [Phase.T a]+freqToPhase phase freq = scanl (flip Phase.increment) phase freq++++limitRelativeShapes :: (RealField.C t) =>+    Interpolation.T t y ->+    Interpolation.T t y ->+    Int -> [y] -> (t,[t]) -> (t,[t])+limitRelativeShapes ipLeap ipStep periodInt sampledTone =+    let -- len = List.genericLength sampledTone+        len = Chunky.fromChunks (replicateMatch sampledTone one)+        (minShape, maxShape) = shapeLimits ipLeap ipStep 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 -> [a] -> (a, [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, replicateMatch yr zero +++              case zs of+                 [] -> []+                 (z:zr) -> fst z : map snd zr)++limitMaxRelativeValues :: (Additive.C a, Ord a) =>+   a -> a -> [a] -> (a, [a])+limitMaxRelativeValues xMax x0 xs =+   let (ys,zs) =+          span (>zero) (scanl (-) (xMax-x0) xs)+   in  maybe+          (xMax, replicateMatch xs zero)+          (\ ~(yl,yr) -> (x0, takeMatch yl xs ++ takeMatch zs (yr : repeat zero)))+          (viewListR ys)++{- |+Avoids negative numbers and thus can be used with Chunky numbers.+-}+limitMaxRelativeValuesNonNeg :: (Additive.C a, Ord a) =>+   a -> a -> [a] -> (a, [a])+limitMaxRelativeValuesNonNeg xMax x0 xs =+   let (ys,zs) =+          span fst (scanl (\(_,acc) d -> safeSub acc d) (safeSub xMax x0) xs)+   in  maybe+          (xMax, replicateMatch xs zero)+          (\ ~(yl, ~(_,yr)) -> (x0, takeMatch yl xs ++ takeMatch zs (yr : repeat zero)))+          (viewListR 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/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/SampleRateContext/Control.hs view
@@ -0,0 +1,202 @@+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes+++Control curves which can be used+as envelopes, for controlling filter parameters and so on.+-}+module Synthesizer.SampleRateContext.Control+   ({- * Primitives -}+    constant, constantVector, linear, line, exponential, exponential2,+    {- * Piecewise -}+    piecewise, piecewiseVolume, Control(..), ControlPiece(..),+    (-|#), ( #|-), (=|#), ( #|=), (|#), ( #|),  -- spaces before # for Haddock+    {- * Preparation -}+    mapLinear, mapExponential, )+   where++import Synthesizer.Plain.Control+   (Control(..), ControlPiece(..), (-|#), ( #|-), (=|#), ( #|=), (|#), ( #|))++import qualified Synthesizer.Amplitude.Control as CtrlV+import qualified Synthesizer.Plain.Control as Ctrl++import qualified Synthesizer.SampleRateContext.Signal as SigC+import qualified Synthesizer.SampleRateContext.Rate as Rate+import Synthesizer.SampleRateContext.Signal+          (toTimeScalar, toAmplitudeScalar, toGradientScalar)++import qualified Algebra.OccasionallyScalar as OccScalar+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 qualified Algebra.Ring               as Ring+import qualified Algebra.Additive           as Additive++import NumericPrelude+import PreludeBase as P+import Prelude ()+++constant :: (Field.C y', Real.C y', OccScalar.C y y') =>+      y' {-^ value -}+   -> Rate.T t t' -> SigC.T y y' y+constant y = Rate.pure $ CtrlV.constant y++{- |+The amplitude must be positive!+This is not checked.+-}+constantVector :: -- (Field.C y', Real.C y', OccScalar.C y y') =>+      y' {-^ amplitude -}+   -> yv {-^ value -}+   -> Rate.T t t' -> SigC.T y y' yv+constantVector y yv = Rate.pure $ CtrlV.constantVector y yv++{- Using the 'Ctrl.linear' instead of 'Ctrl.linearStable'+   the type class constraints would be weaker.+linear :: (Additive.C y, Field.C y', Real.C y', OccScalar.C y y') =>+-}++{- |+Caution: This control curve can contain samples+with an absolute value greater than 1.++Linear curves starting with zero are impossible.+Maybe you prefer using 'line'.+-}+linear ::+   (Additive.C q, Field.C q',+    Real.C q', OccScalar.C q q') =>+      q' {-^ slope of the curve -}+   -> q' {-^ initial value -}+   -> Rate.T q q' -> SigC.T q q' q+linear slope y0 sr =+   let amp = abs y0+       steep = toGradientScalar amp sr slope+   in  SigC.Cons amp+          (Ctrl.linearMultiscale steep (OccScalar.toScalar (signum y0)))++{- |+Generates a finite ramp.+-}+line ::+   (RealField.C q, Field.C q',+    Real.C q', OccScalar.C q q') =>+      q'      {-^ duration of the ramp -}+   -> (q',q') {-^ initial and final value -}+   -> Rate.T q q' -> SigC.T q q' q+line dur' (y0',y1') sr =+   let amp = max (abs y0') (abs y1')+       dur = toTimeScalar sr dur'+       y0  = toAmplitudeScalar z y0'+       y1  = toAmplitudeScalar z y1'+       z = SigC.Cons amp+              (take (floor dur)+                 (Ctrl.linearMultiscale ((y1-y0)/dur) y0))+   in  z++exponential :: (Trans.C q, Ring.C q', Real.C q', OccScalar.C q q') =>+      q' {-^ time where the function reaches 1\/e of the initial value -}+   -> q' {-^ initial value -}+   -> Rate.T q q' -> SigC.T q q' q+exponential time y0 sr =+   SigC.Cons (abs y0)+      (Ctrl.exponentialMultiscale+         (toTimeScalar sr time) (OccScalar.toScalar (signum y0)))++{-+  take 1000 $ show (run (fixSampleRate 100 (exponential 0.1 1)) :: SigDouble)+-}++exponential2 :: (Trans.C q, Ring.C q', Real.C q', OccScalar.C q q') =>+      q' {-^ half life, time where the function reaches 1\/2 of the initial value -}+   -> q' {-^ initial value -}+   -> Rate.T q q' -> SigC.T q q' q+exponential2 time y0 sr =+   SigC.Cons (abs y0)+      (Ctrl.exponential2Multiscale+         (toTimeScalar sr time) (OccScalar.toScalar (signum y0)))++++{- |+Since this function looks for the maximum node value,+and since the signal parameter inference phase must be completed before signal processing,+infinite descriptions cannot be used here.+-}+piecewise :: (Trans.C q, RealField.C q,+              Real.C q', Field.C q', OccScalar.C q q') =>+      [ControlPiece q']+   -> Rate.T q q' -> SigC.T q q' q+piecewise cs =+   let amplitude = maximum+         (map (\c -> max (abs (Ctrl.pieceY0 c))+                         (abs (Ctrl.pieceY1 c))) cs)+   in  piecewiseVolume cs amplitude+++piecewiseVolume ::+   (Trans.C q, RealField.C q,+    Real.C q', Field.C q', OccScalar.C q q') =>+      [ControlPiece q']+   -> q'+   -> Rate.T q q' -> SigC.T q q' q+piecewiseVolume cs amplitude sr =+   let ps = map (\(Ctrl.ControlPiece typ y0 y1 d) ->+          Ctrl.ControlPiece+             {- We cannot provide an default case like "_ -> typ",+                because the returned constructors+                have different parameter type. -}+             (case typ of+                CtrlStep -> CtrlStep+                CtrlLin  -> CtrlLin+                -- this may exceed value range (-1,1)+                CtrlCubic d0 d1 ->+                   CtrlCubic+                      (toGradientScalar amplitude sr d0)+                      (toGradientScalar amplitude sr d1)+                CtrlExp sat ->+                   CtrlExp+                      (toAmplitudeScalar z sat)+                CtrlCos  -> CtrlCos)+             (toAmplitudeScalar z y0)+             (toAmplitudeScalar z y1)+             (toTimeScalar sr d)) cs+       z = SigC.Cons amplitude (Ctrl.piecewise ps)+   in  z++++{- |+Map a control curve without amplitude unit+by a linear (affine) function with a unit.+-}+mapLinear :: (Ring.C y, Field.C y', Real.C y', OccScalar.C y y') =>+      y'  {- ^ range: one is mapped to @center+range@ -}+   -> y'  {- ^ center: zero is mapped to @center@ -}+   -> Rate.T t t'+   -> SigC.T y y' y+   -> SigC.T y y' y+mapLinear range center =+   Rate.pure $ CtrlV.mapLinear range center++{- |+Map a control curve without amplitude unit+exponentially to one with a unit.+-}+mapExponential :: (Field.C y', Trans.C y, Module.C y y') =>+      y   {- ^ range: one is mapped to @center*range@, must be positive -}+   -> y'  {- ^ center: zero is mapped to @center@ -}+   -> Rate.T t t'+   -> SigC.T y y  y+   -> SigC.T y y' y+mapExponential range center =+   Rate.pure $ CtrlV.mapExponential range center
+ src/Synthesizer/SampleRateContext/Cut.hs view
@@ -0,0 +1,214 @@+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes+-}+module Synthesizer.SampleRateContext.Cut (+   {- * dissection -}+   splitAt,+   take,+   drop,+   takeUntilPause,+   unzip,+   unzip3,++   {- * glueing -}+   concat,   concatVolume,+   append,   appendVolume,+   zip,      zipVolume,+   zip3,     zip3Volume,+   arrange,  arrangeVolume,+  ) where++import qualified Synthesizer.Amplitude.Cut as CutV+import qualified Synthesizer.Plain.Cut as CutS++import qualified Synthesizer.SampleRateContext.Signal as SigC+import qualified Synthesizer.SampleRateContext.Rate as Rate+-- import Synthesizer.SampleRateContext.Rate (($#))+import Synthesizer.SampleRateContext.Signal+   (toTimeScalar, toAmplitudeScalar)++import qualified Data.EventList.Relative.TimeBody as EventList+import qualified Numeric.NonNegative.Class as NonNeg++import qualified Algebra.NormedSpace.Maximum as NormedMax+import qualified Algebra.OccasionallyScalar  as OccScalar+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 Data.List as List++import PreludeBase ((.), ($), Ord, (<=), map, fst, snd)+-- import NumericPrelude+import Prelude (RealFrac)+++{- * dissection -}++splitAt :: (RealField.C t, Ring.C t', OccScalar.C t t') =>+   t' -> Rate.T t t' -> SigC.T y y' yv -> (SigC.T y y' yv, SigC.T y y' yv)+splitAt t' sr x =+   let (ss0,ss1) = List.splitAt (RealField.round (toTimeScalar sr t')) (SigC.samples x)+   in  (SigC.replaceSamples ss0 x,+        SigC.replaceSamples ss1 x)++take :: (RealField.C t, Ring.C t', OccScalar.C t t') =>+   t' -> Rate.T t t' -> SigC.T y y' yv -> SigC.T y y' yv+take t sr = fst . splitAt t sr++drop :: (RealField.C t, Ring.C t', OccScalar.C t t') =>+   t' -> Rate.T t t' -> SigC.T y y' yv -> SigC.T y y' yv+drop t sr = snd . splitAt t sr++takeUntilPause ::+  (RealField.C t, Ring.C t', OccScalar.C t t',+   Field.C y', NormedMax.C y yv, OccScalar.C y y') =>+   y' -> t' -> Rate.T t t' -> SigC.T y y' yv -> SigC.T y y' yv+takeUntilPause y' t' sr x =+   let t = toTimeScalar      sr t'+       y = toAmplitudeScalar x  y'+   in  SigC.replaceSamples+         (CutS.takeUntilInterval ((<=y) . NormedMax.norm)+             (RealField.ceiling t) (SigC.samples x)) x+++unzip ::+   Rate.T t t' ->+   SigC.T y y' (yv0, yv1) ->+   (SigC.T y y' yv0, SigC.T y y' yv1)+unzip = Rate.pure CutV.unzip++unzip3 ::+   Rate.T t t' ->+   SigC.T y y' (yv0, yv1, yv2) ->+   (SigC.T y y' yv0, SigC.T y y' yv1, SigC.T y y' yv2)+unzip3 = Rate.pure CutV.unzip3++++{- * glueing -}++{- |+Similar to @foldr1 append@ but more efficient and accurate,+because it reduces the number of amplifications.+Does not work for infinite lists,+because no maximum amplitude can be computed.+-}+concat ::+   (Ord y', Field.C y', OccScalar.C y y',+    Module.C y yv) =>+   Rate.T t t' -> [SigC.T y y' yv] -> SigC.T y y' yv+concat = Rate.pure $ CutV.concat++{- |+Give the output volume explicitly.+Does also work for infinite lists.+-}+concatVolume ::+   (Field.C y', OccScalar.C y y',+    Module.C y yv) =>+   y' -> Rate.T t t' -> [SigC.T y y' yv] -> SigC.T y y' yv+concatVolume amp = Rate.pure $ CutV.concatVolume amp+++append ::+   (Ord y', Field.C y', OccScalar.C y y',+    Module.C y yv) =>+   Rate.T t t' -> SigC.T y y' yv -> SigC.T y y' yv -> SigC.T y y' yv+append = Rate.pure $ CutV.append++appendVolume ::+   (Field.C y', OccScalar.C y y',+    Module.C y yv) =>+   y' ->+   Rate.T t t' -> SigC.T y y' yv -> SigC.T y y' yv -> SigC.T y y' yv+appendVolume amp = Rate.pure $ CutV.appendVolume amp+++zip ::+   (Ord y', Field.C y', OccScalar.C y y',+    Module.C y yv0, Module.C y yv1) =>+   Rate.T t t' -> SigC.T y y' yv0 -> SigC.T y y' yv1 -> SigC.T y y' (yv0,yv1)+zip = Rate.pure $ CutV.zip++zipVolume ::+   (Field.C y', OccScalar.C y y',+    Module.C y yv0, Module.C y yv1) =>+   y' ->+   Rate.T t t' -> SigC.T y y' yv0 -> SigC.T y y' yv1 -> SigC.T y y' (yv0,yv1)+zipVolume amp = Rate.pure $ CutV.zipVolume amp++++zip3 ::+   (Ord y', Field.C y', OccScalar.C y y',+    Module.C y yv0, Module.C y yv1, Module.C y yv2) =>+   Rate.T t t' -> SigC.T y y' yv0 -> SigC.T y y' yv1 -> SigC.T y y' yv2 ->+                 SigC.T y y' (yv0,yv1,yv2)+zip3 = Rate.pure $ CutV.zip3++zip3Volume ::+   (Field.C y', OccScalar.C y y',+    Module.C y yv0, Module.C y yv1, Module.C y yv2) =>+   y' ->+   Rate.T t t' -> SigC.T y y' yv0 -> SigC.T y y' yv1 -> SigC.T y y' yv2 ->+                 SigC.T y y' (yv0,yv1,yv2)+zip3Volume amp = Rate.pure $ CutV.zip3Volume amp+++{- |+Uses maximum input volume as output volume.+-}+arrange ::+   (Ring.C t', OccScalar.C t t',+    RealFrac t, NonNeg.C t,+    Ord y', Field.C y', OccScalar.C y y',+    Module.C y yv) =>+      t'  {-^ Unit of the time values in the time ordered list. -}+   -> Rate.T t t'+   -> EventList.T t (SigC.T y y' yv)+            {- ^ A list of pairs: (relative start time, signal part),+                 The start time is relative+                 to the start time of the previous event. -}+   -> SigC.T y y' yv+             {- ^ The mixed signal. -}+arrange unit' sr sched =+   let amp = List.maximum (map SigC.amplitude (EventList.getBodies sched))+   in  arrangeVolume amp unit' sr sched+++{- |+Given a list of signals with time stamps,+mix them into one signal as they occur in time.+Ideally for composing music.+Infinite schedules are not supported.+Does not work for infinite lists,+because no maximum amplitude can be computed.+-}+arrangeVolume ::+   (Ring.C t', OccScalar.C t t',+    RealFrac t, NonNeg.C t,+    Field.C y', OccScalar.C y y',+    Module.C y yv) =>+      y'  {-^ Output volume. -}+   -> t'  {-^ Unit of the time values in the time ordered list. -}+   -> Rate.T t t'+   -> EventList.T t (SigC.T y y' yv)+            {- ^ A list of pairs: (relative start time, signal part),+                 The start time is relative+                 to the start time of the previous event. -}+   -> SigC.T y y' yv+            {- ^ The mixed signal. -}+arrangeVolume amp unit' sr sched' =+   let unit = toTimeScalar sr unit'+       sched =+          EventList.mapBody (SigC.vectorSamples (toAmplitudeScalar z)) sched'+       z = SigC.Cons amp+              (CutS.arrange (EventList.resample unit sched))+   in  z
+ src/Synthesizer/SampleRateContext/Displacement.hs view
@@ -0,0 +1,83 @@+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes+-}+module Synthesizer.SampleRateContext.Displacement (+   mix, mixVolume,+   mixMulti, mixMultiVolume,+   raise,+   ) where++import qualified Synthesizer.Amplitude.Displacement as MiscV++import qualified Synthesizer.SampleRateContext.Signal as SigC+import qualified Synthesizer.SampleRateContext.Rate as Rate++-- import Synthesizer.SampleRateContext.Signal (toAmplitudeScalar)++-- import qualified Synthesizer++import qualified Algebra.OccasionallyScalar as OccScalar+import qualified Algebra.Module         as Module+-- import qualified Algebra.Transcendental as Trans+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 Algebra.Module ((*>))++import PreludeBase+-- import NumericPrelude+import Prelude ()+++{- * Mixing -}++{-| Mix two signals.+    In opposition to 'zipWith' the result has the length of the longer signal. -}+mix :: (Real.C y', Field.C y', Module.C y yv, OccScalar.C y y') =>+      Rate.T t t'+   -> SigC.T y y' yv+   -> SigC.T y y' yv+   -> SigC.T y y' yv+mix = Rate.pure MiscV.mix++mixVolume ::+   (Real.C y', Field.C y', Module.C y yv, OccScalar.C y y') =>+      y'+   -> Rate.T t t'+   -> SigC.T y y' yv+   -> SigC.T y y' yv+   -> SigC.T y y' yv+mixVolume v = Rate.pure $ MiscV.mixVolume v++{-| Mix one or more signals. -}+mixMulti ::+   (Real.C y', Field.C y', Module.C y yv, OccScalar.C y y') =>+      Rate.T t t'+   -> [SigC.T y y' yv]+   ->  SigC.T y y' yv+mixMulti = Rate.pure MiscV.mixMulti++mixMultiVolume ::+   (Real.C y', Field.C y', Module.C y yv, OccScalar.C y y') =>+      y'+   -> Rate.T t t'+   -> [SigC.T y y' yv]+   ->  SigC.T y y' yv+mixMultiVolume v = Rate.pure $ MiscV.mixMultiVolume v++{-| Add a number to all of the signal values.+    This is useful for adjusting the center of a modulation. -}+raise :: (Field.C y', Module.C y yv, OccScalar.C y y') =>+      y'+   -> yv+   -> Rate.T t t'+   -> SigC.T y y' yv+   -> SigC.T y y' yv+raise y' yv = Rate.pure $ MiscV.raise y' yv
+ src/Synthesizer/SampleRateContext/Filter.hs view
@@ -0,0 +1,345 @@+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes+-}+module Synthesizer.SampleRateContext.Filter (+   {- * Non-recursive -}++   {- ** Amplification -}+   amplify,+   negate,+   envelope,+   {- ** Filter operators from calculus -}+   differentiate,++{-+   {- ** Smooth -}+   mean,++   {- ** Delay -}+   delay,+   phaseModulation,+   phaser,+   phaserStereo,+++   {- * Recursive -}++   {- ** Without resonance -}+   firstOrderLowpass,+   firstOrderHighpass,+   butterworthLowpass,+   butterworthHighpass,+   chebyshevALowpass,+   chebyshevAHighpass,+   chebyshevBLowpass,+   chebyshevBHighpass,+   {- ** With resonance -}+   universal,+   moogLowpass,+   {- ** Allpass -}+   allpassCascade,+-}+   {- ** Reverb -}+   comb,++   {- ** Filter operators from calculus -}+   integrate,+) where+++import qualified Synthesizer.Amplitude.Filter as FiltV+import qualified Synthesizer.SampleRateContext.Signal as SigC+import qualified Synthesizer.SampleRateContext.Rate as Rate++import Synthesizer.SampleRateContext.Signal+   (toTimeScalar, {- toFrequencyScalar, -} )++-- import qualified Synthesizer.Plain.Displacement as Syn+-- import qualified Synthesizer.Plain.Filter.Recursive    as FiltR+import qualified Synthesizer.Plain.Filter.Recursive.Comb        as Comb+import qualified Synthesizer.Plain.Filter.Recursive.Integration as Integrate+import qualified Synthesizer.Plain.Filter.NonRecursive as FiltNR+{-+import qualified Synthesizer.Plain.Interpolation as Interpolation+import qualified Synthesizer.Plain.Filter.Delay.Block as Delay++import Synthesizer.Utility(clip)+-}++import qualified Algebra.OccasionallyScalar as OccScalar+-- 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 Algebra.Module         as Module+-- import qualified Algebra.VectorSpace    as VectorSpace++-- import Control.Monad(liftM2)++import NumericPrelude hiding (negate)+import PreludeBase as P+import Prelude ()+++{- | The amplification factor must be positive. -}+amplify :: (Ring.C y') =>+      y'+   -> Rate.T t t'+   -> SigC.T y y' yv+   -> SigC.T y y' yv+amplify volume = Rate.pure $ FiltV.amplify volume++negate :: (Additive.C yv) =>+      Rate.T t t'+   -> SigC.T y y' yv+   -> SigC.T y y' yv+negate = Rate.pure FiltV.negate++envelope :: (Module.C y0 yv, Ring.C y') =>+      Rate.T t t'+   -> SigC.T y y' y0  {-  the envelope -}+   -> SigC.T y y' yv  {-  the signal to be enveloped -}+   -> SigC.T y y' yv+envelope = Rate.pure FiltV.envelope++++differentiate :: (Additive.C v, Ring.C q') =>+      Rate.T t q'+   -> SigC.T y q' v+   -> SigC.T y q' v+differentiate sr x =+   SigC.Cons+      (SigC.amplitude x * Rate.toNumber sr)+      (FiltNR.differentiate (SigC.samples x))+++{-+{- | needs a good handling of boundaries, yet -}+mean :: (Additive.C yv, Field.C y', RealField.C a,+         Module.C a v, OccScalar.C a q) =>+      q            {- ^ time length of the window -}+   -> SigC.T y y' yv+   -> Rate.T t t' -> (SigC.T y y' yv)+mean time x =+   do t <- toTimeScalar x (Expr.constant time)+      let tInt  = round ((t-1)/2)+      let width = tInt*2+1+      returnModified []+         ((SigP.asTypeOfAmplitude (recip (fromIntegral width)) x *> ) .+          Filt.sums width . FiltNR.delay tInt) x+++delay :: (Additive.C yv, Field.C y', RealField.C a, OccScalar.C a q) =>+      q+   -> SigC.T y y' yv+   -> Rate.T t t' -> (SigC.T y y' yv)+delay time x =+   do t <- toTimeScalar x (Expr.constant time)+      returnModified [] (FiltNR.delay (round t)) x+++phaseModulation ::+         (Additive.C yv, Field.C y', RealField.C a, OccScalar.C a q) =>+      Interpolation.T a v+   -> q   {- ^ minDelay, minimal delay, may be negative -}+   -> q   {- ^ maxDelay, maximal delay, it must be @minDelay <= maxDelay@+               and the modulation must always be+               in the range [minDelay,maxDelay]. -}+   -> SigI.T a q a+          {- ^ delay control, positive numbers mean delay,+               negative numbers mean prefetch -}+   -> SigC.T y y' yv+   -> Rate.T t t' -> (SigC.T y y' yv)+phaseModulation ip minDelay maxDelay delays x =+   do t0 <- toTimeScalar x (Expr.constant minDelay)+      t1 <- toTimeScalar x (Expr.constant maxDelay)+      let tInt0 = floor   t0+      let tInt1 = ceiling t1+      let tInt0Neg = Additive.negate tInt0+      ds <- SigI.scalarSamples (toTimeScalar delays) delays+      returnModified [SigP.sampleRate delays]+         (FiltNR.delay tInt0 .+             Delay.modulated ip (tInt1-tInt0+1)+               (FiltNR.delay tInt0Neg+                  (Syn.raise (fromIntegral tInt0Neg)+                     (map (clip t0 t1) ds)))) x+++{- | symmetric phaser -}+phaser :: (Additive.C yv, Field.C y', RealField.C a,+           Module.C a v, OccScalar.C a q) =>+      Interpolation.T a v+   -> q   {- ^ maxDelay, must be positive -}+   -> SigI.T a q a+          {- ^ delay control -}+   -> SigC.T y y' yv+   -> Rate.T t t' -> (SigC.T y y' yv)+phaser ip maxDelay delays x =+   amplify (asTypeOf 0.5 maxDelay) =<<+      uncurry SynI.mix =<< phaserCore ip maxDelay delays x++phaserStereo :: (Additive.C yv, Field.C y', Real.C q, RealField.C a,+                 Module.C a v, OccScalar.C a q) =>+      Interpolation.T a v+   -> q   {- ^ maxDelay, must be positive -}+   -> SigI.T a q a+          {- ^ delay control -}+   -> SigC.T y y' yv+   -> SigI.Process a q (v,v)+phaserStereo ip maxDelay delays x =+   uncurry CutI.zip =<< phaserCore ip maxDelay delays x++phaserCore :: (Additive.C yv, Field.C y', RealField.C a,+               Module.C a v, OccScalar.C a q) =>+      Interpolation.T a v+   -> q   {- ^ maxDelay, must be positive -}+   -> SigI.T a q a+          {- ^ delay control -}+   -> SigC.T y y' yv+   -> Process.T q (SigC.T y y' yv, SigC.T y y' yv)+phaserCore ip maxDelay delays x =+   do let minDelay = Additive.negate maxDelay+      negDelays <- Inference.Signal.Filter.negate delays+      liftM2 (,)+         (phaseModulation ip minDelay maxDelay delays x)+         (phaseModulation ip minDelay maxDelay negDelays x)++++firstOrderLowpass, firstOrderHighpass ::+   (Trans.C a, Trans.C q, Module.C a v, OccScalar.C a q) =>+      SigI.T a q a {- ^ Control signal for the cut-off frequency. -}+   -> SigC.T y y' yv {- ^ Input signal -}+   -> Rate.T t t' -> (SigC.T y y' yv)+firstOrderLowpass  = firstOrderGen Filt1.lowpass+firstOrderHighpass = firstOrderGen Filt1.highpass++firstOrderGen :: (Trans.C a, Trans.C q, Module.C a v, OccScalar.C a q) =>+      ([a] -> [v] -> [v])+   -> SigI.T a q a+   -> SigC.T y y' yv+   -> Rate.T t t' -> (SigC.T y y' yv)+firstOrderGen filt freq x =+   do freqs <- SigI.scalarSamples (toFrequencyScalar x) freq+      returnModified [SigP.sampleRate freq]+         (filt (map Filt1.parameter freqs)) x+++butterworthLowpass, butterworthHighpass,+   chebyshevALowpass, chebyshevAHighpass,+   chebyshevBLowpass, chebyshevBHighpass ::+      (Field.C y', Trans.C a, VectorSpace.C a v, OccScalar.C a q) =>+      Int          {- ^ Order of the filter, must be even,+                        the higher the order, the sharper is the separation of frequencies. -}+   -> a            {- ^ The attenuation at the cut-off frequency.+                        Should be between 0 and 1. -}+   -> SigI.T a q a {- ^ Control signal for the cut-off frequency. -}+   -> SigC.T y y' yv {- ^ Input signal -}+   -> Rate.T t t' -> (SigC.T y y' yv)++butterworthLowpass  = higherOrderNoResoGen Butter.lowpass+butterworthHighpass = higherOrderNoResoGen FiltR.butterworthHighpass+chebyshevALowpass   = higherOrderNoResoGen FiltR.chebyshevALowpass+chebyshevAHighpass  = higherOrderNoResoGen FiltR.chebyshevAHighpass+chebyshevBLowpass   = higherOrderNoResoGen FiltR.chebyshevBLowpass+chebyshevBHighpass  = higherOrderNoResoGen FiltR.chebyshevBHighpass++higherOrderNoResoGen ::+   (Field.C y', Ring.C a, OccScalar.C a q) =>+      (Int -> a -> [a] -> [v] -> [v])+   -> Int+   -> a+   -> SigI.T a q a+   -> SigC.T y y' yv+   -> Rate.T t t' -> (SigC.T y y' yv)+higherOrderNoResoGen filt order ratio freq x =+   do freqs <- SigI.scalarSamples (toFrequencyScalar x) freq+      returnModified [SigP.sampleRate freq]+         (filt order ratio freqs) x++++universal :: (Trans.C a, Module.C a v, Field.C y', OccScalar.C a q) =>+      SigI.T a q a {- ^ signal for resonance,+                        i.e. factor of amplification at the resonance frequency+                        relatively to the transition band. -}+   -> SigI.T a q a {- ^ signal for cut off and band center frequency -}+   -> SigC.T y y' yv {- ^ input signal -}+   -> SigI.Process a q (v,v,v) {- ^ highpass, bandpass, lowpass filter -}+universal reso freq x =+   do resos <- SigI.scalarSamples (Process.exprToScalar) reso+      freqs <- SigI.scalarSamples (toFrequencyScalar x) freq+      let params =+             map FiltR.uniFilterParam+                 (zipWith FiltR.Pole resos freqs)+      returnModified [SigP.sampleRate reso, SigP.sampleRate freq]+         (FiltR.uniFilter params) x++moogLowpass :: (Trans.C a, Module.C a v, Field.C y', OccScalar.C a q) =>+      Int+   -> SigI.T a q a {- ^ signal for resonance,+                        i.e. factor of amplification at the resonance frequency+                        relatively to the transition band. -}+   -> SigI.T a q a {- ^ signal for cut off and band center frequency -}+   -> SigC.T y y' yv+   -> Rate.T t t' -> (SigC.T y y' yv)+moogLowpass order reso freq x =+   do resos <- SigI.scalarSamples (Process.exprToScalar) reso+      freqs <- SigI.scalarSamples (toFrequencyScalar x) freq+      let params =+             map (Moog.parameter order)+                 (zipWith FiltR.Pole resos freqs)+      returnModified [SigP.sampleRate reso, SigP.sampleRate freq]+         (Moog.lowpass order params) x++allpassCascade :: (Trans.C a, Module.C a v, Field.C y', OccScalar.C a q) =>+      Int          {- ^ order, number of filters in the cascade -}+   -> a            {- ^ the phase shift to be achieved for the given frequency -}+   -> SigI.T a q a {- ^ lowest comb frequency -}+   -> SigC.T y y' yv+   -> Rate.T t t' -> (SigC.T y y' yv)+allpassCascade order phase freq x =+   do freqs <- SigI.scalarSamples (toFrequencyScalar x) freq+      let params = map (FiltR.allpassCascadeParam order phase) freqs+      returnModified [SigP.sampleRate freq]+         (FiltR.allpassCascade order params) x+-}++++{- | Infinitely many equi-delayed exponentially decaying echos. -}+comb :: (RealField.C t, Ring.C t', OccScalar.C t t', Module.C y yv) =>+   t' -> y -> Rate.T t t' -> SigC.T y y' yv -> SigC.T y y' yv+comb time gain sr x =+   SigC.Cons (SigC.amplitude x)+      (Comb.run (round (toTimeScalar sr time)) gain (SigC.samples x))+++integrate :: (Additive.C v, Field.C q') =>+      Rate.T t q'+   -> SigC.T y q' v+   -> SigC.T y q' v+integrate sr x =+   SigC.Cons+      (SigC.amplitude x / Rate.toNumber sr)+      (Integrate.run (SigC.samples x))+++{-+returnModified :: (Eq q) =>+   [Process.Value q] -> ([v] -> [w]) -> SigC.T y y' yv -> SigI.Process a q w+returnModified sampleRates proc x =+   do let sampleRate = SigP.sampleRate x+      mapM_ (Process.equalValue sampleRate) sampleRates+      SigI.returnCons+         sampleRate (SigP.amplitude x)+         (proc (SigP.samples x))+-}
+ src/Synthesizer/SampleRateContext/Noise.hs view
@@ -0,0 +1,137 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++-}+module Synthesizer.SampleRateContext.Noise+  (white,    whiteBandEnergy,    randomPeeks,+   whiteGen, whiteBandEnergyGen, randomPeeksGen,+   ) where+++import qualified Synthesizer.Plain.Noise as Noise++import qualified Synthesizer.SampleRateContext.Signal as SigC+import qualified Synthesizer.SampleRateContext.Rate as Rate++import qualified Algebra.OccasionallyScalar as OccScalar+import qualified Algebra.Algebraic          as Algebraic+import qualified Algebra.Field              as Field+import qualified Algebra.Ring               as Ring++import System.Random (Random, RandomGen, randomRs, mkStdGen)++import NumericPrelude+import PreludeBase as P++++{- |+Uniformly distributed white noise.+The volume is given by two values:+The width of a frequency band and the volume caused by it.+The width of a frequency band must be given+in order to achieve independence from sample rate.++See 'whiteBandEnergy'.+-}+white :: (Ring.C yv, Random yv, Algebraic.C q') =>+      q'  {-^ width of the frequency band -}+   -> q'  {-^ volume caused by the given frequency band -}+   -> Rate.T t q' -> SigC.T y q' yv+          {-^ noise -}+white = whiteGen (mkStdGen 6746)++whiteGen :: (Ring.C yv, Random yv, RandomGen g, Algebraic.C q') =>+      g   {-^ random generator, can be used to choose a seed -}+   -> q'  {-^ width of the frequency band -}+   -> q'  {-^ volume caused by the given frequency band -}+   -> Rate.T t q' -> SigC.T y q' yv+         {-^ noise -}+whiteGen gen bandWidth volume sr =+   SigC.Cons+      (sqrt (3 * bandWidth / Rate.toNumber sr) * volume)+      (Noise.whiteGen gen)+++{-|+Uniformly distributed white noise.+Instead of an amplitude you must specify a value+that is like an energy per frequency band.+It makes no sense to specify an amplitude+because if you keep the same signal amplitude+while increasing the sample rate by a factor of four+the amplitude of the frequency spectrum halves.+Thus deep frequencies would be damped+when higher frequencies enter.++Example:+If your signal is a function from time to voltage,+the amplitude must have the unit @volt^2*second@,+which can be also viewed as @volt^2\/hertz@.++Note that the energy is proportional to the square of the signal amplitude.+In order to double the noise amplitude,+you must increase the energy by a factor of four.++Using this notion of amplitude+the behaviour amongst several frequency filters+is quite consistent but a problem remains:+When the noise is quantised+then noise at low sample rates and noise at high sample rates+behave considerably different.+This indicates that quantisation should not just pick values,+but it should average over the hold periods.+-}+whiteBandEnergy :: (Ring.C yv, Random yv, Algebraic.C q') =>+      q'  {-^ energy per frequency band -}+   -> Rate.T t q' -> SigC.T y q' yv+          {-^ noise -}+whiteBandEnergy = whiteBandEnergyGen (mkStdGen 6746)++whiteBandEnergyGen :: (Ring.C yv, Random yv, RandomGen g, Algebraic.C q') =>+      g   {-^ random generator, can be used to choose a seed -}+   -> q'  {-^ energy per frequency band -}+   -> Rate.T t q' -> SigC.T y q' yv+         {-^ noise -}+whiteBandEnergyGen gen energy sr =+   SigC.Cons (sqrt (3 * Rate.toNumber sr * energy)) (Noise.whiteGen gen)+++{-+The Field.C q constraint could be lifted to Ring.C+if we would use direct division instead of toFrequencyScalar.+-}+randomPeeks ::+   (Field.C q, Random q, Ord q,+    Field.C q', OccScalar.C q q') =>+       Rate.T q q'+    -> SigC.T q q' q  {- ^ momentary densities (frequency),+                           @p@ means that there is about one peak+                           in the time range of @1\/p@. -}+    -> [Bool]+                      {- ^ Every occurence of 'True' represents a peak. -}+randomPeeks =+   randomPeeksGen (mkStdGen 876)++randomPeeksGen ::+   (Field.C q, Random q, Ord q,+    Field.C q', OccScalar.C q q',+    RandomGen g) =>+       g  {-^ random generator, can be used to choose a seed -}+    -> Rate.T q q'+    -> SigC.T q q' q  {- ^ momentary densities (frequency),+                           @p@ means that there is about one peak+                           in the time range of @1\/p@. -}+    -> [Bool]+                      {- ^ Every occurence of 'True' represents a peak. -}+randomPeeksGen g sr dens =+   let amp = SigC.toFrequencyScalar sr (SigC.amplitude dens)+   in  zipWith (<)+          (randomRs (0, recip amp) g)+          (SigC.samples dens)
+ src/Synthesizer/SampleRateContext/Oscillator.hs view
@@ -0,0 +1,89 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes++-}+module Synthesizer.SampleRateContext.Oscillator (+   {- * Oscillators with constant waveforms -}+   static,+   freqMod,+   phaseMod,+   phaseFreqMod,+) where++import qualified Synthesizer.Plain.Oscillator as Osci+import qualified Synthesizer.Basic.Wave       as Wave+-- import qualified Synthesizer.Basic.Phase      as Phase++import qualified Synthesizer.SampleRateContext.Signal as SigC+import qualified Synthesizer.SampleRateContext.Rate   as Rate+import Synthesizer.SampleRateContext.Signal (toFrequencyScalar)++import qualified Algebra.OccasionallyScalar as OccScalar+import qualified Algebra.RealField          as RealField+import qualified Algebra.Field              as Field++-- import NumericPrelude+import PreludeBase as P+++{- * Oscillators with constant waveforms -}++{- | oscillator with a functional waveform with constant frequency -}+static :: (RealField.C t, Field.C t', OccScalar.C t t') =>+      Wave.T t yv  {- ^ waveform -}+   -> y'           {- ^ amplitude -}+   -> t            {- ^ start phase from the range [0,1] -}+   -> t'           {- ^ frequency -}+   -> Rate.T t t'+   -> SigC.T y y' yv+static wave amplitude phase freq' sr =+   let freq = toFrequencyScalar sr freq'+   in  SigC.Cons amplitude (Osci.static wave phase freq)++{- | oscillator with a functional waveform with modulated frequency -}+freqMod :: (RealField.C t, Field.C t', OccScalar.C t t') =>+      Wave.T t yv  {- ^ waveform -}+   -> y'           {- ^ amplitude -}+   -> t            {- ^ start phase from the range [0,1] -}+   -> Rate.T t t'+   -> SigC.T t t' t  {- ^ frequency control -}+   -> SigC.T y y' yv+freqMod wave amplitude phase sr xs =+   let freqs = SigC.scalarSamples (toFrequencyScalar sr) xs+   in  SigC.Cons amplitude+          (Osci.freqMod wave phase freqs)++{- | oscillator with modulated phase -}+phaseMod :: (RealField.C t, Field.C t', OccScalar.C t t') =>+      Wave.T t yv  {- ^ waveform -}+   -> y'           {- ^ amplitude -}+   -> t'           {- ^ frequency control -}+   -> Rate.T t t'+   -> SigC.T t t  t  {- ^ phase modulation, phases must have no unit and+                          are from range [0,1] -}+   -> SigC.T y y' yv+phaseMod wave amplitude freq' sr xs =+   let freq = toFrequencyScalar sr freq'+       phases = SigC.scalarSamples id xs+   in  SigC.Cons amplitude+          (Osci.phaseMod wave freq phases)++{- | oscillator with a functional waveform with modulated phase and frequency -}+phaseFreqMod :: (RealField.C t, Field.C t', OccScalar.C t t') =>+      Wave.T t yv  {- ^ waveform -}+   -> y'           {- ^ amplitude -}+   -> Rate.T t t'+   -> SigC.T t t  t  {- ^ phase control -}+   -> SigC.T t t' t  {- ^ frequency control -}+   -> SigC.T y y' yv+phaseFreqMod wave amplitude sr xs ys =+   let phases = SigC.scalarSamples id xs+       freqs  = SigC.scalarSamples (toFrequencyScalar sr) ys+   in  SigC.Cons amplitude+          (Osci.phaseFreqMod wave phases freqs)
+ src/Synthesizer/SampleRateContext/Play.hs view
@@ -0,0 +1,22 @@+module Synthesizer.SampleRateContext.Play where++import qualified BinarySample as BinSmp++import qualified Synthesizer.SampleRateContext.Signal as SigC+import qualified Synthesizer.SampleRateContext.Rate   as Rate+import qualified Synthesizer.Physical.Signal         as SigP+import qualified Synthesizer.Physical.Play           as PlayP++import qualified Algebra.OccasionallyScalar as OccScalar+import qualified Algebra.VectorSpace        as VectorSpace+import qualified Algebra.RealField          as RealField+import qualified Algebra.Field              as Field+++auto :: (RealField.C t, BinSmp.C yv,+         Field.C t', OccScalar.C t t',+         Field.C y', OccScalar.C y y',+         VectorSpace.C y yv) =>+   t' -> y' -> t' -> (Rate.T t t' -> SigC.T y y' yv) -> IO ()+auto freqUnit amp sampleRate proc =+   PlayP.auto freqUnit amp (SigP.runPlain sampleRate proc)
+ src/Synthesizer/SampleRateContext/Rate.hs view
@@ -0,0 +1,68 @@+{- |++Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes (OccasionallyScalar)++++Light-weight sample parameter inference which will fit most needs.+We only do \"poor man's inference\", only for sample rates.+The sample rate will be provided as an argument of a special type 'T'.+This argument will almost never be passed explicitly+but handled operators analogous to '($)' and '(.)'.++In contrast to the run-time inference approach,+we have the static guarantee that the sample rate is fixed+before passing a signal to the outside world.+-}+module Synthesizer.SampleRateContext.Rate (+      T(..),+      fromNumber, toNumber,+      loop, pure,+      ($:), ($::), ($^), ($#),+      (.:), (.^),+      liftP, liftP2, liftP3, liftP4,+   ) where++import Synthesizer.ApplicativeUtility++{-+import NumericPrelude+import PreludeBase as P+-}+++{- |+This wraps a function which computes a sample rate dependent result.+Sample rate tells how many values per unit are stored+for representation of a signal.+-}+newtype T t t' = Cons {decons :: t'}+   deriving (Eq, Ord, Show)+++fromNumber :: t' -> T t t'+fromNumber = Cons++toNumber :: T t t' -> t'+toNumber = decons+++pure :: a -> T t t' -> a+pure = const+++{-+{- |+The first argument will be a function like 'Synthesizer.SampleRateContext.Signal.toTimeScalar'.+If you use this function instead of 'Synthesizer.SampleRateContext.Signal.toTimeScalar' directly,+the type @t@ can be automatically infered.+-}+convertTimeParam :: (t' -> t' -> t) -> t' -> (t -> a) -> T t t' -> a+convertTimeParam convert t' f = Cons $ \sr ->+   f (convert sr t')+-}
+ src/Synthesizer/SampleRateContext/Signal.hs view
@@ -0,0 +1,72 @@+{- |+Copyright   :  (c) Henning Thielemann 2008+License     :  GPL++Maintainer  :  synthesizer@henning-thielemann.de+Stability   :  provisional+Portability :  requires multi-parameter type classes (OccasionallyScalar)++For a description see "Synthesizer.SampleRateContext.Rate".+-}+module Synthesizer.SampleRateContext.Signal (+   T(..),+   toTimeScalar,+   toFrequencyScalar,+   toAmplitudeScalar,+   toGradientScalar,+   scalarSamples,+   vectorSamples,+   replaceAmplitude,+   replaceSamples,+   ($-),+   ) where++import Synthesizer.SampleRateContext.Rate (($:))+import qualified Synthesizer.SampleRateContext.Rate as Rate++import Synthesizer.Amplitude.Signal+import qualified Synthesizer.Amplitude.Control as CtrlV++import qualified Algebra.OccasionallyScalar as OccScalar+-- 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 Algebra.OccasionallyScalar (toScalar)++import NumericPrelude+-- import PreludeBase as P+import Prelude ()+++{-+returnCons ::+   y' -> [yv] -> Rate t t' (T y y' yv)+returnCons amp sig = Proc.pure (Cons amp sig)+-}+++toTimeScalar :: (Ring.C t', OccScalar.C t t') =>+   Rate.T t t' -> t' -> t+toTimeScalar sampleRate t =+   toScalar (t * Rate.toNumber sampleRate)++toFrequencyScalar :: (Field.C t', OccScalar.C t t') =>+   Rate.T t t' -> t' -> t+toFrequencyScalar sampleRate f =+   toScalar (f / Rate.toNumber sampleRate)++toGradientScalar :: (Field.C q', OccScalar.C q q') =>+   q' -> Rate.T q q' -> q' -> q+toGradientScalar amp sampleRate steepness =+   toFrequencyScalar sampleRate (steepness / amp)+++{- |+Take a scalar argument where a process expects a signal.+Only possible for non-negative values so far.+-}+($-) :: (Field.C y', Real.C y', OccScalar.C y y') =>+    (Rate.T t t' -> T y y' y -> a) -> y' -> (Rate.T t t' -> a)+($-) f x = f $: Rate.pure (CtrlV.constant x)
+ src/Synthesizer/State/Analysis.hs view
@@ -0,0 +1,362 @@+{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}+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 =+   maybe+      (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)+   . Sig.viewL+++++{- * 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 xs =+   scalarProduct (Sig.iterate (one+) zero) xs / Sig.sum xs++{-+centroidAlt :: Field.C y => Sig.T y -> y+centroidAlt xs =+   Sig.sum (scanr (+) zero (tail xs)) / sum xs+-}+++{-# INLINE average #-}+average :: Field.C y => Sig.T y -> y+average 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,250 @@+{-# OPTIONS_GHC -O2 -fglasgow-exts -fno-implicit-prelude #-}+{- |+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 Data.List (zipWith4, tails)+-- import NumericPrelude.List (iterateAssoc)++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))+++-- * 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.iterateAssoc op d))++{-# INLINE curveMultiscaleNeutral #-}+curveMultiscaleNeutral :: (y -> y -> y) -> y -> y -> Sig.T y+curveMultiscaleNeutral op d neutral =+   Sig.cons neutral (Sig.iterateAssoc op d)
+ src/Synthesizer/State/Cut.hs view
@@ -0,0 +1,157 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+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 Synthesizer.Utility (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.mixStep (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 @@+{-# OPTIONS -fno-implicit-prelude #-}+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,67 @@+{-# OPTIONS -fno-implicit-prelude #-}+module Synthesizer.State.Filter.Delay where++import qualified Synthesizer.State.Interpolation as Interpolation+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 = Interpolation.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 -> Interpolation.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,290 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+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 Synthesizer.Utility (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+-}+{-# 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,68 @@+{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}+{- |+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,45 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+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 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 (+)++{- other quadrature methods may follow -}
+ src/Synthesizer/State/Filter/Recursive/MovingAverage.hs view
@@ -0,0 +1,183 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+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 $ viewListL++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 () (viewListL 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,282 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+ToDo:+use AffineSpace instead of Module for the particular interpolation types,+since affine combinations assert reconstruction of constant functions.+They are more natural for interpolation of internal control parameters.+However, how can cubic interpolation expressed by affine combinations+without divisions?+-}+module Synthesizer.State.Interpolation where++import qualified Synthesizer.State.Signal  as Sig+import qualified Synthesizer.Plain.Control as Ctrl++import qualified Synthesizer.Generic.Interpolation as InterpolationG+import qualified Synthesizer.Generic.Signal as SigG+import qualified Synthesizer.Generic.SampledValue as Sample++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 Data.Maybe (fromMaybe)++import Control.Monad.State (StateT(StateT), evalStateT, ap, )+import Control.Applicative (Applicative(pure, (<*>)), (<$>), liftA2, )+import Synthesizer.ApplicativeUtility (liftA4, )+import Synthesizer.Utility (affineComb, )++import PreludeBase+import NumericPrelude+++++{- | interpolation as needed for resampling -}+data T t y =+  Cons {+    number :: Int,  -- interpolation requires a total number of 'number'+    offset :: Int,  -- interpolation requires 'offset' values before the current+    func   :: t -> Sig.T y -> y+  }+++{-# INLINE toGeneric #-}+toGeneric ::+   (Sample.C y, SigG.C sig) =>+   T t y -> InterpolationG.T sig t y+toGeneric ip =+   InterpolationG.Cons {+      InterpolationG.number = number ip,+      InterpolationG.offset = offset ip,+      InterpolationG.func = \ t x -> func ip t (Sig.fromGenericSignal x)+   }++++{-* 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])+-}++++{-* Different kinds of interpolation -}++{-** Hard-wired interpolations -}++data PrefixReader y a =+   PrefixReader Int (StateT (Sig.T y) Maybe a)++instance Functor (PrefixReader y) where+   fmap f (PrefixReader count parser) =+      PrefixReader count (fmap f parser)++instance Applicative (PrefixReader y) where+   pure = PrefixReader 0 . return+   (PrefixReader count0 parser0) <*> (PrefixReader count1 parser1) =+       PrefixReader (count0+count1) (parser0 `ap` parser1)++{-# INLINE getNode #-}+getNode :: PrefixReader y y+getNode = PrefixReader 1 (StateT Sig.viewL)++{-# INLINE fromPrefixReader #-}+fromPrefixReader :: String -> Int -> PrefixReader y (t -> y) -> T t y+fromPrefixReader name off (PrefixReader count parser) =+   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)++{-| 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)++{-# 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 steepness 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]+-}+++{-* 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 @@+{-# OPTIONS -fno-implicit-prelude #-}+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 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- | 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 @@+{-# OPTIONS -fno-implicit-prelude #-}+{- |+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,139 @@+{-# OPTIONS_GHC -O2 -fno-implicit-prelude #-}+{- |+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.State.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)++++{- * 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,712 @@+{-# OPTIONS_GHC -O -fglasgow-exts -fno-implicit-prelude #-}+{- glasgow-exts are for higher rank types -}+module Synthesizer.State.Signal where++import qualified Synthesizer.Generic.Signal as SigG+import qualified Synthesizer.Generic.SampledValue as Sample++-- 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.State+          (State, runState, StateT(StateT), runStateT, liftM2, )+import Control.Monad (Monad, mplus, msum,+           (>>), (>>=), fail, return, (=<<),+           Functor, fmap, )++import qualified Synthesizer.Storable.Signal as SigSt+import Foreign.Storable (Storable)++import Synthesizer.Utility+   (viewListL, mapFst, mapSnd, mapPair, fst3, snd3, thd3, nest, )++import NumericPrelude.Condition (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+++instance SigG.C T where+   empty = empty+   null = null+   cons = cons+   fromList = fromList+   toList = toList+   repeat = repeat+   cycle = cycle+   replicate = replicate+   iterate = iterate+   iterateAssoc op x = iterate (op x) x -- should be optimized+   unfoldR = generate+   map = map+   mix = mix+   zipWith = zipWith+   scanL = scanL+   viewL = viewL+   viewR = viewR+   foldL = foldL+   length = length+   take = take+   drop = drop+   splitAt = splitAt+   dropMarginRem = dropMarginRem+   takeWhile = takeWhile+   dropWhile = dropWhile+   span = span+   append = append+   concat = concat+   reverse = reverse+{-+   mapAccumL = mapAccumL+   mapAccumR = mapAccumR+-}+   crochetL = crochetL+++++{-# 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 viewListL++{-# INLINE toList #-}+toList :: T y -> [y]+toList (Cons f x0) =+   List.unfoldr (runStateT f) x0+++{-# INLINE fromGenericSignal #-}+fromGenericSignal ::+   (Sample.C a, SigG.C sig) =>+   sig a -> T a+fromGenericSignal =+   generate SigG.viewL++{-# INLINE toGenericSignal #-}+toGenericSignal ::+   (Sample.C a, SigG.C sig) =>+   T a -> sig a+toGenericSignal (Cons f a) =+   SigG.unfoldR (runStateT f) a+++{-# 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++++{-# INLINE iterate #-}+iterate :: (a -> a) -> a -> T a+iterate f = generateInfinite (\x -> (x, f x))++{-# INLINE iterateAssoc #-}+iterateAssoc :: (a -> a -> a) -> a -> T a+iterateAssoc 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, ())) ()+++{-# 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 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 =+   curry (unfoldR mixStep)+++mixStep :: (Additive.C a) =>+   (T a, T a) -> Maybe (a, (T a, T a))+mixStep (xt,yt) =+   case (viewL xt, viewL yt) of+      (Just (x,xs), Just (y,ys)) -> Just (x Additive.+ y, (xs,ys))+      (Nothing,     Just (y,ys)) -> Just (y,   (xt,ys))+      (Just (x,xs), Nothing)     -> Just (x,   (xs,yt))+      (Nothing,     Nothing)     -> Nothing+++{-# 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 -> viewListL 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 "FusionList.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 "FusionList.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)))++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
+ src/Synthesizer/Storable/Cut.hs view
@@ -0,0 +1,74 @@+module Synthesizer.Storable.Cut where++import qualified Synthesizer.Storable.Signal as Sig++import qualified Data.EventList.Relative.TimeBody as EventList+import Control.Monad.State (runState, modify, gets, put, )+import Synthesizer.Utility (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+++{-# 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
+ src/Synthesizer/Storable/Filter/Recursive/Comb.hs view
@@ -0,0 +1,90 @@+{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-}+{- |+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.++We cannot generalize this to "Synthesizer.Generic.Signal"+since we need control over the chunk size.+-}+module Synthesizer.Storable.Filter.Recursive.Comb where++import qualified Synthesizer.Storable.Signal as Sig+import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1++import qualified Synthesizer.Generic.Signal as SigG+import qualified Synthesizer.Generic.SampledValue as Sample++-- import qualified Synthesizer.Storable.Filter.Delay as Delay++import Foreign.Storable (Storable)++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, Sample.C v) =>+   Filt1.Parameter a -> Sig.T v -> Sig.T v+karplusStrong c wave =+   Sig.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 a v, Storable v) =>+   Int -> a -> Sig.T v -> Sig.T v+run time gain =+   Sig.delayLoopOverlap time (amplify gain)++{- |+Echos of different delays.+Chunk size must be smaller than all of the delay times.+-}+{-# INLINE runMulti #-}+runMulti :: (Ring.C a, Module.C a v, Storable v) =>+   [Int] -> a -> Sig.T v -> Sig.T v+runMulti times gain x =+    let y = foldl+               (Sig.zipWith (+)) x+               (map (flip (Sig.delay Sig.defaultChunkSize zero) (amplify 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 v, Storable v) =>+   Int -> (Sig.T v -> Sig.T v) -> Sig.T v -> Sig.T v+runProc = Sig.delayLoopOverlap+++{-# INLINE amplify #-}+amplify :: (Storable v, Module.C a v) =>+   a -> Sig.T v -> Sig.T v+amplify gain = Sig.map (gain *>)
+ src/Synthesizer/Storable/Oscillator.hs view
@@ -0,0 +1,157 @@+{-# OPTIONS_GHC -O2 -fno-implicit-prelude #-}+{- |+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,1318 @@+{- OPTIONS_GHC -O2 -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.span,+      Vector.append,+      Vector.concat,+      Vector.span,+      Vector.splitAt,+      Vector.viewL,+      Vector.viewR,+      Vector.switchL,+      Vector.unfoldr,+      Vector.reverse,+      -- for Dimensional.File+      Vector.writeFile,+      -- for Storable.Cut+      splitAtPad,+      -- 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,+   ) where++-- import qualified Sound.Signal as Signal++import qualified Synthesizer.Generic.Signal as SigG+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 qualified Data.Char as Char+-- import Data.Int (Int8)++import Data.StorableVector(Vector)+import Foreign.Storable (Storable)+import Foreign.Ptr (minusPtr)+import Foreign.ForeignPtr (withForeignPtr)+import Foreign.Marshal (advancePtr)+import StorableInstance ()++-- 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 NumericPrelude.Condition (toMaybe)+import NumericPrelude.List (sliceVert, dropWhileRev, )++import Synthesizer.Utility (viewListL, viewListR, nest, mapFst, mapSnd, mapPair)++-- import qualified Algebra.Additive as Additive+++import System.IO (openBinaryFile, hClose, hPutBuf, IOMode(WriteMode), Handle)+import Control.Exception (bracket)+++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++instance SigG.C Vector.Vector where+   {-# INLINE empty #-}+   empty = Vector.empty+   {-# INLINE null #-}+   null = Vector.null+   {-# INLINE cons #-}+   cons = Vector.cons+   {-# INLINE fromList #-}+   fromList = Vector.pack defaultChunkSize+   {-# INLINE toList #-}+   toList = Vector.unpack+   {-# INLINE repeat #-}+   repeat = Vector.repeat defaultChunkSize+   {-# INLINE cycle #-}+   cycle = Vector.cycle+   {-# INLINE replicate #-}+   replicate = Vector.replicate defaultChunkSize+   {-# INLINE iterate #-}+   iterate = Vector.iterate defaultChunkSize+   {-# INLINE iterateAssoc #-}+   iterateAssoc op x = Vector.iterate defaultChunkSize (op x) x -- should be optimized+   {-# INLINE unfoldR #-}+   unfoldR = Vector.unfoldr defaultChunkSize+   {-# INLINE map #-}+   map = Vector.map+   {-# INLINE mix #-}+   mix = mix+   {-# INLINE zipWith #-}+   zipWith = Vector.zipWith+   {-# INLINE scanL #-}+   scanL = Vector.scanl+   {-# INLINE viewL #-}+   viewL = Vector.viewL+   {-# INLINE viewR #-}+   viewR = Vector.viewR+   {-# INLINE foldL #-}+   foldL = Vector.foldl+   {-# INLINE length #-}+   length = Vector.length+   {-# INLINE take #-}+   take = Vector.take+   {-# INLINE drop #-}+   drop = Vector.drop+   {-# INLINE splitAt #-}+   splitAt = Vector.splitAt+   {-# INLINE dropMarginRem #-}+   dropMarginRem = Vector.dropMarginRem  -- can occur in an inner loop in Interpolation+   {-# INLINE takeWhile #-}+   takeWhile = Vector.takeWhile+   {-# INLINE dropWhile #-}+   dropWhile = Vector.dropWhile+   {-# INLINE span #-}+   span = Vector.span+   {-# INLINE append #-}+   append = Vector.append+   {-# INLINE concat #-}+   concat = Vector.concat+   {-# INLINE reverse #-}+   reverse = Vector.reverse+{-+   {-# INLINE mapAccumL #-}+   mapAccumL = Vector.mapAccumL+   {-# INLINE mapAccumR #-}+   mapAccumR = Vector.mapAccumR+-}+   {-# INLINE crochetL #-}+   crochetL = Vector.crochetL+++{-+{- * 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 recurse i acc =+          if i < Vector.length x+            then (acc, True)+            else+               maybe+                  (acc, False)+                  (recurse (succ i))+                  (f (Vector.index x i) acc)+   in  recurse 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) <- viewListL 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) <- viewListL (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) <- viewListR (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) <- viewListL 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 viewListL++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 recurse acc xt =+          case xt of+             [] -> acc+             (x:xs) ->+                 let (acc',continue) = reduceLVector f acc x+                 in  if continue+                       then recurse acc' xs+                       else acc'+   in  recurse 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 recurse _ [] = ([], [])+       recurse 0 xs = ([], xs)+       recurse n (x:xs) =+          let m = Vector.length x+          in  if m<=n+                then mapFst (x:) $ recurse (n-m) xs+                else mapPair ((:[]), (:xs)) $ Vector.splitAt n x+   in  mapPair (Cons, Cons) . recurse 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 recurse [] = ([],[])+       recurse (x:xs) =+          let (y,z) = Vector.span p x+          in  if Vector.null z+                then mapFst (x:) (recurse xs)+                else (decons $ fromChunk y, (z:xs))+   in  mapPair (Cons, Cons) . recurse . 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 recurse n xt =+          if n<=0+            then xt+            else+              case xt of+                 [] -> decons $ replicate size n y+                 x:xs -> x : recurse (n - Vector.length x) xs+   in  Cons . recurse 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) #-}+{-# INLINE mix #-}+{-+'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 xs ys =+   let len = min (lazyLength xs) (lazyLength ys) :: Chunky.T NonNeg.Int+       (prefixX,suffixX) = genericSplitAt len xs+       (prefixY,suffixY) = genericSplitAt len ys+   in  Vector.append+          (Vector.crochetL+              (\y xs0 ->+                  fmap (mapFst (y+)) (Vector.viewL xs0))+              prefixX prefixY)+          (if Vector.null suffixX+             then suffixY+             else suffixX)+{-+List.map V.unpack $ Vector.chunks $ mix (fromList defaultChunkSize [1,2,3,4,5::P.Double]) (fromList defaultChunkSize [1,2,3,4])+-}+++{-+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 recurse n xs0 =+          maybe+             ([], [])+             (\(x,xs) ->+                if isZero n+                  then ([], xs0)+                  else+                    let m = fromIntegral $ V.length x+                    in  if m<=n+                          then mapFst (x:) $ recurse (n-m) xs+                          else mapPair ((:[]), (:xs)) $+                               V.splitAt (fromInteger $ toInteger n) x)+           $ viewListL xs0+   in  mapPair (Vector.SV, Vector.SV) . recurse n0 . Vector.chunks+++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 the like. -}+   -> 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 recurse n a =+          maybe n (recurse (succ n) . snd) (f a)+   in  recurse 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.recurse (\(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) . viewListL)++{-# 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/Utility.hs view
@@ -0,0 +1,129 @@+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+++{-# INLINE viewListL #-}+viewListL :: [a] -> Maybe (a, [a])+viewListL [] = Nothing+viewListL (x:xs) = Just (x,xs)++-- for constant padding+{-# INLINE viewListR #-}+viewListR :: [a] -> Maybe ([a], a)+viewListR =+   foldr (\x -> Just . maybe ([],x) (mapFst (x:))) Nothing++{-|+Apply the function @f@ n times to the start value.++You can express that function using ++> nest n f x = (iterate f x) !! n+> nest n f = foldl (.) id (replicate n f)++but this is not as elegant as calling @nest@.+Simon Thompson calls it @iter@.+-}+{-# INLINE nest #-}+nest :: Int -> (a -> a) -> a -> a+nest 0 _ x = x+nest n f x = f (nest (n-1) f x)+++-- see event-list package+-- | Control.Arrow.***+{-# INLINE mapPair #-}+mapPair :: (a -> c, b -> d) -> (a,b) -> (c,d)+mapPair ~(f,g) ~(x,y) = (f x, g y)++-- | Control.Arrow.first+{-# INLINE mapFst #-}+mapFst :: (a -> c) -> (a,b) -> (c,b)+mapFst f ~(x,y) = (f x, y)++-- | Control.Arrow.second+{-# INLINE mapSnd #-}+mapSnd :: (b -> d) -> (a,b) -> (a,d)+mapSnd g ~(x,y) = (x, g y)+++{-# INLINE fst3 #-}+fst3 :: (a,b,c) -> a+fst3 (a,_,_) = a++{-# INLINE snd3 #-}+snd3 :: (a,b,c) -> b+snd3 (_,b,_) = b++{-# INLINE thd3 #-}+thd3 :: (a,b,c) -> c+thd3 (_,_,c) = c+++{-# INLINE swap #-}+swap :: (a,b) -> (b,a)+swap (x,y) = (y,x)+++{-|+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)+++{-# INLINE clip #-}+clip :: Ord a => a -> a -> a -> a+clip lower upper = max lower . min upper
+ src/Test/Main.hs view
@@ -0,0 +1,26 @@+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.ToneModulation as ToneModulation+import qualified Test.Sound.Synthesizer.Plain.Wave           as Wave++prefix :: String -> [(String, IO ())] -> [(String, IO ())]+prefix msg =+   map (\(str,test) -> (msg ++ "." ++ str, test))++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.ToneModulation" ToneModulation.tests :+      prefix "Plain.Wave"           Wave.tests :+      []
+ 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,87 @@+module Test.Sound.Synthesizer.Plain.Interpolation+   (T, ip,+    LinePreserving, lpIp,+    tests) where++import qualified Synthesizer.Plain.Interpolation as Interpolation++import Test.QuickCheck (test, Arbitrary(..), elements, {- Property, (==>), -} )+-- 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 Test.Utility (equalList)+++import NumericPrelude+import PreludeBase+import Prelude ()+++++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, Module.C a v) => Arbitrary (T a v) where+   arbitrary = elements $+      Cons "constant" Interpolation.constant :+      Cons "linear"   Interpolation.linear :+      Cons "cubic"    Interpolation.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, Module.C a v) => Arbitrary (LinePreserving a v) where+   arbitrary = elements $+      LPCons "linear"   Interpolation.linear :+      LPCons "cubic"    Interpolation.cubic :+      []+   coarbitrary = undefined++++constant :: (Module.C a v, Eq v) => a -> v -> [v] -> Bool+constant t x0 xs =+   equalList $ map ($(x0:xs)) $ map ($t) $+      Interpolation.func Interpolation.constant :+      Interpolation.func Interpolation.piecewiseConstant :+      []++linear :: (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 Interpolation.linear :+      Interpolation.func Interpolation.piecewiseLinear :+      []++cubic :: (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 Interpolation.cubic :+      Interpolation.func Interpolation.cubicAlt :+      Interpolation.func Interpolation.piecewiseCubic :+      []++++tests :: [(String, IO ())]+tests =+   ("constant", test (\t x -> constant (t::Rational) (x::Rational))) :+   ("linear",   test (\t x -> linear   (t::Rational) (x::Rational))) :+   ("cubic",    test (\t x -> cubic    (t::Rational) (x::Rational))) :+   []
+ 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,490 @@+module Test.Sound.Synthesizer.Plain.ToneModulation (tests) where++import qualified Synthesizer.Plain.Oscillator     as Osci+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.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 Synthesizer.Utility (clip, mapPair, )+import qualified Data.List as List+++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+++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 (ToneMod.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 (ToneMod.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 (ToneMod.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) == ToneMod.limitMinRelativeValues 0 x0 xs++limitMaxRelativeValuesIdentity ::+   Chunky.T NonNeg.Int -> [Chunky.T NonNeg.Int] -> Bool+limitMaxRelativeValuesIdentity x0 xs =+   let inf = 1 + inf+   in  (x0,xs) == ToneMod.limitMaxRelativeValues inf x0 xs++limitMaxRelativeValuesNonNegIdentity ::+   Chunky.T NonNeg.Int -> [Chunky.T NonNeg.Int] -> Bool+limitMaxRelativeValuesNonNegIdentity x0 xs =+   let inf = 1 + inf+   in  (x0,xs) == ToneMod.limitMaxRelativeValuesNonNeg inf x0 xs++limitMaxRelativeValuesInfinity ::+   Chunky.T NonNeg.Int -> (Chunky.T NonNeg.Int, [Chunky.T NonNeg.Int]) -> Bool+limitMaxRelativeValuesInfinity x0 (x,xs) =+   let inf = 1 + inf+       ys = cycle (x:xs)+       (z0,zs) = ToneMod.limitMaxRelativeValues inf x0 ys+   in  (x0, take 100 ys) == (z0, take 100 zs)++limitMaxRelativeValuesNonNegInfinity ::+   Chunky.T NonNeg.Int -> (Chunky.T NonNeg.Int, [Chunky.T NonNeg.Int]) -> Bool+limitMaxRelativeValuesNonNegInfinity x0 (x,xs) =+   let inf = 1 + inf+       ys = cycle (x:xs)+       (z0,zs) = ToneMod.limitMaxRelativeValuesNonNeg inf x0 ys+   in  (x0, take 100 ys) == (z0, take 100 zs)+++dropRem :: Eq a => Int -> [a] -> Bool+dropRem n xs =+   let n1 = abs n+   in  map (flip ToneMod.dropRem xs) [0 .. n1 + length xs] ==+       map ((,) 0) (List.tails xs) ++ map (flip (,) []) [1..n1]+++withInterpolation ::+   (Interpolation.T a v -> x) ->+   (InterpolationTest.T a v -> x)+withInterpolation f ipt =+   f (InterpolationTest.ip ipt)++withLPInterpolation ::+   (Interpolation.T a v -> x) ->+   (InterpolationTest.LinePreserving a v -> x)+withLPInterpolation f ipt =+   f (InterpolationTest.lpIp ipt)++withInterpolation2 ::+   (Interpolation.T a v ->+    Interpolation.T a v -> x) ->+   (InterpolationTest.T a v ->+    InterpolationTest.T a v -> x)+withInterpolation2 f =+   withInterpolation $ \ ipLeap ->+   withInterpolation $ \ ipStep ->+      f ipLeap ipStep++minLength ::+   Interpolation.T a v ->+   Interpolation.T a v ->+   Int -> NonNeg.Int -> Int+minLength ipLeap ipStep periodInt ext =+   Interpolation.number ipStep ++   Interpolation.number ipLeap * periodInt ++   NonNeg.toNumber ext++sampledTone :: (RealField.C a, Eq v) =>+   InterpolationTest.T a v ->+   InterpolationTest.T a v ->+   NonNeg.T a -> NonNeg.Int -> (v,[v]) -> a -> Phase.T a -> Property+sampledTone =+   withInterpolation2 $ \ ipLeap ipStep+         periodNN ext (x,xs) shape phase ->+   let period = NonNeg.toNumber periodNN+       len = minLength ipLeap ipStep (ceiling period) ext+       tone = take len (List.cycle (x:xs))+   in  period /= zero ==>+          Wave.sampledToneAlt ipLeap ipStep period tone shape `Wave.apply` phase ==+             Wave.sampledTone ipLeap ipStep period tone shape `Wave.apply` phase+++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+       len = minLength ipLeap ipStep (ceiling period) ext+       tone = take len (Osci.staticSine phase0 (recip period))+   in  abs (Wave.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+       len = minLength ipLeap ipStep (ceiling period) ext+       tone = take len (Osci.staticSine origPhase (recip period))+   in  all ((< ten ^- (-2)) . abs) $+       zipWith (-)+          (Osci.shapeFreqMod (Wave.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 =+   withLPInterpolation $ \ ipLeap ->+   withLPInterpolation $ \ ipStep ->+         \ periodNN ext (i,d) shape phase ->+   let period = NonNeg.toNumber periodNN+       len = minLength ipLeap ipStep (ceiling period) ext+       ramp = take len (List.iterate (d+) i)+       limits =+          mapPair (fromIntegral, fromIntegral) $+             ToneMod.shapeLimits ipLeap ipStep (round period) len+   in  period /= zero ==>+          -- should be (fraction phase), right?+          Wave.sampledTone ipLeap ipStep period ramp shape `Wave.apply` phase ==+             i + uncurry clip limits shape *> d+{-+let len=100; period=1/0.06::Double; ip = Interpolation.linear in GNUPlot.plotFuncs [] (GNUPlot.linearScale 1000 (0,fromIntegral len)) [\s -> Wave.sampledTone ip ip period (take len $ iterate (1+) (0::Double)) s 0, uncurry clip (mapPair (fromIntegral, fromIntegral) $ Wave.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 =+   withLPInterpolation $ \ 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) $+             ToneMod.shapeLimits ipLeap ipStep periodInt len+   in  periodInt /= zero ==>+          Wave.sampledTone ipLeap ipStep period stair shape `Wave.apply` zero ==+             i + uncurry clip 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 -> Wave.sampledTone ipl ipc period (concatMap (replicate periodInt) $ take rep $ iterate (period+) (0::Double)) s 0, uncurry clip (mapPair (fromIntegral, fromIntegral) $ Wave.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 ==>+          Wave.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 =+   withInterpolation2 $ \ 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 ==>+          Wave.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)) [Wave.sampledTone ip ip period (concat $ replicate 3 wave) 0.3, \phase -> Interpolation.cyclicPad Interpolation.single Interpolation.linear (phase*period) wave]+-}++++-- candidate for Utility+zapWith :: (a -> a -> b) -> [a] -> [b]+zapWith f xs = zipWith f xs (tail xs)++-- candidate for Utility+monotoniclyIncreasing :: Ord a => [a] -> Bool+monotoniclyIncreasing [] = True+monotoniclyIncreasing xs = and $ zapWith (<=) xs+++shapeFreqModFromSampledToneLimitIdentity :: (RealField.C t) =>+   InterpolationTest.T t y ->+   InterpolationTest.T t y ->+   NonNeg.Int -> (y,[y]) -> (t, [NonNeg.T t]) -> Bool+shapeFreqModFromSampledToneLimitIdentity =+   withInterpolation2 $ \ ipLeap ipStep+          periodIntNN (x,xs) (shape0,shapesNN) ->+   let periodInt = NonNeg.toNumber periodIntNN+       shapes = map NonNeg.toNumber shapesNN+       a =+          snd (ToneMod.limitRelativeShapes+             ipLeap ipStep periodInt (List.cycle (x:xs))+             (shape0, cycle (zero: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 =+          ToneMod.oscillatorCoords+             periodInt period+             (shape0, shapes) (phase, freqs)+   in  period /= zero  &&  periodInt /= zero  ==>+          all+             (\(skip,(k,(qShape,qWave))) ->+                  skip >= zero &&+                  monotoniclyIncreasing [negate periodInt, k, zero] &&+                  monotoniclyIncreasing [zero, qShape, one] &&+                  monotoniclyIncreasing [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)+             (ToneMod.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 -> (v,[v]) ->+   t -> t -> [NonNeg.T t] -> [t] ->+   Property+shapeFreqModFromSampledTone =+   withInterpolation2 $ \ ipLeap ipStep+         periodNN ext (x,xs) shape0 phase shapesNN freqs ->+   let shapes = map NonNeg.toNumber shapesNN+       period = NonNeg.toNumber periodNN+       len = minLength ipLeap ipStep (ceiling period) ext+       tone = take len (List.cycle (x:xs))+       resampledToneA =+          Osci.shapeFreqModFromSampledTone ipLeap ipStep period tone+             shape0 phase shapes freqs+       resampledToneB =+          Osci.shapeFreqMod+             (Wave.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 (Wave.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 (Wave.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 (Wave.sampledTone ipLeap ipStep period tone) 0 (scanl (+) shape0 shapes) (repeat 0), Osci.shapeFreqModFromSampledTone ipLeap ipStep period tone shape0 0 shapes (repeat 0)])+-}++oscillatorCells :: (RealField.C t, Eq v) =>+   InterpolationTest.T t v ->+   InterpolationTest.T t v ->+   NonNeg.T t ->+   NonNeg.Int -> (v,[v]) ->+   t -> t -> [NonNeg.T t] -> [t] ->+   Property+oscillatorCells =+   withInterpolation2 $ \ ipLeap ipStep+         periodNN ext (x,xs) shape0 phase shapesNN freqs ->+   let shapes = map NonNeg.toNumber shapesNN+       period = NonNeg.toNumber periodNN+       len = minLength ipLeap ipStep (ceiling period) ext+       tone = take len (List.cycle (x:xs))+       crop = cropCell ipLeap ipStep+       resampledToneA =+          ToneMod.oscillatorCells ipLeap ipStep period tone+             (shape0, shapes) (Phase.fromRepresentative phase, freqs)+       resampledToneB =+          Osci.shapeFreqMod+             (Wave.Cons . ToneMod.sampledToneCell+                (ToneMod.makePrototype ipLeap ipStep period tone))+             phase (scanl (+) shape0 shapes) freqs+   in  period /= zero  ==>+          map crop resampledToneA == map crop resampledToneB++cropCell ::+   Interpolation.T t v ->+   Interpolation.T t v ->+   ((t,t),[[v]]) -> ((t,t),[[v]])+cropCell ipLeap ipStep (q,cell) =+   (q,+      take (Interpolation.number ipStep) $+      map (take (Interpolation.number ipLeap)) $+      cell)+++shapeFreqModFromSampledToneIdentity :: (RealField.C t, Eq v) =>+   InterpolationTest.T t v ->+   InterpolationTest.T t v ->+   NonNeg.T t ->+   NonNeg.Int -> (v,[v]) ->+   Property+shapeFreqModFromSampledToneIdentity =+   withInterpolation2 $ \ ipLeap ipStep+          periodNN ext (x,xs) ->+   let period = NonNeg.toNumber periodNN+       len = minLength ipLeap ipStep (ceiling period) ext+       tone = take len (List.cycle (x:xs))+       shape0 = zero+       shapes = repeat one+       phase  = zero+       freqs  = repeat (recip period)+       (n0,n1) =+          ToneMod.shapeLimits ipLeap ipStep (round period) len++       resampledTone =+          Osci.shapeFreqModFromSampledTone ipLeap ipStep period tone+             shape0 phase shapes freqs+   in  period /= zero  ==>+          and (drop n0 (take (succ n1) (zipWith (==) resampledTone tone)))+++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))) :+   ("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 :: Int -> [Double] -> Bool)) :+   ("sampledTone",+      testRationalIp sampledTone) :+   ("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",+      testRationalIp shapeFreqModFromSampledToneLimitIdentity) :+   ("oscillatorCoords",+      test (\periodInt period ->+               oscillatorCoords+                  periodInt (period :: NonNeg.Rational))) :+   ("shapeFreqModFromSampledToneCoordsIdentity",+      test (\periodInt period ->+               shapeFreqModFromSampledToneCoordsIdentity+                  periodInt (period :: NonNeg.Rational))) :+   ("shapeFreqModFromSampledTone",+      testRationalIp shapeFreqModFromSampledTone) :+   ("oscillatorCells",+      testRationalIp oscillatorCells) :+   ("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,33 @@+{-# OPTIONS -fno-implicit-prelude #-}+module Test.Utility where++-- import Test.QuickCheck (Arbitrary(..))++import qualified Algebra.Real                  as Real+import qualified Algebra.Ring                  as Ring++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+
+ synthesizer.cabal view
@@ -0,0 +1,309 @@+Name:           synthesizer+Version:        0.0.3+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+Package-URL:    http://darcs.haskell.org/synthesizer/+Category:       Sound+Synopsis:       Audio signal processing coded in Haskell+Description:+   Audio signal processing+   featuring both low-level functions+   and high-level functions which use physical units,+   abstract from the sample rate and are 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 an introduction see @doc/Prologue.txt@.+Stability:      Experimental+Tested-With:    GHC==6.4.1, GHC==6.8.2+Cabal-Version:  >=1.2+Build-Type:     Simple++Extra-Source-Files:+  Makefile+  src/OsciDiffEq.hs+  doc/Prologue.txt++Flag splitBase+  description: Choose the new smaller, split-up base package.++Flag buildExamples+  description: Build example executables+  default:     False++Flag buildProfilers+  description: Build executables for investigating efficiency of code+  default:     False++Flag buildTests+  description: Build test suite+  default:     False+++Library+  Build-Depends:+    mtl >=1.1 && <1.2,+    event-list >=0.0.6 && <0.1,+    non-negative >=0.0.1 && <0.1,+    numeric-prelude >=0.0.4 && <0.1,+    -- numeric-quest/Orthogonals is only needed by Filter.Graph+    numeric-quest,+    -- bytestring and binary are only needed by SpeedTest+    bytestring >= 0.9 && <0.10,+    binary >=0.1 && <1,+    storablevector >=0.1.3,+    -- QuickCheck is needed for Filter.Delay.Block+    QuickCheck >=1 && <2++  If flag(splitBase)+    Build-Depends:+      base >= 3, array >=0.1 && <0.2, containers >=0.1 && <0.2, random >=1.0 && <1.1, process >=1.0 && <1.1, unix >=2.3 && <2.4+  Else+    Build-Depends:+      base >= 1.0 && < 2, special-functors++  GHC-Options:    -Wall+  Hs-source-dirs: src+  Exposed-modules:+    Sound.Signal+    Sound.Signal.Block+    Sound.Signal.StrictBlock+    -- further implementations of Signal class are in the Synthesizer.*.Signal modules+    StorableInstance+    BinarySample+    Filter.Basic+    Filter.Composition+    Filter.Example+    Filter.Fix+    Filter.Graph+    Filter.Graphic+    Filter.MonadFix+    Filter.OneWay+    Filter.TwoWay+    FourierSeries+    Sox+    Sox.File+    Sox.Play+    Synthesizer.Utility+    Synthesizer.ApplicativeUtility+    Synthesizer.Format+    Synthesizer.RandomKnuth+    Synthesizer.Piecewise+    Synthesizer.Basic.Distortion+    Synthesizer.Basic.DistortionControlled+    Synthesizer.Basic.Phase+    Synthesizer.Basic.Wave+    Synthesizer.Basic.WaveSmoothed+    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.Integration+    Synthesizer.Plain.Filter.Recursive.Moog+    Synthesizer.Plain.Filter.Recursive.MovingAverage+    Synthesizer.Plain.Filter.Recursive.SecondOrder+    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.Miscellaneous+    Synthesizer.Plain.Instrument+    Synthesizer.Plain.Effect+    Synthesizer.Plain.Effect.Fly+    Synthesizer.Plain.Effect.Glass+    Synthesizer.FusionList.Control+    Synthesizer.FusionList.Filter.NonRecursive+    Synthesizer.FusionList.Oscillator+    Synthesizer.FusionList.Signal+    Synthesizer.Storable.Cut+    Synthesizer.Storable.Oscillator+    Synthesizer.Storable.Signal+    Synthesizer.Storable.Filter.Recursive.Comb+    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.Causal.Process+    Synthesizer.Causal.Displacement+    Synthesizer.Causal.Interpolation+    Synthesizer.Causal.Oscillator+    Synthesizer.Generic.Analysis+    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.Interpolation+    Synthesizer.Generic.Noise+    Synthesizer.Generic.Oscillator+    Synthesizer.Generic.SampledValue+    Synthesizer.Generic.Signal+  --+    Synthesizer.Physical+    Synthesizer.Physical.Cut+    Synthesizer.Physical.Control+    Synthesizer.Physical.File+    Synthesizer.Physical.Filter+    Synthesizer.Physical.Noise+    Synthesizer.Physical.Oscillator+    Synthesizer.Physical.Play+    Synthesizer.Physical.Signal+    Synthesizer.Physical.Displacement+    Synthesizer.Amplitude.Signal+    Synthesizer.Amplitude.Cut+    Synthesizer.Amplitude.Control+    Synthesizer.Amplitude.Filter+    Synthesizer.Amplitude.Displacement+    Synthesizer.SampleRateContext.Rate+    Synthesizer.SampleRateContext.Signal+    Synthesizer.SampleRateContext.Oscillator+    Synthesizer.SampleRateContext.Cut+    Synthesizer.SampleRateContext.Control+    Synthesizer.SampleRateContext.Filter+    Synthesizer.SampleRateContext.Displacement+    Synthesizer.SampleRateContext.Noise+    Synthesizer.SampleRateContext.Play+    Synthesizer.Inference.DesignStudy.Applicative+    Synthesizer.Inference.DesignStudy.Arrow+    Synthesizer.Inference.DesignStudy.Monad+    Synthesizer.Inference.Func.Cut+    Synthesizer.Inference.Func.Signal+    Synthesizer.Inference.Reader.Play+    Synthesizer.Inference.Reader.Process+    Synthesizer.Inference.Reader.Signal+    Synthesizer.Inference.Reader.Control+    Synthesizer.Inference.Reader.Cut+    Synthesizer.Inference.Reader.Filter+    Synthesizer.Inference.Reader.Noise+    Synthesizer.Inference.Reader.Oscillator+  --+    Synthesizer.Dimensional.Abstraction.Flat+    Synthesizer.Dimensional.Abstraction.Homogeneous+    Synthesizer.Dimensional.Abstraction.RateIndependent+    Synthesizer.Dimensional.Amplitude.Analysis+    Synthesizer.Dimensional.Amplitude.Cut+    Synthesizer.Dimensional.Amplitude.Control+    Synthesizer.Dimensional.Amplitude.Displacement+    Synthesizer.Dimensional.Amplitude.Filter+    Synthesizer.Dimensional.Amplitude.Signal+    Synthesizer.Dimensional.Causal.Process+    Synthesizer.Dimensional.ControlledProcess+    Synthesizer.Dimensional.Cyclic.Signal+    Synthesizer.Dimensional.Process+    Synthesizer.Dimensional.Rate+    Synthesizer.Dimensional.RatePhantom+    Synthesizer.Dimensional.RateWrapper+    Synthesizer.Dimensional.Rate.Analysis+    Synthesizer.Dimensional.Rate.Control+    Synthesizer.Dimensional.Rate.Cut+    Synthesizer.Dimensional.Rate.Filter+    Synthesizer.Dimensional.Rate.Oscillator+    Synthesizer.Dimensional.RateAmplitude.Analysis+    Synthesizer.Dimensional.RateAmplitude.Cut+    Synthesizer.Dimensional.RateAmplitude.Control+    Synthesizer.Dimensional.RateAmplitude.Displacement+    Synthesizer.Dimensional.RateAmplitude.File+    Synthesizer.Dimensional.RateAmplitude.Filter+    Synthesizer.Dimensional.RateAmplitude.Instrument+    Synthesizer.Dimensional.RateAmplitude.Noise+    Synthesizer.Dimensional.RateAmplitude.Play+    Synthesizer.Dimensional.RateAmplitude.Signal+    Synthesizer.Dimensional.Straight.Displacement+    Synthesizer.Dimensional.Straight.Signal++Executable demonstration+  If !flag(buildExamples)+    Buildable: False+  GHC-Options: -Wall -O2 -fexcess-precision -fvia-C -optc-O2+-- -ddump-simpl-stats+  Hs-Source-Dirs: src+  Main-Is: Synthesizer/Dimensional/RateAmplitude/Demonstration.hs++Executable traumzauberbaum+  If !flag(buildExamples)+    Buildable: False+  GHC-Options: -Wall -O2 -fexcess-precision -fvia-C -optc-O2+  Hs-Source-Dirs: src+  Main-Is: Synthesizer/Dimensional/RateAmplitude/Traumzauberbaum.hs++Executable test+  If !flag(buildTests)+    Buildable: False+  GHC-Options: -Wall+  Hs-Source-Dirs: src+  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+  Main-Is: Test/Main.hs++Executable fusiontest+  If !flag(buildProfilers)+    Buildable: False+  GHC-Options: -Wall -fexcess-precision -ddump-simpl-stats+  Hs-Source-Dirs: speedtest, src+  Main-Is: FusionTest.hs++Executable speedtest+  If !flag(buildProfilers)+    Buildable: False+  GHC-Options: -Wall -fexcess-precision -optc-ffast-math -optc-O3+  --  -funfolding-use-threshold=20 -funfolding-creation-threshold=100+  --  -optc-march=pentium4 -optc-mfpmath=sse+  Hs-Source-Dirs: speedtest, src+  Main-Is: SpeedTest.hs++Executable speedtest-exp+  If !flag(buildProfilers)+    Buildable: False+  GHC-Options: -Wall -fexcess-precision+  Hs-Source-Dirs: speedtest, src+  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+  Main-Is: SpeedTestSimple.hs