diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + 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. + + + Copyright (C) + + 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 . + +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: + + Copyright (C) + 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 +. + + 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 +. diff --git a/Makefile b/Makefile new file mode 100644 --- /dev/null +++ b/Makefile @@ -0,0 +1,7 @@ +MODULE_PATH = src:src-3 + +ghci: + ghci -Wall -odirdist/build -hidirdist/build -hide-package synthesizer -i:$(MODULE_PATH) + +tutorial: + ghci -Wall -fobject-code -fexcess-precision -O2 -fvia-C -optc-O2 -odirdist/build -hidirdist/build -hide-package synthesizer -i:$(MODULE_PATH) src/Synthesizer/Generic/Tutorial.hs diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#! /usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/speedtest/FusionTest.hs b/speedtest/FusionTest.hs new file mode 100644 --- /dev/null +++ b/speedtest/FusionTest.hs @@ -0,0 +1,819 @@ +{-# OPTIONS_GHC -O2 #-} +module Main (main) where + +import qualified Synthesizer.Storable.Signal as SigSt +import qualified Synthesizer.Storable.Oscillator as OsciSt +import qualified Synthesizer.Storable.Cut as CutSt + +import qualified Synthesizer.State.Signal as SigS +import qualified Synthesizer.State.Oscillator as OsciS +import qualified Synthesizer.State.Control as CtrlS +import qualified Synthesizer.State.Filter.NonRecursive as FiltNRS +import qualified Synthesizer.State.Cut as CutS +import qualified Synthesizer.State.NoiseCustom as NoiseS +import qualified Synthesizer.State.Interpolation as InterpolationS + +import qualified Synthesizer.FusionList.Signal as SigFL +import qualified Synthesizer.FusionList.Oscillator as OsciFL +import qualified Synthesizer.FusionList.Control as CtrlFL +import qualified Synthesizer.FusionList.Filter.NonRecursive as FiltNRFL + +import qualified Synthesizer.Generic.Signal as SigG +import qualified Synthesizer.Generic.Filter.Delay as DelayG +import qualified Synthesizer.Generic.Interpolation as InterpolationG + +import qualified Synthesizer.Interpolation.Module as InterpolationM +import qualified Synthesizer.Basic.Wave as Wave +import qualified Synthesizer.Basic.Phase as Phase +import qualified Synthesizer.Basic.DistortionControlled as Dist +import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilter +import qualified Synthesizer.Plain.Filter.Recursive as FiltR +import qualified Synthesizer.Plain.Control as Ctrl +import Synthesizer.Piecewise ((|#), (#|-), (-|#), (#|), ) + +import qualified Data.EventList.Relative.TimeBody as EventList + +import Synthesizer.Basic.Binary (int16FromCanonical, int16FromDouble, ) +import Data.Int (Int8, Int16, ) +import Foreign.Storable (Storable, ) +import qualified Data.List as List +import qualified Data.Char as Char + +import GHC.Float (double2Int, int2Double) +import NumericPrelude ((^?)) +import qualified NumericPrelude as NP + +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import System.Random (mkStdGen) +import qualified Synthesizer.RandomKnuth as Knuth + + +{- +If you increase the chunk size to 10000 the computation becomes slower. +Is this reproducable? +-} +defaultChunkSize :: SigSt.ChunkSize +defaultChunkSize = SigSt.chunkSize 1000 + + +{-# INLINE storableFromFusionList #-} +storableFromFusionList :: Storable a => SigFL.T a -> SigSt.T a +storableFromFusionList = + SigFL.toStorableSignal defaultChunkSize +-- SigSt.fromFusionList defaultChunkSize + +mapTest0 :: SigSt.T Char +mapTest0 = + SigSt.fromList defaultChunkSize + (List.map succ (List.replicate 200000 'a')) + +mapTest1 :: [Char] -> SigSt.T Char +mapTest1 = + SigSt.fromList defaultChunkSize . List.map Char.toUpper + +mapTest2 :: [Char] -> SigSt.T Char +mapTest2 xs = + SigSt.fromList defaultChunkSize (List.map Char.toUpper xs) + +mapTest3 :: SigSt.T Int8 +mapTest3 = + SigSt.fromList defaultChunkSize + (List.map succ (List.replicate 200000 1234)) + +mapTest4 :: SigSt.T Int8 +mapTest4 = + SigSt.fromList defaultChunkSize + (List.map pred (List.replicate 200000 1234)) + +mapTest5 :: SigSt.T Int8 +mapTest5 = + storableFromFusionList + (SigFL.map pred (SigFL.replicate 200000 1234)) + +{- inlining here even reduces the application of rules - Why? -} +{- INLINE mapTest6 -} +mapTest6 :: SigSt.T Int16 +mapTest6 = + storableFromFusionList $ SigFL.take 200000 $ + SigFL.map int16FromCanonical $ +-- SigFL.map (^2) $ + SigFL.repeat (3::Double) + + +{-# INLINE zeroPhase #-} +zeroPhase :: Phase.T Double +zeroPhase = NP.zero + +osciTest0 :: SigSt.T Int16 +osciTest0 = + storableFromFusionList $ + SigFL.take 200000 $ + -- int16FromCanonical is not only slow in execution but also blocks fusion - why? + SigFL.map int16FromCanonical $ + (OsciFL.staticSaw zeroPhase 0.01 :: SigFL.T Double) + +osciTest0a :: SigSt.T Int16 +osciTest0a = + storableFromFusionList $ + SigFL.take 200000 $ + SigFL.map int16FromDouble $ + OsciFL.staticSaw zeroPhase 0.01 + +{- +{-# INLINE exponential2 #-} +exponential2 :: Trans.C a => + a {-^ half life -} + -> a {-^ initial value -} + -> SigFL.T a + {-^ exponential decay -} +exponential2 halfLife = + SigFL.iterate (((Ring.one Field./ (Ring.one Additive.+ Ring.one)) Trans.^? Field.recip halfLife) Ring.*) +-} + + +osciTest0b :: SigSt.T Int16 +osciTest0b = + storableFromFusionList $ + SigFL.take 200000 $ + SigFL.map int16FromDouble $ + FiltNRFL.envelope + (CtrlFL.exponential2 50000 1) + (OsciFL.staticSaw zeroPhase 0.01) + +osciTest0ba :: SigSt.T Int16 +osciTest0ba = + storableFromFusionList $ + SigFL.take 200000 $ + SigFL.map int16FromDouble $ + CtrlFL.exponential2 50000 1 + +osciTest0c :: SigSt.T Int16 +osciTest0c = + storableFromFusionList $ + SigFL.take 200000 $ + SigFL.map int16FromDouble $ + FiltNRFL.envelope + (CtrlFL.exponential2 50000 0.5) + (OsciFL.shapeMod Wave.squareBalanced zeroPhase 0.01 $ + SigFL.map (0.5*) $ OsciFL.staticSine zeroPhase 0.00002) + +osciTest0d :: SigSt.T Int16 +osciTest0d = + storableFromFusionList $ + SigFL.take 200000 $ + SigFL.map int16FromDouble $ + FiltNRFL.envelope +-- (exponential2 50000 0.5) + (CtrlFL.exponential2 50000 0.5) +-- (SigFL.iterate ((0.5 ^? recip 50000)*) 0.5) + (OsciFL.freqMod Wave.square zeroPhase + (SigFL.map (0.01+) $ SigFL.map (0.0001*) $ OsciFL.staticSine zeroPhase 0.0001)) + +osciTest0e :: SigSt.T Int16 +osciTest0e = + storableFromFusionList $ + SigFL.take 200000 $ + SigFL.map int16FromDouble $ + FiltNRFL.envelope + (CtrlFL.exponential2 50000 0.5) + (OsciFL.shapeFreqMod Wave.squareBalanced zeroPhase + (SigFL.map (0.5*) $ OsciFL.staticSine zeroPhase 0.00002) + (SigFL.map (0.01+) $ SigFL.map (0.0001*) $ OsciFL.staticSine zeroPhase 0.0001)) + +osciTest0ea :: SigSt.T Int16 +osciTest0ea = + storableFromFusionList $ + SigFL.take 200000 $ + SigFL.map int16FromDouble $ + (OsciFL.shapeFreqMod Wave.squareBalanced zeroPhase + (OsciFL.staticSine zeroPhase 0.00002) + (OsciFL.staticSine zeroPhase 0.0001)) + +osciTest0f :: SigSt.T Int16 +osciTest0f = + storableFromFusionList $ + SigFL.take 200000 $ + SigFL.map int16FromDouble $ + FiltNRFL.envelope + (CtrlFL.exponential2 50000 1) +-- (SigFL.zipWith (\x y -> (x+y)/2) +-- (MiscFL.mix + (SigFL.mix + (OsciFL.static Wave.saw zeroPhase 0.01003) + (OsciFL.static Wave.saw zeroPhase 0.00997)) +-- staticSaw blocks fusion +-- (OsciFL.staticSaw zeroPhase 0.01003) +-- (OsciFL.staticSaw zeroPhase 0.00997)) + +osciTest0fa :: SigSt.T Int16 +osciTest0fa = + storableFromFusionList $ + SigFL.take 200000 $ + SigFL.map int16FromDouble $ + FiltNRFL.envelope + (CtrlFL.exponential2 50000 1) + (SigFL.mix + (SigFL.mix + (OsciFL.staticSaw zeroPhase 0.01001) + (OsciFL.staticSaw zeroPhase 0.00998)) + (SigFL.mix + (OsciFL.staticSaw zeroPhase 0.01005) + (OsciFL.staticSaw zeroPhase 0.00996))) + +osciTest1 :: SigSt.T Double +osciTest1 = + storableFromFusionList $ + SigFL.take 200000 $ + (OsciFL.staticSaw zeroPhase 0.01 :: SigFL.T Double) + +osciTest2 :: SigSt.T Int16 +osciTest2 = + storableFromFusionList $ + SigFL.take 200000 $ + SigFL.iterate (200+) 0 + +osciTest3 :: SigSt.T Double +osciTest3 = + SigSt.take 200000 $ + SigSt.map (\x->x*x) $ + SigSt.iterate defaultChunkSize (200+) 0 + +osciTest4 :: SigSt.T Int16 +osciTest4 = + SigSt.take 200000 $ + SigSt.map int16FromCanonical $ -- this is now really fast thanks to specialisation + (SigSt.iterate defaultChunkSize (1+) 0 :: SigSt.T Double) + +osciTest5 :: SigSt.T Int16 +osciTest5 = + SigSt.take 200000 $ + SigSt.map int16FromDouble $ + (SigSt.iterate defaultChunkSize (1+) 0 :: SigSt.T Double) + +osciTest6 :: SigSt.T Int16 +osciTest6 = + -- takeCrochet is slow if not fused away + SigSt.takeCrochet 200000 $ + SigSt.map int16FromDouble $ + (SigSt.iterate defaultChunkSize (1+) 0 :: SigSt.T Double) + + +{- +waveSine :: Floating a => a -> a +waveSine x = sin (2*pi*x) +-} + +{- +waveSine :: Trans.C a => a -> a +waveSine x = Trans.sin (NP.fromInteger 2 NP.* Trans.pi NP.* x) + +incrFracDouble :: Double -> Double -> Double +incrFracDouble d x = NP.fraction (d + x) + +{-# ONLINE incrFrac #-} +incrFrac :: NP.RealFrac a => a -> a -> a +incrFrac d x = NP.fraction (d NP.+ x) + +fraction :: Double -> Double +fraction x = + let second :: (Int, a) -> a + second = snd + f = second (properFraction x) + in if f>=0 then f else f+1 +-} + +{- +fraction :: Double -> Double +fraction x = x - fromIntegral (floor x :: Int) +-} + +{- +fraction :: Double -> Double +fraction x = x - int2Double (double2Int x) + +incrFracDouble :: Double -> Double -> Double +incrFracDouble d x = fraction (d + x) +-} + +{- +incrFracDouble :: Double -> Double -> Double +incrFracDouble d x = d + x +-} + + +osciTest7 :: SigSt.T Int16 +osciTest7 = + SigSt.take 200000 $ + SigSt.map int16FromDouble $ +-- SigSt.map (\x -> sin (2*pi*x)) $ + SigSt.map (Wave.apply Wave.sine) $ +-- SigSt.map (Wave.apply waveSine) $ +-- (SigSt.iterate defaultChunkSize (0.01 +) NP.zero :: SigSt.T (Phase.T Double)) + (SigSt.iterate defaultChunkSize (Phase.increment 0.01) NP.zero :: SigSt.T (Phase.T Double)) +-- (SigSt.iterate defaultChunkSize (incrFrac 0.01) NP.zero :: SigSt.T (Phase.T Double)) +-- (SigSt.iterate defaultChunkSize (incrFracDouble 0.01) NP.zero :: SigSt.T (Phase.T Double)) + +osciTest8 :: SigSt.T Int16 +osciTest8 = + SigSt.take 200000 $ + SigSt.map int16FromDouble $ + (OsciSt.staticSaw defaultChunkSize zeroPhase 0.01 :: SigSt.T Double) + + +appendTest0 :: SigSt.T Int16 +appendTest0 = + storableFromFusionList $ + SigFL.map int16FromDouble $ + let tone0 = SigFL.take 100000 $ OsciFL.static Wave.saw zeroPhase 0.010 + tone1 = SigFL.take 100000 $ OsciFL.static Wave.saw zeroPhase 0.015 + in SigFL.append tone0 tone1 + +appendTest1 :: SigSt.T Int16 +appendTest1 = + let tone0 = SigFL.take 100000 $ OsciFL.static Wave.saw zeroPhase 0.010 + tone1 = SigFL.take 100000 $ OsciFL.static Wave.saw zeroPhase 0.015 + in storableFromFusionList $ + SigFL.map int16FromDouble $ + SigFL.append tone0 tone1 + +appendTest2 :: SigSt.T Int16 +appendTest2 = + SigSt.map int16FromDouble $ + SigSt.appendFromFusionList defaultChunkSize + (SigFL.take 100000 $ OsciFL.static Wave.saw zeroPhase 0.010) + (SigFL.take 100000 $ OsciFL.static Wave.saw zeroPhase 0.015) + +appendTest3 :: SigSt.T Int16 +appendTest3 = + storableFromFusionList $ + SigFL.map int16FromDouble $ + SigSt.appendFusionList defaultChunkSize + (SigFL.take 100001 $ OsciFL.static Wave.sine zeroPhase 0.010) + (SigFL.take 100000 $ OsciFL.static Wave.saw zeroPhase 0.015) + +mixTest0 :: SigSt.T Int16 +mixTest0 = + SigSt.map int16FromDouble $ + SigSt.mixSize defaultChunkSize + (SigSt.replicate defaultChunkSize 100000 NP.zero) + (SigSt.replicate defaultChunkSize 100001 NP.one) + +mixTest3 :: SigSt.T Int16 +mixTest3 = + SigSt.map int16FromDouble $ + SigSt.mixSize defaultChunkSize +-- (storableFromFusionList $ SigFL.take 100000 $ OsciFL.static Wave.sine zeroPhase 0.010) +-- (storableFromFusionList $ SigFL.take 100000 $ CtrlFL.exponential2 50000 1) + (storableFromFusionList $ SigFL.take 100001 $ OsciFL.static Wave.saw zeroPhase 0.015) + (SigSt.empty) + +mixTest4 :: SigSt.T Int16 +mixTest4 = + SigSt.map int16FromDouble $ + SigSt.mixSize defaultChunkSize + (SigSt.take 100002 $ OsciSt.staticSine defaultChunkSize zeroPhase 0.020) $ + SigSt.mixSize defaultChunkSize + (SigSt.take 100001 $ OsciSt.staticSine defaultChunkSize zeroPhase 0.010) + (SigSt.take 100000 $ OsciSt.staticSaw defaultChunkSize zeroPhase 0.015) + + +mixTest5 :: SigSt.T Int16 +mixTest5 = + SigSt.map int16FromDouble $ + SigSt.take 441000 $ +-- SigSt.append + SigSt.mix +-- SigSt.mixSize defaultChunkSize + (SigSt.iterate defaultChunkSize ((1-1e-6)*) 0.5) + (SigSt.iterate defaultChunkSize (1e-6 +) 0) + +mixTest6 :: SigSt.T Int16 +mixTest6 = + SigSt.map int16FromDouble $ + SigSt.take 441000 $ +-- SigSt.append + SigSt.mix +-- SigSt.mixSize defaultChunkSize + (SigS.toStorableSignal defaultChunkSize $ SigS.iterate ((1-1e-6)*) 0.5) + (SigS.toStorableSignal defaultChunkSize $ SigS.iterate (1e-6 +) 0) + + +stateTest0 :: SigSt.T Int16 +stateTest0 = + SigS.toStorableSignal defaultChunkSize $ + SigS.map int16FromDouble $ + SigS.take 441000 $ + SigS.zipWith (*) (SigS.iterate ((1-1e-4)*) 1) $ +-- SigS.map (\t -> if even (floor t :: Int) then 1 else -1) $ + SigS.map sin $ + SigS.iterate ((2*pi/100)+) (0::Double) + +stateTest1 :: SigSt.T Int16 +stateTest1 = + SigS.toStorableSignal defaultChunkSize $ + SigS.map int16FromDouble $ + SigS.take 100000 $ + SigS.zipWith Dist.sine (SigS.iterate ((1-0.3e-4)*) 1) $ + SigS.map (Wave.apply Wave.sine) $ + SigS.iterate (Phase.increment 0.01) zeroPhase + +stateTest2 :: SigSt.T Int16 +stateTest2 = + SigS.toStorableSignal defaultChunkSize $ + SigS.map int16FromDouble $ + SigS.take 100000 $ + SigS.map (Dist.logit 1) $ + SigS.map (Dist.sine 5) $ + SigS.zipWith (*) (SigS.iterate ((1-0.3e-4)*) 30) $ + SigS.map (Wave.apply Wave.sine) $ + SigS.iterate (Phase.increment 0.01) zeroPhase + +stateOsciTest0 :: SigSt.T Int16 +stateOsciTest0 = + SigS.toStorableSignal defaultChunkSize $ + SigS.take 200000 $ + SigS.map int16FromCanonical $ + (OsciS.static Wave.saw zeroPhase 0.01 :: SigS.T Double) + +stateOsciTest0a :: SigSt.T Int16 +stateOsciTest0a = + SigS.toStorableSignal defaultChunkSize $ + SigS.take 200000 $ + SigS.map int16FromDouble $ + OsciS.static Wave.saw zeroPhase 0.01 + +stateOsciTest0fa :: SigSt.T Int16 +stateOsciTest0fa = + SigS.toStorableSignal defaultChunkSize $ + SigS.take 200000 $ + SigS.map int16FromDouble $ +-- FiltNRS.envelope +-- (CtrlS.exponential2 50000 1) + SigS.map (0.5*) $ + (SigS.mix + (SigS.mix + (OsciS.static Wave.saw (Phase.fromRepresentative 0.1) 0.01001) + (OsciS.static Wave.saw (Phase.fromRepresentative 0.7) 0.00998)) + (SigS.mix + (OsciS.static Wave.saw (Phase.fromRepresentative 0.2) 0.01005) + (OsciS.static Wave.saw (Phase.fromRepresentative 0.4) 0.00996))) + +{-# INLINE chord #-} +chord :: SigS.T Double +chord = + let freq = 0.005 + {-# INLINE tone #-} + tone f = + SigS.mix + (SigS.mix + (OsciS.static Wave.saw zeroPhase (f*1.001)) + (OsciS.static Wave.saw zeroPhase (f*0.998))) + (SigS.mix + (OsciS.static Wave.saw zeroPhase (f*1.005)) + (OsciS.static Wave.saw zeroPhase (f*0.996))) + in tone (freq*1.00) `SigS.mix` + tone (freq*1.25) `SigS.mix` + tone (freq*1.50) + +stateOsciTestChord :: SigSt.T Int16 +stateOsciTestChord = + SigS.toStorableSignal defaultChunkSize $ + SigS.take 200000 $ + SigS.map int16FromDouble $ + SigS.map (0.2*) $ + chord + +stateFilterTest :: SigSt.T Int16 +stateFilterTest = + SigS.toStorableSignal defaultChunkSize $ + SigS.take 200000 $ + SigS.map int16FromDouble $ + SigS.map (0.05*) $ + SigS.map UniFilter.lowpass $ + SigS.modifyModulated + UniFilter.modifier + (SigS.map UniFilter.parameter $ + SigS.zipWith FiltR.Pole + (SigS.repeat (5::Double)) + (SigS.map (\f -> 0.02*3 ^? f) $ + OsciS.static Wave.fastSine2 (Phase.fromRepresentative 0.75) 0.000005)) $ + chord + +stateAppendTest0 :: SigSt.T Int16 +stateAppendTest0 = + SigS.toStorableSignal defaultChunkSize $ + SigS.map int16FromDouble $ + let tone f = + SigS.take 50000 $ + SigS.map (Wave.apply Wave.saw) $ + SigS.iterate (Phase.increment f) zeroPhase + in tone 0.010 `SigS.append` + tone 0.015 `SigS.append` + tone 0.020 + +stateAppendTest1 :: SigSt.T Int16 +stateAppendTest1 = + SigS.toStorableSignal defaultChunkSize $ + SigS.map int16FromDouble $ + let tone f = + SigS.take 50000 $ + SigS.map (Wave.apply Wave.saw) $ + SigS.iterate (Phase.increment f) zeroPhase + in tone 0.010 `SigS.appendStored` + tone 0.015 `SigS.appendStored` + tone 0.020 + +stateAppendTest2 :: SigSt.T Int16 +stateAppendTest2 = + SigSt.map int16FromDouble $ + let tone f = + SigS.toStorableSignal defaultChunkSize $ + SigS.take 50000 $ + SigS.map (Wave.apply Wave.saw) $ + SigS.iterate (Phase.increment f) zeroPhase + in tone 0.010 `SigSt.append` + tone 0.015 `SigSt.append` + tone 0.020 + +stateConcatTest0 :: SigSt.T Int16 +stateConcatTest0 = + SigS.toStorableSignal defaultChunkSize $ + SigS.map int16FromDouble $ + let tone f = + SigS.take 50000 $ + SigS.map (Wave.apply Wave.saw) $ + SigS.iterate (Phase.increment f) zeroPhase + in SigS.concat $ + tone 0.010 : + tone 0.015 : + tone 0.020 : + [] + +stateConcatTest1 :: SigSt.T Int16 +stateConcatTest1 = + SigS.toStorableSignal defaultChunkSize $ + SigS.map int16FromDouble $ + let tone f = + SigS.take 50000 $ + SigS.map (Wave.apply Wave.saw) $ + SigS.iterate (Phase.increment f) zeroPhase + in SigS.concatStored $ + tone 0.010 : + tone 0.015 : + tone 0.020 : + [] + +{-# NOINLINE storablePercTone #-} +storablePercTone :: Double -> SigSt.T Double +storablePercTone f = + SigS.toStorableSignal defaultChunkSize $ + SigS.take 22000 $ + FiltNRS.envelope (CtrlS.exponential2 10000 1) $ +-- OsciS.static Wave.saw zero f + SigS.map (0.5*) $ + SigS.mix + (OsciS.static Wave.saw zeroPhase (f*0.999)) + (OsciS.static Wave.saw zeroPhase (f*1.001)) + +storableConcatTest :: SigSt.T Int16 +storableConcatTest = + SigSt.map int16FromDouble $ + SigSt.concat $ + take 13 $ + map storablePercTone $ + iterate (* 2^?(1/12)) 0.005 + +storableArrangeTest :: SigSt.T Int16 +storableArrangeTest = + SigSt.map int16FromDouble $ + SigSt.map (0.5*) $ + CutSt.arrange defaultChunkSize $ + foldr (EventList.cons 4000) (EventList.empty) $ +-- foldr (EventList.cons 4000) (EventList.pause 0) $ + take 25 $ + map storablePercTone $ + iterate (* 2^?(1/12)) 0.005 + +-- This is much faster than Arrange. +-- about 2 seconds +storableConcatInfTest :: SigSt.T Int16 +storableConcatInfTest = + SigSt.map int16FromDouble $ + SigSt.map (0.5*) $ + SigSt.concat $ + take 110 $ + map storablePercTone $ + iterate (* 2^?(1/12)) 0.002 + +-- about 5-6 seconds +storableArrangeInfTest :: SigSt.T Int16 +storableArrangeInfTest = + SigSt.map int16FromDouble $ + SigSt.map (0.5*) $ + SigSt.take 440000 $ + CutSt.arrange defaultChunkSize $ + foldr (EventList.cons 4000) (EventList.empty) $ + map storablePercTone $ + iterate (* 2^?(1/12)) 0.002 + + + +statePercTone :: Double -> SigS.T Double +statePercTone f = + SigS.take 22000 $ + FiltNRS.envelope (CtrlS.exponential2 10000 1) $ +-- OsciS.static Wave.saw zeroPhase f + SigS.map (0.5*) $ + SigS.mix + (OsciS.static Wave.saw zeroPhase (f*0.999)) + (OsciS.static Wave.saw zeroPhase (f*1.001)) + +stateArrangeInfTest :: SigSt.T Int16 +stateArrangeInfTest = + SigS.toStorableSignal defaultChunkSize $ + SigS.map int16FromDouble $ + SigS.map (0.5*) $ + SigS.take 440000 $ + CutS.arrange $ + foldr (EventList.cons 4000) (EventList.empty) $ + map statePercTone $ + iterate (* 2^?(1/12)) 0.002 + + +{-# INLINE fastSine2 #-} +fastSine2 :: (Ord a, Ring.C a, Num a) => a -> a +fastSine2 x = + if 2*x<1 + then 1 - NP.sqr (4*x-1) + else NP.sqr (4*x-3) - 1 + +fastSineTest :: SigSt.T Int16 +fastSineTest = + SigS.toStorableSignal defaultChunkSize $ + SigS.map int16FromDouble $ + SigS.take 440000 $ +-- OsciS.static Wave.sine zeroPhase $ +-- OsciS.static Wave.fastSine4 zeroPhase $ + OsciS.static Wave.fastSine2 zeroPhase $ +-- OsciS.static fastSine2 zeroPhase $ + 0.01 + + +{-# INLINE stateBubbles #-} +stateBubbles :: SigS.T Double +stateBubbles = + OsciS.freqMod Wave.sine zeroPhase $ + SigS.map (\p -> 0.01 * exp(-p)) $ + SigS.mix + (SigS.map (1.5*) $ OsciS.static Wave.saw zeroPhase 0.00001) + (SigS.map (0.5*) $ OsciS.static Wave.saw zeroPhase 0.0002) + +stateBubblesTest :: SigSt.T Int16 +stateBubblesTest = + SigS.toStorableSignal defaultChunkSize $ + SigS.map int16FromDouble $ + SigS.take 440000 $ + stateBubbles + +storableCombTest :: SigSt.T Int16 +storableCombTest = + SigSt.map int16FromDouble $ + SigSt.delayLoopOverlap 11000 (SigSt.map (0.5*)) $ + SigS.toStorableSignal defaultChunkSize $ +-- SigS.append (statePercTone 0.01) (SigS.replicate 40000 0) + SigS.take 440000 $ + SigS.map (0.5*) $ + stateBubbles + + +storableTakeTest :: SigSt.T Int16 +storableTakeTest = + SigSt.take 440000 $ + SigS.toStorableSignal defaultChunkSize $ + SigS.map int16FromDouble $ + OsciS.static Wave.saw zeroPhase 0.01 + + +stateNoiseTest :: SigSt.T Int16 +stateNoiseTest = + SigS.toStorableSignal defaultChunkSize $ + SigS.take 440000 $ + SigS.map int16FromDouble $ + SigS.map (0.3*) $ + SigS.map UniFilter.lowpass $ + SigS.modifyModulated + UniFilter.modifier + (SigS.map UniFilter.parameter $ + SigS.zipWith FiltR.Pole + (SigS.repeat (10::Double)) + (SigS.map (\f -> 0.02*3 ^? f) $ + OsciS.static Wave.sine (Phase.fromRepresentative 0.75) 0.000005)) $ +-- NoiseS.whiteGen (mkStdGen 1) + NoiseS.whiteGen (Knuth.cons 1) + + +stateADSRTest :: SigSt.T Int16 +stateADSRTest = + SigS.toStorableSignal defaultChunkSize $ + SigS.map int16FromDouble $ + FiltNRS.envelope + (CtrlS.piecewise + (0 |# (5000, CtrlS.cubicPiece 0.001 0) #|- + 0.5 -|# (40000, CtrlS.stepPiece) #|- + 0.5 -|# (8000, CtrlS.exponentialPiece 0) #| + 0.01)) $ + OsciS.static Wave.saw zeroPhase 0.01 + + +phaserTest :: SigSt.T Int16 +phaserTest = + SigSt.take 440000 $ + SigSt.map int16FromDouble $ + SigSt.map (0.5*) $ + (\noise -> + SigSt.mix + noise + (DelayG.modulated InterpolationM.linear (-500) + (SigS.toStorableSignal defaultChunkSize + (SigS.map + (\x -> 100*(2+x) :: Double) + (OsciS.static Wave.sine zeroPhase 0.00001))) + noise)) $ + SigS.toStorableSignal defaultChunkSize $ +-- OsciS.static Wave.saw zeroPhase 0.01 + NoiseS.whiteGen (Knuth.cons 1) + + +phaserTest0 :: SigSt.T Int16 +phaserTest0 = + SigSt.take 440000 $ + SigSt.map int16FromDouble $ + DelayG.modulated InterpolationM.constant (-500) + (SigSt.repeat defaultChunkSize (142::Double)) $ + SigSt.repeat defaultChunkSize (23::Double) + + +phaserTest1 :: SigSt.T Int16 +phaserTest1 = + SigSt.take 440000 $ + SigSt.map int16FromDouble $ +-- SigG.mapTails (maybe 0 fst . SigSt.viewL . SigSt.drop 100) $ +{- + (\noise -> + SigSt.mix + (SigG.zipWithTails + (\n -> maybe 0 fst . SigSt.viewL . SigSt.drop (div n 50)) + (SigG.iterate succ 0) noise) + noise) $ +-} +{- + SigG.zipWithTails + (\n -> maybe 0 fst . SigSt.viewL . SigSt.drop (div n 50)) + (SigG.iterate succ 0) $ +-} + (\noise -> SigSt.mix noise noise) $ + SigS.toStorableSignal defaultChunkSize $ + NoiseS.whiteGen (Knuth.cons 1) + + + +main :: IO () +main = + do SigSt.writeFile "storable-fusion.sw" phaserTest + -- SigSt.writeFile "storable-fusion.sw" stateFilterTest + -- SigSt.writeFile "storable-fusion.sw" osciTest4 + -- SigSt.writeFile "storable-fusion.sw" mapTest5 + + +{- +show highlighted core output + +ghc-core -o dist/build/fusiontest/fusiontest -O -Wall -fexcess-precision -package synthesizer speedtest/FusionTest.hs + +use installed synthesizer package + +ghc -o dist/build/fusiontest/fusiontest -O -Wall -fexcess-precision -ddump-simpl-stats -package synthesizer speedtest/FusionTest.hs + +ghc -o dist/build/fusiontest/fusiontest -O -Wall -fexcess-precision -ddump-simpl-stats -ddump-simpl -package synthesizer speedtest/FusionTest.hs >dist/build/fusiontest/FusionTest.log + + +with make and no explicit package specification: + +ghc -Idist/build -o dist/build/fusiontest/fusiontest --make -Wall -O2 -fexcess-precision -ddump-simpl-stats -i -idist/build/autogen -isrc -odir dist/build/fusiontest/fusiontest-tmp -hidir dist/build/fusiontest/fusiontest-tmp src/FusionTest.hs + +with make and explicit package specification: + +ghc -Idist/build -o dist/build/fusiontest/fusiontest --make -Wall -O2 -fexcess-precision -hide-all-packages -i -idist/build/autogen -isrc -odir dist/build/fusiontest/fusiontest-tmp -hidir dist/build/fusiontest/fusiontest-tmp -package base-1.0 -package mtl-1.0 -package non-negative-0.0.2 -package numeric-prelude-0.0.3 -package event-list-0.0.7 -package Haskore-0.0.2 -package HTam-0.0 -package numeric-quest-0.1 -package bytestring-0.9.0.5 -package binary-0.4.1 -package storablevector-0.1 -package UniqueLogicNP-0.0 -package QuickCheck-1.0 src/FusionTest.hs + +without make and with detailed simplifier report: + +ghc -Idist/build -o dist/build/fusiontest/fusiontest -Wall -O2 -fexcess-precision -ddump-simpl-stats -ddump-simpl-iterations -ddump-asm -i -idist/build/autogen -isrc -idist/build/fusiontest/fusiontest-tmp -odir dist/build/fusiontest/fusiontest-tmp -hidir dist/build/fusiontest/fusiontest-tmp -package base-1.0 -package mtl-1.0 -package non-negative-0.0.2 -package numeric-prelude-0.0.3 -package event-list-0.0.7 -package Haskore-0.0.2 -package HTam-0.0 -package numeric-quest-0.1 -package bytestring-0.9.0.5 -package binary-0.4.1 -package storablevector-0.1 -package UniqueLogicNP-0.0 -package QuickCheck-1.0 dist/build/HSsynthesizer*.o src/FusionTest.hs + +ghc -Idist/build -o dist/build/fusiontest/fusiontest -Wall -O2 -fexcess-precision -ddump-simpl-stats -ddump-simpl-iterations -i -idist/build/autogen -isrc -idist/build/fusiontest/fusiontest-tmp -odir dist/build/fusiontest/fusiontest-tmp -hidir dist/build/fusiontest/fusiontest-tmp -package base-1.0 -package mtl-1.0 -package non-negative-0.0.2 -package numeric-prelude-0.0.3 -package event-list-0.0.7 -package Haskore-0.0.2 -package HTam-0.0 -package numeric-quest-0.1 -package bytestring-0.9.0.5 -package binary-0.4.1 -package storablevector-0.1 -package UniqueLogicNP-0.0 -package QuickCheck-1.0 dist/build/HSsynthesizer*.o src/FusionTest.hs >src/FusionTest.log + +ghc-6.8.2 -Idist/build -o dist/build/fusiontest/fusiontest -Wall -O2 -fexcess-precision -ddump-simpl-stats -ddump-simpl-iterations -i -idist/build/autogen -isrc -idist/build/fusiontest/fusiontest-tmp -odir dist/build/fusiontest/fusiontest-tmp -hidir dist/build/fusiontest/fusiontest-tmp -package base -package mtl -package non-negative -package numeric-prelude -package event-list -package Haskore -package HTam -package numeric-quest -package bytestring -package binary -package storablevector -package UniqueLogicNP -package QuickCheck dist/build/HSsynthesizer*.o src/FusionTest.hs >src/FusionTest.log +-} diff --git a/speedtest/SpeedTest.hs b/speedtest/SpeedTest.hs new file mode 100644 --- /dev/null +++ b/speedtest/SpeedTest.hs @@ -0,0 +1,318 @@ +{-# OPTIONS -fno-implicit-prelude #-} +module Main (main) where + +-- import BinarySample (numToInt16) + +import System.Time (getClockTime, diffClockTimes, tdSec, tdPicosec) +import System.Directory (removeFile) + +-- the strict ByteString variant is not faster here +import qualified Data.ByteString.Lazy as B +import qualified Data.Binary.Put as Bin + +import Foreign (Int16, Ptr, alloca, allocaBytes, poke, pokeElemOff, sizeOf) +import System.IO (openBinaryFile, IOMode(WriteMode), hClose, Handle, hPutBuf) +import Control.Exception (bracket) + +import qualified Algebra.Transcendental as Trans +import qualified Algebra.RealField as RealField + +import GHC.Float (double2Int) + +import Data.Word (Word8) + +import Control.Monad (when, foldM, zipWithM_, ) +import Data.List (unfoldr) +import Data.Maybe.HT (toMaybe, ) +import Data.List.HT (sliceVertical, ) + +import PreludeBase +import NumericPrelude + +import qualified Prelude as P98 + +{- + ghc -prof -auto-all -O -fvia-C SpeedTest.hs + a.out +RTS -p -RTS +-} + + +{-# SPECIALIZE osciModSaw :: Double -> [Double] -> [Double] #-} +{-# SPECIALIZE freqToPhase :: Double -> [Double] -> [Double] #-} +{-# SPECIALIZE exponential2 :: Double -> Double -> [Double] #-} +{-# SPECIALIZE clip :: Double -> Double -> Double -> Double #-} +{-# SPECIALIZE numToInt :: Double -> Int #-} +{-# SPECIALIZE numToInt16 :: Double -> Int16 #-} + +{- INLINE zeroSignal #-} +{- INLINE sawSignal #-} +{- INLINE zeroSignal16 #-} +{- INLINE sawSignal16 #-} + + +{- | +saw tooth oscillator with modulated frequency +-} +osciModSaw :: RealField.C a => a -> [a] -> [a] +osciModSaw phase freq = map (\x -> 2*x-1) (freqToPhase phase freq) + +{- | +Convert a list of phase steps into a list of momentum phases +phase is a number in the interval [0,1) +freq contains the phase steps +-} +freqToPhase :: RealField.C a => a -> [a] -> [a] +freqToPhase phase freq = + scanl (\curphase dif -> fraction (curphase+dif)) phase freq + +exponential2 :: Trans.C a => a -> a -> [a] +exponential2 halfLife y0 = + let k = 0.5**(1/halfLife) + in iterate (k*) y0 + + + +-- write the signal as binary file containing 16 bit words +writeSignalMono, writeSignalMonoS :: + FilePath -> [Int16] -> IO () +writeSignalMono fileName signal = + writeFile fileName (signalToBinaryMono signal) +writeSignalMonoS fileName signal = + writeFile fileName (signalToBinaryMonoS signal) + +signalToBinaryMono, signalToBinaryMonoS :: + [Int16] -> String +signalToBinaryMono = concatMap (int16ToChars . P98.fromIntegral) +signalToBinaryMonoS = foldr int16ToCharsS [] . map P98.fromIntegral + +writeSignalMonoInt :: + FilePath -> [Int] -> IO () +writeSignalMonoInt fileName signal = + writeFile fileName (signalToBinaryMonoInt signal) + +signalToBinaryMonoInt :: [Int] -> String +signalToBinaryMonoInt = concatMap int16ToChars + + +writeSignalMonoBStr :: FilePath -> [Int16] -> IO () +writeSignalMonoBStr fileName = + B.writeFile fileName . signalToBinaryMonoBStr + +signalToBinaryMonoBStr :: [Int16] -> B.ByteString +signalToBinaryMonoBStr = + B.pack . concatMap (int16ToBytes . P98.fromIntegral) + + +writeSignalMonoBinaryPut :: + FilePath -> [Int16] -> IO () +writeSignalMonoBinaryPut fileName = + B.writeFile fileName . signalToBinaryBinaryPut + +signalToBinaryBinaryPut :: [Int16] -> B.ByteString +signalToBinaryBinaryPut = + Bin.runPut . mapM_ (Bin.putWord16host . P98.fromIntegral) + + +writeSignalMonoBinaryIntPut :: + FilePath -> [Int] -> IO () +writeSignalMonoBinaryIntPut fileName = + B.writeFile fileName . signalToBinaryBinaryIntPut + +signalToBinaryBinaryIntPut :: [Int] -> B.ByteString +signalToBinaryBinaryIntPut = + Bin.runPut . mapM_ (Bin.putWord16host . P98.fromIntegral) + + + +-- from BinarySample +clip :: Ord a => a -> a -> a -> a +clip lower upper = max lower . min upper + +numToInt :: (RealField.C a) => a -> Int +numToInt x = round (32767 * clip (-1) 1 x) + +-- from BinarySample +-- return type could be Int16, but that is not well supported by NumericPrelude +numToInt16 :: (RealField.C a) => a -> Int16 +numToInt16 = P98.fromIntegral . numToInt + +roundDouble :: Double -> Int +roundDouble x = + double2Int (if x<0 then x-0.5 else x+0.5) + +doubleToInt :: Double -> Int +doubleToInt x = roundDouble (32767 * clip (-1) 1 x) + +doubleToInt16 :: Double -> Int16 +doubleToInt16 = P98.fromIntegral . doubleToInt + + + + +int16ToChars :: Int -> String +int16ToChars x = + let (hi,lo) = divMod x 256 + in [toEnum lo, toEnum (mod hi 256)] + +int16ToCharsS :: Int -> String -> String +int16ToCharsS x s = + let (hi,lo) = divMod x 256 + in toEnum lo : toEnum (mod hi 256) : s + +int16ToBytes :: Int -> [Word8] +int16ToBytes x = + let (hi,lo) = divMod x 256 +-- in [P98.fromIntegral lo, P98.fromIntegral (mod hi 256)] + in [P98.fromIntegral lo, P98.fromIntegral hi] + -- conversion to Word8 wraps silently to positive values + + +{- * machine oriented techniques -} + +writeSignalMonoPoke :: + FilePath -> [Int16] -> IO () +writeSignalMonoPoke fileName signal = + bracket (openBinaryFile fileName WriteMode) hClose $ + \h -> alloca $ + \p -> mapM_ (putInt h p) signal + +putInt :: Handle -> Ptr Int16 -> Int16 -> IO () +putInt h p n = + poke p n >> hPutBuf h p (sizeOf n) + + +maxBlockSize :: Int +maxBlockSize = 1000 + +int16size :: Int +int16size = sizeOf (undefined::Int16) + +writeSignalMonoBlock :: + FilePath -> [Int16] -> IO () +writeSignalMonoBlock fileName signal = + bracket (openBinaryFile fileName WriteMode) hClose $ + \h -> let blocks = sliceVertical maxBlockSize signal + in allocaBytes (int16size * maxBlockSize) $ + \p -> mapM_ (putIntBlock h p) blocks + +putIntBlock :: Handle -> Ptr Int16 -> [Int16] -> IO () +putIntBlock h p xs = + do cnt <- foldM (\n x -> pokeElemOff p n x >> return (n+1)) 0 xs + hPutBuf h p (int16size * cnt) + +putIntBlockSlow :: Handle -> Ptr Int16 -> [Int16] -> IO () +putIntBlockSlow h p xs = + do zipWithM_ (pokeElemOff p) [0..] xs + hPutBuf h p (int16size * length xs) + + +chopLength :: Int {- ^ block size -} -> Int {- ^ length -} -> [Int] +chopLength blockSize = + unfoldr (\l -> let chunkSize = min blockSize l + in toMaybe (l>0) (chunkSize, l-chunkSize)) + +writeZeroBlocks :: + FilePath -> Int -> IO () +writeZeroBlocks fileName len = + bracket (openBinaryFile fileName WriteMode) hClose $ + \h -> allocaBytes (int16size * maxBlockSize) $ + \p -> + do mapM_ (\off -> pokeElemOff p off (P98.fromInteger 0 :: Int16)) + [0 .. maxBlockSize-1] + mapM_ (hPutBuf h p) + (map (int16size*) (chopLength maxBlockSize len)) + + +{- * driver -} + +measureTime :: String -> IO () -> IO () +measureTime name act = + do putStr (name++": ") + timeA <- getClockTime + act + timeB <- getClockTime + let td = diffClockTimes timeB timeA + print (fromIntegral (tdSec td) + + fromInteger (tdPicosec td) * 1e-12 :: Double) + +numSamples :: Int +numSamples = 200000 + +zeroSignal, sawSignal :: [Double] +zeroSignal = replicate numSamples 0 +sawSignal = take numSamples (osciModSaw 0 (exponential2 100000 0.1)) + +polysawSignal :: [Double] +polysawSignal = + take numSamples + (osciModSaw 0 (exponential2 100000 0.1) + + osciModSaw 0 (exponential2 100000 0.1001)) + +zeroSignal16, sawSignal16 :: [Int16] +zeroSignal16 = map numToInt16 zeroSignal +sawSignal16 = map numToInt16 sawSignal + +sawSignal16NonShared :: Double -> [Int16] +sawSignal16NonShared halfLife = + map numToInt16 + (take numSamples (osciModSaw 0 (exponential2 halfLife 0.1) :: [Double])) + +sawSignalIntNonShared :: Double -> [Int] +sawSignalIntNonShared halfLife = + map doubleToInt + (take numSamples (osciModSaw 0 (exponential2 halfLife 0.1) :: [Double])) + +zeroStream, zeroStreamPaired :: String +zeroStream = replicate (2*numSamples) '\000' +zeroStreamPaired = concat $ replicate numSamples "\001\000" + +sawStream :: String +sawStream = take (2*numSamples) (cycle ['\000'..'\177']) + +zeroByteString :: B.ByteString +zeroByteString = + B.replicate (P98.fromIntegral (2 * numSamples)) + (P98.fromIntegral (0::Int)) + +zeroByteStringPaired :: B.ByteString +zeroByteStringPaired = + B.concat $ replicate numSamples $ + B.pack [P98.fromIntegral (0::Int), P98.fromIntegral (1::Int)] + + +tests :: [(String, FilePath, FilePath -> IO ())] +tests = + ("zero bytestring", "zerobytestring.sw", flip B.writeFile zeroByteString) : + ("zero bytestring words", "zerobytestrnwd.sw", flip B.writeFile zeroByteStringPaired) : + ("zero blocks", "zerofastblocks.sw", flip writeZeroBlocks numSamples) : + ("zero bytes", "zerofast.sw", flip writeFile zeroStream) : + ("zero words", "zerowords.sw", flip writeFile zeroStreamPaired) : + ("saw bytes", "sawbytes.sw", flip writeFile sawStream) : + -- only the first test is reliable, because the subsequent test can access the already computed data + ("zero signal binary put", "zerowordbinary.sw", flip writeSignalMonoBinaryPut zeroSignal16) : + ("zero signal bytestring", "zerowordstring.sw", flip writeSignalMonoBStr zeroSignal16) : + ("zero signal block-wise", "zeroblock.sw", flip writeSignalMonoBlock zeroSignal16) : + ("zero signal poke", "zeropoke.sw", flip writeSignalMonoPoke zeroSignal16) : + ("zero signal foldr", "zerofoldr.sw", flip writeSignalMonoS zeroSignal16) : + ("zero signal", "zero.sw", flip writeSignalMono zeroSignal16) : + ("saw binary int lib", "sawbinaryint.sw", flip writeSignalMonoBinaryIntPut $ sawSignalIntNonShared 100004) : + ("saw int", "sawint.sw", flip writeSignalMonoInt $ sawSignalIntNonShared 100005) : + -- the same problem as with zeros + ("saw bytestring", "sawbytestring.sw", flip writeSignalMono sawSignal16) : + ("saw", "saw.sw", flip writeSignalMono sawSignal16) : + ("saw bytestring non-shd", "sawbytestrngns.sw", flip writeSignalMono $ sawSignal16NonShared 100001) : + ("saw non-shared", "sawns.sw", flip writeSignalMono $ sawSignal16NonShared 100002) : + ("saw binary lib", "sawbinary.sw", flip writeSignalMonoBinaryPut $ sawSignal16NonShared 100003) : + ("poly-saw binary lib", "polysawbinary.sw", flip writeSignalMonoBinaryPut $ map numToInt16 polysawSignal) : + [] + + +main :: IO () +main = + do mapM (\(label, fileName, action) -> + measureTime label (action fileName)) + tests + + when False $ + mapM_ (\(_,fileName,_) -> removeFile fileName) + tests diff --git a/speedtest/SpeedTestExp.hs b/speedtest/SpeedTestExp.hs new file mode 100644 --- /dev/null +++ b/speedtest/SpeedTestExp.hs @@ -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> + 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> + 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> + 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) diff --git a/speedtest/SpeedTestSimple.hs b/speedtest/SpeedTestSimple.hs new file mode 100644 --- /dev/null +++ b/speedtest/SpeedTestSimple.hs @@ -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) diff --git a/src-3/Synthesizer/Causal/Process.hs b/src-3/Synthesizer/Causal/Process.hs new file mode 100644 --- /dev/null +++ b/src-3/Synthesizer/Causal/Process.hs @@ -0,0 +1,393 @@ +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ExistentialQuantification #-} +{- | +Processes that use only the current and past data. +Essentially this is a data type for the 'Synthesizer.State.Signal.crochetL' function. +-} +{- +ToDo: +Causal process usually depend on the sample rate, +so we need a phantom type parameter of T for the rate. + +Include ST monad for mutable arrays, +this can be useful for delay lines. +On the other hand, couldn't we also use the StorableVector.Cursor data structure +and avoid the ST monad here? +-} +module Synthesizer.Causal.Process ( + T, + fromStateMaybe, + fromState, + fromSimpleModifier, + + id, + map, + first, + second, + compose, + split, + fanout, + loop, + +{- + We don't re-export these identifiers + because people could abuse them for other Arrows. + + (>>>), (***), (&&&), + (Arrow.^<<), (Arrow.^>>), (Arrow.<<^), (Arrow.>>^), +-} + + apply, + applyFst, + applySnd, + applyGeneric, + applyGenericSameType, + applyConst, + apply2, + apply3, + + feed, + feedFst, + feedSnd, + feedGenericFst, + feedGenericSnd, + feedConstFst, + feedConstSnd, + + crochetL, + scanL, + scanL1, + zipWith, + consInit, + chainControlled, + replicateControlled, + feedback, + feedbackControlled, + + -- for testing + applyFst', + applySnd', +) where + +import qualified Synthesizer.State.Signal as Sig +import qualified Synthesizer.Generic.Signal as SigG +import qualified Synthesizer.Generic.Signal2 as SigG2 + +import qualified Synthesizer.Plain.Modifier as Modifier + +-- import qualified Control.Arrow as Arrow + +import Control.Arrow + (Arrow(..), returnA, (<<<), (^>>), {- ArrowApply(..), -} ArrowLoop(..), + Kleisli(Kleisli), runKleisli, ) +import Control.Monad.Trans.State + (State, state, runState, + StateT(StateT), runStateT, ) +import Control.Monad (liftM, ) + +import Data.Tuple.HT (mapSnd, ) +import Data.Function.HT (nest, ) +import Prelude hiding (id, map, zipWith, ) + + + +-- | Cf. StreamFusion 'Synthesizer.State.Signal.T' +data T a b = + forall s. -- Seq s => + Cons !(a -> StateT s Maybe b) -- compute next value + !s -- initial state + + + +{-# INLINE fromStateMaybe #-} +fromStateMaybe :: (a -> StateT s Maybe b) -> s -> T a b +fromStateMaybe = Cons + +{-# INLINE fromState #-} +fromState :: (a -> State s b) -> s -> T a b +fromState f = + fromStateMaybe (\x -> StateT (Just . runState (f x))) + +{-# INLINE fromSimpleModifier #-} +fromSimpleModifier :: + Modifier.Simple s ctrl a b -> T (ctrl,a) b +fromSimpleModifier (Modifier.Simple s f) = + fromState (uncurry f) s + + +{- +It's almost a Kleisli Arrow, +but the hidden type of the state disturbs. +-} +instance Arrow T where + {-# INLINE pure #-} + {-# INLINE (>>>) #-} + {-# INLINE first #-} + {-# INLINE second #-} + {-# INLINE (***) #-} + {-# INLINE (&&&) #-} + + pure = map + (>>>) = compose + first = liftKleisli first + second = liftKleisli second + (***) = split + (&&&) = fanout + + +{- +I think we cannot define an ArrowApply instance, +because we must extract the initial state somehow +from the inner (T a b) which is not possible. + +instance ArrowApply T where +-- app = Cons (runKleisli undefined) () + app = first (arr (flip Cons () . runKleisli)) >>> app +-} + + +instance ArrowLoop T where + {-# INLINE loop #-} + loop = liftKleisli loop + + +{-# INLINE extendStateFstT #-} +extendStateFstT :: Monad m => StateT s m a -> StateT (t,s) m a +extendStateFstT st = + StateT (\(t0,s0) -> liftM (mapSnd (\s1 -> (t0,s1))) (runStateT st s0)) + +{-# INLINE extendStateSndT #-} +extendStateSndT :: Monad m => StateT s m a -> StateT (s,t) m a +extendStateSndT st = + StateT (\(s0,t0) -> liftM (mapSnd (\s1 -> (s1,t0))) (runStateT st s0)) + + +{-# INLINE liftKleisli #-} +liftKleisli :: + (forall s. + Kleisli (StateT s Maybe) a0 a1 -> + Kleisli (StateT s Maybe) b0 b1) -> + T a0 a1 -> T b0 b1 +liftKleisli op (Cons f s) = + Cons (runKleisli $ op $ Kleisli f) s + +{-# INLINE liftKleisli2 #-} +liftKleisli2 :: + (forall s. + Kleisli (StateT s Maybe) a0 a1 -> + Kleisli (StateT s Maybe) b0 b1 -> + Kleisli (StateT s Maybe) c0 c1) -> + T a0 a1 -> T b0 b1 -> T c0 c1 +liftKleisli2 op (Cons f s) (Cons g t) = + Cons + (runKleisli + (Kleisli (extendStateSndT . f) `op` + Kleisli (extendStateFstT . g))) + (s,t) + + +{-# INLINE id #-} +id :: T a a +id = returnA + +{-# INLINE map #-} +map :: (a -> b) -> T a b +map f = fromState (return . f) () + +{-# INLINE compose #-} +compose :: T a b -> T b c -> T a c +compose = liftKleisli2 (>>>) + +{-# INLINE split #-} +split :: T a b -> T c d -> T (a,c) (b,d) +split = liftKleisli2 (***) + +{-# INLINE fanout #-} +fanout :: T a b -> T a c -> T a (b,c) +fanout = liftKleisli2 (&&&) + + +{-# INLINE getNext #-} +getNext :: StateT (Sig.T a) Maybe a +getNext = StateT Sig.viewL + +{-# INLINE apply #-} +apply :: T a b -> Sig.T a -> Sig.T b +apply (Cons f s) = + Sig.crochetL (runStateT . f) s + +{- | +I think this function does too much. +Better use 'feedFst' and (>>>). +-} +{-# INLINE applyFst #-} +applyFst, applyFst' :: T (a,b) c -> Sig.T a -> T b c +applyFst c as = + c <<< feedFst as + +applyFst' (Cons f s) as = + Cons (\b -> + do a <- extendStateFstT getNext + extendStateSndT (f (a,b))) + (s,as) + +{- | +I think this function does too much. +Better use 'feedSnd' and (>>>). +-} +{-# INLINE applySnd #-} +applySnd, applySnd' :: T (a,b) c -> Sig.T b -> T a c +applySnd c as = + c <<< feedSnd as + +applySnd' (Cons f s) bs = + Cons (\a -> + do b <- extendStateFstT getNext + extendStateSndT (f (a,b))) + (s,bs) + +{-# INLINE applyGeneric #-} +applyGeneric :: (SigG2.Transform sig a b) => + T a b -> sig a -> sig b +applyGeneric (Cons f s) = + SigG2.crochetL (runStateT . f) s + +{-# INLINE applyGenericSameType #-} +applyGenericSameType :: (SigG.Transform sig a) => + T a a -> sig a -> sig a +applyGenericSameType (Cons f s) = + SigG.crochetL (runStateT . f) s + + +{- | +applyConst c x == apply c (repeat x) +-} +{-# INLINE applyConst #-} +applyConst :: T a b -> a -> Sig.T b +applyConst (Cons f s) a = + Sig.unfoldR (runStateT (f a)) s + +{- +Can be easily done by converting the result of applyConst to generic signal +{-# INLINE applyConstGeneric #-} +applyConstGeneric :: SigG.LazySize -> T a b -> a -> sig b +applyConstGeneric size (Cons f s) a = + SigG.unfoldR size (runStateT (f a)) s +-} + + +{-# INLINE apply2 #-} +apply2 :: T (a,b) c -> Sig.T a -> Sig.T b -> Sig.T c +apply2 f x y = + apply (applyFst f x) y + +{-# INLINE apply3 #-} +apply3 :: T (a,b,c) d -> Sig.T a -> Sig.T b -> Sig.T c -> Sig.T d +apply3 f x y z = + apply2 (applyFst ((\(a,(b,c)) -> (a,b,c)) ^>> f) x) y z + + +{-# INLINE feed #-} +feed :: Sig.T a -> T () a +feed = fromStateMaybe (const getNext) + +{-# INLINE feedFst #-} +feedFst :: Sig.T a -> T b (a,b) +feedFst = fromStateMaybe (\b -> fmap (flip (,) b) getNext) + +{-# INLINE feedSnd #-} +feedSnd :: Sig.T a -> T b (b,a) +feedSnd = fromStateMaybe (\b -> fmap ((,) b) getNext) + +{-# INLINE feedConstFst #-} +feedConstFst :: a -> T b (a,b) +feedConstFst a = map (\b -> (a,b)) + +{-# INLINE feedConstSnd #-} +feedConstSnd :: a -> T b (b,a) +feedConstSnd a = map (\b -> (b,a)) + +{-# INLINE feedGenericFst #-} +feedGenericFst :: (SigG.Read sig a) => + sig a -> T b (a,b) +feedGenericFst = + feedFst . SigG.toState + +{-# INLINE feedGenericSnd #-} +feedGenericSnd :: (SigG.Read sig a) => + sig a -> T b (b,a) +feedGenericSnd = + feedSnd . SigG.toState + + + +-- * list like functions + +{-# INLINE crochetL #-} +crochetL :: (x -> acc -> Maybe (y, acc)) -> acc -> T x y +crochetL f s = fromStateMaybe (StateT . f) s + +{-# INLINE scanL #-} +scanL :: (acc -> x -> acc) -> acc -> T x acc +scanL f start = + fromState (\x -> state $ \acc -> (acc, f acc x)) start + +{-# INLINE scanL1 #-} +scanL1 :: (x -> x -> x) -> T x x +scanL1 f = + crochetL (\x acc -> Just (x, Just $ maybe x (flip f x) acc)) Nothing + +{-# INLINE zipWith #-} +zipWith :: (a -> b -> c) -> Sig.T a -> T b c +zipWith f = applyFst (map (uncurry f)) + +{- | +Prepend an element to a signal, +but keep the signal length, +i.e. drop the last element. +-} +{-# INLINE consInit #-} +consInit :: x -> T x x +consInit = + crochetL (\x acc -> Just (acc, x)) + + + +{-# INLINE chainControlled #-} +chainControlled :: [T (c,x) x] -> T (c,x) x +chainControlled = + foldr + (\p rest -> map fst &&& p >>> rest) + (map snd) + +{- | +If @T@ would be the function type @->@ +then @replicateControlled 3 f@ computes +@\(c,x) -> f(c, f(c, f(c, x)))@. +-} +{-# INLINE replicateControlled #-} +replicateControlled :: Int -> T (c,x) x -> T (c,x) x +replicateControlled n p = + nest n + (map fst &&& p >>> ) + (map snd) + + +{-# INLINE feedback #-} +feedback :: T (a,c) b -> T b c -> T a b +feedback forth back = + loop (forth >>> id &&& back) + +{-# INLINE feedbackControlled #-} +feedbackControlled :: T ((ctrl,a),c) b -> T (ctrl,b) c -> T (ctrl,a) b +feedbackControlled forth back = + loop (map (fst.fst) &&& forth >>> map snd &&& back) + +{- +{-# INLINE feedbackControlled #-} +feedbackControlled :: T (ctrl, (a,c)) b -> T (ctrl,b) c -> T (ctrl,a) b +feedbackControlled forth back = + loop ((\((ctrl,a),c) -> (ctrl, (a,c))) ^>> + map fst &&& forth >>> + map snd &&& back) +-} diff --git a/src-4/Synthesizer/Causal/Process.hs b/src-4/Synthesizer/Causal/Process.hs new file mode 100644 --- /dev/null +++ b/src-4/Synthesizer/Causal/Process.hs @@ -0,0 +1,398 @@ +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ExistentialQuantification #-} +{- | +Processes that use only the current and past data. +Essentially this is a data type for the 'Synthesizer.State.Signal.crochetL' function. +-} +{- +ToDo: +Causal process usually depend on the sample rate, +so we need a phantom type parameter of T for the rate. + +Include ST monad for mutable arrays, +this can be useful for delay lines. +On the other hand, couldn't we also use the StorableVector.Cursor data structure +and avoid the ST monad here? +-} +module Synthesizer.Causal.Process ( + T, + fromStateMaybe, + fromState, + fromSimpleModifier, + + id, + map, + first, + second, + compose, + split, + fanout, + loop, + +{- + We don't re-export these identifiers + because people could abuse them for other Arrows. + + (>>>), (***), (&&&), + (Arrow.^<<), (Arrow.^>>), (Arrow.<<^), (Arrow.>>^), +-} + + apply, + applyFst, + applySnd, + applyGeneric, + applyGenericSameType, + applyConst, + apply2, + apply3, + + feed, + feedFst, + feedSnd, + feedGenericFst, + feedGenericSnd, + feedConstFst, + feedConstSnd, + + crochetL, + scanL, + scanL1, + zipWith, + consInit, + chainControlled, + replicateControlled, + feedback, + feedbackControlled, + + -- for testing + applyFst', + applySnd', +) where + +import qualified Synthesizer.State.Signal as Sig +import qualified Synthesizer.Generic.Signal as SigG +import qualified Synthesizer.Generic.Signal2 as SigG2 + +import qualified Synthesizer.Plain.Modifier as Modifier + +-- import qualified Control.Arrow as Arrow + +import qualified Control.Category as Cat +import Control.Arrow + (Arrow(..), returnA, (<<<), (>>>), (^>>), {- ArrowApply(..), -} ArrowLoop(..), + Kleisli(Kleisli), runKleisli, ) +import Control.Monad.Trans.State + (State, state, runState, + StateT(StateT), runStateT, ) +import Control.Monad (liftM, ) + +import Data.Tuple.HT (mapSnd, ) +import Data.Function.HT (nest, ) +import Prelude hiding (id, map, zipWith, ) + + + +-- | Cf. StreamFusion 'Synthesizer.State.Signal.T' +data T a b = + forall s. -- Seq s => + Cons !(a -> StateT s Maybe b) -- compute next value + !s -- initial state + + + +{-# INLINE fromStateMaybe #-} +fromStateMaybe :: (a -> StateT s Maybe b) -> s -> T a b +fromStateMaybe = Cons + +{-# INLINE fromState #-} +fromState :: (a -> State s b) -> s -> T a b +fromState f = + fromStateMaybe (\x -> StateT (Just . runState (f x))) + +{-# INLINE fromSimpleModifier #-} +fromSimpleModifier :: + Modifier.Simple s ctrl a b -> T (ctrl,a) b +fromSimpleModifier (Modifier.Simple s f) = + fromState (uncurry f) s + + +{- +It's almost a Kleisli Arrow, +but the hidden type of the state disturbs. +-} +instance Cat.Category T where + {-# INLINE id #-} + {-# INLINE (.) #-} + + id = fromState return () + (.) = flip compose + +instance Arrow T where + {-# INLINE arr #-} + {-# INLINE first #-} + {-# INLINE second #-} + {-# INLINE (***) #-} + {-# INLINE (&&&) #-} + + arr = map + first = liftKleisli first + second = liftKleisli second + (***) = split + (&&&) = fanout + +{- +I think we cannot define an ArrowApply instance, +because we must extract the initial state somehow +from the inner (T a b) which is not possible. + +instance ArrowApply T where +-- app = Cons (runKleisli undefined) () + app = first (arr (flip Cons () . runKleisli)) >>> app +-} + + +instance ArrowLoop T where + {-# INLINE loop #-} + loop = liftKleisli loop + + +{-# INLINE extendStateFstT #-} +extendStateFstT :: Monad m => StateT s m a -> StateT (t,s) m a +extendStateFstT st = + StateT (\(t0,s0) -> liftM (mapSnd (\s1 -> (t0,s1))) (runStateT st s0)) + +{-# INLINE extendStateSndT #-} +extendStateSndT :: Monad m => StateT s m a -> StateT (s,t) m a +extendStateSndT st = + StateT (\(s0,t0) -> liftM (mapSnd (\s1 -> (s1,t0))) (runStateT st s0)) + + +{-# INLINE liftKleisli #-} +liftKleisli :: + (forall s. + Kleisli (StateT s Maybe) a0 a1 -> + Kleisli (StateT s Maybe) b0 b1) -> + T a0 a1 -> T b0 b1 +liftKleisli op (Cons f s) = + Cons (runKleisli $ op $ Kleisli f) s + +{-# INLINE liftKleisli2 #-} +liftKleisli2 :: + (forall s. + Kleisli (StateT s Maybe) a0 a1 -> + Kleisli (StateT s Maybe) b0 b1 -> + Kleisli (StateT s Maybe) c0 c1) -> + T a0 a1 -> T b0 b1 -> T c0 c1 +liftKleisli2 op (Cons f s) (Cons g t) = + Cons + (runKleisli + (Kleisli (extendStateSndT . f) `op` + Kleisli (extendStateFstT . g))) + (s,t) + + +{-# INLINE id #-} +id :: T a a +id = returnA + +{-# INLINE map #-} +map :: (a -> b) -> T a b +map f = fromState (return . f) () + +{-# INLINE compose #-} +compose :: T a b -> T b c -> T a c +compose = liftKleisli2 (>>>) + +{-# INLINE split #-} +split :: T a b -> T c d -> T (a,c) (b,d) +split = liftKleisli2 (***) + +{-# INLINE fanout #-} +fanout :: T a b -> T a c -> T a (b,c) +fanout = liftKleisli2 (&&&) + + +{-# INLINE getNext #-} +getNext :: StateT (Sig.T a) Maybe a +getNext = StateT Sig.viewL + +{-# INLINE apply #-} +apply :: T a b -> Sig.T a -> Sig.T b +apply (Cons f s) = + Sig.crochetL (runStateT . f) s + +{- | +I think this function does too much. +Better use 'feedFst' and (>>>). +-} +{-# INLINE applyFst #-} +applyFst, applyFst' :: T (a,b) c -> Sig.T a -> T b c +applyFst c as = + c <<< feedFst as + +applyFst' (Cons f s) as = + Cons (\b -> + do a <- extendStateFstT getNext + extendStateSndT (f (a,b))) + (s,as) + +{- | +I think this function does too much. +Better use 'feedSnd' and (>>>). +-} +{-# INLINE applySnd #-} +applySnd, applySnd' :: T (a,b) c -> Sig.T b -> T a c +applySnd c as = + c <<< feedSnd as + +applySnd' (Cons f s) bs = + Cons (\a -> + do b <- extendStateFstT getNext + extendStateSndT (f (a,b))) + (s,bs) + +{-# INLINE applyGeneric #-} +applyGeneric :: (SigG2.Transform sig a b) => + T a b -> sig a -> sig b +applyGeneric (Cons f s) = + SigG2.crochetL (runStateT . f) s + +{-# INLINE applyGenericSameType #-} +applyGenericSameType :: (SigG.Transform sig a) => + T a a -> sig a -> sig a +applyGenericSameType (Cons f s) = + SigG.crochetL (runStateT . f) s + + +{- | +applyConst c x == apply c (repeat x) +-} +{-# INLINE applyConst #-} +applyConst :: T a b -> a -> Sig.T b +applyConst (Cons f s) a = + Sig.unfoldR (runStateT (f a)) s + +{- +Can be easily done by converting the result of applyConst to generic signal +{-# INLINE applyConstGeneric #-} +applyConstGeneric :: SigG.LazySize -> T a b -> a -> sig b +applyConstGeneric size (Cons f s) a = + SigG.unfoldR size (runStateT (f a)) s +-} + + +{-# INLINE apply2 #-} +apply2 :: T (a,b) c -> Sig.T a -> Sig.T b -> Sig.T c +apply2 f x y = + apply (applyFst f x) y + +{-# INLINE apply3 #-} +apply3 :: T (a,b,c) d -> Sig.T a -> Sig.T b -> Sig.T c -> Sig.T d +apply3 f x y z = + apply2 (applyFst ((\(a,(b,c)) -> (a,b,c)) ^>> f) x) y z + + +{-# INLINE feed #-} +feed :: Sig.T a -> T () a +feed = fromStateMaybe (const getNext) + +{-# INLINE feedFst #-} +feedFst :: Sig.T a -> T b (a,b) +feedFst = fromStateMaybe (\b -> fmap (flip (,) b) getNext) + +{-# INLINE feedSnd #-} +feedSnd :: Sig.T a -> T b (b,a) +feedSnd = fromStateMaybe (\b -> fmap ((,) b) getNext) + +{-# INLINE feedConstFst #-} +feedConstFst :: a -> T b (a,b) +feedConstFst a = map (\b -> (a,b)) + +{-# INLINE feedConstSnd #-} +feedConstSnd :: a -> T b (b,a) +feedConstSnd a = map (\b -> (b,a)) + +{-# INLINE feedGenericFst #-} +feedGenericFst :: (SigG.Read sig a) => + sig a -> T b (a,b) +feedGenericFst = + feedFst . SigG.toState + +{-# INLINE feedGenericSnd #-} +feedGenericSnd :: (SigG.Read sig a) => + sig a -> T b (b,a) +feedGenericSnd = + feedSnd . SigG.toState + + + +-- * list like functions + +{-# INLINE crochetL #-} +crochetL :: (x -> acc -> Maybe (y, acc)) -> acc -> T x y +crochetL f s = fromStateMaybe (StateT . f) s + +{-# INLINE scanL #-} +scanL :: (acc -> x -> acc) -> acc -> T x acc +scanL f start = + fromState (\x -> state $ \acc -> (acc, f acc x)) start + +{-# INLINE scanL1 #-} +scanL1 :: (x -> x -> x) -> T x x +scanL1 f = + crochetL (\x acc -> Just (x, Just $ maybe x (flip f x) acc)) Nothing + +{-# INLINE zipWith #-} +zipWith :: (a -> b -> c) -> Sig.T a -> T b c +zipWith f = applyFst (map (uncurry f)) + +{- | +Prepend an element to a signal, +but keep the signal length, +i.e. drop the last element. +-} +{-# INLINE consInit #-} +consInit :: x -> T x x +consInit = + crochetL (\x acc -> Just (acc, x)) + + + +{-# INLINE chainControlled #-} +chainControlled :: [T (c,x) x] -> T (c,x) x +chainControlled = + foldr + (\p rest -> map fst &&& p >>> rest) + (map snd) + +{- | +If @T@ would be the function type @->@ +then @replicateControlled 3 f@ computes +@\(c,x) -> f(c, f(c, f(c, x)))@. +-} +{-# INLINE replicateControlled #-} +replicateControlled :: Int -> T (c,x) x -> T (c,x) x +replicateControlled n p = + nest n + (map fst &&& p >>> ) + (map snd) + + +{-# INLINE feedback #-} +feedback :: T (a,c) b -> T b c -> T a b +feedback forth back = + loop (forth >>> id &&& back) + +{-# INLINE feedbackControlled #-} +feedbackControlled :: T ((ctrl,a),c) b -> T (ctrl,b) c -> T (ctrl,a) b +feedbackControlled forth back = + loop (map (fst.fst) &&& forth >>> map snd &&& back) + +{- +{-# INLINE feedbackControlled #-} +feedbackControlled :: T (ctrl, (a,c)) b -> T (ctrl,b) c -> T (ctrl,a) b +feedbackControlled forth back = + loop ((\((ctrl,a),c) -> (ctrl, (a,c))) ^>> + map fst &&& forth >>> + map snd &&& back) +-} diff --git a/src-4/Synthesizer/Inference/DesignStudy/Applicative.hs b/src-4/Synthesizer/Inference/DesignStudy/Applicative.hs new file mode 100644 --- /dev/null +++ b/src-4/Synthesizer/Inference/DesignStudy/Applicative.hs @@ -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 diff --git a/src-4/Synthesizer/Inference/DesignStudy/Arrow.hs b/src-4/Synthesizer/Inference/DesignStudy/Arrow.hs new file mode 100644 --- /dev/null +++ b/src-4/Synthesizer/Inference/DesignStudy/Arrow.hs @@ -0,0 +1,50 @@ +module Synthesizer.Inference.DesignStudy.Arrow where + +{- + A hint from Haskell cafe about how to design signal processors + that adapt to a common sample rate. +-} + +{- +Date: Fri, 12 Nov 2004 02:59:31 +0900 +From: Koji Nakahara +To: haskell-cafe@haskell.org +-} + +import Control.Category +import Control.Arrow +import Data.List (intersect) +data Rates = Rates [Int] | Any deriving Show +data Processor b c = P Rates (Rates -> b -> c) + +-- test Stream +type Stream = String + +intersectRates :: Rates -> Rates -> Rates +intersectRates Any y = y +intersectRates x Any = x +intersectRates (Rates xs) (Rates ys) = Rates $ intersect xs ys + +instance Category Processor where + id = P Any (const Prelude.id) + (P r1 f1) . (P r0 f0) = + P (intersectRates r0 r1) (\r -> f1 r Prelude.. f0 r) + +instance Arrow Processor where + arr f = P Any (const f) + first (P r0 f) = P r0 (\r (x, s) -> (f r x, s)) + + +runProcessor :: Processor b c -> b -> c +runProcessor (P r f) s = f r s + +-- test processors +process, processor1, processor2, processor3 :: Processor String String +processor1 = P (Rates [44100, 48000]) (\r -> ( ++ show r)) +processor2 = P Any (\r -> ( ++ show r)) +processor3 = P (Rates [48000]) (\r -> ( ++ show r)) + +process = processor1 >>> processor2 >>> processor3 + +test :: String +test = runProcessor process "bla" diff --git a/src-4/Synthesizer/Inference/DesignStudy/Monad.hs b/src-4/Synthesizer/Inference/DesignStudy/Monad.hs new file mode 100644 --- /dev/null +++ b/src-4/Synthesizer/Inference/DesignStudy/Monad.hs @@ -0,0 +1,44 @@ +{- | + A design study about how to design signal processors + that adapt to a common sample rate. + I tried to simplify "Synthesizer.Inference.DesignStudy.Arrow" to this module which uses only Monads. + However the module is now very weird and does not really represent, + what I intended to do. +-} +module Synthesizer.Inference.DesignStudy.Monad where + +import Control.Monad.Trans.Writer (Writer, execWriter, tell) +import Data.List (intersect) + +data Rates = Rates [Int] | Any deriving Show +-- it is a combination of Reader and Writer monad with context processing +data Processor a = P Rates (Rates -> Writer Stream a) + +-- test Stream +type Stream = String + +intersectRates :: Rates -> Rates -> Rates +intersectRates Any y = y +intersectRates x Any = x +intersectRates (Rates xs) (Rates ys) = Rates $ intersect xs ys + +instance Monad Processor where + return x = P Any (\_ -> return x) + -- maybe we should turn this into an Applicative instance + (P r0 f0) >> (P r1 f1) = + P (intersectRates r0 r1) (\r -> f0 r >> f1 r) + (P _ _) >>= _ = error "Is it possible to implement that?" + +runProcessor :: Processor a -> Stream +runProcessor (P r f) = execWriter (f r) + +-- test processors +process, processor1, processor2, processor3 :: Processor () +processor1 = P (Rates [44100, 48000]) (tell . show) +processor2 = P Any (tell . show) +processor3 = P (Rates [47000]) (tell . show) + +process = processor1 >> processor2 >> processor3 + +test :: Stream +test = runProcessor process diff --git a/src/Synthesizer/ApplicativeUtility.hs b/src/Synthesizer/ApplicativeUtility.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/ApplicativeUtility.hs @@ -0,0 +1,111 @@ +-- this is also used by synthesizer-dimensional and synthesizer-inference +module Synthesizer.ApplicativeUtility where + +import Control.Applicative (Applicative, pure, (<*>), (<$>), liftA2, ) +import Data.Traversable (Traversable, sequenceA, ) + +import Control.Monad.Fix (fix, ) + + +{-# INLINE liftA4 #-} +liftA4 :: Applicative f => + (a -> b -> c -> d -> e) -> f a -> f b -> f c -> f d -> f e +liftA4 f a b c d = f <$> a <*> b <*> c <*> d + +{-# INLINE liftA5 #-} +liftA5 :: Applicative f => + (a -> b -> c -> d -> e -> g) -> f a -> f b -> f c -> f d -> f e -> f g +liftA5 f a b c d e = f <$> a <*> b <*> c <*> d <*> e + +{-# INLINE liftA6 #-} +liftA6 :: Applicative f => + (a -> b -> c -> d -> e -> g -> h) -> f a -> f b -> f c -> f d -> f e -> f g -> f h +liftA6 f a b c d e g = f <$> a <*> b <*> c <*> d <*> e <*> g + + +{- | +Create a loop (feedback) from one node to another one. +That is, compute the fix point of a process iteration. +-} +{-# INLINE loop #-} +loop :: (Functor f) => + f (a -> a) {-^ process chain that shall be looped -} + -> f a +loop = fmap fix + + +infixl 0 $:, $::, $^, $# +infixr 9 .:, .^ + +{- | +This corresponds to 'Control.Applicative.<*>' +-} +{-# INLINE ($:) #-} +($:) :: (Applicative f) => f (a -> b) -> f a -> f b +($:) = (<*>) + +{- | +Instead of @mixMulti $:: map f xs@ +the caller should write @mixMulti $: mapM f xs@ +in order to save the user from learning another infix operator. +-} +{-# INLINE ($::) #-} +($::) :: (Applicative f, Traversable t) => + f (t a -> b) -> t (f a) -> f b +($::) f arg = f $: sequenceA arg +-- ($::) f arg sr = f sr (map ($sr) arg) + +{-# INLINE (.:) #-} +(.:) :: (Applicative f) => f (b -> c) -> f (a -> b) -> f (a -> c) +(.:) = liftA2 (.) +-- (.:) f g sr x = f sr (g sr x) +-- (.:) f g sr x = ($:) f (flip g x) sr + +{-# INLINE ($^) #-} +($^) :: (Functor f) => (a -> b) -> f a -> f b +($^) = fmap +-- ($^) = (.) +-- ($^) f x = pure f $: x + +{-# INLINE (.^) #-} +(.^) :: (Functor f) => (b -> c) -> f (a -> b) -> f (a -> c) +(.^) f = fmap (f.) +-- (.^) f = (.:) (pure f) + +{-# INLINE ($#) #-} +($#) :: (Applicative f) => f (a -> b) -> a -> f b +($#) f x = f $: pure x +-- ($#) = flip + + +{- | +Our signal processors have types like @f (a -> b -> c)@. +They could also have the type @a -> b -> f c@ +or @f a -> f b -> f c@. +We did not choose the last variant for reduction of redundancy in type signatures, +and we did not choose the second variant for easy composition of processors. +However the forms are freely convertible, +and if you prefer the last one because you do not want to sprinkle '($:)' in your code, +then you may want to convert the processors using the following functions, +that can be defined purely in the 'Control.Applicative.Applicative' class. +-} + +{-# INLINE liftP #-} +liftP :: (Applicative f) => + f (a -> b) -> f a -> f b +liftP = ($:) + +{-# INLINE liftP2 #-} +liftP2 :: (Applicative f) => + f (a -> b -> c) -> f a -> f b -> f c +liftP2 f a b = f $: a $: b + +{-# INLINE liftP3 #-} +liftP3 :: (Applicative f) => + f (a -> b -> c -> d) -> f a -> f b -> f c -> f d +liftP3 f a b c = f $: a $: b $: c + +{-# INLINE liftP4 #-} +liftP4 :: (Applicative f) => + f (a -> b -> c -> d -> e) -> f a -> f b -> f c -> f d -> f e +liftP4 f a b c d = f $: a $: b $: c $: d diff --git a/src/Synthesizer/Basic/Binary.hs b/src/Synthesizer/Basic/Binary.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Basic/Binary.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Synthesizer.Basic.Binary + (C(..), toCanonical, fromCanonicalWith, + numberOfSignalChannels, + int16ToCanonical, int16FromCanonical, + int16FromFloat, int16FromDouble, + ) where + +import qualified Synthesizer.Frame.Stereo as Stereo + +import Data.Monoid (Monoid, mappend, ) + +import qualified Algebra.ToInteger as ToInteger +import qualified Algebra.RealField as RealField +import qualified Algebra.Real as Real +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring + +import Data.Ord.HT (limit, ) + +import Data.Int (Int16, ) +import GHC.Float (float2Int, double2Int, ) + +import qualified Prelude as P98 + +import PreludeBase +import NumericPrelude + + + + +class C a where + outputFromCanonical :: + (Bounded int, ToInteger.C int, Monoid out) => + (int -> out) -> a -> out + numberOfChannels :: a -> Int + +instance C Float where + outputFromCanonical pack = + pack . + fromCanonicalWith + (fromIntegral . truncToRound float2Int) + numberOfChannels _ = 1 + +instance C Double where + outputFromCanonical pack = + pack . + fromCanonicalWith + (fromIntegral . truncToRound double2Int) + numberOfChannels _ = 1 + +instance (C a, C b) => C (a,b) where + outputFromCanonical pack x = + outputFromCanonical pack (fst x) `mappend` + outputFromCanonical pack (snd x) + numberOfChannels x = + numberOfChannels (fst x) + + numberOfChannels (snd x) + +instance (C a) => C (Stereo.T a) where + outputFromCanonical pack x = + outputFromCanonical pack (Stereo.left x) `mappend` + outputFromCanonical pack (Stereo.right x) + numberOfChannels x = + numberOfChannels (Stereo.left x) + + numberOfChannels (Stereo.right x) + + + +{-# INLINE numberOfSignalChannels #-} +numberOfSignalChannels :: + C yv => sig yv -> Int +numberOfSignalChannels sig = + let aux :: C yv => sig yv -> yv -> Int + aux _ dummy = numberOfChannels dummy + in aux sig undefined + +{-# INLINE fromCanonicalWith #-} +fromCanonicalWith :: + (Real.C real, Bounded int, ToInteger.C int) => + (real -> int) -> (real -> int) +fromCanonicalWith rnd r = + let s = fromIntegral (maxBound `asTypeOf` i) + i = rnd (s * limit (-1, 1) r) + in i + +{-# INLINE truncToRound #-} +truncToRound :: + (RealField.C real) => + (real -> int) -> (real -> int) +truncToRound trunc x = + trunc $ + if x<0 + then x - 0.5 + else x + 0.5 + +{-# INLINE scale16 #-} +scale16 :: (Ring.C a, Ord a) => a -> a +scale16 x = 32767 * limit (-1, 1) x + +{-# INLINE int16FromCanonical #-} +int16FromCanonical :: (RealField.C a) => a -> Int16 +int16FromCanonical = (P98.fromIntegral :: Int -> Int16) . round . scale16 +{- in GHC-6.4 inefficient, since 'round' for target Int16 is not optimized +int16FromCanonical = round . scale16 +-} + +{-# INLINE int16FromFloat #-} +int16FromFloat :: Float -> Int16 +int16FromFloat = P98.fromIntegral . float2Int . scale16 + + +{- +{-# INLINE scale16Double #-} +scale16Double :: (Ring.C a, Ord a) => a -> a +scale16Double x = 32767 * clip (-1) 1 x +-} + +{-# INLINE int16FromDouble #-} +int16FromDouble :: Double -> Int16 +{- Why is scale16 not inlined here? See FusionTest.mixTest3 +int16FromDouble = P98.fromIntegral . double2Int . scale16 +-} +-- int16FromDouble = P98.fromIntegral . double2Int . scale16Double +-- int16FromDouble x = P98.fromIntegral (double2Int (scale16 x)) +int16FromDouble = P98.fromIntegral . double2Int . (32767*) . limit (-1, 1) + + + + +{-# INLINE toCanonical #-} +toCanonical :: + (Field.C real, Bounded int, ToInteger.C int) => + (int -> real) +toCanonical i = + let s = fromIntegral (maxBound `asTypeOf` i) + in fromIntegral i / s + +{-# INLINE int16ToCanonical #-} +int16ToCanonical :: (Field.C a) => Int16 -> a +int16ToCanonical x = fromIntegral x / 32767 diff --git a/src/Synthesizer/Basic/Distortion.hs b/src/Synthesizer/Basic/Distortion.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Basic/Distortion.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Synthesizer.Basic.Distortion ( + clip, logit, + zigZag, sine, + quantize, + ) where + +import qualified Algebra.Transcendental as Trans +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Real as Real +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Data.Ord.HT (limit, ) + +-- import qualified Prelude as P +-- import PreludeBase +import NumericPrelude + + +{- * Clipping -} + +{- | +limit, fuzz booster +-} +clip :: (Real.C a) => a -> a +clip = limit (negate one, one) + +{- | +logit, tanh +-} +logit :: (Trans.C a) => a -> a +logit = tanh + +{- +probit, error function +-} + + + +{- * Wrapping -} + +{- | +zig-zag +-} +zigZag :: (RealField.C a) => a -> a +zigZag x = + let (n,y) = splitFraction ((x+1)/2) + in if even (n::Int) + then 2*y - 1 + else 1 - 2*y + +{- | +sine +-} +sine :: (Trans.C a) => a -> a +sine = sin + + + + +{- * Quantization -} + +quantize :: (RealField.C a) => a -> a +quantize x = fromIntegral (round x :: Int) diff --git a/src/Synthesizer/Basic/DistortionControlled.hs b/src/Synthesizer/Basic/DistortionControlled.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Basic/DistortionControlled.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Synthesizer.Basic.DistortionControlled ( + clip, logit, + zigZag, sine, + quantize, + ) where + +import qualified Synthesizer.Basic.Distortion as Dist + +import qualified Algebra.Transcendental as Trans +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Real as Real +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Data.Ord.HT (limit, ) + +-- import qualified Prelude as P +-- import PreludeBase +import NumericPrelude + +{- * Clipping -} + +{- | +limit, fuzz booster +-} +clip :: (Real.C a) => a -> a -> a +clip c = limit (negate c, c) + +{- | +logit, tanh +-} +logit :: (Trans.C a) => a -> a -> a +logit k = rescale k Dist.logit + +{- +probit, error function +-} + + + +{- * Wrapping -} + +{- | +zig-zag +-} +zigZag :: (RealField.C a) => a -> a -> a +zigZag k = rescale k Dist.zigZag + +{- | +sine +-} +sine :: (Trans.C a) => a -> a -> a +sine k = rescale k Dist.sine + + + + +{- * Quantization -} + +quantize :: (RealField.C a) => a -> a -> a +quantize k = rescale k Dist.quantize + + + +{- Auxilary function -} + +rescale :: (Field.C a) => a -> (a -> a) -> a -> a +rescale k f x = k * f (x/k) + +{- +*Synthesizer.Basic.Distortion> GNUPlot.plotFuncs [] (GNUPlot.linearScale 1000 (-3,3::Double)) (map logit [0,0.1..1]) +-} diff --git a/src/Synthesizer/Basic/Phase.hs b/src/Synthesizer/Basic/Phase.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Basic/Phase.hs @@ -0,0 +1,90 @@ +module Synthesizer.Basic.Phase + (T, + fromRepresentative, + toRepresentative, + increment, + decrement, + multiply, + ) where + +import qualified Algebra.RealField as RealField +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import qualified Algebra.ToInteger as ToInteger + +import System.Random (Random(..)) +import Test.QuickCheck (Arbitrary(..), choose) + +import Foreign.Storable (Storable(..), ) +import Foreign.Ptr (castPtr, ) + +import Data.Tuple.HT (mapFst, ) +import qualified NumericPrelude as NP + + +newtype T a = Cons {decons :: a} + deriving Eq + + +instance Show a => Show (T a) where + showsPrec p x = + showParen (p >= 10) + (showString "Phase.fromRepresentative " . showsPrec 11 (toRepresentative x)) + +instance Storable a => Storable (T a) where + {-# INLINE sizeOf #-} + sizeOf = sizeOf . toRepresentative + {-# INLINE alignment #-} + alignment = alignment . toRepresentative + {-# INLINE peek #-} + peek ptr = fmap Cons $ peek (castPtr ptr) + {-# INLINE poke #-} + poke ptr = poke (castPtr ptr) . toRepresentative + + +instance (Ring.C a, Random a) => Random (T a) where + randomR = error "Phase.randomR makes no sense" + random = mapFst Cons . randomR (NP.zero, NP.one) + +instance (Ring.C a, Random a) => Arbitrary (T a) where + arbitrary = fmap Cons $ choose (NP.zero, NP.one) + coarbitrary = error "Phase.coarbitrary not implemented" + + + +{-# INLINE fromRepresentative #-} +fromRepresentative :: RealField.C a => a -> T a +fromRepresentative = Cons . RealField.fraction + +{-# INLINE toRepresentative #-} +toRepresentative :: T a -> a +toRepresentative = decons + +{-# INLINE increment #-} +increment :: RealField.C a => a -> T a -> T a +increment d = lift (d Additive.+) + +{-# INLINE decrement #-} +decrement :: RealField.C a => a -> T a -> T a +decrement d = lift (Additive.subtract d) + +{-# INLINE multiply #-} +multiply :: (RealField.C a, ToInteger.C b) => b -> T a -> T a +multiply n x = fromRepresentative (toRepresentative x Ring.* NP.fromIntegral n) + + +instance RealField.C a => Additive.C (T a) where + {-# INLINE zero #-} + {-# INLINE (+) #-} + {-# INLINE (-) #-} + {-# INLINE negate #-} + zero = Cons Additive.zero + x + y = fromRepresentative (toRepresentative x Additive.+ toRepresentative y) + x - y = fromRepresentative (toRepresentative x Additive.- toRepresentative y) + negate = lift Additive.negate + +{-# INLINE lift #-} +lift :: RealField.C a => (a -> a) -> T a -> T a +lift f = + fromRepresentative . f . toRepresentative diff --git a/src/Synthesizer/Basic/ToneModulation.hs b/src/Synthesizer/Basic/ToneModulation.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Basic/ToneModulation.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Synthesizer.Basic.ToneModulation where + +import qualified Synthesizer.Basic.Phase as Phase + +import Synthesizer.Interpolation (Margin, marginOffset, marginNumber, ) + +-- import qualified Algebra.Transcendental as Trans +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +-- import qualified Algebra.Real as Real +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import NumericPrelude + +-- import qualified Prelude as P +import PreludeBase + + +{- | +Convert from the (shape,phase) parameter pair +to the index within a wave (step) and the index of a wave (leap) +in the sampled prototype tone. + +For this routine it would be simpler, +if @shape@ would measure in multiples of @period@ +(we would only need a Ring instance), +but for 'shapeLimit' it is better the way it is. +-} +untangleShapePhase :: (Field.C a) => + Int -> a -> (a, a) -> (a, a) +untangleShapePhase periodInt period (shape,phase) = + let leap = shape/period - phase + step = shape - leap * fromIntegral periodInt + in (leap, step) + +untangleShapePhaseAnalytic :: (Field.C a) => + Int -> a -> (a, a) -> (a, a) +untangleShapePhaseAnalytic periodInt period (shape,phase) = + let periodRound = fromIntegral periodInt + vLeap = (periodRound, periodRound-period) + vStep = (1,1) + in solveSLE2 (vLeap,vStep) (shape,period*phase) + +{- +Cramer's rule + +see HTam/Numerics/ZeroFinder/Root, however the matrix is transposed +-} +solveSLE2 :: Field.C a => ((a,a), (a,a)) -> (a,a) -> (a,a) +solveSLE2 a@(a0,a1) b = + let det = det2 a + in (det2 (b, a1) / det, + det2 (a0, b) / det) + +det2 :: Ring.C a => ((a,a), (a,a)) -> a +det2 ((a00,a10),(a01,a11)) = + a00*a11 - a10*a01 + +{- +transpose :: ((a,a), (a,a)) -> ((a,a), (a,a)) +transpose ((a00,a10),(a01,a11)) = ((a00,a01),(a10,a11)) +-} + + +flattenShapePhase, flattenShapePhaseAnalytic :: RealField.C a => + Int + -> a + -> (a, Phase.T a) + -> (Int, (a, a)) +flattenShapePhase periodInt period (shape,phase) = + let xLeap = shape/period - Phase.toRepresentative phase + qLeap = fraction xLeap + xStep = shape - qLeap * fromIntegral periodInt + (n,qStep) = splitFraction xStep + in (n,(qLeap,qStep)) + +flattenShapePhaseAnalytic periodInt period (shape,phase) = + let (xLeap,xStep) = + untangleShapePhase periodInt period (shape, Phase.toRepresentative phase) + (nLeap,qLeap) = splitFraction xLeap + (nStep,qStep) = splitFraction xStep + {- reverse solveSLE2 for the shape parameter + with respect to the rounded (wave,shape) coordinates -} + n = nStep + nLeap * periodInt + in (n,(qLeap,qStep)) + + +shapeLimits :: Ring.C t => + Margin -> + Margin -> + Int -> + t -> + (t, t) +shapeLimits marginLeap marginStep periodInt len = + let minShape = + fromIntegral $ + interpolationOffset marginLeap marginStep periodInt + + periodInt + maxShape = + minShape + len - + fromIntegral (interpolationNumber marginLeap marginStep periodInt) + in (minShape, maxShape) + +interpolationOffset :: + Margin -> + Margin -> + Int -> + Int +interpolationOffset marginLeap marginStep periodInt = + marginOffset marginStep + + marginOffset marginLeap * periodInt + +interpolationNumber :: + Margin -> + Margin -> + Int -> + Int +interpolationNumber marginLeap marginStep periodInt = + marginNumber marginStep + + marginNumber marginLeap * periodInt + + + +type Coords t = (Int,(Int,(t,t))) +type Skip t = (Int, (t, Phase.T t)) diff --git a/src/Synthesizer/Basic/Wave.hs b/src/Synthesizer/Basic/Wave.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Basic/Wave.hs @@ -0,0 +1,773 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{- | +Copyright : (c) Henning Thielemann 2006 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +Basic waveforms + +If you want to use parametrized waves with two parameters +then zip your parameter signals and apply 'uncurry' to the wave function. +-} +module Synthesizer.Basic.Wave where + +import qualified Synthesizer.Basic.Phase as Phase + +import qualified Algebra.RealTranscendental as RealTrans +import qualified Algebra.Transcendental as Trans +import qualified Algebra.RealField as RealField +import qualified Algebra.Algebraic as Algebraic +import qualified Algebra.Module as Module +import qualified Algebra.Field as Field +import qualified Algebra.Real as Real +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive +import qualified Algebra.ToInteger as ToInteger + +import qualified MathObj.Polynomial as Poly +import qualified Number.Complex as Complex + +import Data.Bool.HT (select, if', ) +import NumericPrelude + +-- import qualified Prelude as P +import PreludeBase + + +{- * Definition and construction -} + +newtype T t y = Cons {decons :: Phase.T t -> y} + + +{-# INLINE fromFunction #-} +fromFunction :: (t -> y) -> (T t y) +fromFunction wave = Cons (wave . Phase.toRepresentative) + + +{- * Operations on waves -} + +{-# INLINE raise #-} +raise :: (Additive.C y) => y -> T t y -> T t y +raise y = distort (y+) + +{-# INLINE amplify #-} +amplify :: (Ring.C y) => y -> T t y -> T t y +amplify k = distort (k*) + +{-# INLINE distort #-} +distort :: (y -> z) -> T t y -> T t z +distort g (Cons f) = Cons (g . f) + +{-# INLINE overtone #-} +overtone :: (RealField.C t, ToInteger.C n) => n -> T t y -> T t y +overtone n (Cons f) = Cons (f . Phase.multiply n) + +{-# INLINE apply #-} +apply :: T t y -> (Phase.T t -> y) +apply = decons + + + +instance Additive.C y => Additive.C (T t y) where + {-# INLINE zero #-} + {-# INLINE (+) #-} + {-# INLINE (-) #-} + {-# INLINE negate #-} + zero = Cons (const zero) + (+) (Cons f) (Cons g) = Cons (\t -> f t + g t) + (-) (Cons f) (Cons g) = Cons (\t -> f t - g t) + negate = distort negate + + +instance Module.C a y => Module.C a (T t y) where + {-# INLINE (*>) #-} + s *> w = distort (s*>) w + + +{- | +Turn an unparametrized waveform into a parametrized one, +where the parameter is a phase offset. +This way you express a phase modulated oscillator +using a shape modulated oscillator. +-} +{-# SPECULATE phaseOffset :: (T Double b) -> (Double -> T Double b) #-} +{-# INLINE phaseOffset #-} +phaseOffset :: (RealField.C a) => T a b -> (a -> T a b) +phaseOffset (Cons wave) offset = + Cons (wave . Phase.increment offset) + + + + +{- * Examples -} + +{- ** unparameterized -} + +{- | map a phase to value of a sine wave -} +{-# SPECULATE sine :: Double -> Double #-} +{-# INLINE sine #-} +sine :: Trans.C a => T a a +sine = fromFunction $ \x -> sin (2*pi*x) + +{-# INLINE cosine #-} +cosine :: Trans.C a => T a a +cosine = fromFunction $ \x -> cos (2*pi*x) + +{-# INLINE helix #-} +helix :: Trans.C a => T a (Complex.T a) +helix = fromFunction $ \x -> Complex.cis (2*pi*x) + +{- | +Approximation of sine by parabolas. +Surprisingly not really faster than 'sine'. +-} +{-# INLINE fastSine2 #-} +fastSine2 :: (Ord a, Ring.C a) => T a a +fastSine2 = fromFunction $ \x -> + if 2*x<1 + then 1 - sqr (4*x-1) + else sqr (4*x-3) - 1 + +{- | +Approximation of sine by fourth order polynomials. +-} +{-# INLINE fastSine4 #-} +fastSine4 :: (Ord a, Trans.C a) => T a a +fastSine4 = fromFunction $ \x -> + -- minimal least squares fit + let pi2 = pi*pi + pi3 = pi2*pi + c = 3*((10080/pi2 - 1050) / pi3 + 1) -- 0.2248391014 + {-# INLINE bow #-} + bow y = let y2 = y*y in 1-y2*(1+c*(1-y2)) + in if 2*x<1 + then bow (4*x-1) + else - bow (4*x-3) +{- +add a residue to fastSine2 and choose 'c' which minimizes the squared error + in if 2*x<1 + then let y = (4*x-1)^2 in 1-y-c*y*(1-y) + else let y = (4*x-3)^2 in y-1+c*y*(1-y) +-} + +{- +GNUPlot.plotFuncs [] (GNUPlot.linearScale 1000 (0,1::Double)) [sine, fastSine2, fastSine4] +-} + + +{- | saw tooth, +it's a ramp down in order to have a positive coefficient for the first partial sine +-} +{-# SPECULATE saw :: Double -> Double #-} +{-# INLINE saw #-} +saw :: Ring.C a => T a a +saw = fromFunction $ \x -> 1-2*x + +{- | +This wave has the same absolute Fourier coefficients as 'saw' +but the partial waves are shifted by 90 degree. +That is, it is the Hilbert transform of the saw wave. +The formula is derived from 'sawComplex'. +-} +{-# INLINE sawCos #-} +sawCos :: (Real.C a, Trans.C a) => T a a +sawCos = fromFunction $ \x -> log (2 * sin (pi*x)) * (-2/pi) + +{- | +@sawCos + i*saw@ + +This is an analytic function and thus it may be used for frequency shifting. + +The formula can be derived from the power series of the logarithm function. +-} +{-# INLINE sawComplex #-} +sawComplex :: + (Complex.Power a, RealTrans.C a) => + T a (Complex.T a) +sawComplex = fromFunction $ \x -> log (1 + Complex.cis (-pi*(1-2*x))) * (-2/pi) +{- +GNUPlot.plotFuncs [] (GNUPlot.linearScale 100 (0,1::Double)) [Complex.real . sawComplex, sawCos] + +GNUPlot.plotFuncs [] (GNUPlot.linearScale 100 (0,1::Double)) [sawCos, composedHarmonics (take 20 $ harmonic 0 0 : map (\n -> harmonic 0.25 ((2/pi) / fromInteger n)) [1..])] +-} + +{- +Matching implementation that do not match 'saw' exactly. + +sawCos :: (Real.C a, Trans.C a) => T a a +sawCos = fromFunction $ \x -> log (2 * abs (cos (pi*x))) + +sawComplex :: + (Complex.Power a, Trans.C a) => + T a (Complex.T a) +sawComplex = fromFunction $ \x -> log (1 + Complex.cis (2*pi*x)) +-} + + +{- | square -} +{-# SPECULATE square :: Double -> Double #-} +{-# INLINE square #-} +square :: (Ord a, Ring.C a) => T a a +square = fromFunction $ \x -> if 2*x<1 then 1 else -1 + +{- | +This wave has the same absolute Fourier coefficients as 'square' +but the partial waves are shifted by 90 degree. +That is, it is the Hilbert transform of the saw wave. +-} +{-# INLINE squareCos #-} +squareCos :: (RealField.C a, Trans.C a) => T a a +squareCos = fromFunction $ \x -> + log (abs (tan (pi*x))) * (-2/pi) + -- sawCos x - sawCos (fraction (0.5-x)) + +{- | +@squareCos + i*square@ + +This is an analytic function and thus it may be used for frequency shifting. + +The formula can be derived from the power series of the area tangens function. +-} +{-# INLINE squareComplex #-} +squareComplex :: + (Complex.Power a, RealTrans.C a) => + T a (Complex.T a) +squareComplex = fromFunction $ \x -> +{- these formulas are equivalent but wrong + + log (0 +: 2 * sine x) * (2/pi) + + log ((1 - Complex.cis (-2*pi*x)) * + (1 + Complex.cis ( 2*pi*x))) * (2/pi) + + sawComplex x + sawComplex (0.5-x) +-} + +{- +The Fourier series is equal to the power series of 'atanh'. +-} + atanh (Complex.cis (2*pi*x)) * (4/pi) +{- +GNUPlot.plotFuncs [] (GNUPlot.linearScale 100 (0,1::Double)) [squareCos, composedHarmonics (take 20 $ zipWith (\b n -> harmonic 0.25 (if b then (4/pi) / fromInteger n else 0)) (cycle [False,True]) [0..])] +-} + + +{- | triangle -} +{-# SPECULATE triangle :: Double -> Double #-} +{-# INLINE triangle #-} +triangle :: (Ord a, Ring.C a) => T a a +triangle = fromFunction $ \x -> + let x4 = 4*x + in select (2-x4) + [(x4<1, x4), + (x4>3, x4-4)] + +{- + +int(arctan(x)/x,x); + +- polylog(2, x*I)*1/2*I + polylog(2, x*(-I))*1/2*I + + +series(int(arctan(x)/x,x),x,10); + +x - 1/9*x^3 + 1/25*x^5 - 1/49*x^7 + 1/81*x^9 + O(x^11) + + + +int(arctan(I*x)/(I*x),x); +int(arctanh(x)/(x),x); + +1/2*polylog(2, x) - 1/2*polylog(2, -x) +int(1/x*arctanh(x), x) + +polylog(2,x) = dilog(1-x); -- dilog is implemented in GSL for complex arguments +polylog(2,x) = hypergeom([1,1,1],[2,2],x) * x; + + +series(int(arctan(I*x)/(I*x),x),x,10); + +x + 1/9*x^3 + 1/25*x^5 + 1/49*x^7 + 1/81*x^9 + O(x^11) +-} + + +{- ** discretely parameterized -} + +{- | +A truncated cosine. This has rich overtones. +-} +truncOddCosine :: Trans.C a => + Int -> T a a +truncOddCosine k = + let f = pi * fromIntegral (2*k+1) + in fromFunction $ \ x -> cos (f*x) + +{- | +For parameter zero this is 'saw'. +-} +truncOddTriangle :: (RealField.C a) => + Int -> T a a +truncOddTriangle k = + let s = fromIntegral (2*k+1) + in fromFunction $ \ x -> + let (n,frac) = splitFraction (s*x) + in if even (n::Int) + then 1-2*frac + else 2*frac-1 + + +{- ** continuously parameterized -} + +{- | +A truncated cosine plus a ramp that guarantees a bump of high 2 at the boundaries. + +It is @truncCosine (2 * fromIntegral n + 0.5) == truncOddCosine (2*n)@ +-} +truncCosine :: Trans.C a => + a -> T a a +truncCosine k = + let f = 2 * pi * k + s = 2 * (sin (f*0.5) - 1) + in fromFunction $ \ x0 -> + let x = x0-0.5 + in - sin (f*x) + s*x +{- +GNUPlot.plotFuncs [] (GNUPlot.linearScale 1000 (0,1::Double)) (map truncCosine [0.5,0.7..2.5]) +-} + +truncTriangle :: (RealField.C a) => + a -> T a a +truncTriangle k = + let tr x = + let (n,frac) = splitFraction (2*k*x+0.5) + in if even (n::Int) + then 1-2*frac + else 2*frac-1 + s = 2 * (1 + tr 0.5) + in fromFunction $ \ x0 -> + let x = x0-0.5 + in tr x - s*x +{- +GNUPlot.plotFuncs [] (GNUPlot.linearScale 1000 (0,1::Double)) (map truncTriangle [0,0.25..2.5]) +-} + + +{- | +Power function. +-} + + +{- | +Roughly the map @\x p -> x**p@ +but retains the sign of @x@ and +normalizes the mapping over @[-1,1]@ to L2 norm of 1. +-} +{-# INLINE powerNormed #-} +powerNormed :: (Real.C a, Trans.C a) => a -> T a a +powerNormed p = fromFunction $ \x -> power01Normed p (2*x-1) + +-- | auxiliary +{-# INLINE power01Normed #-} +power01Normed :: (Real.C a, Trans.C a) => a -> a -> a +power01Normed p x = (p+0.5) * powerSigned p x + +-- | auxiliary +{-# INLINE powerSigned #-} +powerSigned :: (Real.C a, Trans.C a) => a -> a -> a +powerSigned p x = signum x * abs x ** p + + +{- | +Tangens hyperbolicus allows interpolation +between some kind of saw tooth and square wave. +In principle it is not necessary +because you can distort a saw tooth oscillation by @map tanh@. +-} +logitSaw :: (Trans.C a) => a -> T a a +logitSaw c = distort tanh $ amplify c saw + + +{- | +Tangens hyperbolicus of a sine allows interpolation +between some kind of sine and square wave. +In principle it is not necessary +because you can distort a square oscillation by @map tanh@. +-} +logitSine :: (Trans.C a) => a -> T a a +logitSine c = distort tanh $ amplify c sine + + +{- | +Interpolation between 'sine' and 'square'. +-} +{-# INLINE sineSquare #-} +sineSquare :: (Real.C a, Trans.C a) => + a {- ^ 0 for 'sine', 1 for 'square' -} + -> T a a +sineSquare c = + distort (powerSigned (1-c)) sine + + + +{- | +Interpolation between 'fastSine2' and 'saw'. +We just shrink the parabola towards the borders +and insert a linear curve such that its slope matches the one of the parabola. +-} +{-# INLINE piecewiseParabolaSaw #-} +piecewiseParabolaSaw :: (Algebraic.C a, Ord a) => + a {- ^ 0 for 'fastSine2', 1 for 'saw' -} + -> T a a +piecewiseParabolaSaw c = + let xb = (1 - sqrt c) / 2 + y x = 1 - ((4*x - (1-c))/(1-c))^2 + in fromFunction $ \ x -> + select + ((2*x - 1)/(2*xb - 1) * y xb) + [(x < xb, y x), + (x > 1-xb, - y (1-x))] + +{- +equ0 c x = + let y = 1 - ((4*x - (3+c))/(1-c))^2 + secant = y/(x-1/2) + tangent = - 8 * (4*x - (3+c))/(1-c)^2 + in (tangent, secant) + +equ1 c x = + let secant = (1 - ((4*x - (3+c))/(1-c))^2)/(x-1/2) + tangent = - 8 * (4*x - (3+c))/(1-c)^2 + in (tangent, secant) + +equ2 c x = + (1, ((4*x - (3+c))/(1-c))^2 + - 8 * (x-1/2) * (4*x - (3+c))/(1-c)^2) + +equ3 c x = + ((1-c)^2, + (4*x - (3+c) - 4 * (2*x-1)) * (4*x - (3+c))) + +equ4 c x = + (4*x - (1-c)) * (4*x - (3+c)) + (1-c)^2 + +equ5 c x = + (4*x - 2) ^ 2 - (1+c)^2 + (1-c)^2 + +equ6 c x = + (4*x - 2) ^ 2 - 4*c +-} + + +{- | +Interpolation between 'sine' and 'saw'. +We just shrink the sine towards the borders +and insert a linear curve such that its slope matches the one of the sine. +-} +{-# INLINE piecewiseSineSaw #-} +piecewiseSineSaw :: (Trans.C a, Ord a) => + a {- ^ 0 for 'sine', 1 for 'saw' -} + -> T a a +piecewiseSineSaw c = + let {- This simple fix point iteration converges very slow for small 'c', + maybe we should use a Newton iteration. -} + iter z = iterate (\zi -> pi + atan (zi - pi / (1-c))) z !! 10 + xb = (1-c)/(2*pi) * iter 0 + -- iter (xInit * (2*pi) / (1-c)) + -- xb = (1 - sqrt c) / 2 + -- y x = sine (x/(1-c)) + y x = sin (2*pi*x/(1-c)) + in fromFunction $ \ x -> select + ((2*x - 1)/(2*xb - 1) * y xb) + [(x < xb, y x), + (x > 1-xb, - y (1-x))] + +{- +equ0 c x = + let secant = 2 * sin (2*pi*x/(1-c)) / (2*x - 1) + tangent = 2*pi/(1-c) * cos (2*pi*x/(1-c)) + in (tangent, secant) + +iter0 c x = + -- secant / tangent + -- (x - 1/2) = tan (2*pi*x/(1-c)) * (1-c) / (2*pi) + tan (2*pi*x/(1-c)) * (1-c) / (2*pi) + 1/2 + +iter1 c x = + (1-c)/(2*pi) * (pi + atan ((x - 1/2) * (2*pi) / (1-c))) + +iter2 c x = + let iter z = iterate (\zi -> pi + atan (zi - pi / (1-c))) z !! 10 + in (1-c)/(2*pi) * iter (x * (2*pi) / (1-c)) +-} + + +{- | +Interpolation between 'sine' and 'saw' +with smooth intermediate shapes but no perfect saw. +-} +{-# INLINE sineSawSmooth #-} +sineSawSmooth :: (Trans.C a) => + a {- ^ 0 for 'sine', 1 for 'saw' -} + -> T a a +sineSawSmooth c = + distort (\x -> sin (affineComb c (pi * x, asin x * 2))) saw + +{- | +Interpolation between 'sine' and 'saw' +with perfect saw, but sharp intermediate shapes. +-} +{-# INLINE sineSawSharp #-} +sineSawSharp :: (Trans.C a) => + a {- ^ 0 for 'sine', 1 for 'saw' -} + -> T a a +sineSawSharp c = + distort (\x -> sin (affineComb c (pi * x, asin x))) saw + + +affineComb :: Ring.C a => a -> (a,a) -> a +affineComb phase (x0,x1) = (1-phase)*x0 + phase*x1 + + +{- +{- | +Smooth saw generated by a quintic polynomial function. +Unfortunately if 'c' approaches the right border, +the function will overshoot the 'y' range (-1,1). +-} +quinticSaw :: Field.C a => + a {- ^ position of the right minimum -} + -> a + -> a +quinticSaw c x = + let (s,t) = ToneMod.solveSLE2 ((c^2-1, 3*c^2-1), (c^4-1, 5*c^4-1)) (-1/c,0) + r = - s - t + x2 = x^2 + in x * (r + x2 * (s + x2*t)) +{- + r*x + s* x^3 + t* x^5 + 0 = r + s + t + -1 = r*c + s* c^3 + t* c^5 + 0 = r + s*3*c^2 + t*5*c^4 + +-1/c = r + s* c^2 + t* c^4 + +-1/c = s*(c^2-1) + t*(c^4-1) + 0 = s*(3*c^2-1) + t*(5*c^4-1) +-} +-} + + +{- | +saw with space +-} +{-# SPECULATE sawPike :: Double -> Double -> Double #-} +{-# INLINE sawPike #-} +sawPike :: (Ord a, Field.C a) => + a {- ^ pike width ranging from 0 to 1, 1 yields 'saw' -} + -> T a a +sawPike r = fromFunction $ \x -> + if x 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) 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)) Double -> Double #-} +{-# INLINE squareAsymmetric #-} +squareAsymmetric :: (Ord a, Ring.C a) => + a {- ^ value between -1 and 1 controlling the ratio of high and low time: + -1 turns the high time to zero, + 1 makes the low time zero, + 0 yields 'square' -} + -> T a a +squareAsymmetric r = fromFunction $ \x -> + if 2*x < r+1 then 1 else -1 + +{- | Like 'squareAsymmetric' but with zero average. +It could be simulated by adding two saw oscillations +with 180 degree phase difference and opposite sign. +-} +{-# SPECULATE squareBalanced :: Double -> Double -> Double #-} +{-# INLINE squareBalanced #-} +squareBalanced :: (Ord a, Ring.C a) => a -> T a a +squareBalanced r = + raise (-r) $ squareAsymmetric r + +{- | +triangle +-} +{-# SPECULATE sawPike :: Double -> Double -> Double #-} +{-# INLINE triangleAsymmetric #-} +triangleAsymmetric :: (Ord a, Field.C a) => + a {- ^ asymmetry parameter ranging from -1 to 1: + For 0 you obtain the usual triangle. + For -1 you obtain a falling saw tooth starting with its maximum. + For 1 you obtain a rising saw tooth starting with a zero. -} + -> T a a +triangleAsymmetric r = fromFunction $ \x -> + select ((2-4*x)/(1-r)) + [(4*x < 1+r, 4/(1+r)*x), + (4*x > 3-r, 4/(1+r)*(x-1))] + +{- | +Mixing 'trapezoid' and 'trianglePike' you can get back a triangle wave form +-} +{-# SPECULATE trapezoid :: Double -> Double -> Double #-} +{-# INLINE trapezoid #-} +trapezoid :: (Real.C a, Field.C a) => + a {- ^ width of the plateau ranging from 0 to 1: + 0 yields 'triangle', 1 yields 'square' -} + -> T a a +trapezoid w = fromFunction $ \x -> + if x < 1/2 + then min 1 ((1 - abs (4*x-1)) / (1-w)) + else max (-1) ((abs (4*x-3) - 1) / (1-w)) + +{- | +Trapezoid with distinct high and low time. +That is the high and low trapezoids are symmetric itself, +but the whole waveform is not symmetric. +-} +{-# SPECULATE trapezoidAsymmetric :: Double -> Double -> Double -> Double #-} +{-# INLINE trapezoidAsymmetric #-} +trapezoidAsymmetric :: (Real.C a, Field.C a) => + a {- ^ sum of the plateau widths ranging from 0 to 1: + 0 yields 'triangleAsymmetric', + 1 yields 'squareAsymmetric' -} + -> a {- ^ asymmetry of the plateau widths ranging from -1 to 1 -} + -> T a a +trapezoidAsymmetric w r = fromFunction $ \x -> + let c0 = 1+w*r + c1 = 1-w*r + in if 2*x < c0 + then min 1 ((c0 - abs (4*x-c0)) / (1-w)) + else max (-1) ((abs (4*(1-x)-c1) - c1) / (1-w)) +{- + let c = w*r+1 + in if 2*x < c + then min 1 ((1 - abs (4*x/c-1))*c/(1-w)) + else max (-1) ((abs (4*(1-x)/(2-c)-1) - 1)*(2-c)/(1-w)) +-} +{- + let c = (w*r+1)/2 + in if x < c + then min 1 ((1 - abs (2*x/c-1))*2*c/(1-w)) + else max (-1) ((abs (2*(1-x)/(1-c)-1) - 1)*2*(1-c)/(1-w)) +-} + +{- | +trapezoid with distinct high and low time and zero direct current offset +-} +{-# SPECULATE trapezoidBalanced :: Double -> Double -> Double -> Double #-} +{-# INLINE trapezoidBalanced #-} +trapezoidBalanced :: (Real.C a, Field.C a) => a -> a -> T a a +trapezoidBalanced w r = + raise (-w*r) $ trapezoidAsymmetric w r + + +-- could also be generated by amplifying and clipping a saw ramp +{- | +parametrized trapezoid that can range from a saw ramp to a square waveform. +-} +trapezoidSkew :: (Ord a, Field.C a) => + a {- ^ width of the ramp, + that is 1 yields a downwards saw ramp + and 0 yields a square wave. -} + -> T a a +trapezoidSkew w = + fromFunction $ \t -> + if' (2*t<=1-w) 1 $ + if' (2*t>=1+w) (-1) $ + (1-2*t)/w + +{- | +This is similar to Polar coordinates, +but the range of the phase is from @0@ to @1@, @0@ to @2*pi@. +-} +data Harmonic a = + Harmonic {harmonicPhase :: Phase.T a, harmonicAmplitude :: a} + +{-# INLINE harmonic #-} +harmonic :: Phase.T a -> a -> Harmonic a +harmonic = Harmonic + +{- | +Specify the wave by its harmonics. + +The function is implemented quite efficiently +by applying the Horner scheme to a polynomial with complex coefficients +(the harmonic parameters) +using a complex exponential as argument. +-} +{-# INLINE composedHarmonics #-} +composedHarmonics :: Trans.C a => [Harmonic a] -> T a a +composedHarmonics hs = + let p = Poly.fromCoeffs $ + map (\h -> Complex.fromPolar (harmonicAmplitude h) + (2*pi * Phase.toRepresentative (harmonicPhase h))) hs + in distort (Complex.imag . Poly.evaluate p) helix +{- +GNUPlot.plotFunc [] (GNUPlot.linearScale 1000 (0,1::Double)) (composedHarmonics [harmonic 0 0, harmonic 0 0, harmonic 0 0, harmonic 0.25 1]) +-} diff --git a/src/Synthesizer/Basic/WaveSmoothed.hs b/src/Synthesizer/Basic/WaveSmoothed.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Basic/WaveSmoothed.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{- | +Copyright : (c) Henning Thielemann 2006 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +Waveforms which are smoothed according to the oscillator frequency +in order to suppress aliasing effects. +-} +module Synthesizer.Basic.WaveSmoothed ( + T, + fromFunction, + fromWave, + fromControlledWave, + + raise, + amplify, + distort, + apply, + + sine, + cosine, + saw, + square, + triangle, + + Wave.Harmonic, + Wave.harmonic, + composedHarmonics, + ) where + + +import qualified Synthesizer.Basic.Wave as Wave +import qualified Synthesizer.Basic.Phase as Phase + +-- import qualified Algebra.RealTranscendental as RealTrans +import qualified Algebra.Transcendental as Trans +-- import qualified Algebra.RealField as RealField +import qualified Algebra.Module as Module +import qualified Algebra.Field as Field +import qualified Algebra.Real as Real +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import qualified MathObj.Polynomial as Poly +import qualified Number.Complex as Complex + +import NumericPrelude + +-- import qualified Prelude as P +import PreludeBase + + +{- * Definition and construction -} + +newtype T t y = Cons {decons :: t -> Phase.T t -> y} + + +{-# INLINE fromFunction #-} +fromFunction :: (t -> t -> y) -> (T t y) +fromFunction wave = + Cons (\f p -> wave f (Phase.toRepresentative p)) + +{- | +Use this function for waves which are sufficiently smooth. +If the Nyquist frequency is exceeded the wave is simply replaced +by a constant zero wave. +-} +{-# INLINE fromWave #-} +fromWave :: + (Field.C t, Real.C t, Additive.C y) => + Wave.T t y -> (T t y) +fromWave wave = + fromControlledWaveAux (\f -> if abs f >= 1/2 then zero else wave) + +{-# INLINE fromControlledWave #-} +fromControlledWave :: + (Field.C t, Real.C t, Additive.C y) => + (t -> Wave.T t y) -> (T t y) +fromControlledWave wave = + fromControlledWaveAux (\f0 -> + let f = abs f0 + in if f >= 1/2 + then zero + else wave f) + +{-# INLINE fromControlledWaveAux #-} +fromControlledWaveAux :: (t -> Wave.T t y) -> (T t y) +fromControlledWaveAux wave = + Cons (\f p -> Wave.apply (wave f) p) + + +{- * Operations on waves -} + +{-# INLINE raise #-} +raise :: (Additive.C y) => y -> T t y -> T t y +raise y = distort (y+) + +{-# INLINE amplify #-} +amplify :: (Ring.C y) => y -> T t y -> T t y +amplify k = distort (k*) + +{-# INLINE distort #-} +distort :: (y -> z) -> T t y -> T t z +distort g (Cons w) = Cons (\f p -> g (w f p)) + +{-# INLINE apply #-} +apply :: T t y -> (t -> Phase.T t -> y) +apply = decons + + + +instance Additive.C y => Additive.C (T t y) where + {-# INLINE zero #-} + {-# INLINE (+) #-} + {-# INLINE (-) #-} + {-# INLINE negate #-} + zero = Cons (const zero) + (+) (Cons w) (Cons v) = Cons (\f p -> w f p + v f p) + (-) (Cons w) (Cons v) = Cons (\f p -> w f p - v f p) + negate = distort negate + + +instance Module.C a y => Module.C a (T t y) where + {-# INLINE (*>) #-} + s *> w = distort (s*>) w + + + + +{- * Examples -} + +{- ** unparameterized -} + +{- | map a phase to value of a sine wave -} +{-# INLINE sine #-} +sine :: (Trans.C a, Real.C a) => T a a +sine = fromWave Wave.sine + +{-# INLINE cosine #-} +cosine :: (Trans.C a, Real.C a) => T a a +cosine = fromWave Wave.cosine + + +{- | saw tooth, +it's a ramp down in order to have a positive coefficient for the first partial sine +-} +{-# INLINE saw #-} +saw :: (Real.C a, Field.C a) => T a a +saw = + fromControlledWave (\f -> Wave.triangleAsymmetric (2*f-1)) + + +{- | square -} +{-# INLINE square #-} +square :: (Real.C a, Field.C a) => T a a +square = + fromControlledWave (\f -> Wave.trapezoid (1-2*f)) + + +{- | triangle -} +{-# INLINE triangle #-} +triangle :: (Real.C a, Field.C a) => T a a +triangle = fromWave Wave.triangle + + + +{- | +Specify the wave by its harmonics. + +The function is implemented quite efficiently +by applying the Horner scheme to a polynomial with complex coefficients +(the harmonic parameters) +using a complex exponential as argument. +-} +{-# INLINE composedHarmonics #-} +composedHarmonics :: (Trans.C a, Real.C a) => [Wave.Harmonic a] -> T a a +composedHarmonics hs = + let c = map (\h -> Complex.fromPolar (Wave.harmonicAmplitude h) + (2*pi * Phase.toRepresentative (Wave.harmonicPhase h))) hs + -- @take (ceiling (1/(2*f)))@ would fail for small @f@ especially @f==zero@ + trunc f = + map snd . takeWhile ((<1/2) . fst) . zip (iterate (abs f +) zero) + in fromControlledWaveAux $ \f -> + Wave.distort + (Complex.imag . Poly.evaluate (Poly.fromCoeffs (trunc f c))) + Wave.helix +{- +GNUPlot.plotFunc [] (GNUPlot.linearScale 1000 (0,1::Double)) (composedHarmonics [harmonic 0 0, harmonic 0 0, harmonic 0 0, harmonic 0.25 1]) +-} diff --git a/src/Synthesizer/Causal/Displacement.hs b/src/Synthesizer/Causal/Displacement.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Causal/Displacement.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Synthesizer.Causal.Displacement where + +import qualified Synthesizer.Causal.Process as Causal + +import qualified Algebra.Additive as Additive + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +{- * Mixing -} + +{-| +Mix two signals. +Unfortunately we have to use 'zipWith' semantic here, +that is the result is as long as the shorter of both inputs. +-} +{-# INLINE mix #-} +mix :: (Additive.C v) => Causal.T (v,v) v +mix = Causal.map (uncurry (+)) + + +{-| +Add a number to all of the signal values. +This is useful for adjusting the center of a modulation. +-} +{-# INLINE raise #-} +raise :: (Additive.C v) => v -> Causal.T v v +raise x = Causal.map (x+) + + +{- * Distortion -} +{-| +In "Synthesizer.Basic.Distortion" you find a collection +of appropriate distortion functions. +-} +{-# INLINE distort #-} +distort :: (c -> a -> a) -> Causal.T (c,a) a +distort f = Causal.map (uncurry f) diff --git a/src/Synthesizer/Causal/Interpolation.hs b/src/Synthesizer/Causal/Interpolation.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Causal/Interpolation.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Synthesizer.Causal.Interpolation ( + Interpolation.T, + + relative, + relativeZeroPad, + relativeConstantPad, + relativeCyclicPad, + relativeExtrapolationPad, + relativeZeroPadConstant, + relativeZeroPadLinear, + relativeZeroPadCubic, + ) where + +import qualified Synthesizer.Interpolation.Module as IpExample +import qualified Synthesizer.Interpolation as Interpolation +import qualified Synthesizer.State.Interpolation as InterpolationS + +import qualified Synthesizer.Causal.Process as Causal +import qualified Synthesizer.State.Signal as Sig + +import qualified Algebra.Module as Module +import qualified Algebra.RealField as RealField +import qualified Algebra.Additive as Additive + +import Algebra.Additive(zero) + + +import PreludeBase +import NumericPrelude + + +{-* Interpolation at multiple nodes with various padding methods -} + +{- | All values of frequency control must be non-negative. -} +{-# INLINE relative #-} +relative :: (RealField.C t) => + Interpolation.T t y -> t -> Sig.T y -> Causal.T t y +relative ip phase0 x0 = + Causal.crochetL + (\freq pos -> + let (phase,x) = InterpolationS.skip ip pos + in Just (Interpolation.func ip phase x, (phase+freq,x))) + (phase0,x0) + + +{-# INLINE relativeZeroPad #-} +relativeZeroPad :: (RealField.C t) => + y -> Interpolation.T t y -> t -> Sig.T y -> Causal.T t y +relativeZeroPad z ip phase x = + InterpolationS.zeroPad relative z ip phase x + +{-# INLINE relativeConstantPad #-} +relativeConstantPad :: (RealField.C t) => + Interpolation.T t y -> t -> Sig.T y -> Causal.T t y +relativeConstantPad ip phase x = + InterpolationS.constantPad relative ip phase x + +{-# INLINE relativeCyclicPad #-} +relativeCyclicPad :: (RealField.C t) => + Interpolation.T t y -> t -> Sig.T y -> Causal.T t y +relativeCyclicPad ip phase x = + InterpolationS.cyclicPad relative ip phase x + +{- | +The extrapolation may miss some of the first and some of the last points +-} +{-# INLINE relativeExtrapolationPad #-} +relativeExtrapolationPad :: (RealField.C t) => + Interpolation.T t y -> t -> Sig.T y -> Causal.T t y +relativeExtrapolationPad ip phase x = + InterpolationS.extrapolationPad relative ip phase x +{- + This example shows pikes, although there shouldn't be any: + plotList (take 100 $ interpolate (Zero (0::Double)) ipCubic (-0.9::Double) (repeat 0.03) [1,0,1,0.8]) +-} + +{-* All-in-one interpolation functions -} + +{-# INLINE relativeZeroPadConstant #-} +relativeZeroPadConstant :: + (RealField.C t, Additive.C y) => + t -> Sig.T y -> Causal.T t y +relativeZeroPadConstant = + relativeZeroPad zero IpExample.constant + +{-# INLINE relativeZeroPadLinear #-} +relativeZeroPadLinear :: + (RealField.C t, Module.C t y) => + t -> Sig.T y -> Causal.T t y +relativeZeroPadLinear = + relativeZeroPad zero IpExample.linear + +{-# INLINE relativeZeroPadCubic #-} +relativeZeroPadCubic :: + (RealField.C t, Module.C t y) => + t -> Sig.T y -> Causal.T t y +relativeZeroPadCubic = + relativeZeroPad zero IpExample.cubic + diff --git a/src/Synthesizer/Causal/Oscillator.hs b/src/Synthesizer/Causal/Oscillator.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Causal/Oscillator.hs @@ -0,0 +1,220 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{- | +Copyright : (c) Henning Thielemann 2006 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +Tone generators +-} +module Synthesizer.Causal.Oscillator where + +import qualified Synthesizer.Basic.WaveSmoothed as WaveSmooth +import qualified Synthesizer.Basic.Wave as Wave +import qualified Synthesizer.Basic.Phase as Phase + +import qualified Synthesizer.Causal.Process as Causal +import qualified Synthesizer.State.Signal as Sig + +import qualified Synthesizer.Causal.Interpolation as InterpolationC +import qualified Synthesizer.Causal.ToneModulation as ToneMod +import qualified Synthesizer.Interpolation as Interpolation + +import qualified Synthesizer.Generic.Signal as SigG + +import Synthesizer.State.ToneModulation (freqsToPhases, ) + +{- +import qualified Algebra.RealTranscendental as RealTrans +import qualified Algebra.Field as Field +import qualified Algebra.Module as Module +import qualified Algebra.VectorSpace as VectorSpace + +import Algebra.Module((*>)) +-} +import qualified Algebra.Transcendental as Trans +import qualified Algebra.RealField as RealField +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Control.Arrow ((^<<), (<<^), (<<<), (&&&), (***), second, returnA, ) + +import NumericPrelude + +import qualified Prelude as P +import PreludeBase + + + +{- * Oscillators with arbitrary but constant waveforms -} + +{-# INLINE freqToPhases #-} +freqToPhases :: RealField.C a => + Phase.T a -> a -> Sig.T (Phase.T a) +freqToPhases phase freq = + Sig.iterate (Phase.increment freq) phase + + +{- +{-# INLINE static #-} +{- | oscillator with constant frequency -} +static :: (RealField.C a) => + Wave.T a b -> (Phase.T a -> a -> Sig.T b) +static wave phase freq = + Sig.map (Wave.apply wave) (freqToPhases phase freq) +-} + + +{-# INLINE phaseMod #-} +{- | oscillator with modulated phase -} +phaseMod :: (RealField.C a) => + Wave.T a b -> a -> Causal.T a b +phaseMod wave = shapeMod (Wave.phaseOffset wave) zero + +{-# INLINE shapeMod #-} +{- | oscillator with modulated shape -} +shapeMod :: (RealField.C a) => + (c -> Wave.T a b) -> Phase.T a -> a -> Causal.T c b +shapeMod wave phase freq = + Causal.applySnd + (Causal.map (uncurry (Wave.apply . wave))) + (freqToPhases phase freq) + + +{-# INLINE freqMod #-} +{- | oscillator with modulated frequency -} +freqMod :: (RealField.C a) => + Wave.T a b -> Phase.T a -> Causal.T a b +freqMod wave phase = + Causal.map (Wave.apply wave) <<< freqsToPhases phase + +{-# INLINE freqModAntiAlias #-} +{- | oscillator with modulated frequency -} +freqModAntiAlias :: (RealField.C a) => + WaveSmooth.T a b -> Phase.T a -> Causal.T a b +freqModAntiAlias wave phase = + Causal.map (uncurry (WaveSmooth.apply wave)) <<< + returnA &&& freqsToPhases phase + +{-# INLINE phaseFreqMod #-} +{- | oscillator with both phase and frequency modulation -} +phaseFreqMod :: (RealField.C a) => + Wave.T a b -> Causal.T (a,a) b +phaseFreqMod wave = shapeFreqMod (Wave.phaseOffset wave) zero + +{-# INLINE shapeFreqMod #-} +{- | oscillator with both shape and frequency modulation -} +shapeFreqMod :: (RealField.C a) => + (c -> Wave.T a b) -> Phase.T a -> Causal.T (c,a) b +shapeFreqMod wave phase = + Causal.map (uncurry (Wave.apply . wave)) <<< + second (freqsToPhases phase) + + +{- +{- | oscillator with a sampled waveform with constant frequency + This essentially an interpolation with cyclic padding. -} +{-# INLINE staticSample #-} +staticSample :: RealField.C a => + Interpolation.T a b -> Sig.T b -> Phase.T a -> a -> Sig.T b +staticSample ip wave phase freq = + Causal.apply (freqModSample ip wave phase) (Sig.repeat freq) +-} + +{- | oscillator with a sampled waveform with modulated frequency + Should behave homogenously for different types of interpolation. -} +{-# INLINE freqModSample #-} +freqModSample :: RealField.C a => + Interpolation.T a b -> Sig.T b -> Phase.T a -> Causal.T a b +freqModSample ip wave phase = + let len = Sig.length wave + pr = fromIntegral len * Phase.toRepresentative phase + in InterpolationC.relativeCyclicPad ip pr wave + <<< Causal.map (fromIntegral len *) + + +{-# INLINE shapeFreqModSample #-} +shapeFreqModSample :: (RealField.C c, RealField.C b) => + Interpolation.T c (Wave.T b a) -> Sig.T (Wave.T b a) -> + c -> Phase.T b -> + Causal.T (c, b) a +shapeFreqModSample ip waves shape0 phase = + uncurry Wave.apply ^<< + (InterpolationC.relativeConstantPad ip shape0 waves *** + freqsToPhases phase) + +{-# INLINE shapeFreqModFromSampledTone #-} +shapeFreqModFromSampledTone :: + (RealField.C t, SigG.Transform sig y) => + Interpolation.T t y -> + Interpolation.T t y -> + t -> sig y -> + t -> Phase.T t -> + Causal.T (t,t) y +shapeFreqModFromSampledTone + ipLeap ipStep period sampledTone shape0 phase = + uncurry (ToneMod.interpolateCell ipLeap ipStep) ^<< + ToneMod.oscillatorCells + (Interpolation.margin ipLeap) (Interpolation.margin ipStep) + (round period) period sampledTone + (shape0, phase) + +{-# INLINE shapePhaseFreqModFromSampledTone #-} +shapePhaseFreqModFromSampledTone :: + (RealField.C t, SigG.Transform sig y) => + Interpolation.T t y -> + Interpolation.T t y -> + t -> sig y -> + t -> Phase.T t -> + Causal.T (t,t,t) y +shapePhaseFreqModFromSampledTone + ipLeap ipStep period sampledTone shape0 phase = + let periodInt = round period + marginLeap = Interpolation.margin ipLeap + marginStep = Interpolation.margin ipStep + in (\(dp, ((s,p), suffix)) -> + uncurry (ToneMod.interpolateCell ipLeap ipStep) $ + ToneMod.seekCell periodInt period $ + ((s, Phase.increment dp p), suffix)) + ^<< + Causal.second + (ToneMod.oscillatorSuffixes + marginLeap marginStep + periodInt period sampledTone + (shape0, phase)) + <<^ + (\(s,p,f) -> (p,(s,f))) + + +{- * Oscillators with specific waveforms -} + +{- +{-# INLINE staticSine #-} +{- | sine oscillator with static frequency -} +staticSine :: (Trans.C a, RealField.C a) => Phase.T a -> a -> Sig.T a +staticSine = static Wave.sine +-} + +{-# INLINE freqModSine #-} +{- | sine oscillator with modulated frequency -} +freqModSine :: (Trans.C a, RealField.C a) => Phase.T a -> Causal.T a a +freqModSine = freqMod Wave.sine + +{-# INLINE phaseModSine #-} +{- | sine oscillator with modulated phase, useful for FM synthesis -} +phaseModSine :: (Trans.C a, RealField.C a) => a -> Causal.T a a +phaseModSine = phaseMod Wave.sine + +{- +{-# INLINE staticSaw #-} +{- | saw tooth oscillator with modulated frequency -} +staticSaw :: RealField.C a => Phase.T a -> a -> Sig.T a +staticSaw = static Wave.saw +-} + +{-# INLINE freqModSaw #-} +{- | saw tooth oscillator with modulated frequency -} +freqModSaw :: RealField.C a => Phase.T a -> Causal.T a a +freqModSaw = freqMod Wave.saw diff --git a/src/Synthesizer/Causal/ToneModulation.hs b/src/Synthesizer/Causal/ToneModulation.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Causal/ToneModulation.hs @@ -0,0 +1,235 @@ +module Synthesizer.Causal.ToneModulation ( + ToneModS.interpolateCell, + seekCell, + oscillatorCells, + oscillatorSuffixes, + integrateFractional, + integrateFractionalClip, + -- for testing + limitRelativeShapes, + limitMinRelativeValues, + ) where + +import qualified Synthesizer.Basic.ToneModulation as ToneMod +import qualified Synthesizer.State.ToneModulation as ToneModS +import qualified Synthesizer.Interpolation as Interpolation + +import Synthesizer.State.ToneModulation (freqsToPhases, freqsToPhasesSync, ) + +{- for testing in GHCi +import qualified Synthesizer.Plain.ToneModulation as ToneModL +import qualified Synthesizer.State.Signal as SigS +import Data.Tuple.HT (mapFst, mapSnd, swap, ) +-} +import Data.Tuple.HT (mapFst, ) + +import qualified Synthesizer.Causal.Process as Causal + +import qualified Synthesizer.Generic.Signal as SigG + +import qualified Synthesizer.Basic.Phase as Phase + +-- import qualified Algebra.Transcendental as Trans +import qualified Algebra.RealField as RealField +-- import qualified Algebra.Field as Field +-- import qualified Algebra.Real as Real +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Control.Arrow (first, (<<<), (<<^), (^<<), (&&&), (***), ) +import Control.Monad.Trans.State (state, ) + +import NumericPrelude +-- import qualified Prelude as P +import PreludeBase +import Prelude () + + + +oscillatorCells :: (RealField.C t, SigG.Transform sig y) => + Interpolation.Margin -> + Interpolation.Margin -> + Int -> t -> sig y -> (t, Phase.T t) -> + Causal.T (t,t) ((t,t), ToneModS.Cell sig y) +oscillatorCells + marginLeap marginStep periodInt period sampledTone (shape0, phase) = + seekCell periodInt period + ^<< oscillatorSuffixes marginLeap marginStep + periodInt period sampledTone (shape0, phase) +{- +*Synthesizer.Causal.ToneModulation> let shapes = [0.3,2.4,0.2,2.1,1.2,1.5::Double]; phases = [0.43,0.72,0.91,0.37,0.42,0.22::Double] +*Synthesizer.Causal.ToneModulation> let marginLeap = Interpolation.Margin 3 1; marginStep = Interpolation.Margin 2 0 +*Synthesizer.Causal.ToneModulation> mapM_ (print . mapSnd List.transpose) $ ToneModL.oscillatorCells marginLeap marginStep 5 5.3 ['a'..'z'] (2.3,shapes) (Phase.fromRepresentative 0.6, phases) +*Synthesizer.Causal.ToneModulation> mapM_ print $ SigS.toList $ oscillatorCells marginLeap marginStep 5 5.3 ['a'..'z'] (2.3, Phase.fromRepresentative 0.6) `Causal.apply` (SigS.fromList $ List.zip shapes phases) +-} + + +seekCell :: (RealField.C t, SigG.Transform sig y) => + Int -> t -> + ((t, Phase.T t), sig y) -> + ((t,t), ToneModS.Cell sig y) +seekCell periodInt period = + {- + n will be zero within the data body. + It's only needed for extrapolation at the end. + Is it really needed? + -} + (\(sp,ptr) -> + let (k,q) = ToneMod.flattenShapePhase periodInt period sp + in (q, ToneModS.makeCell periodInt $ + SigG.drop (ToneModS.checkNonNeg $ periodInt+k) ptr)) + + +{- | +In contrast to the counterpart of this function for plain lists, +it does not use sophisticated list transposition tricks, +but seeks through the prototype signal using 'drop'. +Since 'drop' is used in an inner loop, it must be fast. +This is true for StorableVectors. +-} +oscillatorSuffixes :: (RealField.C t, SigG.Transform sig y) => + Interpolation.Margin -> + Interpolation.Margin -> + Int -> t -> + sig y -> (t, Phase.T t) -> + Causal.T (t,t) ((t, Phase.T t), sig y) +oscillatorSuffixes + marginLeap marginStep periodInt period sampledTone (shape0, phase) = + let margin = + ToneMod.interpolationNumber marginLeap marginStep periodInt + ipOffset = + periodInt + + ToneMod.interpolationOffset marginLeap marginStep periodInt + (shape0min, shapeLimiter) = + limitMinRelativeValues (fromIntegral ipOffset) shape0 + ((skip0,coord0), coordinator) = + integrateFractional period (shape0min, phase) + in (\(((b,n),ptr), sp@(_,p)) -> + (if b + then (zero, Phase.increment (fromIntegral n / period) p) + else sp, + ptr)) + ^<< + (Causal.scanL + (\ ((_,n),ptr) d -> dropMargin margin (n+d) ptr) + (dropMargin margin (skip0 - ipOffset) sampledTone) + *** + Causal.consInit coord0) + <<< + coordinator + <<< + Causal.first shapeLimiter +{- +*Synthesizer.Causal.ToneModulation> let shapes = replicate 10 (2.6::Double); phases = cycle [0.43,0.72,0.91,0.37,0.42,0.22::Double] +*Synthesizer.Causal.ToneModulation> let marginLeap = Interpolation.Margin 3 1; marginStep = Interpolation.Margin 2 0 +*Synthesizer.Causal.ToneModulation> mapM_ (print . swap . mapSnd (mapSnd (map head))) $ ToneModL.oscillatorSuffixes marginLeap marginStep 5 5.3 ['a'..'z'] (2.3,shapes) (Phase.fromRepresentative 0.6, phases) +*Synthesizer.Causal.ToneModulation> mapM_ print $ SigS.toList $ oscillatorSuffixes marginLeap marginStep 5 5.3 ['a'..'z'] (2.3, Phase.fromRepresentative 0.6) `Causal.apply` (SigS.fromList $ List.zip shapes phases) +-} + +{- ToDo: +Both lengthAtMost and dropMarginRem seek through the list. +Maybe an improved version of dropMargin could avoid this. +E.g. dropMarginRem :: dropMarginRem :: Int -> Int -> sig y -> (Maybe Int, sig y), +where return value (Just 0) means, +that drop could actually drop the requested number of elements, +but that we reached the end of the list. +-} +dropMargin :: (SigG.Transform sig y) => + Int -> Int -> sig y -> ((Bool, Int), sig y) +dropMargin margin n xs = + mapFst ((,) (SigG.lengthAtMost (margin+n) xs)) $ + SigG.dropMarginRem margin + (ToneModS.checkNonNeg n) xs + +regroup :: (Int,t) -> Phase.T t -> ToneMod.Skip t +regroup (d,s) p = (d, (s,p)) + +integrateFractional :: (RealField.C t) => + t -> + (t, Phase.T t) -> + (ToneMod.Skip t, Causal.T (t,t) (ToneMod.Skip t)) +integrateFractional period (shape0, phase) = + let sf0 = splitFraction shape0 + -- shapeOffsets :: RealField.C t => Causal.T t (Int,t) + shapeOffsets = + Causal.fromState + (\c -> state $ \s0 -> + let s1 = splitFraction (s0+c) + in (s1, snd s1)) + (snd sf0) + scale (n,_) = fromIntegral n / period + -- phases :: RealField.C t => Causal.T ((Int,t), t) (Phase.T t) + phase0 = Phase.decrement (scale sf0) phase + phases = + freqsToPhasesSync phase0 + <<^ (\(s,f) -> f - scale s) + in (regroup sf0 phase0, + uncurry regroup + ^<< + (Causal.map fst &&& phases) + <<< + first shapeOffsets) + +{- | +Delays output by one element and shorten it by one element at the end. +-} +integrateFractionalClip :: (RealField.C t) => + t -> + (t, Phase.T t) -> + Causal.T (t,t) (ToneMod.Skip t) +integrateFractionalClip period (shape0, phase) = + let sf0 = splitFraction shape0 + -- shapeOffsets :: RealField.C t => Causal.T t (Int,t) + shapeOffsets = + Causal.fromState + (\c -> state $ \s0 -> + let s1 = splitFraction (s0+c) + in (s1, snd s1)) + (snd sf0) + scale (n,_) = fromIntegral n / period + -- phases :: RealField.C t => Causal.T ((Int,t), t) (Phase.T t) + phases = + freqsToPhases + (Phase.decrement (scale sf0) phase) + <<^ (\(s,f) -> f - scale s) + in uncurry regroup + ^<< + ((Causal.consInit sf0 <<^ fst) &&& phases) + <<< + first shapeOffsets +{- +test to automate: +*Synthesizer.Generic.ToneModulation> let shapes = [0.3,0.4,0.2::Double]; phases = [0.43,0.72,0.91::Double] +*Synthesizer.Generic.ToneModulation> ToneMod.oscillatorCoords 9 10 (2.3,shapes) (Phase.fromRepresentative 0.6, phases) +[(2,(-6,(0.63,0.6299999999999999))),(0,(-2,(0.22999999999999998,0.53))),(0,(-4,(0.5500000000000002,4.9999999999998934e-2))),(1,(-6,(0.6600000000000001,0.2599999999999989)))] + +*Synthesizer.Generic.ToneModulation> ToneModS.oscillatorCoords 9 10 (2.3, SigS.fromList shapes) (Phase.fromRepresentative 0.6, SigS.fromList phases) +StateSignal.fromList [(2,(-6,(0.63,0.6299999999999999))),(0,(-2,(0.22999999999999998,0.53))),(0,(-4,(0.5500000000000002,4.9999999999998934e-2)))] + +*Synthesizer.Generic.ToneModulation> Data.Tuple.HT.mapSnd (flip Causal.apply $ SigS.fromList (zip shapes phases)) $ oscillatorCoords 9 10 (2.3, Phase.fromRepresentative 0.6) +((2,(-6,(0.63,0.6299999999999999))),StateSignal.fromList [(0,(-2,(0.22999999999999998,0.53))),(0,(-4,(0.5500000000000002,4.9999999999998934e-2))),(1,(-6,(0.6600000000000001,0.2599999999999989)))]) + +*Synthesizer.Generic.ToneModulation> oscillatorCoords' 9 10 (2.3, Phase.fromRepresentative 0.6) `Causal.apply` SigS.fromList (zip shapes phases) +StateSignal.fromList [(2,(-6,(0.63,0.6299999999999999))),(0,(-2,(0.22999999999999998,0.53))),(0,(-4,(0.5500000000000002,4.9999999999998934e-2)))] +-} + +limitRelativeShapes :: (Ring.C t, Ord t) => + Interpolation.Margin -> + Interpolation.Margin -> + Int -> t -> (t, Causal.T t t) +limitRelativeShapes marginLeap marginStep periodInt = + limitMinRelativeValues $ fromIntegral $ + ToneMod.interpolationOffset marginLeap marginStep periodInt + periodInt + +limitMinRelativeValues :: (Additive.C t, Ord t) => + t -> t -> (t, Causal.T t t) +limitMinRelativeValues xMin x0 = + let x1 = xMin-x0 + in if x1<=zero + then (x0, Causal.id) + else (xMin, + Causal.crochetL + (\x lim -> + let d = x-lim + in Just $ if d>=zero + then (d,zero) else (zero, negate d)) x1) diff --git a/src/Synthesizer/Filter/Basic.hs b/src/Synthesizer/Filter/Basic.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Filter/Basic.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +module Synthesizer.Filter.Basic where + +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Module as Module +import qualified Algebra.RealField as RealField +import qualified Number.Complex as Complex + +import NumericPrelude +import PreludeBase + +{- todo: + - support of data before time 0 + - the problem is that all past data has to be kept, + the garbage collector can't flush it :-( + - this means we will also need functions for plain lists, + in this case we can't provide initial conditions to recursive filters + - the question of initial conditions is especially problematic + since for Graphs we have no explicit feed back + where initial conditions can be plugged in + - thus for two-way signal we must request the user + to insert initial conditions in every loop of a Graph + using the Past constructor + - all of the following filter primitives in static and modulated form: + - mask + - integer delay + - fractional delay + - shall the fractional delay constructor store the interpolation type? + (this discussion is similar to the one concerning + initial conditions for recursive filters) + - yes, because each delay may use a different interpolation type, + if no fractional delay is used, + no interpolation type needs to be specified + - no, because the interpolation is only of interest for filter + application not for the transfer function + - Is there a way to avoid the multi-parameter type class? + - Can we provide a class for lists (OneWay and TwoWay) + that help implementing filters and filter networks? + - The 'transferFunction' obviously does not depend on the signal list type. + - 'transferFunction' should not be restricted to complex numbers. + - For arguments of type 'Ratio (Polynomial Rational)' + you could compute the transfer function in terms of a rational function. +-} + +screw :: Trans.C a => a -> [Complex.T a] +screw w = iterate (Complex.cis w *) 1 + + +class Filter list filter | filter -> list where + {-| Apply a filter to a signal. -} + apply :: (RealField.C t, Trans.C t, + Module.C a v, Module.C a (list v)) => + filter t a v -> list v -> list v + {-| Compute the complex amplification factor + that is applied to the given frequency. -} + transferFunction :: (Trans.C t, Module.C a t) => + filter t a v -> t -> Complex.T t diff --git a/src/Synthesizer/Filter/Composition.hs b/src/Synthesizer/Filter/Composition.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Filter/Composition.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +module Synthesizer.Filter.Composition where + +import qualified Synthesizer.Filter.Basic as FilterBasic +import Synthesizer.Filter.Basic (Filter, apply, ) + +import qualified Algebra.Module as Module +import qualified Algebra.Transcendental as Trans +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Additive as Additive +import qualified Number.Complex as Complex + +import Algebra.Additive ((+)) + +import PreludeBase +import NumericPrelude + +{- todo: + - functions that build a FilterComposition for specific filters + (1st order, universal, allpass, butterworth, chebyshev) + - functions that turn physical filter parameters into + internal ones + - How can these function be combined? + A function like + [ FilterComposition v [m] ] -> FilterComposition v [[m]] + is not satisfying, since the conversion function cannot rely + that the structure of all FilterComposition v [m] is equal. + If the list is empty the structure can't even be reconstructed. +-} + +{-| + This describes a generic filter with one input and one main output + that consists of non-recursive and recursive parts. + If you use Feedback, make sure that at least + one of the filters of a circle includes a delay, + otherwise the recursion will fail. + The main output is used to glue different parts together. + Additionally the functions 'apply' and 'transferFunction' + provide the signals at every node of the network. +-} +data T filter t a v = + Prim (filter t a v) + {-^ a filter primitve -} + | Serial [T filter t a v] + {-^ serial chain of filters -} + | Parallel [T filter t a v] + {-^ filters working parallel, there output is mixed together -} + | Feedback (T filter t a v) (T filter t a v) + {-^ filter the signal in the forward direction and + feed back the output signal filtered by the second filter -} + +{-| + This is the data structure is used for the results + of 'apply' and 'transferFunction'. + Each constructor corresponds to one of 'Filter.Composition.T'. + By choosing only some of the outputs + the lazy evaluation will content + with applying the necessary filter steps, only. +-} +data Sockets s = Sockets {output :: s, socket :: SocketSpec s} + +data SocketSpec s = + Output + | Multiplier [Sockets s] + | Adder [Sockets s] + | Loop (Sockets s) (Sockets s) + +instance (Filter list filter) => + Filter (list) (T filter) where +{- + apply :: (Module.C a v) => + FilterComposition a v -> TwoWayList v -> TwoWayList v +-} + apply f x = output (applyMulti f x) +{- + transferFunction :: (Trans.C b, Module.C a (Complex.T b)) => + T filter a v -> b -> (Complex.T b) +-} + transferFunction f w = output (transferFunctionMulti f w) + + +{-| Apply a filter network to a signal and keep the output of all nodes. + Generic function that is wrapped by 'apply'. -} +applyMulti :: (RealField.C t, Trans.C t, + Module.C a v, Module.C a (list v), Filter list filter) => + T filter t a v -> list v -> Sockets (list v) +applyMulti (Prim f) x = + Sockets (apply f x) Output +applyMulti (Serial fs) x = + let sq = scanl (\(Sockets y _) -> flip applyMulti y) (Sockets x Output) fs + in Sockets (output (last sq)) (Multiplier (tail sq)) +applyMulti (Parallel fs) x = + let socks = map (flip applyMulti x) fs + y = foldr (Additive.+) zero (map output socks) + in Sockets y (Adder socks) +{- the distinction between 'feed' and 'back' + can be dropped in a more general net structure -} +applyMulti (Feedback feed back) x = + let sockY@(Sockets y _) = applyMulti feed ((Additive.+) x z) + sockZ@(Sockets z _) = applyMulti back y + in Sockets y (Loop sockY sockZ) + + +transferFunctionMulti :: + (Trans.C t, Module.C a t, Filter list filter) => + T filter t a v -> t -> Sockets (Complex.T t) +transferFunctionMulti f w = tfAbsolutize 1 (tfRelative w f) + +{-| Compute the transitivity for each part of the filter network. + We must do this in such a relative manner to be able + to compute feedback. -} +tfRelative :: + (Trans.C t, Module.C a t, Filter list filter) => + t -> T filter t a v -> Sockets (Complex.T t) +tfRelative w (Prim f) = + Sockets (FilterBasic.transferFunction f w) Output +tfRelative w (Serial fs) = + let sq = map (tfRelative w) fs + in Sockets (product (map output sq)) (Multiplier sq) +tfRelative w (Parallel fs) = + let sq = map (tfRelative w) fs + in Sockets (sum (map output sq)) (Adder sq) +tfRelative w (Feedback feed back) = + let sockY = tfRelative w feed + sockZ = tfRelative w back + q = output sockY / (1 - output sockZ) + in Sockets q (Loop sockY sockZ) + + +{-| Make the results from 'tfRelative' absolute. -} +tfAbsolutize :: (Field.C a) => a -> Sockets a -> Sockets a +tfAbsolutize x (Sockets y spec) = Sockets (x*y) + (case spec of + (Multiplier socks) -> + let sq = scanl (\(Sockets z _) -> tfAbsolutize z) + (Sockets x Output) socks + in Multiplier (tail sq) + (Adder socks) -> + let sq = map (tfAbsolutize x) socks + in Adder sq + (Loop feed back) -> + let sockY = tfAbsolutize (x / (1 - output back)) feed + sockZ = tfAbsolutize (output sockY) back + -- it should be x*y == output sockY + in Loop sockY sockZ + Output -> spec) diff --git a/src/Synthesizer/Filter/Example.hs b/src/Synthesizer/Filter/Example.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Filter/Example.hs @@ -0,0 +1,243 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Synthesizer.Filter.Example where + +import qualified Synthesizer.Filter.OneWay as OneWay +import qualified Synthesizer.Filter.TwoWay as TwoWay +import qualified Synthesizer.Filter.Composition as Composition +import qualified Synthesizer.Filter.Graph as Graph +import qualified Synthesizer.Plain.Interpolation as Interpolation + +import Synthesizer.Filter.Basic (apply, ) +import Synthesizer.Filter.Composition (T(..)) + +import qualified Synthesizer.Plain.Oscillator as Osci +import qualified Synthesizer.Basic.Wave as Wave +import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1 +import qualified Synthesizer.Plain.Filter.NonRecursive as FiltNR + +import qualified Algebra.Module as Module +import qualified Algebra.Transcendental as Trans +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Real as Real + +import Data.Maybe (fromMaybe) + +import PreludeBase +import NumericPrelude + + + +{-* Reconstruction of the sound of a plucked guitar string -} + +guitarInit :: Field.C a => [a] +guitarInit = map (/128) ( + 1 : 1 : 1 : 1 : 1 : 1 : 1 : 1 : + 1 : 2 : 2 : 2 : 2 : 2 : 2 : 2 : + 2 : 2 : 2 : 2 : 2 : 2 : 2 : 2 : + 2 : 2 : 2 : 3 : 3 : 3 : 3 : 3 : + 3 : 3 : 3 : 3 : 3 : 3 : 3 : 3 : + 3 : 3 : 3 : 4 : 4 : 4 : 4 : 4 : + 4 : 4 : 4 : 4 : 4 : 4 : 4 : 4 : + 5 : 5 : 5 : 5 : 5 : 5 : 5 : 5 : + 6 : 6 : 6 : 7 : 7 : 8 : 8 : 9 : + 10 : 11 : 12 : 13 : 14 : 15 : 15 : 16 : + 17 : 17 : 17 : 18 : 18 : 18 : 18 : 18 : + 18 : 18 : 18 : 17 : 17 : 16 : 16 : 15 : + 15 : 14 : 14 : 14 : 13 : 13 : 14 : 14 : + 15 : 16 : 17 : 18 : 19 : 20 : 22 : 23 : + 25 : 27 : 30 : 32 : 35 : 37 : 39 : 41 : + 43 : 45 : 47 : 48 : 49 : 49 : 48 : 46 : + 41 : 34 : 24 : 11 : -6 : -26 : -48 : -72 : + -96 : -114 : -128 : -128 : -128 : -128 : -128 : -128 : + -128 : -125 : -110 : -93 : -75 : -57 : -41 : -27 : + -17 : -10 : -6 : -4 : -2 : -2 : -2 : -2 : + -2 : -3 : -4 : -4 : -5 : -6 : -7 : -8 : + -9 : -10 : -11 : -12 : -12 : -12 : -13 : -13 : + -13 : -13 : -13 : -13 : -12 : -12 : -11 : -10 : + -9 : -9 : -8 : -8 : -7 : -6 : -6 : -5 : + -5 : -5 : -5 : -4 : -4 : -4 : -4 : -4 : + -4 : -4 : -4 : -4 : -4 : -5 : -7 : -8 : + -8 : -9 : -10 : -11 : -12 : -13 : -13 : -14 : + -14 : -14 : -13 : -10 : -7 : -2 : 5 : 15 : + 26 : 37 : 49 : 61 : 73 : 83 : 92 : 99 : + 105 : 109 : 111 : 112 : 110 : 105 : 99 : 90 : + 80 : 71 : 63 : 57 : 52 : 49 : 47 : 47 : + 48 : 49 : 51 : 51 : 52 : 52 : 50 : 48 : + 42 : 34 : 22 : 7 : -12 : -32 : -56 : -78 : + -96 : -114 : -127 : -128 : -128 : -128 : -128 : -128 : + -128 : -118 : -102 : -83 : -67 : -50 : -37 : -26 : + -17 : -12 : -8 : -5 : -3 : -3 : -2 : -2 : + -2 : -3 : -4 : -4 : -6 : -7 : -8 : -10 : + -11 : -12 : -12 : -13 : []) + +guitarCompShort, guitarCompLong :: + Field.C a => [a] -> Composition.T TwoWay.T Double a a +guitarCompShort past = Feedback (Prim (TwoWay.Past past)) (Parallel [ + Serial [Prim (TwoWay.Delay 1), + Prim (TwoWay.Mask [0.6519177892575342, 0.2331904728998289])], + Serial [Prim (TwoWay.Delay 126), + Prim (TwoWay.Mask [0.08253506238277844, + 0.2369601607320473, 0.18367848836060044, + -0.06422525077173147, -0.31836517142623727])]]) +guitarCompLong past = Feedback (Prim (TwoWay.Past past)) ( + Serial [Prim (TwoWay.Delay 122), + Prim (TwoWay.Mask [ + -0.23742303494466988, + 0.020278040917954415, + 0.12495333789385828, + 0.16125537461091102, + 0.1993410924766678, + 0.24673057006071691, + 0.25438881375430467, + 0.1424676847770117, + 0.03848071949084291, + -0.016618282409355676, + -0.04517323927531556, + -0.0061713683480988475, + 0.11137126130878339 + ])]) + +{-| Reconstruct the guitar sound from the sampled initial wave + and the analysed feedback factors. + This sounds pretty like the sampled sound. -} +guitarRaw :: (Field.C a, Module.C a a) => [a] +guitarRaw = + let gi = guitarInit -- assert monomorphism + y = TwoWay.future + (TwoWay.delay (length gi) + (apply (guitarCompLong (reverse gi)) + (TwoWay.Signal [] []))) + in y + +{-| Reconstruct the guitar sound from the sampled initial wave + but with simple smoothing on feedback. + This sounds more statically. -} +guitarRawSimple :: (Field.C a, Module.C a a) => [a] +guitarRawSimple = + let gi = guitarInit -- assert monomorphism + y = gi ++ drop (length gi) + (FiltNR.delay 128 (Filt1.lowpass + (repeat (Filt1.Parameter (0.4 `asTypeOf` head y))) y)) + in y + +{-| Reconstruct the guitar sound with the analysed feedback factors + but with an synthetic initial wave. + The sharpness of the initial wave can be controlled. + This is used to implement various velocities. -} +guitarRawVelo :: (Real.C a, Trans.C a, Module.C a a) => a -> [a] +guitarRawVelo velo = + let len = 128::Int + wave = + map (Wave.power01Normed velo) + (take len (iterate (+ 2 / fromIntegral len) (-1))) + y = TwoWay.future + (TwoWay.delay len + (apply (guitarCompLong wave) + (TwoWay.Signal [] []))) + in y + + +{-| Resample the reconstructed string sound + so that notes can be played. -} +guitar :: (RealField.C a, Module.C a a) => a -> [a] +guitar freq = + let srcFreq = 128 * freq + in Interpolation.multiRelativeZeroPadLinear 0 + (repeat (srcFreq `asTypeOf` freq)) guitarRawSimple + + + +{-* Tests for FilterGraphs -} + +type CompositionDouble = + Composition.T TwoWay.T Double Double Double + +{-| a simple lowpass used to create an exponential2 -} +--expo :: (RealField.C a, Module.C a a) => TwoWay.Signal a +expo :: TwoWay.Signal Double +expo = + let _flt1 = Feedback (Serial [Prim (OneWay.Delay ([0] `asTypeOf` past))]) + (Serial [Prim (OneWay.Mask + ([0.9] `asTypeOf` past))]) + _flt2 = (Prim (TwoWay.Mask ([0.5] `asTypeOf` past))) + :: CompositionDouble + flt3 = (Feedback (Serial []) + (Prim (TwoWay.Delay 1))) + :: CompositionDouble + TwoWay.Signal past future = apply flt3 (TwoWay.Signal [] [1]) + in TwoWay.Signal past (take 10 future) + +type GraphDouble f = Graph.T f Int Double Double Double + +simpleGraph :: TwoWay.Signal Double +simpleGraph = + let out = + Graph.apply + (Graph.fromList + [(0, []), + (1, [(0, TwoWay.Delay (-1))]), + (2, [(1, TwoWay.Mask [0.95])])] :: + GraphDouble TwoWay.T) + (Graph.signalFromList + [(0, TwoWay.Signal [] [1])]) + in fromMaybe (error "requested output of non-existing socket") + (Graph.lookupSignal out (2::Int)) + +expoGraphTwoWay :: [Double] +expoGraphTwoWay = + let out = + Graph.apply + (Graph.fromList + [(0, [(2, TwoWay.Past [1])]), + (1, [(0, TwoWay.Delay 1)]), + (2, [(1, TwoWay.Mask [0.95])])] :: + GraphDouble TwoWay.T) + (Graph.signalFromList + [(0, TwoWay.Signal [] [])]) + in TwoWay.take 20 $ TwoWay.delay 10 + (fromMaybe (error "requested output of non-existing socket") + (Graph.lookupSignal out (0::Int))) + + +expoGraph :: [Double] +expoGraph = + let out = + Graph.apply + (Graph.fromList + [(0, [(1, OneWay.Delay [0])]), + (1, [(0, OneWay.Mask [0.99])])] :: + GraphDouble OneWay.T) + (Graph.signalFromList + [(0, [1])]) + in fromMaybe (error "requested output of non-existing socket") + (Graph.lookupSignal out (0::Int)) + +{-| make recursive flanger with help of the two way interpolation -} +flangedSaw :: Double -> [Double] +flangedSaw sampleRate = + let {- The flanger's principal filter frequency will vary between + flangeFreq * 2**flangeRange and flangeFreq / 2**flangeRange -} + flangeFreq = 1000 + flangeRange = 2 + sawFreq = 440 + gain = 0.6 + vol = 0.5 + + {- 'control' contains the feedback times -} + control = map (\c -> sampleRate/flangeFreq * 2**(-flangeRange*c)) + (map sin (iterate (pi/(0.5*sampleRate)+) 0)) + sawPast = Osci.freqModSaw 0 (repeat (-sawFreq/sampleRate)) + sawFuture = Osci.freqModSaw 0 (repeat ( sawFreq/sampleRate)) + --lowNoise = amplify vol noise + flt = Feedback + (Prim (TwoWay.Mask [vol])) + (Serial [Prim (TwoWay.Mask [gain]), + Prim (TwoWay.Past []), + Prim (TwoWay.ModFracDelay + Interpolation.linear + (TwoWay.Signal [] control))]) + :: CompositionDouble + + in TwoWay.future + (apply flt (TwoWay.Signal sawPast sawFuture)) diff --git a/src/Synthesizer/Filter/Fix.hs b/src/Synthesizer/Filter/Fix.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Filter/Fix.hs @@ -0,0 +1,38 @@ +module Synthesizer.Filter.Fix where + +import qualified Synthesizer.Filter.Graph as Graph + + +{-| +A 'Graph.T' with numbered nodes is not very comfortable. +Better provide a 'Control.Monad.Fix.fix'-like function +which allows to enter a graph this way: + +> fix $ \[v,w,y] -> +> [a·(u + d·w), +> b·(v + e·y), +> c· w] + +-} + +type T filter t a v = + [Channel filter t a v] -> [[(Channel filter t a v, filter t a v)]] + +type ChannelId = Int + +data Channel filter t a v = + Channel {channelId :: ChannelId, + channelInputs :: [(ChannelId, filter t a v)]} + + +fix :: T filter t a v -> [Channel filter t a v] +fix f = + let cs = zipWith (\n inputs -> + Channel n (map (\(c,filt) -> (channelId c, filt)) inputs)) + [0 ..] (f cs) + in cs + + +toGraph :: T filter t a v -> Graph.T filter Int t a v +toGraph = + Graph.fromList . map (\(Channel n inputs) -> (n, inputs)) . fix diff --git a/src/Synthesizer/Filter/Graph.hs b/src/Synthesizer/Filter/Graph.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Filter/Graph.hs @@ -0,0 +1,183 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts #-} +module Synthesizer.Filter.Graph where + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + +import qualified Synthesizer.Filter.Basic as FilterBasic +import Synthesizer.Filter.Basic (Filter, apply, ) +import qualified Data.Map as Map +import Data.Map(Map) +import MathObj.DiscreteMap() {- Module.C instances for Map -} + +import qualified Number.Complex as Complex +import qualified Algebra.RealField as RealField +import qualified Algebra.Additive as Additive +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Module as Module +import Algebra.Module((*>)) +import Orthogonals(Scalar,inverse,add_to_diagonal) + + +{-| +A filter network is a graph consisting +of nodes (input and output signals) +and edges (filter processes). +Output signals can be taken from every node, +inputs can be injected in some nodes +which means that the signal at this node is superposed with +the injected signal. +The same can be achieved by duplicating the network, +one duplicate per input, +and superposing the corresponding outputs. +It is also sensible to setup a graph without inputs, +e.g. a recursive filter with some initial conditions +that works independent from any input. + +In opposition to electric filter networks +digital filter networks must be directed. + +Test-case: leap-frog filters like + +> +-----------[d]-----------+ +> v | +>(u) -+-> [a] (v) -+-> [b] (w) -+-> [c] (y) -+-> +> ^ | +> +-----------[e]-----------+ + +@ +v = a·(u + d·w) +w = b·(v + e·y) +y = c· w +@ + +We model the general network by a list of nodes, +where each node is an adder that holds a list of its inputs. +Each input of a node is an output +of another node that has gone through a processor. +Additionally there may be one input from outside. +In principle a processor could be a simple filter network +as defined by the structure 'Filter'. + +The network is an applyable filter +whenever each circle contains a delay. +To compute the transfer function +we have to solve a system of linear equations +which we can construct quite straight forward +from the processors' input lists. + +The current design can be abstractly seen +as the system of linear equations: + + y = A*y + u + +where A is a matrix containing the edges hosting the filters, +y the vector of output signals, +u the vector of input signals. +In this formulation the number of inputs and outputs must match +but since you are free to ignore some of the inputs and outputs +you can use nodes for pure output, pure input or both of them. + +-} + +newtype T filter i t a v = + C (Map i + [(i, {- index of the processor whose output goes in here -} + filter t a v {- description of the filter -} + )]) + + +newtype Signal list i v = Signal (Map i (list v)) + + +fromList :: (Ord i) => [(i, [(i, filter t a v)])] -> T filter i t a v +fromList = C . Map.fromList + +toList :: T filter i t a v -> [(i, [(i, filter t a v)])] +toList (C fg) = Map.toList fg + +signalFromList :: (Ord i) => [(i, list v)] -> Signal list i v +signalFromList = Signal . Map.fromList + +signalToList :: Signal list i v -> [(i, list v)] +signalToList (Signal x) = Map.toList x + +lookupSignal :: (Ord i) => Signal list i v -> i -> Maybe (list v) +lookupSignal (Signal x) = flip Map.lookup x + + +{- + These instance may help to include FilterGraphs + in even bigger structures. +-} +instance (Ord i, Additive.C (list v), Eq (list v)) + => Additive.C (Signal list i v) where + zero = Signal Additive.zero + (+) (Signal x) (Signal y) = Signal ((Additive.+) x y) + (-) (Signal x) (Signal y) = Signal ((Additive.-) x y) + negate (Signal x) = Signal (Additive.negate x) + +instance (Ord i, Eq a, Additive.C a, Additive.C (list v), Eq (list v), + Module.C a v, Module.C a (list v)) + => Module.C a (Signal list i v) where + s *> (Signal x) = Signal (s *> x) + + +{- + It would be interesting to make FilterGraphs + an instance of Filter. + To achieve that we had to make GraphSignals an instance of Module.C + and the transferFunction would no longer return a factor + but a function that maps input amplitudes + of a given frequency to output amplitudes. + +instance (Ord i, Show i, Filter list filter) => + Filter (Signal list i) (T filter i) where +-} + +apply :: (Ord i, Show i, Additive.C t, Trans.C t, RealField.C t, + Module.C a v, Module.C a (list v), + Filter list filter) => + T filter i t a v -> Signal list i v -> Signal list i v +apply (C fg) (Signal inputs) = + let getInput i = Map.findWithDefault Additive.zero i inputs + getOutput i = Map.findWithDefault + (error ("Unknown processor: "++show i)) i outputs + output i edges = + foldl (Additive.+) (getInput i) (map (\(j,f) -> + FilterBasic.apply f (getOutput j)) edges) + outputs = Map.mapWithKey output fg + in Signal outputs + +{-| Compute a matrix that tells how an input frequency + is mapped to the various output nodes. + + According to the formulation given above + we have to invert the matrix (I-A). + + Currently this is done by a QR decomposition for each frequency. + It would be probably faster if we decompose + the matrix containing polynomial elements. + Then the inverted matrix would consist of some + polynomial ratios which can be evaluated for each frequency. +-} +transferFunction :: + (Ord i, Show i, Trans.C t, + P.Fractional (Complex.T t), Scalar (Complex.T t), + Module.C a t, Filter list filter) => + T filter i t a v -> t -> [[Complex.T t]] +transferFunction (C fg) w = + let keys = Map.keys fg + elts = Map.elems fg + inputsToMap procs = + Map.mapWithKey (\_ f -> FilterBasic.transferFunction f w) + (Map.fromList procs) + makeRow procs = + map (flip (Map.findWithDefault 0) (inputsToMap procs)) keys + matrix = map makeRow elts + in inverse (add_to_diagonal (-1) matrix) diff --git a/src/Synthesizer/Filter/Graphic.hs b/src/Synthesizer/Filter/Graphic.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Filter/Graphic.hs @@ -0,0 +1,7 @@ +module Synthesizer.Filter.Graphic where + +{-| + This module should be populated with functions + that create flowchart graphics from the filter networks + of the 'Composition' module. +-} diff --git a/src/Synthesizer/Filter/MonadFix.hs b/src/Synthesizer/Filter/MonadFix.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Filter/MonadFix.hs @@ -0,0 +1,44 @@ +module Synthesizer.Filter.MonadFix where + +import qualified Synthesizer.Filter.Graph as Graph +import qualified Synthesizer.Filter.Fix as FFix + +import Synthesizer.Filter.Fix (Channel(Channel), ChannelId) + +import Control.Monad.Trans.State (StateT, evalStateT, get, modify, ) +import Control.Monad.Trans.Writer (Writer, execWriter, tell, ) +import Control.Monad.Trans (lift, ) + + +{-| +If you find 'Filter.Fix.T' still inconvenient, +and if you don't care about portability, +you can also use the following monad with the @mdo@ notation. + +> mdo +> v <- a·(u + d·w) +> w <- b·(v + e·y) +> y <- c· w + +-} + + +type T filter t a v x = StateT ChannelId (Writer [Channel filter t a v]) x + +makeChannel :: + [(ChannelId, filter t a v)] -> + T filter t a v ChannelId +makeChannel inputs = + do n <- get + modify succ + lift $ tell [Channel n inputs] + return n + + +run :: T filter t a v x -> [Channel filter t a v] +run m = execWriter (evalStateT m 0) + + +toGraph :: T filter t a v x -> Graph.T filter Int t a v +toGraph = + Graph.fromList . map (\(Channel n inputs) -> (n, inputs)) . run diff --git a/src/Synthesizer/Filter/OneWay.hs b/src/Synthesizer/Filter/OneWay.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Filter/OneWay.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +module Synthesizer.Filter.OneWay where + +import Synthesizer.Filter.Basic + +import qualified Synthesizer.Plain.Interpolation as Interpolation +import qualified Synthesizer.Plain.Filter.NonRecursive as FiltNR +import Number.Complex(cis) + +import qualified Algebra.Module as Module +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Algebra.Module(linearComb) +import Algebra.Additive(zero) + +import PreludeBase +import NumericPrelude + +type Signal = [] + +{-| shift signal in time -} +delay :: (Additive.C v) => + Int -> Signal v -> Signal v +delay = FiltNR.delayPad zero + +delayOnce :: (Additive.C v) => + Signal v -> Signal v +delayOnce = (zero:) + + +{-| Unmodulated non-recursive filter -} +nonRecursiveFilter :: Module.C a v => + [a] -> [v] -> [v] +nonRecursiveFilter = FiltNR.generic + +{-| Modulated non-recursive filter. -} +nonRecursiveFilterMod :: Module.C a v => + [[a]] -> [v] -> [v] +nonRecursiveFilterMod ms x = + zipWith linearComb ms (tail (scanl (flip (:)) [] x)) + + +{-| Description of a basic filter that can be used in larger networks. -} +data T t a v = + Mask [a] + {-^ A static filter described by its mask -} + | ModMask (Signal [a]) + {-^ A modulated filter described by a list of masks -} + | FracDelay (Interpolation.T t v) t + {-^ Delay the signal by a fractional amount of samples. + This is achieved by interpolation. -} + | ModFracDelay (Interpolation.T t v) (Signal t) + {-^ Delay with varying delay times. + The delay times sequence must monotonically decrease. + (This includes constant parts!) -} + | Delay [v] + {-^ Delay the signal by prepending another one -} + +instance Filter [] T where + + apply (Mask m) = nonRecursiveFilter m + apply (ModMask m) = nonRecursiveFilterMod m + apply (FracDelay ip t) = Interpolation.multiRelativeZeroPad zero + ip (-t) (repeat 1) + apply (ModFracDelay ip ts) = Interpolation.multiRelativeZeroPad zero + ip (- head ts) (repeat 1 - FiltNR.differentiate ts) + apply (Delay x) = (x++) + + transferFunction (Mask m) w = linearComb m (screw (negate w)) + transferFunction (FracDelay _ t) w = cis (negate w * t) + transferFunction (Delay x) w = cis (negate w * fromIntegral (length x)) + transferFunction _ _ = + error "transfer function can't be computed for modulated filters" diff --git a/src/Synthesizer/Filter/TwoWay.hs b/src/Synthesizer/Filter/TwoWay.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Filter/TwoWay.hs @@ -0,0 +1,247 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +module Synthesizer.Filter.TwoWay where + +import Synthesizer.Filter.Basic + +import qualified Synthesizer.Plain.Signal as Sig +import qualified Synthesizer.Plain.Interpolation as Ip +import qualified Synthesizer.Plain.Interpolation as Interpolation + +import Algebra.Module(linearComb,(*>)) + +import qualified Algebra.Module as Module +import qualified Algebra.RealField as RealField +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Number.Complex(cis, ) +import Data.Function.HT (nest, ) +import qualified Data.List as List + +import PreludeBase hiding (take) +import NumericPrelude + + +{-| A TwoWay.Signal stores values of the past and the future -} +data Signal v = Signal {past, future :: [v]} + deriving (Show, Eq) + +{-| Take n values starting from time zero. + If you want clips from elsewhere, + call 'take' after 'delay'. -} +take :: Int -> Signal v -> [v] +take n (Signal _ x) = List.take n x + +zipSignalWith :: (a -> b -> c) -> Signal a -> Signal b -> Signal c +zipSignalWith f (Signal xPast xFuture) (Signal yPast yFuture) = + (Signal (zipWith f xPast yPast) (zipWith f xFuture yFuture)) + +{-| Take the value at time zero. -} +origin :: Ring.C a => Signal a -> a +origin (Signal _ (x:_)) = x +origin _ = 0 + +{-| A signal that consists entirely of ones -} +ones :: Ring.C a => Signal a +ones = Signal (repeat 1) (repeat 1) + +{-| shift signal in time, + keep all values but if required pad with zeros -} +delay :: (Additive.C v) => + Int -> Signal v -> Signal v +delay = delayGen delayOnce + +delayPad :: v -> Int -> Signal v -> Signal v +delayPad z = delayGen (delayPadOnce z) + +{-| shift signal in time, + zero values at either ends will be flushed -} +delayOpt :: (Eq v, Additive.C v) => + Int -> Signal v -> Signal v +delayOpt = delayGen delayOptOnce + + +{-| Delay by one sample. -} +delayOnce :: (Additive.C v) => + Signal v -> Signal v +--delayOnce (Signal [] []) = ([],[]) +delayOnce (Signal [] ys) = Signal [] (zero:ys) +delayOnce (Signal (x:xs) ys) = Signal xs (x:ys) + +delayPadOnce :: v -> Signal v -> Signal v +--delayPadOnce _ (Signal [] []) = ([],[]) +delayPadOnce z (Signal [] ys) = Signal [] (z:ys) +delayPadOnce _ (Signal (x:xs) ys) = Signal xs (x:ys) + +delayOptOnce :: (Eq v, Additive.C v) => + Signal v -> Signal v +--delayOptOnce (Signal [] []) = Signal [] [] +delayOptOnce (Signal [] ys) = Signal [] (zero:ys) +delayOptOnce (Signal (x:xs) []) = Signal xs (if x==zero then [] else x:[]) +delayOptOnce (Signal (x:xs) ys) = Signal xs (x:ys) + + +{-| General routine that supports delaying and prefetching + using a general one-sample delaying routine. -} +delayGen :: (Signal v -> Signal v) -> + Int -> Signal v -> Signal v +{- Using this optimization applications of recursive filters + with zero initial conditions represented by an empty list will fail. + This is because in this case the value of the first item of the future list + depends on the first item of the input future list, + whereas normally the first future value depends on no input future value, + at all. +delayGen _ _ (Signal [] []) = Signal [] [] + cf. the next example -} +delayGen delOnce t = + if t < 0 + then reverseTwoWay . nest (negate t) delOnce . reverseTwoWay + else nest t delOnce + +reverseTwoWay :: Signal v -> Signal v +reverseTwoWay (Signal x y) = Signal y x + + +instance (Additive.C v) => Additive.C (Signal v) where + zero = Signal zero zero + (+) (Signal y0 y1) (Signal x0 x1) = Signal (y0 + x0) (y1 + x1) + (-) (Signal y0 y1) (Signal x0 x1) = Signal (y0 - x0) (y1 - x1) + negate (Signal x0 x1) = Signal (negate x0) (negate x1) + +instance (Module.C a v) => Module.C a (Signal v) where + (*>) s (Signal x0 x1) = Signal (s *> x0) (s *> x1) + + + + +{-| for a Signal this means a reversion of the elements -} +flipPair :: (a,b) -> (b,a) +flipPair (x,y) = (y,x) + +{- This example simulates what happens if you call + apply (Feedback (Serial []) (Prim (Delay 1)) []) ([],[1]) + depending on the implementation of delayGen it may work or + loop infinitely when yFuture is computed. + It's even before the first element of yFuture is computed. + Note, that the equivalent + apply (Feedback (Serial []) (Prim (Delay 1)) [0]) ([],[1]) + works! (i.e. set yPast = [0] -} +testDelayGen :: Signal Double +testDelayGen = + let yPast = [] + x = Signal [] [1] + y = Signal yPast yFuture + Signal _ yFuture = delayOnce (x + y) + -- Signal _ yFuture = delayOptOnce (add x y) + -- Signal _ yFuture = delayGen delayOnce 1 (add x y) + in Signal yPast (List.take 10 yFuture) + + + +{-| Unmodulated non-recursive filter -} +nonRecursiveFilter :: Module.C a v => + [a] -> Signal v -> Signal v +nonRecursiveFilter m x = + linearComb m (iterate delayOnce x) + +{-| Modulated non-recursive filter. + The number of values before time 0 (past) or + the filter mask lengths must be at most finite. -} +nonRecursiveFilterMod :: Module.C a v => + Signal [a] -> Signal v -> Signal v +nonRecursiveFilterMod (Signal mpre msuf) x = + let (pre, suf) = unzip (map (\(Signal a b) -> (a,b)) (iterate delayOnce x)) + in Signal (zipWith linearComb mpre pre) (zipWith linearComb msuf suf) + + +{-| Interpolation allowing negative frequencies, + but requires storage of all past values. -} +interpolatePaddedZero :: (Ord a, RealField.C a) => + b -> Interpolation.T a b + -> a -> Signal a -> Signal b -> Signal b +interpolatePaddedZero z ip phase fs (Signal xPast xFuture) = + let (phInt, phFrac) = splitFraction phase + xPadded = Signal (xPast ++ repeat z) (xFuture ++ repeat z) + in interpolateCore ip phFrac fs + (delayPad z (Ip.offset ip - phInt) xPadded) + +interpolatePaddedCyclic :: (Ord a, RealField.C a) => + Interpolation.T a b + -> a -> Signal a -> Signal b -> Signal b +interpolatePaddedCyclic ip phase fs (Signal xPast xFuture) = + let (phInt, phFrac) = splitFraction phase + xCyclic = xFuture ++ reverse xPast + in interpolateCore ip phFrac fs + -- mod is for efficiency, only + (delayPad (error "interpolate: infinite signal needs no zero padding") + (mod (Ip.offset ip - phInt) (length xCyclic)) + (Signal (cycle (reverse xCyclic)) (cycle xCyclic))) + +-- note that the extrapolation may miss some of the first and some of the last points +interpolatePaddedExtrapolation :: (Ord a, RealField.C a) => + Interpolation.T a b + -> a -> Signal a -> Signal b -> Signal b +interpolatePaddedExtrapolation ip phase fs x = + interpolateCore ip (phase - fromIntegral (Ip.offset ip)) fs x + +interpolateCore :: (Ord a, Ring.C a) => + Interpolation.T a b -> a -> Signal a -> Signal b -> Signal b +interpolateCore ip phase (Signal freqPast freqFuture) x = + Signal (interpolateHalfWay ip (1-phase) freqPast + (delayPadOnce (error "interpolateCore: infinite signal needs no zero padding") + (reverseTwoWay x))) + (interpolateHalfWay ip phase freqFuture x) + +interpolateHalfWay :: (Ord a, Ring.C a) => + Interpolation.T a b -> a -> [a] -> Signal b -> [b] +interpolateHalfWay ip phase freqs (Signal xPast xFuture) = + if phase >= 1 && Sig.lengthAtLeast (1+Ip.number ip) xFuture + then interpolateHalfWay ip (phase-1) freqs + (Signal (head xFuture : xPast) (tail xFuture)) + else if phase < 0 && Sig.lengthAtLeast 1 xPast + then interpolateHalfWay ip (phase + 1) freqs + (Signal (tail xPast) (head xPast : xFuture)) + else Ip.func ip phase xFuture : + interpolateHalfWay ip (phase + head freqs) (tail freqs) + (Signal xPast xFuture) + + +{-| Description of a basic filter that can be used in larger networks. -} +data T t a v = + Mask [a] + {-^ A static filter described by its mask -} + | ModMask (Signal [a]) + {-^ A modulated filter described by a list of masks -} + | FracDelay (Interpolation.T t v) t + {-^ Delay the signal by a fractional amount of samples. + This is achieved by interpolation. -} + | ModFracDelay (Interpolation.T t v) (Signal t) + {-^ Delay with varying delay times. -} + | Delay Int + {-^ Delay the signal by given amount of samples. -} + | Past [v] + {-^ Replace the past by the given one. + This must be present in each recursive filter cycle + to let the magic work! -} + +instance Filter Signal T where + + apply (Mask m) = nonRecursiveFilter m + apply (ModMask m) = nonRecursiveFilterMod m + apply (FracDelay ip t) = interpolatePaddedZero zero + ip (-t) ones + apply (ModFracDelay ip ts) = interpolatePaddedZero zero + ip (- origin ts) (ts - delay (-1) ts + ones) + apply (Delay t) = delay t + apply (Past x) = Signal x . future + + {- This is in principle the same as for one way filters. + How can one merge them? -} + transferFunction (Mask m) w = linearComb m (screw (negate w)) + transferFunction (FracDelay _ t) w = cis (negate w * t) + transferFunction (Delay t) w = cis (negate w * fromIntegral t) + transferFunction (Past _) _ = 1 + transferFunction _ _ = + error "transfer function can't be computed for modulated filters" diff --git a/src/Synthesizer/Format.hs b/src/Synthesizer/Format.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Format.hs @@ -0,0 +1,4 @@ +module Synthesizer.Format where + +class C sig where + format :: Show x => Int -> sig x -> ShowS diff --git a/src/Synthesizer/Frame/Stereo.hs b/src/Synthesizer/Frame/Stereo.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Frame/Stereo.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{- +This data type can be used as sample type for stereo signals. +-} +module Synthesizer.Frame.Stereo (T, left, right, cons, map, ) where + +import qualified Sound.Sox.Frame as Frame + +import qualified Synthesizer.Interpolation.Class as Interpol +import qualified Algebra.Module as Module +import qualified Algebra.Additive as Additive + +import Foreign.Storable (Storable (..), ) +import qualified Foreign.Storable.Record as Store + +import Control.Applicative (liftA2, ) + +import NumericPrelude +import PreludeBase hiding (map) +import Prelude () + + + +-- cf. Sound.Sox.Frame.Stereo +data T a = Cons {left, right :: !a} + + +{-# INLINE cons #-} +cons :: a -> a -> T a +cons = Cons + +{-# INLINE map #-} +map :: (a -> b) -> T a -> T b +map f (Cons l r) = Cons (f l) (f r) + +instance Functor T where + fmap = map + + +store :: Storable a => Store.Dictionary (T a) +store = + Store.run $ + liftA2 Cons + (Store.element left) + (Store.element right) + +instance (Storable a) => Storable (T a) where + sizeOf = Store.sizeOf store + alignment = Store.alignment store + peek = Store.peek store + poke = Store.poke store + + +instance (Additive.C a) => Additive.C (T a) where + {-# INLINE zero #-} + {-# INLINE negate #-} + {-# INLINE (+) #-} + {-# INLINE (-) #-} + zero = Cons zero zero + (+) (Cons xl xr) (Cons yl yr) = Cons (xl+yl) (xr+yr) + (-) (Cons xl xr) (Cons yl yr) = Cons (xl-yl) (xr-yr) + negate (Cons xl xr) = Cons (negate xl) (negate xr) + +instance (Module.C a b) => Module.C a (T b) where + {-# INLINE (*>) #-} + s *> (Cons l r) = Cons (s *> l) (s *> r) + +instance Interpol.C a b => Interpol.C a (T b) where + {-# INLINE scaleAndAccumulate #-} + scaleAndAccumulate = + Interpol.makeMac2 Cons left right + + +instance Frame.C a => Frame.C (T a) where + numberOfChannels y = 2 * Frame.numberOfChannels (left y) + format y = Frame.format (left y) diff --git a/src/Synthesizer/FusionList/Control.hs b/src/Synthesizer/FusionList/Control.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/FusionList/Control.hs @@ -0,0 +1,252 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes +-} +module Synthesizer.FusionList.Control where + +import qualified Synthesizer.Plain.Control as Ctrl +import qualified Synthesizer.Piecewise as Piecewise + +-- import Synthesizer.FusionList.Displacement (raise) +import qualified Synthesizer.FusionList.Signal as Sig + +import qualified Algebra.Module as Module +import qualified Algebra.Transcendental as Trans +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Algebra.Module((*>)) + +-- import Number.Complex (cis,real) +-- import qualified Number.Complex as Complex + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +{- * Control curve generation -} + +{-# INLINE constant #-} +constant :: a -> Sig.T a +constant = Sig.repeat + +{-# INLINE linear #-} +linear :: Additive.C a => + a {-^ steepness -} + -> a {-^ initial value -} + -> Sig.T a + {-^ linear progression -} +linear d y0 = Sig.iterate (d+) y0 + +{- | +As stable as the addition of time values. +-} +{-# INLINE linearMultiscale #-} +linearMultiscale :: Additive.C y => + y + -> y + -> Sig.T y +linearMultiscale = curveMultiscale (+) + +{- | +Linear curve starting at zero. +-} +{-# INLINE linearMultiscaleNeutral #-} +linearMultiscaleNeutral :: Additive.C y => + y + -> Sig.T y +linearMultiscaleNeutral slope = + curveMultiscaleNeutral (+) slope zero + +{-# INLINE exponential #-} +{-# INLINE exponentialMultiscale #-} +exponential, exponentialMultiscale :: Trans.C a => + a {-^ time where the function reaches 1\/e of the initial value -} + -> a {-^ initial value -} + -> Sig.T a + {-^ exponential decay -} +exponential time = + Sig.iterate (exp (- recip time) *) + +exponentialMultiscale time = curveMultiscale (*) (exp (- recip time)) + +{-# INLINE exponentialMultiscaleNeutral #-} +exponentialMultiscaleNeutral :: Trans.C y => + y {-^ time where the function reaches 1\/e of the initial value -} + -> Sig.T y {-^ exponential decay -} +exponentialMultiscaleNeutral time = + curveMultiscaleNeutral (*) (exp (- recip time)) one + + +{-# INLINE exponential2 #-} +{-# INLINE exponential2Multiscale #-} +exponential2, exponential2Multiscale :: Trans.C a => + a {-^ half life -} + -> a {-^ initial value -} + -> Sig.T a + {-^ exponential decay -} +exponential2 halfLife = + Sig.iterate (((Ring.one+Ring.one) ** (- recip halfLife)) *) +-- Sig.iterate (((Ring.one/(Ring.one+Ring.one)) ** recip halfLife) *) + +exponential2Multiscale halfLife = curveMultiscale (*) (0.5 ** recip halfLife) + +{- the 0.5 constant seems to block fusion + Sig.iterate ((0.5 ** recip halfLife) *) +-} +{- dito fromInteger + Sig.iterate ((fromInteger 2 ** (- recip halfLife)) *) +-} + +{-# INLINE exponential2MultiscaleNeutral #-} +exponential2MultiscaleNeutral :: Trans.C y => + y {-^ half life -} + -> Sig.T y {-^ exponential decay -} +exponential2MultiscaleNeutral halfLife = + curveMultiscaleNeutral (*) (0.5 ** recip halfLife) one + + +{-# INLINE exponentialFromTo #-} +{-# INLINE exponentialFromToMultiscale #-} +exponentialFromTo, exponentialFromToMultiscale :: Trans.C y => + y {-^ time where the function reaches 1\/e of the initial value -} + -> y {-^ initial value -} + -> y {-^ value after given time -} + -> Sig.T y {-^ exponential decay -} +exponentialFromTo time y0 y1 = + Sig.iterate (* (y1/y0) ** recip time) y0 +exponentialFromToMultiscale time y0 y1 = + curveMultiscale (*) ((y1/y0) ** recip time) y0 + + + + +{-| This is an extension of 'exponential' to vectors + which is straight-forward but requires more explicit signatures. + But since it is needed rarely I setup a separate function. -} +{-# INLINE vectorExponential #-} +vectorExponential :: (Trans.C a, Module.C a v) => + a {-^ time where the function reaches 1\/e of the initial value -} + -> v {-^ initial value -} + -> Sig.T v + {-^ exponential decay -} +vectorExponential time y0 = + Sig.iterate (exp (-1/time) *>) y0 + +{-# INLINE vectorExponential2 #-} +vectorExponential2 :: (Trans.C a, Module.C a v) => + a {-^ half life -} + -> v {-^ initial value -} + -> Sig.T v + {-^ exponential decay -} +vectorExponential2 halfLife y0 = + Sig.iterate (0.5**(1/halfLife) *>) y0 + + + +{-# INLINE cosine #-} +cosine :: Trans.C a => + a {-^ time t0 where 1 is approached -} + -> a {-^ time t1 where -1 is approached -} + -> Sig.T a + {-^ a cosine wave where one half wave is between t0 and t1 -} +cosine = Ctrl.cosineWithSlope $ + \d x -> Sig.map cos (linear d x) + + + +{-# INLINE cubicHermite #-} +cubicHermite :: Field.C a => (a, (a,a)) -> (a, (a,a)) -> Sig.T a +cubicHermite node0 node1 = + Sig.map (Ctrl.cubicFunc node0 node1) (linear 1 0) + + + +-- * piecewise curves + + +splitDurations :: (RealField.C t) => + [t] -> [(Int, t)] +splitDurations ts0 = + let (ds,ts) = + unzip $ scanl + (\(_,fr) d -> splitFraction (fr+d)) + (0,1) ts0 + in zip (tail ds) (map (subtract 1) ts) + +{-# INLINE piecewise #-} +piecewise :: (RealField.C a) => + Piecewise.T a a (a -> Sig.T a) -> Sig.T a +piecewise xs = + Sig.concat $ zipWith + (\(n, t) (Piecewise.PieceData c yi0 yi1 d) -> + Sig.take n $ Piecewise.computePiece c yi0 yi1 d t) + (splitDurations $ map Piecewise.pieceDur xs) + xs + + +type Piece a = + Piecewise.Piece a a + (a {- fractional start time -} -> Sig.T a) + + +{-# INLINE stepPiece #-} +stepPiece :: Piece a +stepPiece = + Piecewise.pieceFromFunction $ \ y0 _y1 _d _t0 -> + constant y0 + +{-# INLINE linearPiece #-} +linearPiece :: (Field.C a) => Piece a +linearPiece = + Piecewise.pieceFromFunction $ \ y0 y1 d t0 -> + let s = (y1-y0)/d in linear s (y0-t0*s) + +{-# INLINE exponentialPiece #-} +exponentialPiece :: (Trans.C a) => a -> Piece a +exponentialPiece saturation = + Piecewise.pieceFromFunction $ \ y0 y1 d t0 -> + let y0' = y0-saturation + y1' = y1-saturation + yd = y0'/y1' + in raise saturation + (exponential (d / log yd) (y0' * yd**(t0/d))) + +{-# INLINE cosinePiece #-} +cosinePiece :: (Trans.C a) => Piece a +cosinePiece = + Piecewise.pieceFromFunction $ \ y0 y1 d t0 -> + Sig.map + (\y -> (1+y)*(y0/2)+(1-y)*(y1/2)) + (cosine t0 (t0+d)) + +{-# INLINE cubicPiece #-} +cubicPiece :: (Field.C a) => a -> a -> Piece a +cubicPiece yd0 yd1 = + Piecewise.pieceFromFunction $ \ y0 y1 d t0 -> + cubicHermite (t0,(y0,yd0)) (t0+d,(y1,yd1)) + +raise :: Additive.C a => a -> Sig.T a -> Sig.T a +raise = Sig.map . (+) + +-- * auxiliary functions + +{-# INLINE curveMultiscale #-} +curveMultiscale :: (y -> y -> y) -> y -> y -> Sig.T y +curveMultiscale op d y0 = + Sig.cons y0 (Sig.map (op y0) (Sig.iterateAssociative op d)) + +{-# INLINE curveMultiscaleNeutral #-} +curveMultiscaleNeutral :: (y -> y -> y) -> y -> y -> Sig.T y +curveMultiscaleNeutral op d neutral = + Sig.cons neutral (Sig.iterateAssociative op d) diff --git a/src/Synthesizer/FusionList/Filter/NonRecursive.hs b/src/Synthesizer/FusionList/Filter/NonRecursive.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/FusionList/Filter/NonRecursive.hs @@ -0,0 +1,314 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes +-} +module Synthesizer.FusionList.Filter.NonRecursive where + +import qualified Synthesizer.FusionList.Control as Ctrl +import qualified Synthesizer.FusionList.Signal as Sig + +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Module as Module +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Algebra.Module( {- linearComb, -} (*>), ) + +import Data.Function.HT (nest, ) + +import PreludeBase +import NumericPrelude + + + +{- * Envelope application -} + +{-# INLINE amplify #-} +amplify :: (Ring.C a) => a -> Sig.T a -> Sig.T a +amplify v = Sig.map (v*) + +{-# INLINE amplifyVector #-} +amplifyVector :: (Module.C a v) => a -> Sig.T v -> Sig.T v +amplifyVector v = Sig.map (v*>) + + +{-# INLINE envelope #-} +envelope :: (Ring.C a) => + Sig.T a {-^ the envelope -} + -> Sig.T a {-^ the signal to be enveloped -} + -> Sig.T a +envelope = Sig.zipWith (*) + +{-# INLINE envelopeVector #-} +envelopeVector :: (Module.C a v) => + Sig.T a {-^ the envelope -} + -> Sig.T v {-^ the signal to be enveloped -} + -> Sig.T v +envelopeVector = Sig.zipWith (*>) + + + +{-# INLINE fadeInOut #-} +fadeInOut :: (Field.C a) => + Int -> Int -> Int -> Sig.T a -> Sig.T a +fadeInOut tIn tHold tOut = + let leadIn = Sig.take tIn $ Ctrl.linear ( recip (fromIntegral tIn)) zero + leadOut = Sig.take tOut $ Ctrl.linear (- recip (fromIntegral tOut)) one + hold = Sig.replicate tHold one + in envelope (leadIn `Sig.append` hold `Sig.append` leadOut) + +{-# INLINE fadeInOutStored #-} +fadeInOutStored :: (Field.C a) => + Int -> Int -> Int -> Sig.T a -> Sig.T a +fadeInOutStored tIn tHold tOut xs = + let leadIn = Sig.take tIn $ Ctrl.linear ( recip (fromIntegral tIn)) 0 + leadOut = Sig.take tOut $ Ctrl.linear (- recip (fromIntegral tOut)) 1 + (partIn, partHoldOut) = Sig.splitAt tIn xs + (partHold, partOut) = Sig.splitAt tHold partHoldOut + in envelope leadIn partIn `Sig.append` + partHold `Sig.append` + envelope leadOut partOut + + +{- * Shift -} + +{-# INLINE delay #-} +delay :: Additive.C y => Int -> Sig.T y -> Sig.T y +delay = delayPad zero + +{-# INLINE delayPad #-} +delayPad :: y -> Int -> Sig.T y -> Sig.T y +delayPad z n = + if n<0 + then Sig.drop (negate n) + else Sig.append (Sig.replicate n z) + + +{- * Smoothing -} + + +{-| Unmodulated non-recursive filter -} +{-# INLINE generic #-} +generic :: (Module.C a v) => + Sig.T a -> Sig.T v -> Sig.T v +generic m x = + let mr = Sig.reverse m + xp = delay (pred (Sig.length m)) x + in Sig.mapTails (Sig.linearComb mr) xp + +{- +genericSlow :: Module.C a v => + Sig.T a -> Sig.T v -> Sig.T v +genericSlow m x = + let mr = Sig.reverse m + xp = delay (pred (Sig.length m)) x + in Sig.fromList (map (Sig.linearComb mr) (init (Sig.tails xp))) +-} + +{- +{- | +@eps@ is the threshold relatively to the maximum. +That is, if the gaussian falls below @eps * gaussian 0@, +then the function truncated. +-} +gaussian :: + (Trans.C a, RealField.C a, Module.C a v) => + a -> a -> a -> Sig.T v -> Sig.T v +gaussian eps ratio freq = + let var = ratioFreqToVariance ratio freq + area = var * sqrt (2*pi) + gau t = exp (-(t/var)^2/2) / area + width = ceiling (var * sqrt (-2 * log eps)) -- inverse gau + gauSmp = map (gau . fromIntegral) [-width .. width] + in drop width . generic gauSmp +-} + +{- +GNUPlot.plotList [] (take 1000 $ gaussian 0.001 0.5 0.04 (Filter.Test.chirp 5000) :: [Double]) + +The filtered chirp must have amplitude 0.5 at 400 (0.04*10000). +-} + +{- + We want to approximate a Gaussian by a binomial filter. + The latter one can be implemented by a convolutional power. + However we still require a number of operations per sample + which is proportional to the variance. +-} +{-# INLINE binomial #-} +binomial :: + (Trans.C a, RealField.C a, Module.C a v) => + a -> a -> Sig.T v -> Sig.T v +binomial ratio freq = + let width = ceiling (2 * ratioFreqToVariance ratio freq ^ 2) + in Sig.drop width . nest (2*width) ((asTypeOf 0.5 freq *>) . binomial1) + +{- +exp (-(t/var)^2/2) / area *> cis (2*pi*f*t) + == exp (-(t/var)^2/2 +: 2*pi*f*t) / area + == exp ((-t^2 +: 2*var^2*2*pi*f*t) / (2*var^2)) / area + == exp ((t^2 - i*2*var^2*2*pi*f*t) / (-2*var^2)) / area + == exp (((t^2 - i*var^2*2*pi*f)^2 + (var^2*2*pi*f)^2) / (-2*var^2)) / area + == exp (((t^2 - i*var^2*2*pi*f)^2 / (-2*var^2) - (var*2*pi*f)^2/2)) / area + +sumMap (\t -> exp (-(t/var)^2/2) / area *> cis (2*pi*f*t)) + [-infinity..infinity] + ~ sumMap (\t -> exp (-(t/var)^2/2)) [-infinity..infinity] + * exp (-(var*2*pi*f)^2/2) / area + = exp (-(var*2*pi*f)^2/2) +-} +{- | + Compute the variance of the Gaussian + such that its Fourier transform has value @ratio@ at frequency @freq@. +-} +{-# INLINE ratioFreqToVariance #-} +ratioFreqToVariance :: (Trans.C a) => a -> a -> a +ratioFreqToVariance ratio freq = + sqrt (-2 * log ratio) / (2*pi*freq) + -- inverse of the fourier transformed gaussian + +{-# INLINE binomial1 #-} +binomial1 :: (Additive.C v) => Sig.T v -> Sig.T v +binomial1 = Sig.zapWith (+) + + + + + +{- | +Moving (uniformly weighted) average in the most trivial form. +This is very slow and needs about @n * length x@ operations. +-} +{-# INLINE sums #-} +sums :: (Additive.C v) => Int -> Sig.T v -> Sig.T v +sums n = Sig.mapTails (Sig.sum . Sig.take n) + + +{- +sumsDownsample2 :: (Additive.C v) => Sig.T v -> Sig.T v +sumsDownsample2 (x0:x1:xs) = (x0+x1) : sumsDownsample2 xs +sumsDownsample2 xs = xs + +downsample2 :: Sig.T a -> Sig.T a +downsample2 (x0:_:xs) = x0 : downsample2 xs +downsample2 xs = xs + + +{- | +Given a list of numbers +and a list of sums of (2*k) of successive summands, +compute a list of the sums of (2*k+1) or (2*k+2) summands. + +Eample for 2*k+1 + +@ + [0+1+2+3, 2+3+4+5, 4+5+6+7, ...] -> + [0+1+2+3+4, 1+2+3+4+5, 2+3+4+5+6, 3+4+5+6+7, 4+5+6+7+8, ...] +@ + +Example for 2*k+2 + +@ + [0+1+2+3, 2+3+4+5, 4+5+6+7, ...] -> + [0+1+2+3+4+5, 1+2+3+4+5+6, 2+3+4+5+6+7, 3+4+5+6+7+8, 4+5+6+7+8+9, ...] +@ +-} +sumsUpsampleOdd :: (Additive.C v) => Int -> Sig.T v -> Sig.T v -> Sig.T v +sumsUpsampleOdd n {- 2*k -} xs ss = + let xs2k = drop n xs + in (head ss + head xs2k) : + concat (zipWith3 (\s x0 x2k -> [x0+s, s+x2k]) + (tail ss) + (downsample2 (tail xs)) + (tail (downsample2 xs2k))) + +sumsUpsampleEven :: (Additive.C v) => Int -> Sig.T v -> Sig.T v -> Sig.T v +sumsUpsampleEven n {- 2*k -} xs ss = + sumsUpsampleOdd (n+1) xs (zipWith (+) ss (downsample2 (drop n xs))) + +sumsPyramid :: (Additive.C v) => Int -> Sig.T v -> Sig.T v +sumsPyramid n xs = + let aux 1 ys = ys + aux 2 ys = ys + tail ys + aux m ys = + let ysd = sumsDownsample2 ys + in if even m + then sumsUpsampleEven (m-2) ys (aux (div (m-2) 2) ysd) + else sumsUpsampleOdd (m-1) ys (aux (div (m-1) 2) ysd) + in aux n xs + + +propSums :: Bool +propSums = + let n = 1000 + xs = [0::Double ..] + naive = sums n xs + rec = drop (n-1) $ sumsRec n xs + pyramid = sumsPyramid n xs + in and $ take 1000 $ + zipWith3 (\x y z -> x==y && y==z) naive rec pyramid + +-} + + + +{- * Filter operators from calculus -} + +{- | +Forward difference quotient. +Shortens the signal by one. +Inverts 'Synthesizer.Plain.Filter.Recursive.Integration.run' in the sense that +@differentiate (zero : integrate x) == x@. +The signal is shifted by a half time unit. +-} +{-# INLINE differentiate #-} +differentiate :: Additive.C v => Sig.T v -> Sig.T v +differentiate x = Sig.zapWith subtract x + +{- | +Central difference quotient. +Shortens the signal by two elements, +and shifts the signal by one element. +(Which can be fixed by prepending an appropriate value.) +For linear functions this will yield +essentially the same result as 'differentiate'. +You obtain the result of 'differentiateCenter' +if you smooth the one of 'differentiate' +by averaging pairs of adjacent values. + +ToDo: Vector variant +-} +{-# INLINE differentiateCenter #-} +differentiateCenter :: Field.C v => Sig.T v -> Sig.T v +differentiateCenter = + Sig.zapWith (\(x0,_) (_,x1) -> (x1 - x0) * (1/2)) . + Sig.zapWith (,) +{- +differentiateCenter :: Field.C v => Sig.T v -> Sig.T v +differentiateCenter x = + Sig.map ((1/2)*) $ + Sig.zipWith subtract x (Sig.tail (Sig.tail x)) +-} + +{- | +Second derivative. +It is @differentiate2 == differentiate . differentiate@ +but 'differentiate2' should be faster. +-} +{-# INLINE differentiate2 #-} +differentiate2 :: Additive.C v => Sig.T v -> Sig.T v +differentiate2 = differentiate . differentiate +{- +differentiate2 :: Additive.C v => Sig.T v -> Sig.T v +differentiate2 xs0 = + let xs1 = Sig.tail xs0 + xs2 = Sig.tail xs1 + in Sig.zipWith3 (\x0 x1 x2 -> x0+x2-(x1+x1)) xs0 xs1 xs2 +-} diff --git a/src/Synthesizer/FusionList/Oscillator.hs b/src/Synthesizer/FusionList/Oscillator.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/FusionList/Oscillator.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{- | +Copyright : (c) Henning Thielemann 2006 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +Tone generators +-} +module Synthesizer.FusionList.Oscillator where + +import qualified Synthesizer.Basic.Wave as Wave +import qualified Synthesizer.Basic.Phase as Phase + +import qualified Synthesizer.FusionList.Signal as Sig + +-- import qualified Synthesizer.FusionList.Interpolation as Interpolation + +{- +import qualified Algebra.RealTranscendental as RealTrans +import qualified Algebra.Module as Module +import qualified Algebra.VectorSpace as VectorSpace + +import Algebra.Module((*>)) +-} +import qualified Algebra.Transcendental as Trans +import qualified Algebra.RealField as RealField +-- import qualified Algebra.Field as Field +-- import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import NumericPrelude + +import qualified Prelude as P +import PreludeBase + + + +{- * Oscillators with arbitrary but constant waveforms -} + +{-# INLINE freqToPhase #-} +{- | Convert a list of phase steps into a list of momentum phases + phase is a number in the interval [0,1) + freq contains the phase steps -} +freqToPhase :: RealField.C a => Phase.T a -> Sig.T a -> Sig.T (Phase.T a) +freqToPhase phase freq = Sig.scanL (flip Phase.increment) phase freq + + +{- Inlining blocks fusion of map and iterate - on the other hand it enables fusion in the main program -} +{-# INLINE static #-} +{- | oscillator with constant frequency -} +static :: (RealField.C a) => Wave.T a b -> (Phase.T a -> a -> Sig.T b) +static wave phase freq = + Sig.map (Wave.apply wave) (Sig.iterate (Phase.increment freq) phase) + +{-# INLINE phaseMod #-} +{- | oscillator with modulated phase -} +phaseMod :: (RealField.C a) => Wave.T a b -> a -> Sig.T a -> Sig.T b +phaseMod wave = shapeMod (Wave.phaseOffset wave) zero + +{-# INLINE shapeMod #-} +{- | oscillator with modulated shape -} +shapeMod :: (RealField.C a) => + (c -> Wave.T a b) -> Phase.T a -> a -> Sig.T c -> Sig.T b +shapeMod wave phase freq parameters = + Sig.zipWith (Wave.apply . wave) parameters (Sig.iterate (Phase.increment freq) phase) + +{-# INLINE freqMod #-} +{- | oscillator with modulated frequency -} +freqMod :: (RealField.C a) => Wave.T a b -> Phase.T a -> Sig.T a -> Sig.T b +freqMod wave phase freqs = + Sig.map (Wave.apply wave) (freqToPhase phase freqs) + +{-# INLINE phaseFreqMod #-} +{- | oscillator with both phase and frequency modulation -} +phaseFreqMod :: (RealField.C a) => + Wave.T a b -> Sig.T a -> Sig.T a -> Sig.T b +phaseFreqMod wave = shapeFreqMod (Wave.phaseOffset wave) zero + +{-# INLINE shapeFreqMod #-} +{- | oscillator with both shape and frequency modulation -} +shapeFreqMod :: (RealField.C a) => + (c -> Wave.T a b) -> Phase.T a -> Sig.T c -> Sig.T a -> Sig.T b +shapeFreqMod wave phase parameters freqs = + Sig.zipWith (Wave.apply . wave) parameters (freqToPhase phase freqs) + +{- +{- | oscillator with a sampled waveform with constant frequency + This essentially an interpolation with cyclic padding. -} +{-# INLINE staticSample #-} +staticSample :: RealField.C a => + Interpolation.T a b -> Sig.T b -> Phase.T a -> a -> Sig.T b +staticSample ip wave phase freq = + freqModSample ip wave phase (Sig.repeat freq) + +{- | oscillator with a sampled waveform with modulated frequency + Should behave homogenously for different types of interpolation. -} +{-# INLINE freqModSample #-} +freqModSample :: RealField.C a => + Interpolation.T a b -> Sig.T b -> Phase.T a -> Sig.T a -> Sig.T b +freqModSample ip wave phase freqs = + let len = Sig.length wave + in Interpolation.multiRelativeCyclicPad + ip (fromIntegral len * Phase.toRepresentative phase) + (Sig.map (* fromIntegral len) freqs) wave +-} + + + +{- * Oscillators with specific waveforms -} + +{-# INLINE staticSine #-} +{- | sine oscillator with static frequency -} +staticSine :: (Trans.C a, RealField.C a) => Phase.T a -> a -> Sig.T a +staticSine = static Wave.sine + +{-# INLINE freqModSine #-} +{- | sine oscillator with modulated frequency -} +freqModSine :: (Trans.C a, RealField.C a) => Phase.T a -> Sig.T a -> Sig.T a +freqModSine = freqMod Wave.sine + +{-# INLINE phaseModSine #-} +{- | sine oscillator with modulated phase, useful for FM synthesis -} +phaseModSine :: (Trans.C a, RealField.C a) => a -> Sig.T a -> Sig.T a +phaseModSine = phaseMod Wave.sine + +{-# INLINE staticSaw #-} +{- | saw tooth oscillator with modulated frequency -} +staticSaw :: RealField.C a => Phase.T a -> a -> Sig.T a +staticSaw = static Wave.saw + +{-# INLINE freqModSaw #-} +{- | saw tooth oscillator with modulated frequency -} +freqModSaw :: RealField.C a => Phase.T a -> Sig.T a -> Sig.T a +freqModSaw = freqMod Wave.saw diff --git a/src/Synthesizer/FusionList/Signal.hs b/src/Synthesizer/FusionList/Signal.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/FusionList/Signal.hs @@ -0,0 +1,716 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fglasgow-exts #-} +{- glasgow-exts are for the rules -} +module Synthesizer.FusionList.Signal where + +import qualified Synthesizer.Plain.Signal as Sig +import qualified Synthesizer.Plain.Modifier as Modifier +import qualified Data.List as List + +import qualified Data.StorableVector.Lazy as Vector +import Data.StorableVector.Lazy (ChunkSize, Vector) +import Foreign.Storable (Storable, ) + +import qualified Algebra.Module as Module +import qualified Algebra.Additive as Additive +import Algebra.Additive (zero) + +import Algebra.Module ((*>)) + +import qualified Synthesizer.Format as Format + +import Control.Monad.Trans.State (runState, ) + +import Data.Monoid (Monoid, mempty, mappend, ) + +import qualified Data.List.HT as ListHT +import Data.Tuple.HT (mapFst, mapSnd, mapPair, fst3, snd3, thd3, ) + +import Data.Maybe.HT (toMaybe) +import NumericPrelude (fromInteger, ) + +import Text.Show (Show(showsPrec), showParen, showString, ) +import Data.Maybe (Maybe(Just, Nothing), maybe) +import Prelude + ((.), ($), id, const, flip, curry, uncurry, fst, snd, error, + (>), (>=), max, Ord, + succ, pred, Bool, not, Int, Functor, fmap, + (>>), (>>=), fail, return, (=<<), +-- fromInteger, + ) +-- import qualified Prelude as P +{- +import Prelude hiding + ((++), iterate, foldl, map, repeat, replicate, + zipWith, zipWith3, take, takeWhile) +-} + + +newtype T y = Cons {decons :: [y]} + +instance (Show y) => Show (T y) where + showsPrec p x = + showParen (p >= 10) + (showString "FusionList.fromList " . showsPrec 11 (toList x)) + +instance Format.C T where + format = showsPrec + +instance Functor T where + fmap = map + +instance Monoid (T y) where + mempty = empty + mappend = append + + +{- * functions based on 'generate' -} + +{-# NOINLINE [0] generate #-} +generate :: (acc -> Maybe (y, acc)) -> acc -> T y +generate f = Cons . snd . Sig.unfoldR f + +{-# INLINE unfoldR #-} +unfoldR :: (acc -> Maybe (y, acc)) -> acc -> T y +unfoldR = generate + +{-# INLINE generateInfinite #-} +generateInfinite :: (acc -> (y, acc)) -> acc -> T y +generateInfinite f = generate (Just . f) + +{-# INLINE fromList #-} +fromList :: [y] -> T y +fromList = generate ListHT.viewL + +{-# INLINE toList #-} +toList :: T y -> [y] +toList = decons + + +toStorableSignal :: Storable y => ChunkSize -> T y -> Vector y +toStorableSignal size = Vector.pack size . decons + +fromStorableSignal :: Storable y => Vector y -> T y +fromStorableSignal = Cons . Vector.unpack + + +{-# INLINE iterate #-} +iterate :: (a -> a) -> a -> T a +iterate f = generateInfinite (\x -> (x, f x)) + +{-# INLINE iterateAssociative #-} +iterateAssociative :: (a -> a -> a) -> a -> T a +iterateAssociative op x = iterate (op x) x -- should be optimized + +{-# INLINE repeat #-} +repeat :: a -> T a +repeat = iterate id + + +{- * functions based on 'crochetL' -} + +{-# NOINLINE [0] crochetL #-} +crochetL :: (x -> acc -> Maybe (y, acc)) -> acc -> T x -> T y +crochetL f a = Cons . Sig.crochetL f a . decons + +{-# INLINE scanL #-} +scanL :: (acc -> x -> acc) -> acc -> T x -> T acc +{- +scanL f start xs = + cons start + (crochetL (\x acc -> let y = f acc x in Just (y, y)) start xs) +-} +scanL f start = + cons start . + crochetL (\x acc -> let y = f acc x in Just (y, y)) start + +-- | input and output have equal length, that's better for fusion +scanLClip :: (acc -> x -> acc) -> acc -> T x -> T acc +scanLClip f start = + crochetL (\x acc -> Just (acc, f acc x)) start + +{-# INLINE map #-} +map :: (a -> b) -> (T a -> T b) +map f = crochetL (\x _ -> Just (f x, ())) () + +{-# RULEZ + "FusionList.map-crochetL" forall f. + map f = crochetL (\x _ -> Just (f x, ())) () ; + + "FusionList.repeat-iterate" + repeat = iterate id ; + + "FusionList.iterate-generate" forall f. + iterate f = generate (\x -> Just (x, f x)) ; + + "FusionList.take-crochetL" + take = crochetL (\x n -> toMaybe (n>zero) (x, pred n)) ; + + "FusionList.unfold-dollar" forall f x. + f $ x = f x ; + + "FusionList.unfold-dot" forall f g. + f . g = \x -> f (g x) ; + #-} + +{-# INLINE unzip #-} +unzip :: T (a,b) -> (T a, T b) +unzip x = (map fst x, map snd x) + +{-# INLINE unzip3 #-} +unzip3 :: T (a,b,c) -> (T a, T b, T c) +unzip3 xs = (map fst3 xs, map snd3 xs, map thd3 xs) + + +{-# INLINE delay1 #-} +{- | +This is a fusion friendly implementation of delay. +However, in order to be a 'crochetL' +the output has the same length as the input, +that is, the last element is removed - at least for finite input. +-} +delay1 :: a -> T a -> T a +delay1 = crochetL (flip (curry Just)) + +{-# INLINE delay #-} +delay :: y -> Int -> T y -> T y +delay z n = append (replicate n z) + + +{-# INLINE take #-} +take :: Int -> T a -> T a +take = crochetL (\x n -> toMaybe (n>zero) (x, pred n)) + +{-# INLINE takeWhile #-} +takeWhile :: (a -> Bool) -> T a -> T a +takeWhile p = crochetL (\x _ -> toMaybe (p x) (x, ())) () + +{-# INLINE replicate #-} +replicate :: Int -> a -> T a +replicate n = take n . repeat + +{-# RULES + "FusionList.map/repeat" forall f x. + map f (repeat x) = repeat (f x) ; + + "FusionList.map/replicate" forall f n x. + map f (replicate n x) = replicate n (f x) ; + + "FusionList.map/cons" forall f x xs. + map f (cons x xs) = cons (f x) (map f xs) ; + + "FusionList.map/append" forall f xs ys. + map f (append xs ys) = append (map f xs) (map f ys) ; + + {- should be subsumed by the map/cons rule, + but it doesn't fire sometimes + "FusionList.map/cons/compose" forall f g x xs. + map f ((cons x . g) xs) = cons (f x) (map f (g xs)) ; + -} + + {- this does not fire, since 'map' is inlined, crochetL/cons should fire instead -} + "FusionList.map/scanL" forall f g x0 xs. + map g (scanL f x0 xs) = + cons (g x0) + (crochetL (\x acc -> let y = f acc x in Just (g y, y)) x0 xs) ; + + "FusionList.map/zipWith" forall f g x y. + map f (zipWith g x y) = + zipWith (\xi yi -> f (g xi yi)) x y ; + + "FusionList.zipWith/map,*" forall f g x y. + zipWith g (map f x) y = + zipWith (\xi yi -> g (f xi) yi) x y ; + + "FusionList.zipWith/*,map" forall f g x y. + zipWith g x (map f y) = + zipWith (\xi yi -> g xi (f yi)) x y ; + #-} + +{- * functions consuming multiple lists -} + +{-# NOINLINE [0] zipWith #-} +zipWith :: (a -> b -> c) -> (T a -> T b -> T c) +zipWith f s0 s1 = + Cons $ List.zipWith f (decons s0) (decons s1) + +{-# INLINE zipWith3 #-} +zipWith3 :: (a -> b -> c -> d) -> (T a -> T b -> T c -> T d) +zipWith3 f s0 s1 = + zipWith (uncurry f) (zip s0 s1) + +{-# INLINE zipWith4 #-} +zipWith4 :: (a -> b -> c -> d -> e) -> (T a -> T b -> T c -> T d -> T e) +zipWith4 f s0 s1 = + zipWith3 (uncurry f) (zip s0 s1) + + +{-# INLINE zip #-} +zip :: T a -> T b -> T (a,b) +zip = zipWith (,) + +{-# INLINE zip3 #-} +zip3 :: T a -> T b -> T c -> T (a,b,c) +zip3 = zipWith3 (,,) + +{-# INLINE zip4 #-} +zip4 :: T a -> T b -> T c -> T d -> T (a,b,c,d) +zip4 = zipWith4 (,,,) + + +{- * functions based on 'reduceL' -} + +reduceL :: (x -> acc -> Maybe acc) -> acc -> T x -> acc +reduceL f x = Sig.reduceL f x . decons + +{-# INLINE foldL' #-} +foldL' :: (x -> acc -> acc) -> acc -> T x -> acc +foldL' f = reduceL (\x -> Just . f x) + +{-# INLINE foldL #-} +foldL :: (acc -> x -> acc) -> acc -> T x -> acc +foldL f = foldL' (flip f) + +{-# INLINE lengthSlow #-} +{- | can be used to check against native length implementation -} +lengthSlow :: T a -> Int +lengthSlow = foldL' (const succ) zero + + +{- +Do we still need rules for fusion of + map f (repeat x) + zipWith f (repeat x) ys +? +-} + +{- * Fusion helpers -} + +{-# INLINE zipWithGenerate #-} +zipWithGenerate :: + (a -> b -> c) + -> (acc -> Maybe (a, acc)) + -> acc + -> T b -> T c +zipWithGenerate h f a y = + crochetL (\y0 a0 -> + do (x0,a1) <- f a0 + Just (h x0 y0, a1)) a y + +{-# INLINE zipWithCrochetL #-} +zipWithCrochetL :: + (a -> b -> c) + -> (x -> acc -> Maybe (a, acc)) + -> acc + -> T x -> T b -> T c +zipWithCrochetL h f a x y = + crochetL (\(x0,y0) a0 -> + do (z0,a1) <- f x0 a0 + Just (h z0 y0, a1)) + a (zip x y) + +{-# INLINE mixGenerate #-} +mixGenerate :: (Additive.C a) => + (a -> a -> a) + -> (acc -> Maybe (a, acc)) + -> acc + -> T a -> T a +mixGenerate plus f a = + crochetL + (\y0 a0 -> + Just (maybe + (y0, Nothing) + (\(x0,a1) -> (plus x0 y0, Just a1)) + (f =<< a0))) + (Just a) + +{-# INLINE crochetLCons #-} +crochetLCons :: + (a -> acc -> Maybe (b, acc)) + -> acc + -> a -> T a -> T b +crochetLCons f a0 x xs = + maybe + empty + (\(y,a1) -> cons y (crochetL f a1 xs)) + (f x a0) + +{- +{-# INLINE crochetLAppend #-} +crochetLAppend :: + (a -> acc -> Maybe (b, acc)) + -> acc + -> a -> T a -> T a -> T b +crochetLAppend f a0 x xs ys = + maybe + empty + (\(y,a1) -> cons y (crochetL f a1 xs)) + (f x a0) +-} + +{-# INLINE reduceLCons #-} +reduceLCons :: + (a -> acc -> Maybe acc) + -> acc + -> a -> T a -> acc +reduceLCons f a0 x xs = + maybe a0 (flip (reduceL f) xs) (f x a0) + + +{- +applyThroughCons :: + (a -> Maybe (b,acc)) -> (T a -> acc -> T b) -> T a -> T b +applyThroughCons f g = + maybe empty + (\(x,xs) -> cons (f x) (g xs)) . viewL +-} + +{-# INLINE zipWithCons #-} +zipWithCons :: + (a -> b -> c) + -> a -> T a -> T b -> T c +zipWithCons f x xs = + maybe + empty + (\(y,ys) -> cons (f x y) (zipWith f xs ys)) + . viewL + + +{-# RULES + "FusionList.crochetL/generate" forall f g a b. + crochetL g b (generate f a) = + generate (\(a0,b0) -> + do (y0,a1) <- f a0 + (z0,b1) <- g y0 b0 + Just (z0, (a1,b1))) (a,b) ; + + "FusionList.crochetL/crochetL" forall f g a b x. + crochetL g b (crochetL f a x) = + crochetL (\x0 (a0,b0) -> + do (y0,a1) <- f x0 a0 + (z0,b1) <- g y0 b0 + Just (z0, (a1,b1))) (a,b) x ; + + "FusionList.crochetL/cons" forall g b x xs. + crochetL g b (cons x xs) = + crochetLCons g b x xs ; + + + "FusionList.tail/generate" forall f a. + tail (generate f a) = + maybe (error "FusionList.tail: empty list") + (generate f . snd) (f a) ; + + "FusionList.tail/cons" forall x xs. + tail (cons x xs) = xs ; + + "FusionList.zipWith/generate,*" forall f h a y. + zipWith h (generate f a) y = + zipWithGenerate h f a y ; + + "FusionList.zipWith/crochetL,*" forall f h a x y. + zipWith h (crochetL f a x) y = + zipWithCrochetL h f a x y ; + + "FusionList.zipWith/*,generate" forall f h a y. + zipWith h y (generate f a) = + zipWithGenerate (flip h) f a y ; + + "FusionList.zipWith/*,crochetL" forall f h a x y. + zipWith h y (crochetL f a x) = + zipWithCrochetL (flip h) f a x y ; + + "FusionList.mix/generate,*" forall f a y. + mix (generate f a) y = + mixGenerate (Additive.+) f a y ; + + "FusionList.mix/*,generate" forall f a y. + mix y (generate f a) = + mixGenerate (flip (Additive.+)) f a y ; + + +{- this blocks further fusion and + is not necessary if the non-cons operand is a 'generate' + "FusionList.zipWith/cons,*" forall h x xs ys. + zipWith h (cons x xs) ys = + zipWithCons h x xs ys ; + + "FusionList.zipWith/*,cons" forall h x xs ys. + zipWith h ys (cons x xs) = + zipWithCons (flip h) x xs ys ; +-} + + "FusionList.zipWith/cons,cons" forall h x xs y ys. + zipWith h (cons x xs) (cons y ys) = + cons (h x y) (zipWith h xs ys) ; + + "FusionList.zipWith/share" forall (h :: a->a->b) (x :: T a). + zipWith h x x = map (\xi -> h xi xi) x ; + + + + "FusionList.reduceL/generate" forall f g a b. + reduceL g b (generate f a) = + snd + (recourse (\(a0,b0) -> + do (y,a1) <- f a0 + b1 <- g y b0 + Just (a1, b1)) (a,b)) ; + + "FusionList.reduceL/crochetL" forall f g a b x. + reduceL g b (crochetL f a x) = + snd + (reduceL (\x0 (a0,b0) -> + do (y,a1) <- f x0 a0 + b1 <- g y b0 + Just (a1, b1)) (a,b) x) ; + + "FusionList.reduceL/cons" forall g b x xs. + reduceL g b (cons x xs) = + reduceLCons g b x xs ; + + + "FusionList.viewL/cons" forall x xs. + viewL (cons x xs) = Just (x,xs) ; + + "FusionList.viewL/generateInfinite" forall f x. + viewL (generateInfinite f x) = + Just (mapSnd (generateInfinite f) (f x)) ; + + "FusionList.viewL/generate" forall f x. + viewL (generate f x) = + fmap (mapSnd (generate f)) (f x) ; + + "FusionList.viewL/crochetL" forall f a xt. + viewL (crochetL f a xt) = + do (x,xs) <- viewL xt + (y,a') <- f x a + return (y, crochetL f a' xs) ; + #-} + + +{- * Other functions -} + +null :: T a -> Bool +null = List.null . decons + +empty :: T a +empty = Cons [] + +singleton :: a -> T a +singleton = Cons . (: []) + +{-# NOINLINE [0] cons #-} +cons :: a -> T a -> T a +cons x = Cons . (x :) . decons + +length :: T a -> Int +length = List.length . decons + +viewL :: T a -> Maybe (a, T a) +viewL = + fmap (mapSnd Cons) . ListHT.viewL . decons + +viewR :: T a -> Maybe (T a, a) +viewR = + fmap (mapFst Cons) . ListHT.viewR . decons + +extendConstant :: T a -> T a +extendConstant xt = + maybe empty (append xt . repeat . snd) $ + viewR xt + +{-# NOINLINE [0] tail #-} +tail :: T a -> T a +tail = Cons . List.tail . decons + +head :: T a -> a +head = List.head . decons + +drop :: Int -> T a -> T a +drop n = Cons . List.drop n . decons + +dropMarginRem :: Int -> Int -> T a -> (Int, T a) +dropMarginRem n m = mapSnd Cons . Sig.dropMarginRem n m . decons + +{- +This implementation does only walk once through the dropped prefix. +It is maximally lazy and minimally space consuming. +-} +dropMargin :: Int -> Int -> T a -> T a +dropMargin n m = Cons . Sig.dropMargin n m . decons + + +index :: Int -> T a -> a +index n = (List.!! n) . decons + + +splitAt :: Int -> T a -> (T a, T a) +splitAt n = mapPair (Cons, Cons) . List.splitAt n . decons + +dropWhile :: (a -> Bool) -> T a -> T a +dropWhile p = Cons . List.dropWhile p . decons + +span :: (a -> Bool) -> T a -> (T a, T a) +span p = mapPair (Cons, Cons) . List.span p . decons + +mapAccumL :: (acc -> x -> (acc, y)) -> acc -> T x -> (acc, T y) +mapAccumL f acc = mapSnd Cons . List.mapAccumL f acc . decons + +mapAccumR :: (acc -> x -> (acc, y)) -> acc -> T x -> (acc, T y) +mapAccumR f acc = mapSnd Cons . List.mapAccumR f acc . decons + + +cycle :: T a -> T a +cycle = Cons . List.cycle . decons + +{-# NOINLINE [0] mix #-} +mix :: Additive.C a => T a -> T a -> T a +mix (Cons xs) (Cons ys) = Cons (xs Additive.+ ys) + +{-# NOINLINE [0] sub #-} +sub :: Additive.C a => T a -> T a -> T a +sub (Cons xs) (Cons ys) = Cons (xs Additive.- ys) + +{-# NOINLINE [0] neg #-} +neg :: Additive.C a => T a -> T a +neg (Cons xs) = Cons (Additive.negate xs) + +instance Additive.C y => Additive.C (T y) where + zero = empty + (+) = mix + (-) = sub + negate = neg + +instance Module.C y yv => Module.C y (T yv) where + (*>) x y = map (x*>) y + + +infixr 5 `append` + +{-# NOINLINE [0] append #-} +append :: T a -> T a -> T a +append (Cons xs) (Cons ys) = Cons (xs List.++ ys) + +concat :: [T a] -> T a +concat = Cons . List.concat . List.map decons + +reverse :: T a -> T a +reverse = Cons . List.reverse . decons + + + +sum :: (Additive.C a) => T a -> a +sum = foldL' (Additive.+) Additive.zero + +maximum :: (Ord a) => T a -> a +maximum = + maybe + (error "FusionList.maximum: empty list") + (uncurry (foldL' max)) + . viewL + +tails :: T y -> [T y] +tails = List.map Cons . List.tails . decons + +init :: T y -> T y +init = Cons . List.init . decons + +sliceVert :: Int -> T y -> [T y] +sliceVert n = + List.map (take n) . List.takeWhile (not . null) . List.iterate (drop n) + + +zapWith :: (a -> a -> b) -> T a -> T b +zapWith f xs0 = + let xs1 = maybe empty snd (viewL xs0) + in zipWith f xs0 xs1 + +modifyStatic :: Modifier.Simple s ctrl a b -> ctrl -> T a -> T b +modifyStatic modif control x = + crochetL + (\a acc -> + Just (runState (Modifier.step modif control a) acc)) + (Modifier.init modif) x + +{-| Here the control may vary over the time. -} +modifyModulated :: Modifier.Simple s ctrl a b -> T ctrl -> T a -> T b +modifyModulated modif control x = + crochetL + (\ca acc -> + Just (runState (uncurry (Modifier.step modif) ca) acc)) + (Modifier.init modif) + (zip control x) + + +-- cf. Module.linearComb +linearComb :: + (Module.C t y) => + T t -> T y -> y +linearComb ts ys = + sum $ zipWith (*>) ts ys + + +-- comonadic 'bind' +-- only non-empty suffixes are processed +mapTails :: + (T y0 -> y1) -> T y0 -> T y1 +mapTails f = + generate (\xs -> + do (_,ys) <- viewL xs + return (f xs, ys)) + +-- only non-empty suffixes are processed +zipWithTails :: + (y0 -> T y1 -> y2) -> T y0 -> T y1 -> T y2 +zipWithTails f = + curry $ generate (\(xs0,ys0) -> + do (x,xs) <- viewL xs0 + (_,ys) <- viewL ys0 + return (f x ys0, (xs,ys))) + +zipWithRest :: + (y0 -> y0 -> y1) -> + T y0 -> T y0 -> + (T y1, (Bool, T y0)) +zipWithRest f xs ys = + mapPair (fromList, mapSnd fromList) $ + Sig.zipWithRest f + (toList xs) (toList ys) + +zipWithAppend :: + (y -> y -> y) -> + T y -> T y -> T y +zipWithAppend f xs ys = + uncurry append $ mapSnd snd $ zipWithRest f xs ys + +delayLoop :: + (T y -> T y) + -- ^ processor that shall be run in a feedback loop + -> T y -- ^ prefix of the output, its length determines the delay + -> T y +delayLoop proc prefix = + let ys = append prefix (proc ys) + in ys + +delayLoopOverlap :: + (Additive.C y) => + Int + -> (T y -> T y) + -- ^ processor that shall be run in a feedback loop + -> T y -- ^ input + -> T y -- ^ output has the same length as the input +delayLoopOverlap time proc xs = + let ys = zipWith (Additive.+) xs (delay zero time (proc ys)) + in ys + + +-- maybe candidate for Utility + +recourse :: (acc -> Maybe acc) -> acc -> acc +recourse f = + let aux x = maybe x aux (f x) + in aux + diff --git a/src/Synthesizer/Generic/Analysis.hs b/src/Synthesizer/Generic/Analysis.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Generic/Analysis.hs @@ -0,0 +1,326 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +module Synthesizer.Generic.Analysis where + +import qualified Synthesizer.State.Analysis as Ana + +import qualified Synthesizer.Generic.Signal as SigG +import qualified Synthesizer.Generic.Signal2 as SigG2 + +-- import qualified Synthesizer.Plain.Control as Ctrl + +-- import qualified Algebra.Module as Module +-- import qualified Algebra.Transcendental as Trans +import qualified Algebra.Algebraic as Algebraic +-- import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Real as Real +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import qualified Algebra.NormedSpace.Maximum as NormedMax +import qualified Algebra.NormedSpace.Euclidean as NormedEuc +import qualified Algebra.NormedSpace.Sum as NormedSum + +-- import qualified Data.Array as Array + +-- import qualified Data.IntMap as IntMap + +-- import Algebra.Module((*>)) + +-- import Data.Array (accumArray) + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +{- * Notions of volume -} + +{- | +Volume based on Manhattan norm. +-} +volumeMaximum :: (Real.C y, SigG.Read sig y) => sig y -> y +volumeMaximum = + Ana.volumeMaximum . SigG.toState + +{- | +Volume based on Energy norm. +-} +volumeEuclidean :: (Algebraic.C y, SigG.Read sig y) => sig y -> y +volumeEuclidean = + Ana.volumeEuclidean . SigG.toState + +volumeEuclideanSqr :: (Field.C y, SigG.Read sig y) => sig y -> y +volumeEuclideanSqr = + Ana.volumeEuclideanSqr . SigG.toState + +{- | +Volume based on Sum norm. +-} +volumeSum :: (Field.C y, Real.C y, SigG.Read sig y) => sig y -> y +volumeSum = + Ana.volumeSum . SigG.toState + + + +{- | +Volume based on Manhattan norm. +-} +volumeVectorMaximum :: + (NormedMax.C y yv, Ord y, SigG.Read sig yv) => + sig yv -> y +volumeVectorMaximum = + Ana.volumeVectorMaximum . SigG.toState + +{- | +Volume based on Energy norm. +-} +volumeVectorEuclidean :: + (Algebraic.C y, NormedEuc.C y yv, SigG.Read sig yv) => + sig yv -> y +volumeVectorEuclidean = + Ana.volumeVectorEuclidean . SigG.toState + +volumeVectorEuclideanSqr :: + (Field.C y, NormedEuc.Sqr y yv, SigG.Read sig yv) => + sig yv -> y +volumeVectorEuclideanSqr = + Ana.volumeVectorEuclideanSqr . SigG.toState + +{- | +Volume based on Sum norm. +-} +volumeVectorSum :: + (NormedSum.C y yv, Field.C y, SigG.Read sig yv) => + sig yv -> y +volumeVectorSum = + Ana.volumeVectorSum . SigG.toState + + + + +{- | +Compute minimum and maximum value of the stream the efficient way. +Input list must be non-empty and finite. +-} +bounds :: (Ord y, SigG.Read sig y) => sig y -> (y,y) +bounds = + Ana.bounds . SigG.toState + + + + +{- * Miscellaneous -} + +{- +histogram: + length x = sum (histogramDiscrete x) + + units: + 1) histogram (amplify k x) = timestretch k (amplify (1/k) (histogram x)) + 2) histogram (timestretch k x) = amplify k (histogram x) + timestretch: k -> (s -> V) -> (k*s -> V) + amplify: k -> (s -> V) -> (s -> k*V) + histogram: (a -> b) -> (a^ia*b^ib -> a^ja*b^jb) + x: (s -> V) + 1) => (s^ia*(k*V)^ib -> s^ja*(k*V)^jb) + = (s^ia*V^ib*k -> s^ja*V^jb/k) + => ib=1, jb=-1 + 2) => ((k*s)^ia*V^ib -> (k*s)^ja*V^jb) + = (s^ia*V^ib -> s^ja*V^jb*k) + => ia=0, ja=1 + histogram: (s -> V) -> (V -> s/V) +histogram': + integral (histogram' x) = integral x + histogram' (amplify k x) = timestretch k (histogram' x) + histogram' (timestretch k x) = amplify k (histogram' x) + -> this does only apply if we slice the area horizontally + and sum the slice up at each level, + we must also restrict to the positive values, + this is not quite the usual histogram +-} + +{- +{- | +Input list must be finite. +List is scanned twice, but counting may be faster. +-} +histogramDiscreteArray :: sig Int -> (Int, sig Int) +histogramDiscreteArray [] = + (error "histogramDiscreteArray: no bounds found", []) +histogramDiscreteArray x = + let hist = + accumArray (+) zero + (bounds x) (attachOne x) + in (fst (Array.bounds hist), Array.elems hist) + + +{- | +Input list must be finite. +If the input signal is empty, the offset is @undefined@. +List is scanned twice, but counting may be faster. +The sum of all histogram values is one less than the length of the signal. +-} +histogramLinearArray :: RealField.C y => sig y -> (Int, sig y) +histogramLinearArray [] = + (error "histogramLinearArray: no bounds found", []) +histogramLinearArray [x] = (floor x, []) +histogramLinearArray x = + let (xMin,xMax) = bounds x + hist = + accumArray (+) zero + (floor xMin, floor xMax) + (meanValues x) + in (fst (Array.bounds hist), Array.elems hist) + +{- | +Input list must be finite. +If the input signal is empty, the offset is @undefined@. +List is scanned once, counting may be slower. +-} +histogramDiscreteIntMap :: sig Int -> (Int, sig Int) +histogramDiscreteIntMap [] = + (error "histogramDiscreteIntMap: no bounds found", []) +histogramDiscreteIntMap x = + let hist = IntMap.fromListWith (+) (attachOne x) + in case IntMap.toAscList hist of + [] -> error "histogramDiscreteIntMap: the list was non-empty before processing ..." + fAll@((fIndex,fHead):fs) -> (fIndex, fHead : + concat (zipWith + (\(i0,_) (i1,f1) -> replicate (i1-i0-1) zero ++ [f1]) + fAll fs)) + +histogramLinearIntMap :: RealField.C y => sig y -> (Int, sig y) +histogramLinearIntMap [] = + (error "histogramLinearIntMap: no bounds found", []) +histogramLinearIntMap [x] = (floor x, []) +histogramLinearIntMap x = + let hist = IntMap.fromListWith (+) (meanValues x) + -- we can rely on the fact that the keys are contiguous + (startKey:_, elems) = unzip (IntMap.toAscList hist) + in (startKey, elems) + -- This doesn't work, due to a bug in IntMap of GHC-6.4.1 + -- in (head (IntMap.keys hist), IntMap.elems hist) +-} + +{- +The bug in IntMap GHC-6.4.1 is: + +*Synthesizer.Plain.Analysis> IntMap.keys $ IntMap.fromList $ [(0,0),(-1,-1::Int)] +[0,-1] +*Synthesizer.Plain.Analysis> IntMap.elems $ IntMap.fromList $ [(0,0),(-1,-1::Int)] +[0,-1] +*Synthesizer.Plain.Analysis> IntMap.assocs $ IntMap.fromList $ [(0,0),(-1,-1::Int)] +[(0,0),(-1,-1)] + +The bug has gone in IntMap as shipped with GHC-6.6. +-} + +{- +histogramIntMap :: (RealField.C y, SigG.Read sig y) => + y -> sig y -> (Int, sig Int) +histogramIntMap binsPerUnit = + histogramDiscreteIntMap . quantize binsPerUnit + +quantize :: (RealField.C y, SigG.Transform sig y) => + y -> sig y -> sig Int +quantize binsPerUnit = SigG.map (floor . (binsPerUnit*)) + +attachOne :: (Sample.C i) => sig i -> sig (i,Int) +attachOne = SigG.map (\i -> (i,one)) + +meanValues :: + (RealField.C y, SigG.Read sig y) => sig y -> [(Int,y)] +meanValues x = concatMap spread (zip x (tail x)) + +spread :: + (RealField.C y, SigG.Read sig y) => (y,y) -> [(Int,y)] +spread (l0,r0) = + let (l,r) = if l0<=r0 then (l0,r0) else (r0,l0) + (li,lf) = splitFraction l + (ri,rf) = splitFraction r + k = recip (r-l) + nodes = + (li,k*(1-lf)) : + zip [li+1 ..] (replicate (ri-li-1) k) ++ + (ri, k*rf) : + [] + in if li==ri + then [(li,one)] + else nodes +-} + +{- | +Requires finite length. +This is identical to the arithmetic mean. +-} +directCurrentOffset :: + (Field.C y, SigG.Read sig y) => sig y -> y +directCurrentOffset = average + + +scalarProduct :: + (Ring.C y, SigG.Read sig y) => sig y -> sig y -> y +scalarProduct xs ys = + Ana.scalarProduct (SigG.toState xs) (SigG.toState ys) + +{- | +'directCurrentOffset' must be non-zero. +-} +centroid :: (Field.C y, SigG.Read sig y) => sig y -> y +centroid = + Ana.centroid . SigG.toState + +average :: (Field.C y, SigG.Read sig y) => sig y -> y +average = + Ana.average . SigG.toState + +rectify :: (Real.C y, SigG.Transform sig y) => sig y -> sig y +rectify = SigG.map abs + +{- | +Detects zeros (sign changes) in a signal. +This can be used as a simple measure of the portion +of high frequencies or noise in the signal. +It ca be used as voiced\/unvoiced detector in a vocoder. + +@zeros x !! n@ is @True@ if and only if +@(x !! n >= 0) \/= (x !! (n+1) >= 0)@. +The result will be one value shorter than the input. +-} +zeros :: (Ord y, Ring.C y, SigG2.Transform sig y Bool) => + sig y -> sig Bool +zeros = + SigG.mapAdjacent (/=) . SigG2.map (>=zero) + + + +{- | +Detect thresholds with a hysteresis. +-} +flipFlopHysteresis :: (Ord y, SigG2.Transform sig y Bool) => + (y,y) -> Bool -> sig y -> sig Bool +flipFlopHysteresis (lower,upper) = + SigG2.scanL + (\state x -> + if state + then not(xupper) + +{- +{- | +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 +-} diff --git a/src/Synthesizer/Generic/Control.hs b/src/Synthesizer/Generic/Control.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Generic/Control.hs @@ -0,0 +1,352 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +module Synthesizer.Generic.Control where + +import qualified Synthesizer.Generic.Signal as SigG +import qualified Synthesizer.Generic.Signal2 as SigG2 + +import Synthesizer.Generic.Displacement (raise) + +import qualified Algebra.Module as Module +import qualified Algebra.Transcendental as Trans +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Algebra.Module((*>)) + +import Number.Complex (cis,real) +import qualified Number.Complex as Complex + +-- import Control.Applicative ((<$>), ) + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +{- * Control curve generation -} + +constant :: (SigG.Write sig y) => + SigG.LazySize -> y -> sig y +constant = SigG.repeat + + +linear :: (Additive.C y, SigG.Write sig y) => + SigG.LazySize + -> y {-^ steepness -} + -> y {-^ initial value -} + -> sig y + {-^ linear progression -} +linear size d y0 = SigG.iterate size (d+) y0 + +{- | +Minimize rounding errors by reducing number of operations per element +to a logarithmuc number. +-} +linearMultiscale :: + (Additive.C y, SigG.Write sig y) => + SigG.LazySize + -> y + -> y + -> sig y +linearMultiscale size = + curveMultiscale size (+) + +{- | +Linear curve starting at zero. +-} +linearMultiscaleNeutral :: (Additive.C y, SigG.Write sig y) => + SigG.LazySize + -> y + -> sig y +linearMultiscaleNeutral size slope = + curveMultiscaleNeutral size (+) slope zero + +{- | +Linear curve of a fixed length. +The final value is not actually reached, +instead we stop one step before. +This way we can concatenate several lines +without duplicate adjacent values. +-} +line :: (Field.C y, SigG.Write sig y) => + SigG.LazySize + -> Int {-^ length -} + -> (y,y) {-^ initial and final value -} + -> sig y + {-^ linear progression -} +line size n (y0,y1) = + SigG.take n $ linear size ((y1-y0) / fromIntegral n) y0 + + +exponential, exponentialMultiscale :: + (Trans.C y, SigG.Write sig y) => + SigG.LazySize + -> y {-^ time where the function reaches 1\/e of the initial value -} + -> y {-^ initial value -} + -> sig y + {-^ exponential decay -} +exponential size time = + SigG.iterate size (* exp (- recip time)) +exponentialMultiscale size time = + curveMultiscale size (*) (exp (- recip time)) + +exponentialMultiscaleNeutral :: (Trans.C y, SigG.Write sig y) => + SigG.LazySize + -> y {-^ time where the function reaches 1\/e of the initial value -} + -> sig y + {-^ exponential decay -} +exponentialMultiscaleNeutral size time = + curveMultiscaleNeutral size (*) (exp (- recip time)) one + +exponential2, exponential2Multiscale :: (Trans.C y, SigG.Write sig y) => + SigG.LazySize + -> y {-^ half life -} + -> y {-^ initial value -} + -> sig y + {-^ exponential decay -} +exponential2 size halfLife = + SigG.iterate size (* 0.5 ** recip halfLife) +exponential2Multiscale size halfLife = + curveMultiscale size (*) (0.5 ** recip halfLife) + +exponential2MultiscaleNeutral :: (Trans.C y, SigG.Write sig y) => + SigG.LazySize + -> y {-^ half life -} + -> sig y + {-^ exponential decay -} +exponential2MultiscaleNeutral size halfLife = + curveMultiscaleNeutral size (*) (0.5 ** recip halfLife) one + + + + +{-| This is an extension of 'exponential' to vectors + which is straight-forward but requires more explicit signatures. + But since it is needed rarely I setup a separate function. -} +vectorExponential :: + (Trans.C y, Module.C y v, SigG.Write sig v) => + SigG.LazySize + -> y {-^ time where the function reaches 1\/e of the initial value -} + -> v {-^ initial value -} + -> sig v + {-^ exponential decay -} +vectorExponential size time y0 = + SigG.iterate size (exp (-1/time) *>) y0 + +vectorExponential2 :: + (Trans.C y, Module.C y v, SigG.Write sig v) => + SigG.LazySize + -> y {-^ half life -} + -> v {-^ initial value -} + -> sig v + {-^ exponential decay -} +vectorExponential2 size halfLife y0 = + SigG.iterate size (0.5**(1/halfLife) *>) y0 + + + +cosine, cosineMultiscaleLinear :: (Trans.C y, SigG.Write sig y) => + SigG.LazySize + -> y {-^ time t0 where 1 is approached -} + -> y {-^ time t1 where -1 is approached -} + -> sig y + {-^ a cosine wave where one half wave is between t0 and t1 -} +cosine size = cosineWithSlope $ + \d x -> SigG.map cos (linear size d x) + +cosineMultiscaleLinear size = cosineWithSlope $ + \d x -> SigG.map cos (linearMultiscale size d x) + +cosineMultiscale :: + (Trans.C y, SigG.Write sig (Complex.T y), + SigG2.Transform sig (Complex.T y) y) => + SigG.LazySize + -> y {-^ time t0 where 1 is approached -} + -> y {-^ time t1 where -1 is approached -} + -> sig y + {-^ a cosine wave where one half wave is between t0 and t1 -} +cosineMultiscale size = cosineWithSlope $ + \d x -> SigG2.map real (curveMultiscale size (*) (cis d) (cis x)) + + +cosineWithSlope :: (Trans.C y) => + (y -> y -> signal) + -> y + -> y + -> signal +cosineWithSlope c t0 t1 = + let inc = pi/(t1-t0) + in c inc (-t0*inc) + + +cubicHermite :: (Field.C y, SigG.Write sig y) => + SigG.LazySize + -> (y, (y,y)) -> (y, (y,y)) -> sig y +cubicHermite size node0 node1 = + SigG.map (cubicFunc node0 node1) $ linear size 1 0 + +{- | +0 16 +0 8 16 +0 4 8 12 16 +0 2 4 6 8 10 12 14 16 +0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 +-} +cubicFunc :: (Field.C y) => + (y, (y,y)) -> (y, (y,y)) -> y -> y +cubicFunc (t0, (y0,dy0)) (t1, (y1,dy1)) t = + let dt = t0-t1 + dt0 = t-t0 + dt1 = t-t1 + x0 = dt1^2 + x1 = dt0^2 + in ((dy0*dt0 + y0 * (1-2/dt*dt0)) * x0 + + (dy1*dt1 + y1 * (1+2/dt*dt1)) * x1) / dt^2 +{- +cubic t0 (y0,dy0) t1 (y1,dy1) t = + let x0 = ((t-t1) / (t0-t1))^2 + x1 = ((t-t0) / (t1-t0))^2 + in y0 * x0 + y1 * x1 + + (dy0 - y0*2/(t0-t1)) * (t-t0)*x0 + + (dy1 - y1*2/(t1-t0)) * (t-t1)*x1 +-} + + + +{- | +The curve type of a piece of a piecewise defined control curve. +-} +data Control y = + CtrlStep + | CtrlLin + | CtrlExp {ctrlExpSaturation :: y} + | CtrlCos + | CtrlCubic {ctrlCubicGradient0 :: y, + ctrlCubicGradient1 :: y} + deriving (Eq, Show) + +{- | +The full description of a control curve piece. +-} +data ControlPiece y = + ControlPiece {pieceType :: Control y, + pieceY0 :: y, + pieceY1 :: y, + pieceDur :: y} + deriving (Eq, Show) + + +newtype PieceRightSingle y = PRS y +newtype PieceRightDouble y = PRD y + +type ControlDist y = (y, Control y, y) + + +-- precedence and associativity like (:) +infixr 5 -|#, #|-, =|#, #|=, |#, #| + +{- | +The 6 operators simplify constructing a list of @ControlPiece a@. +The description consists of nodes (namely the curve values at nodes) +and the connecting curve types. +The naming scheme is as follows: +In the middle there is a bar @|@. +With respect to the bar, +the pad symbol @\#@ is at the side of the curve type, +at the other side there is nothing, a minus sign @-@, or an equality sign @=@. + + (1) Nothing means that here is the start or the end node of a curve. + + (2) Minus means that here is a node where left and right curve meet at the same value. + The node description is thus one value. + + (3) Equality sign means that here is a split node, + where left and right curve might have different ending and beginning values, respectively. + The node description consists of a pair of values. +-} + +-- the leading space is necessary for the Haddock parser + +( #|-) :: (y, Control y) -> (PieceRightSingle y, [ControlPiece y]) -> + (ControlDist y, [ControlPiece y]) +(d,c) #|- (PRS y1, xs) = ((d,c,y1), xs) + +(-|#) :: y -> (ControlDist y, [ControlPiece y]) -> + (PieceRightSingle y, [ControlPiece y]) +y0 -|# ((d,c,y1), xs) = (PRS y0, ControlPiece c y0 y1 d : xs) + +( #|=) :: (y, Control y) -> (PieceRightDouble y, [ControlPiece y]) -> + (ControlDist y, [ControlPiece y]) +(d,c) #|= (PRD y1, xs) = ((d,c,y1), xs) + +(=|#) :: (y,y) -> (ControlDist y, [ControlPiece y]) -> + (PieceRightDouble y, [ControlPiece y]) +(y01,y10) =|# ((d,c,y11), xs) = (PRD y01, ControlPiece c y10 y11 d : xs) + +( #|) :: (y, Control y) -> y -> + (ControlDist y, [ControlPiece y]) +(d,c) #| y1 = ((d,c,y1), []) + +(|#) :: y -> (ControlDist y, [ControlPiece y]) -> + [ControlPiece y] +y0 |# ((d,c,y1), xs) = ControlPiece c y0 y1 d : xs + + +piecewise :: (Trans.C y, RealField.C y, SigG.Write sig y) => + SigG.LazySize -> [ControlPiece y] -> sig y +piecewise size xs = + let ts = scanl (\(_,fr) d -> splitFraction (fr+d)) + (0,1) (map pieceDur xs) + in SigG.concat (zipWith3 + (\n t (ControlPiece c yi0 yi1 d) -> + piecewisePart size yi0 yi1 t d n c) + (map fst (tail ts)) (map (subtract 1 . snd) ts) + xs) + + +piecewisePart :: (Trans.C y, SigG.Write sig y) => + SigG.LazySize -> y -> y -> y -> y -> Int -> Control y -> sig y +piecewisePart size y0 y1 t0 d n ctrl = + SigG.take n + (case ctrl of + CtrlStep -> constant size y0 + CtrlLin -> let s = (y1-y0)/d in linearMultiscale size s (y0-t0*s) + CtrlExp s -> let y0' = y0-s; y1' = y1-s; yd = y0'/y1' + in raise s (exponentialMultiscale size (d / log yd) + (y0' * yd**(t0/d))) + CtrlCos -> SigG.map + (\y -> (1+y)*(y0/2)+(1-y)*(y1/2)) + (cosineMultiscaleLinear size t0 (t0+d)) + CtrlCubic yd0 yd1 -> + cubicHermite size (t0,(y0,yd0)) (t0+d,(y1,yd1))) + +{- + exp (-1/time) == yd**(-1/d) + 1/time == log yd / d + time == d / log yd +-} + +{- + piecewise (0 |# (10.21, CtrlExp 1.1) #|- 1 -|# (10,CtrlExp 0.49) #|- 0.5 -|# (30, CtrlLin) #|- 0.5 -|# (20, CtrlCos) #| 0) + + piecewise (0 |# (10.21, CtrlExp 1.1) #|- 1 -|# (10,CtrlCubic (-0.1) 0) #|- 0.5 -|# (30, CtrlLin) #|- 0.5 -|# (20, CtrlCos) #| 0) +-} + + +{- * Auxiliary functions -} + + +curveMultiscale :: (SigG.Write sig y) => + SigG.LazySize -> (y -> y -> y) -> y -> y -> sig y +curveMultiscale size op d y0 = + SigG.cons y0 . SigG.map (op y0) $ SigG.iterateAssociative size op d + + +curveMultiscaleNeutral :: (SigG.Write sig y) => + SigG.LazySize -> (y -> y -> y) -> y -> y -> sig y +curveMultiscaleNeutral size op d neutral = + SigG.cons neutral $ SigG.iterateAssociative size op d diff --git a/src/Synthesizer/Generic/Cut.hs b/src/Synthesizer/Generic/Cut.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Generic/Cut.hs @@ -0,0 +1,258 @@ +{- | +This module allows abstraction of operations +that operate on the time axis +and do also work on signal types without sample values. +The most distinctive instances are certainly +Dirac signals and chunky time values. +-} +module Synthesizer.Generic.Cut where + +import qualified Synthesizer.Plain.Signal as Sig +import qualified Synthesizer.State.Signal as SigS +import qualified Synthesizer.FusionList.Signal as SigFL +-- import qualified Synthesizer.Storable.Signal as SigSt +import qualified Data.StorableVector.Lazy as Vector + +-- import qualified Algebra.ToInteger as ToInteger +-- import qualified Numeric.NonNegative.Wrapper as NonNegW +import qualified Numeric.NonNegative.Class as NonNeg +import qualified Numeric.NonNegative.Chunky as Chunky + +import Foreign.Storable (Storable) + +import Data.Function (fix, ) +import qualified Data.List as List +import Data.Tuple.HT (mapPair, ) +import qualified Data.Monoid as Monoid +import Data.Monoid (Monoid, ) + +import qualified Prelude as P +import NumericPrelude +import Prelude + (Bool, Int, String, (++), error, + pred, (<=), (>=), (<), + (.), not, (||), (&&), ) + + +class Read sig where + null :: sig -> Bool + length :: sig -> Int + +class (Read sig, Monoid sig) => Transform sig where + {- Monoid functions + empty :: sig + cycle :: sig -> sig + append :: sig -> sig -> sig + concat :: [sig] -> sig + -} + take :: Int -> sig -> sig + drop :: Int -> sig -> sig + -- can occur in an inner loop in Interpolation + dropMarginRem :: Int -> Int -> sig -> (Int, sig) + splitAt :: Int -> sig -> (sig, sig) + reverse :: sig -> sig + + +-- instance Storable y => Read SigSt.T y where +instance Storable y => Read (Vector.Vector y) where + {-# INLINE null #-} + null = Vector.null + {-# INLINE length #-} + length = Vector.length + +instance Storable y => Transform (Vector.Vector y) where + {- + {-# INLINE empty #-} + empty = Vector.empty + {-# INLINE cycle #-} + cycle = Vector.cycle + {-# INLINE append #-} + append = Vector.append + {-# INLINE concat #-} + concat = Vector.concat + -} + {-# INLINE take #-} + take = Vector.take + {-# INLINE drop #-} + drop = Vector.drop + {-# INLINE splitAt #-} + splitAt = Vector.splitAt + {-# INLINE dropMarginRem #-} + dropMarginRem = Vector.dropMarginRem + {-# INLINE reverse #-} + reverse = Vector.reverse + + +instance Read ([] y) where + {-# INLINE null #-} + null = List.null + {-# INLINE length #-} + length = List.length + +instance Transform ([] y) where + {- + {-# INLINE empty #-} + empty = [] + {-# INLINE cycle #-} + cycle = List.cycle + {-# INLINE append #-} + append = (List.++) + {-# INLINE concat #-} + concat = List.concat + -} + {-# INLINE take #-} + take = List.take + {-# INLINE drop #-} + drop = List.drop + {-# INLINE dropMarginRem #-} + dropMarginRem = Sig.dropMarginRem + {-# INLINE splitAt #-} + splitAt = List.splitAt + {-# INLINE reverse #-} + reverse = List.reverse + + +instance Read (SigFL.T y) where + {-# INLINE null #-} + null = SigFL.null + {-# INLINE length #-} + length = SigFL.length + +instance Transform (SigFL.T y) where + {- + {-# INLINE empty #-} + empty = SigFL.empty + {-# INLINE cycle #-} + cycle = SigFL.cycle + {-# INLINE append #-} + append = SigFL.append + {-# INLINE concat #-} + concat = SigFL.concat + -} + + {-# INLINE take #-} + take = SigFL.take + {-# INLINE drop #-} + drop = SigFL.drop + {-# INLINE dropMarginRem #-} + dropMarginRem = SigFL.dropMarginRem + {-# INLINE splitAt #-} + splitAt = SigFL.splitAt + {-# INLINE reverse #-} + reverse = SigFL.reverse + + +instance Read (SigS.T y) where + {-# INLINE null #-} + null = SigS.null + {-# INLINE length #-} + length = SigS.length + +instance Transform (SigS.T y) where + {- + {-# INLINE empty #-} + empty = SigS.empty + {-# INLINE cycle #-} + cycle = SigS.cycle + {-# INLINE append #-} + append = SigS.append + {-# INLINE concat #-} + concat = SigS.concat + -} + + {-# INLINE take #-} + take = SigS.take + {-# INLINE drop #-} + drop = SigS.drop + {-# INLINE dropMarginRem #-} + dropMarginRem = SigS.dropMarginRem + {-# INLINE splitAt #-} + splitAt n = + -- This implementation is slow. Better leave it unimplemented? + mapPair (SigS.fromList, SigS.fromList) . + List.splitAt n . SigS.toList + {-# INLINE reverse #-} + reverse = SigS.reverse + + +{- +useful for application of non-negative chunky numbers as gate signals +-} +instance (P.Integral a) => Read (Chunky.T a) where + {-# INLINE null #-} + null = List.null . Chunky.toChunks + {-# INLINE length #-} + length = sum . List.map (P.fromIntegral . P.toInteger) . Chunky.toChunks + + +intToChunky :: (NonNeg.C a) => String -> Int -> Chunky.T a +intToChunky name = + Chunky.fromNumber . +-- NonNegW.fromNumberMsg ("Generic.Cut."++name) . + P.fromIntegral . + (\x -> + if x<0 + then error ("Generic.Cut.NonNeg.Chunky."++name++": negative argument") + else x) + +instance (P.Integral a, NonNeg.C a) => Transform (Chunky.T a) where + {-# INLINE take #-} + take n = P.min (intToChunky "take" n) + {-# INLINE drop #-} + drop n x = x NonNeg.-| intToChunky "drop" n + {-# INLINE dropMarginRem #-} + dropMarginRem n m x = + let (z,d,b) = + Chunky.minMaxDiff + (intToChunky "dropMargin/n" n) + (x NonNeg.-| intToChunky "dropMargin/m" m) + in (if b then 0 else P.fromIntegral (Chunky.toNumber d), + x NonNeg.-| z) + {-# INLINE splitAt #-} + splitAt n x = + let (z,d,b) = Chunky.minMaxDiff (intToChunky "splitAt" n) x + in (z, if b then d else Chunky.zero) + {-# INLINE reverse #-} + reverse = Chunky.fromChunks . P.reverse . Chunky.toChunks + + +{-# INLINE empty #-} +empty :: (Monoid sig) => sig +empty = Monoid.mempty + +{-# INLINE cycle #-} +cycle :: (Monoid sig) => sig -> sig +cycle x = fix (append x) + +{-# INLINE append #-} +append :: (Monoid sig) => sig -> sig -> sig +append = Monoid.mappend + +{-# INLINE concat #-} +concat :: (Monoid sig) => [sig] -> sig +concat = Monoid.mconcat + + +{- | +Like @lengthAtLeast n xs = length xs >= n@, +but is more efficient, because it is more lazy. +-} +{-# INLINE lengthAtLeast #-} +lengthAtLeast :: (Transform sig) => + Int -> sig -> Bool +lengthAtLeast n xs = + n<=0 || not (null (drop (pred n) xs)) + +{-# INLINE lengthAtMost #-} +lengthAtMost :: (Transform sig) => + Int -> sig -> Bool +lengthAtMost n xs = + n>=0 && null (drop n xs) + +{-# INLINE sliceVertical #-} +sliceVertical :: (Transform sig) => + Int -> sig -> SigS.T sig +sliceVertical n = + SigS.map (take n) . + SigS.takeWhile (not . null) . + SigS.iterate (drop n) diff --git a/src/Synthesizer/Generic/Displacement.hs b/src/Synthesizer/Generic/Displacement.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Generic/Displacement.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{- | + +-} +module Synthesizer.Generic.Displacement where + +import qualified Algebra.Additive as Additive + +import qualified Synthesizer.Generic.Signal as SigG + +-- import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +{- * Mixing -} + +{-| Mix two signals. + In opposition to 'zipWith' the result has the length of the longer signal. -} +mix :: (Additive.C v, SigG.Transform sig v) => + sig v -> sig v -> sig v +mix = SigG.mix + +{- relict from Prelude98's Num +mixMono :: Ring.C a => [a] -> [a] -> [a] +mixMono [] x = x +mixMono x [] = x +mixMono (x:xs) (y:ys) = x+y : mixMono xs ys +-} + +{-| Mix one or more signals. -} +mixMulti :: (Additive.C v, SigG.Transform sig v) => + [sig v] -> sig v +mixMulti = foldl mix SigG.empty + + +{-| Add a number to all of the signal values. + This is useful for adjusting the center of a modulation. -} +raise :: (Additive.C v, SigG.Transform sig v) => + v -> sig v -> sig v +raise x = SigG.map ((+) x) + + +{- * Distortion -} +{- | +In "Synthesizer.Basic.Distortion" you find a collection +of appropriate distortion functions. +-} +distort :: (SigG.Read sig c, SigG.Transform sig v) => + (c -> v -> v) -> sig c -> sig v -> sig v +distort = SigG.zipWith diff --git a/src/Synthesizer/Generic/Filter/Delay.hs b/src/Synthesizer/Generic/Filter/Delay.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Generic/Filter/Delay.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Synthesizer.Generic.Filter.Delay where + +import qualified Synthesizer.Generic.Filter.NonRecursive as FiltNR +import qualified Synthesizer.Generic.Interpolation as Interpolation +import qualified Synthesizer.Generic.Signal2 as SigG2 +import qualified Synthesizer.Generic.Signal as SigG + +import qualified Algebra.RealField as RealField +import qualified Algebra.Additive as Additive + +-- import qualified Prelude as P +-- import PreludeBase +import NumericPrelude + + + +{- * Shift -} + +{-# INLINE static #-} +static :: + (Additive.C y, SigG.Write sig y) => + Int -> sig y -> sig y +static = FiltNR.delay + +{-# INLINE staticPad #-} +staticPad :: + (SigG.Write sig y) => + y -> Int -> sig y -> sig y +staticPad = FiltNR.delayPad + +{-# INLINE staticPos #-} +staticPos :: + (Additive.C y, SigG.Write sig y) => + Int -> sig y -> sig y +staticPos = FiltNR.delayPos + +{-# INLINE staticNeg #-} +staticNeg :: + (SigG.Write sig y) => + Int -> sig y -> sig y +staticNeg = FiltNR.delayNeg + + + + +{-# INLINE modulatedCore #-} +modulatedCore :: + (RealField.C t, Additive.C y, SigG.Read sig t, SigG2.Transform sig t y) => + Interpolation.T t y -> Int -> + sig t -> sig y -> sig y +modulatedCore ip size = + SigG2.zipWithTails + (\t -> Interpolation.single ip (fromIntegral size + t)) + + +{- | +This is essentially different for constant interpolation, +because this function "looks forward" +whereas the other two variants "look backward". +For the symmetric interpolation functions +of linear and cubic interpolation, this does not really matter. +-} +{-# INLINE modulated #-} +modulated :: + (RealField.C t, Additive.C y, + SigG.Read sig t, SigG2.Transform sig t y, SigG.Write sig y) => + Interpolation.T t y -> Int -> + sig t -> sig y -> sig y +modulated ip minDev ts xs = + let size = Interpolation.number ip - minDev + in modulatedCore ip + (size - Interpolation.offset ip) + ts + (staticPos size xs) diff --git a/src/Synthesizer/Generic/Filter/NonRecursive.hs b/src/Synthesizer/Generic/Filter/NonRecursive.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Generic/Filter/NonRecursive.hs @@ -0,0 +1,363 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes +-} +module Synthesizer.Generic.Filter.NonRecursive where + +import qualified Synthesizer.Generic.Signal as SigG + +import qualified Synthesizer.Generic.Control as Ctrl + +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Module as Module +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Algebra.Module( {- linearComb, -} (*>), ) + +import Data.Function.HT (nest, ) + +import PreludeBase +import NumericPrelude + + + +{- * Envelope application -} + +{-# INLINE negate #-} +negate :: + (Additive.C a, SigG.Transform sig a) => + sig a -> sig a +negate = SigG.map Additive.negate + +{-# INLINE amplify #-} +amplify :: + (Ring.C a, SigG.Transform sig a) => + a -> sig a -> sig a +amplify v = SigG.map (v*) + +{-# INLINE amplifyVector #-} +amplifyVector :: + (Module.C a v, SigG.Transform sig v) => + a -> sig v -> sig v +amplifyVector v = SigG.map (v*>) + +{-# INLINE envelope #-} +envelope :: + (Ring.C a, SigG.Transform sig a) => + sig a {-^ the envelope -} + -> sig a {-^ the signal to be enveloped -} + -> sig a +envelope = SigG.zipWith (*) + +{-# INLINE envelopeVector #-} +envelopeVector :: + (Module.C a v, SigG.Read sig a, SigG.Transform sig v) => + sig a {-^ the envelope -} + -> sig v {-^ the signal to be enveloped -} + -> sig v +envelopeVector = SigG.zipWith (*>) + + + +{-# INLINE fadeInOut #-} +fadeInOut :: + (Field.C a, SigG.Write sig a) => + Int -> Int -> Int -> sig a -> sig a +fadeInOut tIn tHold tOut xs = + let slopeIn = recip (fromIntegral tIn) + slopeOut = Additive.negate (recip (fromIntegral tOut)) + {- + Since we use the size only for the internal envelope + no laziness effect can be observed outside the function. + We could also create the envelope as State.Signal. + But I assume that concatenating chunks of an envelope + is more efficient than concatenating generator loops. + However, our intermediate envelope is still observable, + because we have to use SigG.Write class. + -} + leadIn = SigG.take tIn $ Ctrl.linear SigG.defaultLazySize slopeIn 0 + leadOut = SigG.take tOut $ Ctrl.linear SigG.defaultLazySize slopeOut 1 + (partIn, partHoldOut) = SigG.splitAt tIn xs + (partHold, partOut) = SigG.splitAt tHold partHoldOut + in envelope leadIn partIn `SigG.append` + partHold `SigG.append` + envelope leadOut partOut + + +{- * Smoothing -} + +{-# INLINE delay #-} +delay :: (Additive.C y, SigG.Write sig y) => + Int -> sig y -> sig y +delay = + delayPad zero + +{-# INLINE delayPad #-} +delayPad :: (SigG.Write sig y) => + y -> Int -> sig y -> sig y +delayPad z n = + if n<0 + then SigG.drop (Additive.negate n) + else SigG.append (SigG.replicate SigG.defaultLazySize n z) + +{-# INLINE delayPos #-} +delayPos :: (Additive.C y, SigG.Write sig y) => + Int -> sig y -> sig y +delayPos n = + SigG.append (SigG.replicate SigG.defaultLazySize n zero) + +{-# INLINE delayNeg #-} +delayNeg :: (SigG.Transform sig y) => + Int -> sig y -> sig y +delayNeg = SigG.drop + + + +{-# INLINE delayLazySize #-} +delayLazySize :: (Additive.C y, SigG.Write sig y) => + SigG.LazySize -> Int -> sig y -> sig y +delayLazySize size = + delayPadLazySize size zero + +{- | +The pad value @y@ must be defined, +otherwise the chunk size of the padding can be observed. +-} +{-# INLINE delayPadLazySize #-} +delayPadLazySize :: (SigG.Write sig y) => + SigG.LazySize -> y -> Int -> sig y -> sig y +delayPadLazySize size z n = + if n<0 + then SigG.drop (Additive.negate n) + else SigG.append (SigG.replicate size n z) + +{-# INLINE delayPosLazySize #-} +delayPosLazySize :: (Additive.C y, SigG.Write sig y) => + SigG.LazySize -> Int -> sig y -> sig y +delayPosLazySize size n = + SigG.append (SigG.replicate size n zero) + + + +{-| Unmodulated non-recursive filter -} +{-# INLINE generic #-} +generic :: + (Module.C a v, SigG.Transform sig a, SigG.Write sig v) => + sig a -> sig v -> sig v +generic m x = + let mr = SigG.reverse m + xp = delayPos (pred (SigG.length m)) x + in SigG.mapTails (SigG.linearComb mr) xp + +{- +{- | +@eps@ is the threshold relatively to the maximum. +That is, if the gaussian falls below @eps * gaussian 0@, +then the function truncated. +-} +gaussian :: + (Trans.C a, RealField.C a, Module.C a v) => + a -> a -> a -> sig v -> sig v +gaussian eps ratio freq = + let var = ratioFreqToVariance ratio freq + area = var * sqrt (2*pi) + gau t = exp (-(t/var)^2/2) / area + width = ceiling (var * sqrt (-2 * log eps)) -- inverse gau + gauSmp = map (gau . fromIntegral) [-width .. width] + in drop width . generic gauSmp +-} + +{- +GNUPlot.plotList [] (take 1000 $ gaussian 0.001 0.5 0.04 (Filter.Test.chirp 5000) :: [Double]) + +The filtered chirp must have amplitude 0.5 at 400 (0.04*10000). +-} + +{- + We want to approximate a Gaussian by a binomial filter. + The latter one can be implemented by a convolutional power. + However we still require a number of operations per sample + which is proportional to the variance. +-} +{-# INLINE binomial #-} +binomial :: + (Trans.C a, RealField.C a, Module.C a v, SigG.Transform sig v) => + a -> a -> sig v -> sig v +binomial ratio freq = + let width = ceiling (2 * ratioFreqToVariance ratio freq ^ 2) + in SigG.drop width . + nest (2*width) (amplifyVector (asTypeOf 0.5 freq) . binomial1) + +{- +exp (-(t/var)^2/2) / area *> cis (2*pi*f*t) + == exp (-(t/var)^2/2 +: 2*pi*f*t) / area + == exp ((-t^2 +: 2*var^2*2*pi*f*t) / (2*var^2)) / area + == exp ((t^2 - i*2*var^2*2*pi*f*t) / (-2*var^2)) / area + == exp (((t^2 - i*var^2*2*pi*f)^2 + (var^2*2*pi*f)^2) / (-2*var^2)) / area + == exp (((t^2 - i*var^2*2*pi*f)^2 / (-2*var^2) - (var*2*pi*f)^2/2)) / area + +sumMap (\t -> exp (-(t/var)^2/2) / area *> cis (2*pi*f*t)) + [-infinity..infinity] + ~ sumMap (\t -> exp (-(t/var)^2/2)) [-infinity..infinity] + * exp (-(var*2*pi*f)^2/2) / area + = exp (-(var*2*pi*f)^2/2) +-} +{- | + Compute the variance of the Gaussian + such that its Fourier transform has value @ratio@ at frequency @freq@. +-} +{-# INLINE ratioFreqToVariance #-} +ratioFreqToVariance :: (Trans.C a) => a -> a -> a +ratioFreqToVariance ratio freq = + sqrt (Additive.negate (2 * log ratio)) / (2*pi*freq) + -- inverse of the fourier transformed gaussian + +{-# INLINE binomial1 #-} +binomial1 :: + (Additive.C v, SigG.Transform sig v) => sig v -> sig v +binomial1 = SigG.mapAdjacent (+) + + + + + +{- | +Moving (uniformly weighted) average in the most trivial form. +This is very slow and needs about @n * length x@ operations. +-} +{-# INLINE sums #-} +sums :: + (Additive.C v, SigG.Transform sig v) => + Int -> sig v -> sig v +sums n = SigG.mapTails (SigG.sum . SigG.take n) + + +{- +sumsDownsample2 :: (Additive.C v) => sig v -> sig v +sumsDownsample2 (x0:x1:xs) = (x0+x1) : sumsDownsample2 xs +sumsDownsample2 xs = xs + +downsample2 :: sig a -> sig a +downsample2 (x0:_:xs) = x0 : downsample2 xs +downsample2 xs = xs + + +{- | +Given a list of numbers +and a list of sums of (2*k) of successive summands, +compute a list of the sums of (2*k+1) or (2*k+2) summands. + +Eample for 2*k+1 + +@ + [0+1+2+3, 2+3+4+5, 4+5+6+7, ...] -> + [0+1+2+3+4, 1+2+3+4+5, 2+3+4+5+6, 3+4+5+6+7, 4+5+6+7+8, ...] +@ + +Example for 2*k+2 + +@ + [0+1+2+3, 2+3+4+5, 4+5+6+7, ...] -> + [0+1+2+3+4+5, 1+2+3+4+5+6, 2+3+4+5+6+7, 3+4+5+6+7+8, 4+5+6+7+8+9, ...] +@ +-} +sumsUpsampleOdd :: (Additive.C v) => Int -> sig v -> sig v -> sig v +sumsUpsampleOdd n {- 2*k -} xs ss = + let xs2k = drop n xs + in (head ss + head xs2k) : + concat (zipWith3 (\s x0 x2k -> [x0+s, s+x2k]) + (tail ss) + (downsample2 (tail xs)) + (tail (downsample2 xs2k))) + +sumsUpsampleEven :: (Additive.C v) => Int -> sig v -> sig v -> sig v +sumsUpsampleEven n {- 2*k -} xs ss = + sumsUpsampleOdd (n+1) xs (zipWith (+) ss (downsample2 (drop n xs))) + +sumsPyramid :: (Additive.C v) => Int -> sig v -> sig v +sumsPyramid n xs = + let aux 1 ys = ys + aux 2 ys = ys + tail ys + aux m ys = + let ysd = sumsDownsample2 ys + in if even m + then sumsUpsampleEven (m-2) ys (aux (div (m-2) 2) ysd) + else sumsUpsampleOdd (m-1) ys (aux (div (m-1) 2) ysd) + in aux n xs + + +propSums :: Bool +propSums = + let n = 1000 + xs = [0::Double ..] + naive = sums n xs + rec = drop (n-1) $ sumsRec n xs + pyramid = sumsPyramid n xs + in and $ take 1000 $ + zipWith3 (\x y z -> x==y && y==z) naive rec pyramid + +-} + + + +{- * Filter operators from calculus -} + +{- | +Forward difference quotient. +Shortens the signal by one. +Inverts 'Synthesizer.Generic.Filter.Recursive.Integration.run' in the sense that +@differentiate (zero : integrate x) == x@. +The signal is shifted by a half time unit. +-} +{-# INLINE differentiate #-} +differentiate :: + (Additive.C v, SigG.Transform sig v) => + sig v -> sig v +differentiate x = SigG.mapAdjacent subtract x + +{- | +Central difference quotient. +Shortens the signal by two elements, +and shifts the signal by one element. +(Which can be fixed by prepending an appropriate value.) +For linear functions this will yield +essentially the same result as 'differentiate'. +You obtain the result of 'differentiateCenter' +if you smooth the one of 'differentiate' +by averaging pairs of adjacent values. + +ToDo: Vector variant +-} +{- +This implementation is a bit cumbersome, +but it fits both StorableVector and State.Signal +(since it avoids recomputation). +-} +{-# INLINE differentiateCenter #-} +differentiateCenter :: + (Field.C v, SigG.Transform sig v) => + sig v -> sig v +differentiateCenter = + SigG.drop 2 . + SigG.crochetL + (\x0 (x1,x2) -> Just ((x2-x0)/2, (x0,x1))) + (zero,zero) + +{- | +Second derivative. +It is @differentiate2 == differentiate . differentiate@ +but 'differentiate2' should be faster. +-} +{-# INLINE differentiate2 #-} +differentiate2 :: + (Additive.C v, SigG.Transform sig v) => + sig v -> sig v +differentiate2 = differentiate . differentiate diff --git a/src/Synthesizer/Generic/Filter/Recursive/Comb.hs b/src/Synthesizer/Generic/Filter/Recursive/Comb.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Generic/Filter/Recursive/Comb.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +Comb filters, useful for emphasis of tones with harmonics +and for repeated echos. +-} +module Synthesizer.Generic.Filter.Recursive.Comb where + +import qualified Synthesizer.Generic.Filter.NonRecursive as Filt +import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1 + +import qualified Synthesizer.Generic.Signal as SigG + +import qualified Algebra.Module as Module +-- import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +{- | +The most simple version of the Karplus-Strong algorithm +which is suitable to simulate a plucked string. +It is similar to the 'runProc' function. +-} +{-# INLINE karplusStrong #-} +karplusStrong :: + (Ring.C t, Module.C t y, SigG.Write sig y) => + Filt1.Parameter t -> sig y -> sig y +karplusStrong c wave = + SigG.delayLoop (SigG.modifyStatic Filt1.lowpassModifier c) wave + + +{- | +Infinitely many equi-delayed exponentially decaying echos. +The echos are clipped to the input length. +We think it is easier (and simpler to do efficiently) +to pad the input with zeros or whatever +instead of cutting the result according to the input length. +-} +{-# INLINE run #-} +run :: (Module.C t y, SigG.Write sig y) => + Int -> t -> sig y -> sig y +run time gain = + runProc time (Filt.amplifyVector gain) + +{- | +Echos of different delays. +Chunk size must be smaller than all of the delay times. +-} +{-# INLINE runMulti #-} +runMulti :: (Ring.C t, Module.C t y, SigG.Write sig y) => + [Int] -> t -> sig y -> sig y +runMulti times gain x = + let y = foldl + (SigG.zipWith (+)) x + (map (flip Filt.delay (Filt.amplifyVector gain y)) times) +-- (map (flip Delay.staticPos (gain *> y)) times) + in y + +{- | Echos can be piped through an arbitrary signal processor. -} +{-# INLINE runProc #-} +runProc :: (Additive.C y, SigG.Write sig y) => + Int -> (sig y -> sig y) -> sig y -> sig y +runProc = SigG.delayLoopOverlap diff --git a/src/Synthesizer/Generic/Filter/Recursive/Integration.hs b/src/Synthesizer/Generic/Filter/Recursive/Integration.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Generic/Filter/Recursive/Integration.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +Filter operators from calculus +-} +module Synthesizer.Generic.Filter.Recursive.Integration where + +import qualified Synthesizer.Generic.Signal as SigG + +-- import qualified Algebra.Field as Field +-- import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import PreludeBase +import NumericPrelude + + + +{- | +Integrate with initial value zero. +However the first emitted value is the value of the input signal. +It maintains the length of the signal. +-} +{-# INLINE run #-} +run :: (Additive.C v, SigG.Transform sig v) => + sig v -> sig v +run = + SigG.crochetL (\x acc -> let y = x+acc in Just (y,y)) zero + -- scanl1 (+) + +{- | +Integrate with initial condition. +First emitted value is the initial condition. +The signal become one element longer. +-} +{-# INLINE runInit #-} +runInit :: (Additive.C v, SigG.Transform sig v) => + v -> sig v -> sig v +runInit = SigG.scanL (+) + +{- other quadrature methods may follow -} diff --git a/src/Synthesizer/Generic/Filter/Recursive/MovingAverage.hs b/src/Synthesizer/Generic/Filter/Recursive/MovingAverage.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Generic/Filter/Recursive/MovingAverage.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +-} +module Synthesizer.Generic.Filter.Recursive.MovingAverage + (sumsStaticInt, + modulatedFrac, + ) where + +import qualified Synthesizer.Generic.Signal as SigG +import qualified Synthesizer.Generic.Signal2 as SigG2 + +import qualified Synthesizer.Generic.Filter.Recursive.Integration as Integration +import qualified Synthesizer.Generic.Filter.Delay as Delay + +import qualified Synthesizer.State.Signal as SigS + +import Data.Function.HT (nest, ) + +import qualified Algebra.Module as Module +import qualified Algebra.RealField as RealField + +-- import qualified Algebra.Field as Field +-- import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import PreludeBase +import NumericPrelude + + + +{- | +Like 'Synthesizer.Generic.Filter.NonRecursive.sums' but in a recursive form. +This needs only linear time (independent of the window size) +but may accumulate rounding errors. + +@ +ys = xs * (1,0,0,0,-1) \/ (1,-1) +ys * (1,-1) = xs * (1,0,0,0,-1) +ys = xs * (1,0,0,0,-1) + ys * (0,1) +@ +-} +{-# INLINE sumsStaticInt #-} +sumsStaticInt :: (Additive.C v, SigG.Write sig v) => + Int -> sig v -> sig v +sumsStaticInt n xs = + Integration.run (sub xs (Delay.staticPos n xs)) + + +{-# INLINE sub #-} +sub :: (Additive.C v, SigG.Transform sig v) => + sig v -> sig v -> sig v +sub xs ys = + SigG.mix xs (SigG.map Additive.negate ys) + + +{- +Sum of a part of a vector with negative sign for reverse order. +It adds from @from@ (inclusively) to @to@ (exclusively), +that is, it sums up @abs (to-from)@ values + +{-# INLINE sumFromTo #-} +sumFromTo :: (Additive.C v) => Int -> Int -> sig v -> v +sumFromTo from to = + if from <= to + then Sig.sum . Sig.take (to-from) . Sig.drop from + else negate . Sig.sum . Sig.take (from-to) . Sig.drop to +-} + +{-# INLINE sumFromToFrac #-} +sumFromToFrac :: + (RealField.C a, Module.C a v, SigG.Transform sig v) => + a -> a -> sig v -> v +sumFromToFrac from to xs = + let (fromInt, fromFrac) = splitFraction from + (toInt, toFrac) = splitFraction to + in case compare fromInt toInt of + EQ -> (to-from) *> index zero fromInt xs + LT -> + (addNext ((1-fromFrac) *>) $ + nest (toInt-fromInt-1) (addNext id) $ + addNext (toFrac *>) $ + const) + zero (SigG.drop fromInt xs) + GT -> + (addNext ((1-toFrac) *>) $ + nest (fromInt-toInt-1) (addNext id) $ + addNext (fromFrac *>) $ + const) + zero (SigG.drop toInt xs) + + +{-# INLINE index #-} +index :: + (SigG.Transform sig y) => + y -> Int -> sig y -> y +index deflt n = + maybe deflt fst . SigG.viewL . SigG.drop n + + +{-# INLINE addNext #-} +addNext :: + (Additive.C v, SigG.Read sig a) => + (a -> v) -> (v -> sig a -> v) -> v -> sig a -> v +addNext f next s = + SigG.switchL s + (\y ys -> next (s + f y) ys) + + +{- | +@sig a@ must contain only non-negative elements. +-} +{-# INLINE sumDiffsModulated #-} +sumDiffsModulated :: + (RealField.C a, Module.C a v, SigG2.Transform sig a v) => + a -> sig a -> sig v -> sig v +sumDiffsModulated d ds = + maybe (error "MovingAverage: signal must be non-empty because we prepended a zero before") fst . + SigG.viewR . + -- prevent negative d's since 'drop' cannot restore past values + zipRangesWithTails sumFromToFrac + (SigG.cons (d+1) ds) (SigG.map (1+) ds) . + SigG.cons zero + +{- + zipRangesWithTails sumFromToFrac + (SigG.cons d (SigG.map (subtract 1) ds)) ds +-} + +zipRangesWithTails :: + (SigG2.Transform sig a v) => + (a -> a -> sig v -> v) -> sig a -> sig a -> sig v -> sig v +zipRangesWithTails f tls tus xs = + SigG2.zipWithState + (\(tl,suffix) tu -> f tl tu suffix) + (SigS.zip (SigG.toState tls) (SigG.tails xs)) + tus + +{- +{-# INLINE sumsModulated #-} +sumsModulated :: (RealField.C a, Module.C a v) => + Int -> sig a -> sig v -> sig v +sumsModulated maxDInt ds xs = + let maxD = fromIntegral maxDInt + posXs = sumDiffsModulated 0 ds xs + negXs = sumDiffsModulated maxD (SigG.map (maxD-) ds) (Delay.static maxDInt xs) + in Integration.run (sub posXs negXs) +-} + +{- | +Shift sampling points by a half sample period +in order to preserve signals for window widths below 1. +-} +{-# INLINE sumsModulatedHalf #-} +sumsModulatedHalf :: + (RealField.C a, Module.C a v, SigG2.Transform sig a v, SigG.Write sig v) => + Int -> sig a -> sig v -> sig v +sumsModulatedHalf maxDInt ds xs = + let maxD = fromIntegral maxDInt + d0 = maxD+0.5 + delXs = Delay.staticPos maxDInt xs + posXs = sumDiffsModulated d0 (SigG.map (d0+) ds) delXs + negXs = sumDiffsModulated d0 (SigG.map (d0-) ds) delXs + in Integration.run (sub posXs negXs) + +{-# INLINE modulatedFrac #-} +modulatedFrac :: + (RealField.C a, Module.C a v, SigG2.Transform sig a v, SigG.Write sig v) => + Int -> sig a -> sig v -> sig v +modulatedFrac maxDInt ds xs = + SigG.zipWith (\d y -> recip (2*d) *> y) ds $ + sumsModulatedHalf maxDInt ds xs diff --git a/src/Synthesizer/Generic/Interpolation.hs b/src/Synthesizer/Generic/Interpolation.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Generic/Interpolation.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Synthesizer.Generic.Interpolation ( + T, func, offset, number, + zeroPad, constantPad, cyclicPad, extrapolationPad, + single, + multiRelative, + multiRelativeZeroPad, multiRelativeConstantPad, + multiRelativeCyclicPad, multiRelativeExtrapolationPad, + multiRelativeZeroPadConstant, multiRelativeZeroPadLinear, + multiRelativeZeroPadCubic, + ) where + +import qualified Synthesizer.Interpolation as Interpolation +import Synthesizer.Interpolation (T, offset, number, ) +import Synthesizer.Interpolation.Module (constant, linear, cubic, ) + +import qualified Synthesizer.Generic.Signal as SigG +import qualified Synthesizer.Generic.Signal2 as SigG2 +import qualified Synthesizer.Generic.Filter.NonRecursive as FiltNR + +import qualified Algebra.Module as Module +import qualified Algebra.RealField as RealField +-- import qualified Algebra.Field as Field +-- import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Algebra.Additive(zero, ) +import Data.Maybe (fromMaybe, ) + +import PreludeBase +import NumericPrelude + + +{-* Interpolation with various padding methods -} + +{-# INLINE zeroPad #-} +zeroPad :: (RealField.C t, SigG.Write sig y) => + (T t y -> t -> sig y -> a) -> + y -> T t y -> t -> sig y -> a +zeroPad interpolate z ip phase x = + let (phInt, phFrac) = splitFraction phase + in interpolate ip phFrac + (FiltNR.delayPad z (offset ip - phInt) + (SigG.append x (SigG.repeat SigG.defaultLazySize z))) + +{-# INLINE constantPad #-} +constantPad :: (RealField.C t, SigG.Write sig y) => + (T t y -> t -> sig y -> a) -> + T t y -> t -> sig y -> a +constantPad interpolate ip phase x = + let (phInt, phFrac) = splitFraction phase + xPad = + do (xFirst,_) <- SigG.viewL x + return (FiltNR.delayPad xFirst + (offset ip - phInt) (SigG.extendConstant SigG.defaultLazySize x)) + in interpolate ip phFrac + (fromMaybe SigG.empty xPad) + + +{- | +Only for finite input signals. +-} +{-# INLINE cyclicPad #-} +cyclicPad :: (RealField.C t, SigG.Transform sig y) => + (T t y -> t -> sig y -> a) -> + T t y -> t -> sig y -> a +cyclicPad interpolate ip phase x = + let (phInt, phFrac) = splitFraction phase + in interpolate ip phFrac + (SigG.drop (mod (phInt - offset ip) (SigG.length x)) (SigG.cycle x)) + +{- | +The extrapolation may miss some of the first and some of the last points +-} +{-# INLINE extrapolationPad #-} +extrapolationPad :: (RealField.C t, SigG.Transform sig y) => + (T t y -> t -> sig y -> a) -> + T t y -> t -> sig y -> a +extrapolationPad interpolate ip phase = + interpolate ip (phase - fromIntegral (offset ip)) +{- + This example shows pikes, although there shouldn't be any: + plotList (take 100 $ interpolate (Zero (0::Double)) ipCubic (-0.9::Double) (repeat 0.03) [1,0,1,0.8]) +-} + + +{-* Interpolation of multiple values with various padding methods -} + +func :: (SigG.Read sig y) => + T t y -> t -> sig y -> y +func ip phase = + Interpolation.func ip phase . SigG.toState + +{-# INLINE skip #-} +skip :: (RealField.C t, SigG.Transform sig y) => + T t y -> (t, sig y) -> (t, sig y) +skip ip (phase0, x0) = + let (n, frac) = splitFraction phase0 + (m, x1) = SigG.dropMarginRem (number ip) n x0 + in (fromIntegral m + frac, x1) + +{-# INLINE single #-} +single :: (RealField.C t, SigG.Transform sig y) => + T t y -> t -> sig y -> y +single ip phase0 x0 = + uncurry (func ip) $ skip ip (phase0, x0) +-- curry (uncurry (func ip) . skip ip) +{- +GNUPlot.plotFunc [] (GNUPlot.linearScale 1000 (0,2)) (\t -> single linear (t::Double) [0,4,1::Double]) +-} + + +{-* Interpolation of multiple values with various padding methods -} + +{- | All values of frequency control must be non-negative. -} +{-# INLINE multiRelative #-} +multiRelative :: + (RealField.C t, SigG2.Transform sig t y) => + T t y -> t -> sig y -> sig t -> sig y +multiRelative ip phase0 x0 = + SigG2.crochetL + (\freq pos -> + let (phase,x) = skip ip pos + in Just (func ip phase x, (phase+freq,x))) + (phase0,x0) + + +{-# INLINE multiRelativeZeroPad #-} +multiRelativeZeroPad :: + (RealField.C t, SigG2.Transform sig t y, SigG.Write sig y) => + y -> T t y -> t -> sig t -> sig y -> sig y +multiRelativeZeroPad z ip phase fs x = + zeroPad multiRelative z ip phase x fs + +{-# INLINE multiRelativeConstantPad #-} +multiRelativeConstantPad :: + (RealField.C t, SigG2.Transform sig t y, SigG.Write sig y) => + T t y -> t -> sig t -> sig y -> sig y +multiRelativeConstantPad ip phase fs x = + constantPad multiRelative ip phase x fs + +{-# INLINE multiRelativeCyclicPad #-} +multiRelativeCyclicPad :: + (RealField.C t, SigG2.Transform sig t y) => + T t y -> t -> sig t -> sig y -> sig y +multiRelativeCyclicPad ip phase fs x = + cyclicPad multiRelative ip phase x fs + +{- | +The extrapolation may miss some of the first and some of the last points +-} +{-# INLINE multiRelativeExtrapolationPad #-} +multiRelativeExtrapolationPad :: + (RealField.C t, SigG2.Transform sig t y) => + T t y -> t -> sig t -> sig y -> sig y +multiRelativeExtrapolationPad ip phase fs x = + extrapolationPad multiRelative ip phase x fs +{- + This example shows pikes, although there shouldn't be any: + plotList (take 100 $ interpolate (Zero (0::Double)) ipCubic (-0.9::Double) (repeat 0.03) [1,0,1,0.8]) +-} + +{-* All-in-one interpolation functions -} + +{-# INLINE multiRelativeZeroPadConstant #-} +multiRelativeZeroPadConstant :: + (RealField.C t, Additive.C y, SigG2.Transform sig t y, SigG.Write sig y) => + t -> sig t -> sig y -> sig y +multiRelativeZeroPadConstant = + multiRelativeZeroPad zero constant + +{-# INLINE multiRelativeZeroPadLinear #-} +multiRelativeZeroPadLinear :: + (RealField.C t, Module.C t y, SigG2.Transform sig t y, SigG.Write sig y) => + t -> sig t -> sig y -> sig y +multiRelativeZeroPadLinear = + multiRelativeZeroPad zero linear + +{-# INLINE multiRelativeZeroPadCubic #-} +multiRelativeZeroPadCubic :: + (RealField.C t, Module.C t y, SigG2.Transform sig t y, SigG.Write sig y) => + t -> sig t -> sig y -> sig y +multiRelativeZeroPadCubic = + multiRelativeZeroPad zero cubic diff --git a/src/Synthesizer/Generic/Noise.hs b/src/Synthesizer/Generic/Noise.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Generic/Noise.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE FlexibleContexts #-} +{- | Noise and random processes. -} +module Synthesizer.Generic.Noise where + +import qualified Synthesizer.State.Noise as Noise + +import qualified Synthesizer.Generic.Signal as SigG +import qualified Synthesizer.Generic.Signal2 as SigG2 +import qualified Synthesizer.State.Signal as SigS + +import qualified Algebra.Real as Real +import qualified Algebra.Ring as Ring + +import System.Random (Random, RandomGen, randomR, mkStdGen, ) +import qualified System.Random as Rnd + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +{-| +Deterministic white noise, uniformly distributed between -1 and 1. +That is, variance is 1\/3. +-} +white :: + (Ring.C y, Random y, SigG.Write sig y) => + SigG.LazySize -> sig y +white size = + SigG.fromState size $ Noise.white + +whiteGen :: + (Ring.C y, Random y, RandomGen g, SigG.Write sig y) => + SigG.LazySize -> g -> sig y +whiteGen size = + SigG.fromState size . Noise.whiteGen + + +{- | +Approximates normal distribution with variance 1 +by a quadratic B-spline distribution. +-} +whiteQuadraticBSplineGen :: + (Ring.C y, Random y, RandomGen g, SigG.Write sig y) => + SigG.LazySize -> g -> sig y +whiteQuadraticBSplineGen size = + SigG.fromState size . Noise.whiteQuadraticBSplineGen + + +randomPeeks :: + (Real.C y, Random y, SigG2.Transform sig y Bool) => + sig y {- ^ momentary densities, @p@ means that there is about one peak + in the time range of @1\/p@ samples -} + -> sig Bool {- ^ Every occurence of 'True' represents a peak. -} +randomPeeks = + randomPeeksGen (mkStdGen 876) + +randomPeeksGen :: + (Real.C y, Random y, RandomGen g, SigG2.Transform sig y Bool) => + g + -> sig y + -> sig Bool +randomPeeksGen = + SigG2.zipWithState (<) . SigS.unfoldR (Just . randomR (0,1)) diff --git a/src/Synthesizer/Generic/Oscillator.hs b/src/Synthesizer/Generic/Oscillator.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Generic/Oscillator.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{- | +Copyright : (c) Henning Thielemann 2006 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +Tone generators + +Frequencies are always specified in ratios of the sample rate, +e.g. the frequency 0.01 for the sample rate 44100 Hz +means a physical frequency of 441 Hz. +-} +module Synthesizer.Generic.Oscillator where + +import qualified Synthesizer.State.Oscillator as OsciS +import qualified Synthesizer.Causal.Oscillator as OsciC +import qualified Synthesizer.Causal.Process as Causal + +import qualified Synthesizer.Basic.Wave as Wave +import qualified Synthesizer.Basic.Phase as Phase + +import qualified Synthesizer.Causal.Interpolation as Interpolation + +import qualified Synthesizer.Generic.Signal as SigG +import qualified Synthesizer.Generic.Signal2 as SigG2 + +import Control.Arrow ((>>>), ) + +{- +import qualified Algebra.RealTranscendental as RealTrans +import qualified Algebra.Module as Module +import qualified Algebra.VectorSpace as VectorSpace + +import Algebra.Module((*>)) +-} +import qualified Algebra.Transcendental as Trans +import qualified Algebra.RealField as RealField +-- import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +-- import qualified Number.NonNegative as NonNeg + +import NumericPrelude + +-- import qualified Prelude as P +import PreludeBase + + + +{- * Oscillators with arbitrary but constant waveforms -} + +{- | oscillator with constant frequency -} +static :: (RealField.C a, SigG.Write sig b) => + SigG.LazySize -> + Wave.T a b -> (Phase.T a -> a -> sig b) +static size wave phase freq = + SigG.fromState size (OsciS.static wave phase freq) + +{- | oscillator with modulated frequency -} +freqMod :: (RealField.C a, SigG2.Transform sig a b) => + Wave.T a b -> Phase.T a -> sig a -> sig b +freqMod wave phase = + Causal.applyGeneric (OsciC.freqMod wave phase) + +{- | oscillator with modulated phase -} +phaseMod :: (RealField.C a, SigG2.Transform sig a b) => + Wave.T a b -> a -> sig a -> sig b +phaseMod wave = + shapeMod (Wave.phaseOffset wave) zero + +{- | oscillator with modulated shape -} +shapeMod :: (RealField.C a, SigG2.Transform sig c b) => + (c -> Wave.T a b) -> Phase.T a -> a -> sig c -> sig b +shapeMod wave phase freq = + Causal.applyGeneric (OsciC.shapeMod wave phase freq) + +{- | oscillator with both phase and frequency modulation -} +phaseFreqMod :: (RealField.C a, SigG2.Transform sig a b) => + Wave.T a b -> sig a -> sig a -> sig b +phaseFreqMod wave = + shapeFreqMod (Wave.phaseOffset wave) zero + +{- | oscillator with both shape and frequency modulation -} +shapeFreqMod :: + (RealField.C a, SigG.Read sig c, SigG2.Transform sig a b) => + (c -> Wave.T a b) -> Phase.T a -> sig c -> sig a -> sig b +shapeFreqMod wave phase parameters = + Causal.applyGeneric + (Causal.feedGenericFst parameters >>> + OsciC.shapeFreqMod wave phase) + + +{- | oscillator with a sampled waveform with constant frequency +This is essentially an interpolation with cyclic padding. +-} +staticSample :: (RealField.C a, SigG.Read wave b, SigG.Write sig b) => + SigG.LazySize -> + Interpolation.T a b -> wave b -> Phase.T a -> a -> sig b +staticSample size ip wave phase freq = + let len = fromIntegral $ SigG.length wave + in SigG.fromState size $ + Interpolation.relativeCyclicPad + ip (len * Phase.toRepresentative phase) + (SigG.toState wave) + `Causal.applyConst` + (freq * len) + +{- | oscillator with a sampled waveform with modulated frequency +Should behave homogenously for different types of interpolation. +-} +freqModSample :: (RealField.C a, SigG.Read wave b, SigG2.Transform sig a b) => + Interpolation.T a b -> wave b -> Phase.T a -> sig a -> sig b +freqModSample ip wave phase freqs = + let len = fromIntegral $ SigG.length wave + in Interpolation.relativeCyclicPad + ip (len * Phase.toRepresentative phase) + (SigG.toState wave) + `Causal.applyGeneric` + SigG.map (* len) freqs + + +{- +Shape+phase modulating oscillators can be found in Causal.Oscillator. +-} + +{- * Oscillators with specific waveforms -} + +{- | sine oscillator with static frequency -} +staticSine :: (Trans.C a, RealField.C a, SigG.Write sig a) => + SigG.LazySize -> + Phase.T a -> a -> sig a +staticSine size = + static size Wave.sine + +{- | sine oscillator with modulated frequency -} +freqModSine :: (Trans.C a, RealField.C a, SigG.Transform sig a) => + Phase.T a -> sig a -> sig a +freqModSine phase = + Causal.applyGenericSameType (OsciC.freqMod Wave.sine phase) + +{- | sine oscillator with modulated phase, useful for FM synthesis -} +phaseModSine :: (Trans.C a, RealField.C a, SigG.Transform sig a) => + a -> sig a -> sig a +phaseModSine freq = + Causal.applyGenericSameType (OsciC.phaseMod Wave.sine freq) + +{- | saw tooth oscillator with modulated frequency -} +staticSaw :: (RealField.C a, SigG.Write sig a) => + SigG.LazySize -> + Phase.T a -> a -> sig a +staticSaw size = + static size Wave.saw + +{- | saw tooth oscillator with modulated frequency -} +freqModSaw :: (RealField.C a, SigG.Transform sig a) => + Phase.T a -> sig a -> sig a +freqModSaw phase = + Causal.applyGenericSameType (OsciC.freqMod Wave.saw phase) diff --git a/src/Synthesizer/Generic/Signal.hs b/src/Synthesizer/Generic/Signal.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Generic/Signal.hs @@ -0,0 +1,521 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{- | +Type classes that give a uniform interface to +storable signals, stateful signals, lists, fusable lists. +Some of the signal types require constraints on the element type. +Storable signals require Storable elements. +Thus we need multiparameter type classes. +In this module we collect functions +where the element type is not altered by the function. +-} +module Synthesizer.Generic.Signal + (module Synthesizer.Generic.Signal, + Cut.null, + Cut.length, + Cut.empty, + Cut.cycle, + Cut.append, + Cut.concat, + Cut.take, + Cut.drop, + Cut.dropMarginRem, + Cut.splitAt, + Cut.reverse, + Cut.lengthAtLeast, + Cut.lengthAtMost, + Cut.sliceVertical, + ) where + +import Synthesizer.Generic.Cut (append, ) +import qualified Synthesizer.Generic.Cut as Cut + +import qualified Synthesizer.Plain.Signal as Sig +import qualified Synthesizer.State.Signal as SigS +import qualified Synthesizer.FusionList.Signal as SigFL +import qualified Synthesizer.Storable.Signal as SigSt +import qualified Data.StorableVector.Lazy as Vector + +import qualified Synthesizer.Plain.Modifier as Modifier + +import qualified Algebra.Module as Module +import qualified Algebra.Additive as Additive + +import Foreign.Storable (Storable) + +import Control.Monad.Trans.State (runState, runStateT, ) + +import Data.Function (fix, ) +import qualified Data.List.HT as ListHT +import qualified Data.List as List +import Data.Tuple.HT (mapPair, mapFst, ) + +import Prelude + (Bool, Int, Maybe(Just), maybe, snd, + flip, uncurry, (.), ($), id, + fmap, return, ) + + +class Cut.Read (sig y) => Read sig y where + toList :: sig y -> [y] + toState :: sig y -> SigS.T y +-- toState :: StateT (sig y) Maybe y + foldL :: (s -> y -> s) -> s -> sig y -> s +-- better move to Transform class? + viewL :: sig y -> Maybe (y, sig y) + viewR :: sig y -> Maybe (sig y, y) + +class (Read sig y, Cut.Transform (sig y)) => Transform sig y where + {- | + This function belongs logically to the Write class, + but since an empty signal contains no data, + the maximum package size is irrelevant. + This makes e.g. the definition of mixMulti more general. + -} + cons :: y -> sig y -> sig y + takeWhile :: (y -> Bool) -> sig y -> sig y + dropWhile :: (y -> Bool) -> sig y -> sig y + span :: (y -> Bool) -> sig y -> (sig y, sig y) + -- functions from Transform2 that are oftenly used with only one type variable + map :: (y -> y) -> (sig y -> sig y) + scanL :: (y -> y -> y) -> y -> sig y -> sig y + crochetL :: (y -> s -> Maybe (y, s)) -> s -> sig y -> sig y + zipWithAppend :: (y -> y -> y) -> sig y -> sig y -> sig y + + +{- | +This type is used for specification of the maximum size of strict packets. +Packets can be smaller, can have different sizes in one signal. +In some kinds of streams, like lists and stateful generators, +the packet size is always 1. +The packet size is not just a burden caused by efficiency, +but we need control over packet size in applications with feedback. +-} +newtype LazySize = LazySize Int + +{- | +This can be used for internal signals +that have no observable effect on laziness. +E.g. when you construct a list +by @repeat defaultLazySize zero@ +we assume that 'zero' is defined for all Additive types. +-} +defaultLazySize :: LazySize +defaultLazySize = + let (Vector.ChunkSize size) = Vector.defaultChunkSize + in LazySize size + +{- | +We could provide the 'LazySize' by a Reader monad, +but we don't do that because we expect that the choice of the lazy size +is more local than say the choice of the sample rate. +E.g. there is no need to have the same laziness coarseness +for multiple signal processors. +-} +class Transform sig y => Write sig y where + fromList :: LazySize -> [y] -> sig y +-- fromState :: LazySize -> SigS.T y -> sig y +-- fromState :: LazySize -> StateT s Maybe y -> s -> sig y + repeat :: LazySize -> y -> sig y + replicate :: LazySize -> Int -> y -> sig y + iterate :: LazySize -> (y -> y) -> y -> sig y + iterateAssociative :: LazySize -> (y -> y -> y) -> y -> sig y + unfoldR :: LazySize -> (s -> Maybe (y,s)) -> s -> sig y + + +-- instance Storable y => Read SigSt.T y where +instance Storable y => Read Vector.Vector y where + {-# INLINE toList #-} + toList = Vector.unpack + {-# INLINE toState #-} + toState = SigS.fromStorableSignal + {-# INLINE viewL #-} + viewL = Vector.viewL + {-# INLINE viewR #-} + viewR = Vector.viewR + {-# INLINE foldL #-} + foldL = Vector.foldl + +instance Storable y => Transform Vector.Vector y where + {-# INLINE cons #-} + cons = Vector.cons + {-# INLINE takeWhile #-} + takeWhile = Vector.takeWhile + {-# INLINE dropWhile #-} + dropWhile = Vector.dropWhile + {-# INLINE span #-} + span = Vector.span + + {-# INLINE map #-} + map = Vector.map + {-# INLINE scanL #-} + scanL = Vector.scanl + {-# INLINE crochetL #-} + crochetL = Vector.crochetL + {-# INLINE zipWithAppend #-} + zipWithAppend = SigSt.zipWithAppend + + + +withStorableContext :: + (Vector.ChunkSize -> a) -> (LazySize -> a) +withStorableContext f = + \(LazySize size) -> f (Vector.ChunkSize size) + +instance Storable y => Write Vector.Vector y where + {-# INLINE fromList #-} + fromList = withStorableContext $ \size -> Vector.pack size + {-# INLINE repeat #-} + repeat = withStorableContext $ \size -> Vector.repeat size + {-# INLINE replicate #-} + replicate = withStorableContext $ \size -> Vector.replicate size + {-# INLINE iterate #-} + iterate = withStorableContext $ \size -> Vector.iterate size + {-# INLINE unfoldR #-} + unfoldR = withStorableContext $ \size -> Vector.unfoldr size + {-# INLINE iterateAssociative #-} + iterateAssociative = withStorableContext $ \size op x -> Vector.iterate size (op x) x -- should be optimized + + + +instance Read [] y where + {-# INLINE toList #-} + toList = id + {-# INLINE toState #-} + toState = SigS.fromList + {-# INLINE viewL #-} + viewL = ListHT.viewL + {-# INLINE viewR #-} + viewR = ListHT.viewR + {-# INLINE foldL #-} + foldL = List.foldl + +instance Transform [] y where + {-# INLINE cons #-} + cons = (:) + {-# INLINE takeWhile #-} + takeWhile = List.takeWhile + {-# INLINE dropWhile #-} + dropWhile = List.dropWhile + {-# INLINE span #-} + span = List.span + + {-# INLINE map #-} + map = List.map + {-# INLINE scanL #-} + scanL = List.scanl + {-# INLINE crochetL #-} + crochetL = Sig.crochetL + {-# INLINE zipWithAppend #-} + zipWithAppend = Sig.zipWithAppend + + +instance Write [] y where + {-# INLINE fromList #-} + fromList _ = id + {-# INLINE repeat #-} + repeat _ = List.repeat + {-# INLINE replicate #-} + replicate _ = List.replicate + {-# INLINE iterate #-} + iterate _ = List.iterate + {-# INLINE unfoldR #-} + unfoldR _ = List.unfoldr + {-# INLINE iterateAssociative #-} + iterateAssociative _ = ListHT.iterateAssociative + + + +instance Read SigFL.T y where + {-# INLINE toList #-} + toList = SigFL.toList + {-# INLINE toState #-} + toState = SigS.fromList . SigFL.toList + {-# INLINE viewL #-} + viewL = SigFL.viewL + {-# INLINE viewR #-} + viewR = SigFL.viewR + {-# INLINE foldL #-} + foldL = SigFL.foldL + +instance Transform SigFL.T y where + {-# INLINE cons #-} + cons = SigFL.cons + {-# INLINE takeWhile #-} + takeWhile = SigFL.takeWhile + {-# INLINE dropWhile #-} + dropWhile = SigFL.dropWhile + {-# INLINE span #-} + span = SigFL.span + + {-# INLINE map #-} + map = SigFL.map + {-# INLINE scanL #-} + scanL = SigFL.scanL + {-# INLINE crochetL #-} + crochetL = SigFL.crochetL + {-# INLINE zipWithAppend #-} + zipWithAppend = SigFL.zipWithAppend + + +instance Write SigFL.T y where + {-# INLINE fromList #-} + fromList _ = SigFL.fromList + {-# INLINE repeat #-} + repeat _ = SigFL.repeat + {-# INLINE replicate #-} + replicate _ = SigFL.replicate + {-# INLINE iterate #-} + iterate _ = SigFL.iterate + {-# INLINE unfoldR #-} + unfoldR _ = SigFL.unfoldR + {-# INLINE iterateAssociative #-} + iterateAssociative _ = SigFL.iterateAssociative + + + +instance Read SigS.T y where + {-# INLINE toList #-} + toList = SigS.toList + {-# INLINE toState #-} + toState = id + {-# INLINE viewL #-} + viewL = SigS.viewL + {-# INLINE viewR #-} + viewR = + -- This implementation is slow. Better leave it unimplemented? + fmap (mapFst SigS.fromList) . + ListHT.viewR . SigS.toList + {-# INLINE foldL #-} + foldL = SigS.foldL + +instance Transform SigS.T y where + {-# INLINE cons #-} + cons = SigS.cons + {-# INLINE takeWhile #-} + takeWhile = SigS.takeWhile + {-# INLINE dropWhile #-} + dropWhile = SigS.dropWhile + {-# INLINE span #-} + span p = + -- This implementation is slow. Better leave it unimplemented? + mapPair (SigS.fromList, SigS.fromList) . + List.span p . SigS.toList + + {-# INLINE map #-} + map = SigS.map + {-# INLINE scanL #-} + scanL = SigS.scanL + {-# INLINE crochetL #-} + crochetL = SigS.crochetL + {-# INLINE zipWithAppend #-} + zipWithAppend = SigS.zipWithAppend + + +instance Write SigS.T y where + {-# INLINE fromList #-} + fromList _ = SigS.fromList + {-# INLINE repeat #-} + repeat _ = SigS.repeat + {-# INLINE replicate #-} + replicate _ = SigS.replicate + {-# INLINE iterate #-} + iterate _ = SigS.iterate + {-# INLINE unfoldR #-} + unfoldR _ = SigS.unfoldR + {-# INLINE iterateAssociative #-} + iterateAssociative _ = SigS.iterateAssociative + + + +{-# INLINE switchL #-} +switchL :: (Read sig y) => + a -> (y -> sig y -> a) -> sig y -> a +switchL nothing just = + maybe nothing (uncurry just) . viewL + +{-# INLINE mix #-} +mix :: (Additive.C y, Transform sig y) => + sig y -> sig y -> sig y +mix = zipWithAppend (Additive.+) + +{-# INLINE zipWith #-} +zipWith :: (Read sig a, Transform sig b) => + (a -> b -> b) -> (sig a -> sig b -> sig b) +zipWith h a = + crochetL + (\x0 a0 -> + do (y0,a1) <- viewL a0 + Just (h y0 x0, a1)) + a + + +{-# INLINE delay #-} +delay :: (Write sig y) => + LazySize -> y -> Int -> sig y -> sig y +delay size z n = + append (replicate size n z) + +{-# INLINE delayLoop #-} +delayLoop :: + (Transform sig y) => + (sig y -> sig y) + -- ^ processor that shall be run in a feedback loop + -> sig y -- ^ prefix of the output, its length determines the delay + -> sig y +delayLoop proc prefix = + fix (append prefix . proc) + + +{-# INLINE delayLoopOverlap #-} +delayLoopOverlap :: + (Additive.C y, Write sig y) => + Int + -> (sig y -> sig y) + {- ^ Processor that shall be run in a feedback loop. + It's absolutely necessary that this function preserves the chunk structure + and that it does not look a chunk ahead. + That's guaranteed for processes that do not look ahead at all, + like 'Vector.map', 'Vector.crochetL' and + all of type @Causal.Process@. -} + -> sig y -- ^ input + -> sig y -- ^ output has the same length as the input +delayLoopOverlap time proc xs = + fix (zipWith (Additive.+) xs . + delay defaultLazySize Additive.zero time . proc) + + + +{-# INLINE sum #-} +sum :: (Additive.C a, Read sig a) => sig a -> a +sum = foldL (Additive.+) Additive.zero + +{-# INLINE tails #-} +tails :: (Transform sig y) => sig y -> SigS.T (sig y) +tails = + SigS.unfoldR (fmap (\x -> (x, fmap snd (viewL x)))) . Just + +{-# INLINE mapAdjacent #-} +mapAdjacent :: (Read sig a, Transform sig a) => + (a -> a -> a) -> sig a -> sig a +mapAdjacent f xs0 = + let xs1 = maybe xs0 snd (viewL xs0) + in zipWith f xs0 xs1 + +{-# INLINE modifyStatic #-} +modifyStatic :: (Transform sig a) => + Modifier.Simple s ctrl a a -> ctrl -> sig a -> sig a +modifyStatic (Modifier.Simple state proc) control = + crochetL (\a acc -> Just (runState (proc control a) acc)) state + +{-| Here the control may vary over the time. -} +{-# INLINE modifyModulated #-} +modifyModulated :: (Transform sig a, Read sig ctrl) => + Modifier.Simple s ctrl a a -> sig ctrl -> sig a -> sig a +modifyModulated (Modifier.Simple state proc) control = + crochetL + (\x (acc0,cs0) -> + do (c,cs1) <- viewL cs0 + let (y,acc1) = runState (proc c x) acc0 + return (y,(acc1,cs1))) + (state,control) +{- +modifyModulated (Modifier.Simple state proc) control x = + crochetL + (\ca acc -> Just (runState (uncurry proc ca) acc)) + state (zip control x) +-} + +-- cf. Module.linearComb +{-# INLINE linearComb #-} +linearComb :: + (Module.C t y, Read sig t, Read sig y) => + sig t -> sig y -> y +linearComb ts ys = + SigS.sum (SigS.zipWith (Module.*>) (toState ts) (toState ys)) + + +fromState :: (Write sig y) => + LazySize -> SigS.T y -> sig y +fromState size (SigS.Cons f x) = + unfoldR size (runStateT f) x + +{-# INLINE extendConstant #-} +extendConstant :: (Write sig y) => + LazySize -> sig y -> sig y +extendConstant size xt = + maybe + xt + (append xt . repeat size . snd) + (viewR xt) + + +-- comonadic 'bind' +-- only non-empty suffixes are processed +{-# INLINE mapTails #-} +mapTails :: (Transform sig a) => + (sig a -> a) -> sig a -> sig a +mapTails f x = + crochetL (\_ xs0 -> + do (_,xs1) <- viewL xs0 + Just (f xs0, xs1)) + x x +{- +Implementation with unfoldR is more natural, +but it could not preserve the chunk structure of the input signal. +Thus we prefer crochetL, although we do not consume single elements of the input signal. +-} +mapTailsAlt :: + (Read sig a, Write sig b) => + LazySize -> (sig a -> b) -> sig a -> sig b +mapTailsAlt size f = + unfoldR size (\xs -> + do (_,ys) <- viewL xs + Just (f xs, ys)) + +{- | +Only non-empty suffixes are processed. +More oftenly we might need + +> zipWithTails :: (Read sig b, Transform2 sig a) => +> (b -> sig a -> a) -> sig b -> sig a -> sig a + +this would preserve the chunk structure of @sig a@, +but it is a bit more hassle to implement that. +-} +{-# INLINE zipWithTails #-} +zipWithTails :: (Read sig b, Transform sig a) => + (a -> sig b -> a) -> sig a -> sig b -> sig a +zipWithTails f = + flip (crochetL (\x ys0 -> + do (_,ys) <- viewL ys0 + Just (f x ys0, ys))) + +{- +instance (Additive.C y, Sample.C y, C sig) => Additive.C (sig y) where + (+) = mix + negate = map Additive.negate +-} + + +{- +This does not work, because we can constrain only the instances of Data +but this is not checked when implementing methods of C. + +class Data sig y where + +class C sig where + add :: (Data sig y, Additive.C y) => sig y -> sig y -> sig y + map :: (Data sig a, Data sig b) => (a -> b) -> (sig a -> sig b) + zipWith :: (Data sig a, Data sig b, Data sig c) => + (a -> b -> c) -> (sig a -> sig b -> sig c) +-} + +{- +This does not work, because we would need type parameters for all occuring element types. + +class C sig y where + add :: (Additive.C y) => sig y -> sig y -> sig y + map :: C sig a => (a -> y) -> (sig a -> sig y) + zipWith :: (a -> b -> y) -> (sig a -> sig b -> sig y) +-} diff --git a/src/Synthesizer/Generic/Signal2.hs b/src/Synthesizer/Generic/Signal2.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Generic/Signal2.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{- | +Type class for several signal storage types +that allows alter element types. +There is some overlap between the two @Transform@ classes. +This was done in order to save us +from ubiquitous @Transform sig y y@ constraints. +-} +module Synthesizer.Generic.Signal2 where + +import Synthesizer.Generic.Signal (Read, viewL, sum, ) +import qualified Synthesizer.Generic.Signal as SigG + +import qualified Algebra.Module as Module +-- import qualified Algebra.Additive as Additive + +import qualified Synthesizer.State.Signal as SigS +import qualified Synthesizer.Plain.Signal as Sig +-- import qualified Synthesizer.Storable.Signal as SigSt +import qualified Data.StorableVector.Lazy as Vector + +import qualified Synthesizer.Plain.Modifier as Modifier + +import Foreign.Storable (Storable) + +import Control.Monad.Trans.State (runState, ) + +import qualified Data.List as List + +import Data.Tuple.HT (fst3, snd3, thd3, ) +import Prelude + (Bool, Int, Maybe(Just), maybe, fst, snd, + flip, + return, ) + + +class (SigG.Transform sig y0, SigG.Transform sig y1) => + Transform sig y0 y1 where + map :: (y0 -> y1) -> (sig y0 -> sig y1) + scanL :: (y1 -> y0 -> y1) -> y1 -> sig y0 -> sig y1 + crochetL :: (y0 -> s -> Maybe (y1, s)) -> s -> sig y0 -> sig y1 + + +instance (Storable y0, Storable y1) => Transform Vector.Vector y0 y1 where + {-# INLINE map #-} + map = Vector.map + {-# INLINE scanL #-} + scanL = Vector.scanl + {-# INLINE crochetL #-} + crochetL = Vector.crochetL + + +instance Transform [] y0 y1 where + {-# INLINE map #-} + map = List.map + {-# INLINE scanL #-} + scanL = List.scanl + {-# INLINE crochetL #-} + crochetL = Sig.crochetL + + +instance Transform SigS.T y0 y1 where + {-# INLINE map #-} + map = SigS.map + {-# INLINE scanL #-} + scanL = SigS.scanL + {-# INLINE crochetL #-} + crochetL = SigS.crochetL + + + +{-# INLINE zipWith #-} +zipWith :: (Read sig a, Transform sig b c) => + (a -> b -> c) -> (sig a -> sig b -> sig c) +zipWith h a = + crochetL + (\x0 a0 -> + do (y0,a1) <- viewL a0 + Just (h y0 x0, a1)) + a + +{-# INLINE mapAdjacent #-} +mapAdjacent :: (Read sig a, Transform sig a b) => + (a -> a -> b) -> sig a -> sig b +mapAdjacent f xs0 = + let xs1 = maybe xs0 snd (viewL xs0) + in zipWith f xs0 xs1 + + +{-# INLINE zip #-} +zip :: (Read sig a, Transform sig b (a,b)) => + sig a -> sig b -> sig (a,b) +zip = zipWith (,) + + +{-# INLINE unzip #-} +unzip :: (Transform sig (a,b) a, Transform sig (a,b) b) => + sig (a,b) -> (sig a, sig b) +unzip xs = + (map fst xs, map snd xs) + +{-# INLINE unzip3 #-} +unzip3 :: (Transform sig (a,b,c) a, Transform sig (a,b,c) b, Transform sig (a,b,c) c) => + sig (a,b,c) -> (sig a, sig b, sig c) +unzip3 xs = + (map fst3 xs, map snd3 xs, map thd3 xs) + + + +{-# INLINE modifyStatic #-} +modifyStatic :: (Transform sig a b) => + Modifier.Simple s ctrl a b -> ctrl -> sig a -> sig b +modifyStatic (Modifier.Simple state proc) control = + crochetL (\a acc -> Just (runState (proc control a) acc)) state + +{-| Here the control may vary over the time. -} +{-# INLINE modifyModulated #-} +modifyModulated :: (Transform sig a b, Read sig ctrl) => + Modifier.Simple s ctrl a b -> sig ctrl -> sig a -> sig b +modifyModulated (Modifier.Simple state proc) control = + crochetL + (\x (acc0,cs0) -> + do (c,cs1) <- viewL cs0 + let (y,acc1) = runState (proc c x) acc0 + return (y,(acc1,cs1))) + (state,control) + +linearComb :: + (Module.C t y, Read sig t, Transform sig y y) => + sig t -> sig y -> y +linearComb ts ys = + sum (zipWith (Module.*>) ts ys) + +mapTails :: (Transform sig a b) => + (sig a -> b) -> sig a -> sig b +mapTails f x = + crochetL (\_ xs0 -> + do (_,xs1) <- viewL xs0 + Just (f xs0, xs1)) + x x + +{-# INLINE zipWithTails #-} +zipWithTails :: (Read sig b, Transform sig a c) => + (a -> sig b -> c) -> sig a -> sig b -> sig c +zipWithTails f = + flip (crochetL (\x ys0 -> + do (_,ys) <- viewL ys0 + Just (f x ys0, ys))) + +{-# INLINE zipWith2Tails #-} +zipWith2Tails :: (Read sig b, Read sig c, Transform sig a d) => + (a -> sig b -> sig c -> d) -> sig a -> sig b -> sig c -> sig d +zipWith2Tails f as bs cs = + crochetL (\x (ys0,zs0) -> + do (_,ys1) <- viewL ys0 + (_,zs1) <- viewL zs0 + Just (f x ys0 zs0, (ys1,zs1))) + (bs,cs) as + +zipWithState :: (Transform sig b c) => + (a -> b -> c) -> SigS.T a -> sig b -> sig c +zipWithState f = + crochetL (\b as0 -> + do (a,as1) <- SigS.viewL as0 + Just (f a b, as1)) diff --git a/src/Synthesizer/Generic/Tutorial.hs b/src/Synthesizer/Generic/Tutorial.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Generic/Tutorial.hs @@ -0,0 +1,231 @@ +{-# LANGUAGE FlexibleContexts #-} +{- | +In this module we demonstrate techniques for getting sound in real-time. +Getting real-time performance is mostly an issue of the right signal data structure. +However, there is no one-size-fits-all data structure. +For choosing the right one, you need to understand how various data structures work, +what are their strengths and what are their weaknesses. +-} +module Synthesizer.Generic.Tutorial +{-# DEPRECATED "do not import that module, it is only intended for demonstration" #-} + where + +import qualified Synthesizer.Plain.Tutorial as Tutorial -- needed for Haddock + +import qualified Sound.Sox.Play as Play +import qualified Sound.Sox.Option.Format as SoxOpt +import qualified Synthesizer.Basic.Binary as BinSmp +import qualified Synthesizer.Storable.Signal as SigSt +import qualified Synthesizer.Generic.Signal as SigG +import qualified Synthesizer.Generic.Signal2 as SigG2 +import qualified Synthesizer.State.Signal as Sig +import qualified Synthesizer.Causal.Process as Causal +import Control.Arrow ((&&&), (^<<), (<<^), (<<<), ) + +import qualified Synthesizer.Generic.Oscillator as Osci +import qualified Synthesizer.Generic.Filter.NonRecursive as Filt +import qualified Synthesizer.Plain.Filter.Recursive as FiltRec +import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilter +import qualified Synthesizer.Basic.Wave as Wave + +import qualified Synthesizer.State.Control as CtrlS +import qualified Synthesizer.State.Oscillator as OsciS + +import System.Exit (ExitCode, ) +import NumericPrelude +import PreludeBase +import Prelude () + + +{- | +First, we define a play routine for lazy storable vectors. +Storable lazy vectors are lazy lists of low-level arrays. +They are both efficient in time and memory consumption, +but the blocks disallow feedback by small delays. +Elements of a storable vector must be of type class Storable. +This means that elements must have fixed size +and advanced data types like functions cannot be used. +-} +play :: SigSt.T Double -> IO ExitCode +play = + Play.simple SigSt.hPut SoxOpt.none 44100 . + SigSt.map BinSmp.int16FromDouble + +{- | +Here is a simple oscillator generated as lazy storable vector. +An oscillator is a signal generator, +that is it produces a signal +without consuming other signals that correspond in time. +Signal generators have the maximal block size as parameter. +This is the lower limit of possible feedback delays. +-} +oscillator :: IO ExitCode +oscillator = + play (Osci.static SigG.defaultLazySize Wave.sine zero (0.01::Double)) + +{- | +We rewrite the filter example 'Tutorial.filterSaw' +in terms of type classes for more signal types. +The constraints become quite large +because we must assert, that a particular sample type +can be used in the addressed signal type. +-} +filterSawSig :: + (SigG.Write sig Double, + SigG2.Transform sig (UniFilter.Result Double) Double, + SigG2.Transform sig Double (UniFilter.Result Double), + SigG2.Transform sig Double (UniFilter.Parameter Double)) => + sig Double +filterSawSig = + SigG2.map UniFilter.lowpass $ SigG2.modifyModulated UniFilter.modifier (SigG2.map (\f -> UniFilter.parameter $ FiltRec.Pole 10 (0.04+0.02*f)) $ Osci.static SigG.defaultLazySize Wave.sine zero (0.00001::Double)) $ Osci.static SigG.defaultLazySize Wave.saw zero (0.002::Double) + +{- | +Here we instantiate 'filterSawSig' for storable vectors and play it. +This means that all operations convert a storable vector into another storable vector. +While every single operation probably is as efficient as possible, +the composition of all those processes could be more efficient. +So keep on reading. +-} +filterSaw :: IO ExitCode +filterSaw = + play filterSawSig + + +{- | +The next signal type we want to consider is the stateful signal generator. +It is not a common data structure, where the sample values are materialized. +Instead it is a description of how to generate sample values iteratively. +This is almost identical to the @Data.Stream@ module from the @stream-fusion@ package. +With respect to laziness and restrictions of the sample type (namely none), +this signal representation is equivalent to lists. +You can convert one into the other in a lossless way. +That is, function as sample type is possible. +Combination of such signal generators is easily possible +and does not require temporary storage, +because this signal representation needs no sample value storage at all. +However at the end of such processes, the signal must be materialized. +Here we write the result into a lazy storable vector and play that. +What the compiler actually does is to create a single loop, +that generates the storable vector to be played in one go. +-} +playState :: Sig.T Double -> IO ExitCode +playState = + Play.simple SigSt.hPut SoxOpt.none 44100 . + SigG.fromState SigG.defaultLazySize . + Sig.map BinSmp.int16FromDouble + +{- | +We demonstrate the stateful signal generator using the known 'filterSaw' example. +Actually we can reuse the code from above, +because the signal generator is also an instance of the generic signal class. +-} +filterSawState :: IO ExitCode +filterSawState = + playState filterSawSig + + +{- | +Merging subsequent signal processes based on signal generators +into an efficient large signal processor is easy. +Not storing intermediate results is however a problem in another situation: +Sometimes you want to share one signal between several processes. +-} +filterPingStateProc :: Sig.T Double -> Sig.T Double +filterPingStateProc env = + Filt.envelope env $ Sig.map UniFilter.lowpass $ Sig.modifyModulated UniFilter.modifier (Sig.map (\f -> UniFilter.parameter $ FiltRec.Pole 10 (0.03*f)) $ env) $ OsciS.static Wave.saw zero (0.002::Double) + +{- | +In the following example we generate an exponential curve +which shall be used both as envelope +and as resonance frequency control of a resonant lowpass. +Actually, recomputing an exponential curve is not an issue, +since it only needs one multiplication per sample. +But it is simple enough to demonstrate the problem and its solutions. +The expression @let env = exponential2 50000 1@ fools the reader of the program, +since the @env@ that is shared, is only the signal generator, +that is, the description of how to compute the exponential curve successively. +That is wherever a signal process reads @env@, it is computed again. +-} +filterPingState :: IO ExitCode +filterPingState = + playState $ + filterPingStateProc $ + CtrlS.exponential2 50000 1 + +{- | +You can achieve sharing by a very simple way. +You can write the result of the signal generator in a list ('Sig.toList') +and use this list as source for a new generator ('Sig.fromList'). +'Sig.fromList' provides a signal generator that generates new sample values +by delivering the next sample from the list. + +In a real world implementation you would move +the @Sig.fromList . Sig.toList@ to 'filterPingStateProc', +since the caller cannot know, that this function uses the signal twice, +and the implementor of 'filterPingStateProc' cannot know, +how expensive the computation of @env@ is. + +You can use any other signal type for sharing, e.g. storable vectors, +but whatever type you choose, you also get its disadvantages. +Namely, storable vectors only work for storable samples +and lists are generally slow, +and they also cannot be optimized away, +since this only works, when no sharing is required. + +Whenever a signal is shared as input between several signal processes, +the actual materialized data is that +between the slowest and the fastest reading process. +This is due to lazy evaluation and garbage collection. +If the different readers read with different speed, +then you will certainly need a temporary sample storage. +-} +filterPingShare :: IO ExitCode +filterPingShare = + playState $ + filterPingStateProc $ + Sig.fromList $ Sig.toList $ CtrlS.exponential2 50000 1 + +{- | +It is however not uncommon that all readers read with the same speed. +In this case we would in principle only need to share the input signal per sample. +This way we would not need a data structure +for storing a sub-sequence of samples temporarily. +But how to do that practically? + +The solution is not to think in terms of signals and signal processors, +e.g. @Sig.T a@ and @Sig.T a -> Sig.T b -> Sig.T c@, respectively, +but in terms of signal processors, that are guaranteed to run in sync. +That is we must assert that signal processors +process the samples in chronological order and emit one sample per input sample. +We call such processes \"causal\" processes. +For example @Causal.T (a,b) c@ represents the function @Sig.T (a,b) -> Sig.T c@ +but it also carries the guarantee, +that for each input of type @(a,b)@ +one sample of type @c@ is emitted or the output terminates. +Internally it is the Kleisli arrow of the @StateT Maybe@ monad. + +Another important application of the Causal arrow is feedback. +Using causal processes guarantees, that a process cannot read ahead, +such that it runs into future data, which does still not exist due to recursion. + +Programming with arrows needs a bit experience or Haskell extensions. +Haskell extensions are either an @Arrow@ syntax preprocessor +or the preprocessor that is built into GHC. +However, for computing with physical dimensions +you can no longer use the original @Arrow@ class +and thus you cannot use the arrow syntax. +So here is an example of how to program 'filterPingShare' +using @Arrow@ combinators. +-} +filterPingCausal :: IO ExitCode +filterPingCausal = + playState $ + let proc = + uncurry (*) ^<< + ((UniFilter.lowpass ^<< + UniFilter.causal <<< + Causal.feedSnd (OsciS.static Wave.saw zero (0.002::Double)) <<^ + (\f -> UniFilter.parameter $ FiltRec.Pole 10 (0.03*f))) + &&& + Causal.id) + in Causal.apply proc $ CtrlS.exponential2 50000 1 diff --git a/src/Synthesizer/Generic/Wave.hs b/src/Synthesizer/Generic/Wave.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Generic/Wave.hs @@ -0,0 +1,48 @@ +module Synthesizer.Generic.Wave where + +import qualified Synthesizer.State.ToneModulation as ToneMod +import qualified Synthesizer.Basic.Wave as Wave + +import qualified Synthesizer.Generic.Signal as SigG + +import qualified Synthesizer.Interpolation as Interpolation + +import qualified Algebra.RealField as RealField + +-- import Data.Tuple.HT (swap, ) + +import NumericPrelude +import PreludeBase +import Prelude () + + +sample :: + (RealField.C a, SigG.Transform sig v) => + Interpolation.T a v -> sig v -> Wave.T a v +sample ip wave = + let len = SigG.length wave + cycleWave = SigG.cycle wave + in Wave.fromFunction $ \ phase -> + let (n,q) = RealField.splitFraction (phase * fromIntegral len) + in Interpolation.func ip q $ + SigG.toState $ + SigG.drop n cycleWave + + +{- | +Interpolate first within waves and then across waves, +which is simpler but maybe less efficient for lists. +However for types with fast indexing/drop like StorableVector this is optimal. +-} +sampledTone :: + (RealField.C a, SigG.Transform sig v) => + Interpolation.T a v -> + Interpolation.T a v -> + a -> sig v -> a -> Wave.T a v +sampledTone ipLeap ipStep period tone shape = Wave.Cons $ \phase -> +-- uncurry (ToneMod.interpolateCell ipStep ipLeap . swap) $ + uncurry (ToneMod.interpolateCell ipLeap ipStep) $ + ToneMod.sampledToneCell + (ToneMod.makePrototype (Interpolation.margin ipLeap) (Interpolation.margin ipStep) period tone) + shape phase + diff --git a/src/Synthesizer/Interpolation.hs b/src/Synthesizer/Interpolation.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Interpolation.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Synthesizer.Interpolation where + +import qualified Synthesizer.State.Signal as Sig + +import Control.Monad.Trans.State (StateT(StateT), evalStateT, ) +import Control.Monad.Trans.Writer (Writer, writer, runWriter, ) +import Data.Monoid (Sum(Sum), ) +import Control.Applicative (Applicative(pure, (<*>)), (<$>), liftA2, ) + +import PreludeBase +import NumericPrelude + + + + +{- | interpolation as needed for resampling -} +data T t y = + Cons { + margin :: !Margin, + func :: !(t -> Sig.T y -> y) + } + +data Margin = + Margin { + marginNumber :: !Int, + -- ^ interpolation requires a total number of 'number' + marginOffset :: !Int + -- ^ interpolation requires 'offset' values before the current + } + deriving (Show, Eq) + +cons :: Int -> Int -> (t -> Sig.T y -> y) -> T t y +cons num off = + Cons (Margin num off) + +number :: T t y -> Int +number = marginNumber . margin + +offset :: T t y -> Int +offset = marginOffset . margin + + + +{-* Different kinds of interpolation -} + +{-** Hard-wired interpolations -} + +{- +Applicative composition of two applicative functors, +namely @Writer@ and @StateT Maybe@. +We could also use (.:) from TypeCompose. +-} +newtype PrefixReader y a = + PrefixReader (Writer (Sum Int) (StateT (Sig.T y) Maybe a)) + +instance Functor (PrefixReader y) where + {-# INLINE fmap #-} + fmap f (PrefixReader m) = + PrefixReader (fmap (fmap f) m) + +instance Applicative (PrefixReader y) where + {-# INLINE pure #-} + {-# INLINE (<*>) #-} + pure = PrefixReader . pure . pure + (PrefixReader f) <*> (PrefixReader x) = + PrefixReader (liftA2 (<*>) f x) + + +{-# INLINE getNode #-} +getNode :: PrefixReader y y +getNode = + PrefixReader $ writer (StateT Sig.viewL, Sum 1) + +{-# INLINE fromPrefixReader #-} +fromPrefixReader :: String -> Int -> PrefixReader y (t -> y) -> T t y +fromPrefixReader name off (PrefixReader pr) = + let (parser, Sum count) = runWriter pr + in cons count off + (\t xs -> + maybe + (error (name ++ " interpolation: not enough nodes")) + ($t) + (evalStateT parser xs)) + +{-| Consider the signal to be piecewise constant. -} +{-# INLINE constant #-} +constant :: T t y +constant = + fromPrefixReader "constant" 0 (const <$> getNode) diff --git a/src/Synthesizer/Interpolation/Class.hs b/src/Synthesizer/Interpolation/Class.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Interpolation/Class.hs @@ -0,0 +1,202 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{- | +See NumericPrelude.AffineSpace for design discussion. +-} +module Synthesizer.Interpolation.Class where + +import qualified Synthesizer.State.Signal as Sig + +import qualified Algebra.Module as Module +import qualified Algebra.PrincipalIdealDomain as PID +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import qualified Number.Ratio as Ratio +import qualified Number.Complex as Complex + +import Control.Applicative (Applicative(pure, (<*>)), ) +import Data.Tuple.HT (mapPair, mapSnd, fst3, snd3, thd3, ) + +import NumericPrelude hiding (zero, ) +import PreludeBase +import Prelude () + +{- | +Given that @scale zero v == Additive.zero@ +this type class is equivalent to Module in the following way: + +> scaleAndAccumulate (a,x) = +> let ax = a *> x +> in (ax, (ax+)) + +(see implementation of 'scaleAndAccumulateModule') +and + +> x+y = scaleAccumulate one y $ scale one x +> zero = scale zero x +> s*>x = scale s x + +But this redundancy is only because of a lack of the type system +or lack of my imagination how to solve it better. +Use this type class for all kinds of interpolation, +that is where addition and scaling alone make no sense. + +I intended to name this class AffineSpace, +because all interpolations should be affine combinations. +This property is equivalent to interpolations that preserve constant functions. +However, I cannot easily assert this property +and I'm not entirely sure +that all reasonable interpolations are actually affine. + +Early versions had a @zero@ method, +but this is against the idea of interpolation. +For implementing @zero@ we needed a @Maybe@ wrapper +for interpolation of @StorableVector@s. +Btw. having @zero@ instead of @scale@ is also inefficient, +since every sum must include a zero summand, +which works well only when the optimizer +simplifies addition with a constant. + +We use only one class method +that contains actually two methods: +@scale@ and @scaleAccumulate@. +We expect that instances are always defined on record types +lifting interpolations from scalars to records. +This should be done using 'makeMac' and friends +or the 'MAC' type and the 'Applicative' interface +for records with many elements. +-} +class Ring.C a => C a v where + scaleAndAccumulate :: (a,v) -> (v, v -> v) + + +instance C Float Float where + {-# INLINE scaleAndAccumulate #-} + scaleAndAccumulate = scaleAndAccumulateRing + +instance C Double Double where + {-# INLINE scaleAndAccumulate #-} + scaleAndAccumulate = scaleAndAccumulateRing + +instance (C a v) => C a (Complex.T v) where + {-# INLINE scaleAndAccumulate #-} + scaleAndAccumulate = + makeMac2 (Complex.+:) Complex.real Complex.imag + +instance (PID.C a) => C (Ratio.T a) (Ratio.T a) where + {-# INLINE scaleAndAccumulate #-} + scaleAndAccumulate = scaleAndAccumulateRing + +instance (C a v, C a w) => C a (v, w) where + {-# INLINE scaleAndAccumulate #-} + scaleAndAccumulate = makeMac2 (,) fst snd + +instance (C a v, C a w, C a u) => C a (v, w, u) where + {-# INLINE scaleAndAccumulate #-} + scaleAndAccumulate = makeMac3 (,,) fst3 snd3 thd3 + + + +infixl 6 +.* + +{-# INLINE scale #-} +scale :: C a v => (a,v) -> v +scale = fst . scaleAndAccumulate + +{-# INLINE scaleAccumulate #-} +scaleAccumulate :: C a v => (a,v) -> v -> v +scaleAccumulate = snd . scaleAndAccumulate + +{- | +Infix variant of 'scaleAccumulate'. +-} +{-# INLINE (+.*) #-} +(+.*) :: C a v => v -> (a,v) -> v +(+.*) = flip scaleAccumulate + + +combine2 :: C a v => a -> (v, v) -> v +combine2 a (x,y) = + scaleAccumulate (one-a, x) $ + scale (a, y) + +combineMany :: C a v => (a, Sig.T a) -> (v, Sig.T v) -> v +combineMany (a,as) (v,vs) = + Sig.foldL (flip scaleAccumulate) (scale (a,v)) $ + Sig.zip as vs + + +-- * convenience functions for defining scaleAndAccumulate + +{-# INLINE scaleAndAccumulateRing #-} +scaleAndAccumulateRing :: + Ring.C a => + (a,a) -> (a, a -> a) +scaleAndAccumulateRing (a,x) = + let ax = a * x + in (ax, (ax+)) + +{-# INLINE scaleAndAccumulateModule #-} +scaleAndAccumulateModule :: + Module.C a v => + (a,v) -> (v, v -> v) +scaleAndAccumulateModule (a,x) = + let ax = a *> x + in (ax, (ax+)) + + +{- | +A special reader monad. +-} +newtype MAC a v x = MAC {runMac :: (a,v) -> (x, v -> x)} + +{-# INLINE element #-} +element :: + (C a x) => + (v -> x) -> MAC a v x +element f = + MAC $ \(a,x) -> + mapSnd (.f) $ scaleAndAccumulate (a, f x) + +instance Functor (MAC a v) where + {-# INLINE fmap #-} + fmap f (MAC x) = + MAC $ mapPair (f, (f .)) . x + +instance Applicative (MAC a v) where + {-# INLINE pure #-} + {-# INLINE (<*>) #-} + pure x = MAC $ const (x, const x) + MAC f <*> MAC x = + MAC $ \av -> + let (xav,add) = x av + (g,fadd) = f av + in (g xav, \y -> fadd y (add y)) + +{-# INLINE makeMac #-} +makeMac :: + (C a x) => + (x -> v) -> + (v -> x) -> + (a,v) -> (v, v -> v) +makeMac cons x = + runMac $ pure cons <*> element x + +{-# INLINE makeMac2 #-} +makeMac2 :: + (C a x, C a y) => + (x -> y -> v) -> + (v -> x) -> (v -> y) -> + (a,v) -> (v, v -> v) +makeMac2 cons x y = + runMac $ pure cons <*> element x <*> element y + +{-# INLINE makeMac3 #-} +makeMac3 :: + (C a x, C a y, C a z) => + (x -> y -> z -> v) -> + (v -> x) -> (v -> y) -> (v -> z) -> + (a,v) -> (v, v -> v) +makeMac3 cons x y z = + runMac $ pure cons <*> element x <*> element y <*> element z diff --git a/src/Synthesizer/Interpolation/Custom.hs b/src/Synthesizer/Interpolation/Custom.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Interpolation/Custom.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{- | +Special interpolations defined in terms of our custom Interpolation class. +-} +module Synthesizer.Interpolation.Custom ( + T, + constant, + linear, + cubic, + piecewise, + piecewiseConstant, + piecewiseLinear, + piecewiseCubic, + function, + ) where + +import qualified Synthesizer.State.Signal as Sig +import qualified Synthesizer.Plain.Control as Ctrl +import qualified Synthesizer.Interpolation.Class as Interpol + +import Synthesizer.Interpolation ( + T, cons, getNode, fromPrefixReader, + constant, + ) + +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Synthesizer.Interpolation.Class ((+.*), ) + +import Control.Applicative (liftA2, ) +import Synthesizer.ApplicativeUtility (liftA4, ) + +import PreludeBase +import NumericPrelude + + + +{-| Consider the signal to be piecewise linear. -} +{-# INLINE linear #-} +linear :: (Interpol.C t y) => T t y +linear = + fromPrefixReader "linear" 0 + (liftA2 + (\x0 x1 phase -> Interpol.combine2 phase (x0,x1)) + getNode getNode) + +{-| +Consider the signal to be piecewise cubic, +with smooth connections at the nodes. +It uses a cubic curve which has node values +x0 at 0 and x1 at 1 and derivatives +(x1-xm1)/2 and (x2-x0)/2, respectively. +You can see how it works +if you evaluate the expression for t=0 and t=1 +as well as the derivative at these points. +-} +{-# INLINE cubic #-} +cubic :: (Field.C t, Interpol.C t y) => T t y +cubic = + fromPrefixReader "cubicAlt" 1 $ liftA4 + (\xm1 x0 x1 x2 t -> + let (am1, a0, a1) = cubicHalf t + ( b2, b1, b0) = cubicHalf (1-t) + in Interpol.scale (am1,xm1) + +.* (a0+b0,x0) + +.* (a1+b1,x1) + +.* (b2,x2)) + getNode getNode getNode getNode + +{- | +See 'cubicHalfModule'. +-} +{-# INLINE cubicHalf #-} +cubicHalf :: (Field.C t) => t -> (t,t,t) +cubicHalf t = + let c = (t-1)^2 + ct2 = c*t/2 + in (-ct2, c*(1+2*t), ct2) + + +{-** Interpolation based on piecewise defined functions -} + +{- | +List of functions must be non-empty. +-} +{-# INLINE piecewise #-} +piecewise :: (Interpol.C t y) => + Int -> [t -> t] -> T t y +piecewise center ps = + cons (length ps) (center-1) $ + \t -> + combineMany + "Interpolation.element: list of functions empty" + "Interpolation.element: list of samples empty" $ + Sig.map ($t) $ Sig.fromList $ reverse ps + +{-# INLINE piecewiseConstant #-} +piecewiseConstant :: (Interpol.C t y) => T t y +piecewiseConstant = + piecewise 1 [const 1] + +{-# INLINE piecewiseLinear #-} +piecewiseLinear :: (Interpol.C t y) => T t y +piecewiseLinear = + piecewise 1 [id, (1-)] + +{-# INLINE piecewiseCubic #-} +piecewiseCubic :: (Field.C t, Interpol.C t y) => T t y +piecewiseCubic = + piecewise 2 $ + Ctrl.cubicFunc (0,(0,0)) (1,(0,1/2)) : + Ctrl.cubicFunc (0,(0,1/2)) (1,(1,0)) : + Ctrl.cubicFunc (0,(1,0)) (1,(0,-1/2)) : + Ctrl.cubicFunc (0,(0,-1/2)) (1,(0,0)) : + [] + +{- +GNUPlot.plotList [] $ take 100 $ interpolate (Zero 0) piecewiseCubic (-2.3 :: Double) (repeat 0.1) [2,1,2::Double] +-} + + +{-** Interpolation based on arbitrary functions -} + +{- | with this wrapper you can use the collection of interpolating functions from Donadio's DSP library -} +{-# INLINE function #-} +function :: (Interpol.C t y) => + (Int,Int) {- ^ @(left extent, right extent)@, e.g. @(1,1)@ for linear hat -} + -> (t -> t) + -> T t y +function (left,right) f = + let len = left+right + ps = Sig.take len $ Sig.iterate pred (pred right) + -- ps = Sig.reverse $ Sig.take len $ Sig.iterate succ (-left) + in cons len left $ + \t -> + combineMany + "Interpolation.function: empty function domain" + "Interpolation.function: list of samples empty" $ + Sig.map (\x -> f (t + fromIntegral x)) ps +{- +GNUPlot.plotList [] $ take 300 $ interpolate (Zero 0) (function (1,1) (\x -> exp (-6*x*x))) (-2.3 :: Double) (repeat 0.03) [2,1,2::Double] +-} + +combineMany :: + (Interpol.C a v) => + String -> String -> + Sig.T a -> Sig.T v -> v +combineMany msgCoefficients msgSamples ct xt = + Sig.switchL (error msgCoefficients) + (\c cs -> + Sig.switchL (error msgSamples) + (curry (Interpol.combineMany (c,cs))) + xt) + ct diff --git a/src/Synthesizer/Interpolation/Module.hs b/src/Synthesizer/Interpolation/Module.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Interpolation/Module.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{- | +Special interpolations defined in terms of Module operations. +-} +module Synthesizer.Interpolation.Module ( + T, + constant, + linear, + cubic, + cubicAlt, + piecewise, + piecewiseConstant, + piecewiseLinear, + piecewiseCubic, + function, + ) where + +import qualified Synthesizer.State.Signal as Sig +import qualified Synthesizer.Plain.Control as Ctrl + +import Synthesizer.Interpolation ( + T, cons, getNode, fromPrefixReader, + constant, + ) + +import qualified Algebra.Module as Module +-- import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Algebra.Module((*>)) + +import Control.Applicative (liftA2, ) +import Synthesizer.ApplicativeUtility (liftA4, ) +import Synthesizer.Utility (affineComb, ) + +import PreludeBase +import NumericPrelude + + +{-| Consider the signal to be piecewise linear. -} +{-# INLINE linear #-} +linear :: (Module.C t y) => T t y +linear = + fromPrefixReader "linear" 0 + (liftA2 + (\x0 x1 phase -> affineComb phase (x0,x1)) + getNode getNode) + +{- | +Consider the signal to be piecewise cubic, +with smooth connections at the nodes. +It uses a cubic curve which has node values +x0 at 0 and x1 at 1 and derivatives +(x1-xm1)/2 and (x2-x0)/2, respectively. +You can see how it works +if you evaluate the expression for t=0 and t=1 +as well as the derivative at these points. +-} +{-# INLINE cubic #-} +cubic :: (Field.C t, Module.C t y) => T t y +cubic = + fromPrefixReader "cubic" 1 + (liftA4 + (\xm1 x0 x1 x2 t -> + let lipm12 = affineComb t (xm1,x2) + lip01 = affineComb t (x0, x1) + three = 3 `asTypeOf` t + in lip01 + (t*(t-1)/2) *> + (lipm12 + (x0+x1) - three *> lip01)) + getNode getNode getNode getNode) + +{- | +The interpolators for module operations +do not simply compute a straight linear combination of some vectors. +Instead they add then scale, then add again, and so on. +This is efficient whenever scaling and addition is cheap. +In this case they might save multiplications. +I can't say much about numeric cancellations, however. +-} +{-# INLINE cubicAlt #-} +cubicAlt :: (Field.C t, Module.C t y) => T t y +cubicAlt = + fromPrefixReader "cubicAlt" 1 + (liftA4 + (\xm1 x0 x1 x2 t -> + let half = 1/2 `asTypeOf` t + in cubicHalf t x0 (half *> (x1-xm1)) + + cubicHalf (1-t) x1 (half *> (x0-x2))) + getNode getNode getNode getNode) + + +{- | +@\t -> cubicHalf t x x'@ has a double zero at 1 and +at 0 it has value x and slope x'. +-} +{-# INLINE cubicHalf #-} +cubicHalf :: (Module.C t y) => t -> y -> y -> y +cubicHalf t x x' = + (t-1)^2 *> ((1+2*t)*>x + t*>x') + + + +{-** Interpolation based on piecewise defined functions -} + +{-# INLINE piecewise #-} +piecewise :: (Module.C t y) => + Int -> [t -> t] -> T t y +piecewise center ps = + cons (length ps) (center-1) + (\t -> Sig.linearComb (Sig.fromList (map ($t) (reverse ps)))) + +{-# INLINE piecewiseConstant #-} +piecewiseConstant :: (Module.C t y) => T t y +piecewiseConstant = + piecewise 1 [const 1] + +{-# INLINE piecewiseLinear #-} +piecewiseLinear :: (Module.C t y) => T t y +piecewiseLinear = + piecewise 1 [id, (1-)] + +{-# INLINE piecewiseCubic #-} +piecewiseCubic :: (Field.C t, Module.C t y) => T t y +piecewiseCubic = + piecewise 2 $ + Ctrl.cubicFunc (0,(0,0)) (1,(0,1/2)) : + Ctrl.cubicFunc (0,(0,1/2)) (1,(1,0)) : + Ctrl.cubicFunc (0,(1,0)) (1,(0,-1/2)) : + Ctrl.cubicFunc (0,(0,-1/2)) (1,(0,0)) : + [] + +{- +GNUPlot.plotList [] $ take 100 $ interpolate (Zero 0) piecewiseCubic (-2.3 :: Double) (repeat 0.1) [2,1,2::Double] +-} + + +{-** Interpolation based on arbitrary functions -} + +{- | with this wrapper you can use the collection of interpolating functions from Donadio's DSP library -} +{-# INLINE function #-} +function :: (Module.C t y) => + (Int,Int) {- ^ @(left extent, right extent)@, e.g. @(1,1)@ for linear hat -} + -> (t -> t) + -> T t y +function (left,right) f = + let len = left+right + ps = Sig.take len $ Sig.iterate pred (pred right) + -- ps = Sig.reverse $ Sig.take len $ Sig.iterate succ (-left) + in cons len left + (\t -> Sig.linearComb $ + Sig.map (\x -> f (t + fromIntegral x)) ps) +{- +GNUPlot.plotList [] $ take 300 $ interpolate (Zero 0) (function (1,1) (\x -> exp (-6*x*x))) (-2.3 :: Double) (repeat 0.03) [2,1,2::Double] +-} diff --git a/src/Synthesizer/Piecewise.hs b/src/Synthesizer/Piecewise.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Piecewise.hs @@ -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 diff --git a/src/Synthesizer/Plain/Analysis.hs b/src/Synthesizer/Plain/Analysis.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Plain/Analysis.hs @@ -0,0 +1,342 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +module Synthesizer.Plain.Analysis where + +import qualified Synthesizer.Plain.Signal as Sig +import qualified Synthesizer.Plain.Control as Ctrl +import qualified Synthesizer.Plain.Filter.Recursive.Integration as Integration + +-- import qualified Algebra.Module as Module +-- import qualified Algebra.Transcendental as Trans +import qualified Algebra.Algebraic as Algebraic +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Real as Real +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import qualified Algebra.NormedSpace.Maximum as NormedMax +import qualified Algebra.NormedSpace.Euclidean as NormedEuc +import qualified Algebra.NormedSpace.Sum as NormedSum + +import qualified Data.Array as Array + +import qualified Data.IntMap as IntMap + +-- import Algebra.Module((*>)) + +import Data.Array (accumArray) +import Data.List (foldl', ) + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +{- * Notions of volume -} + +{- | +Volume based on Manhattan norm. +-} +volumeMaximum :: (Real.C y) => Sig.T y -> y +volumeMaximum = + foldl max zero . rectify +-- maximum . rectify + +{- | +Volume based on Energy norm. +-} +volumeEuclidean :: (Algebraic.C y) => Sig.T y -> y +volumeEuclidean = + Algebraic.sqrt . volumeEuclideanSqr + +volumeEuclideanSqr :: (Field.C y) => Sig.T y -> y +volumeEuclideanSqr = + average . map sqr + +{- | +Volume based on Sum norm. +-} +volumeSum :: (Field.C y, Real.C y) => Sig.T y -> y +volumeSum = average . rectify + + + +{- | +Volume based on Manhattan norm. +-} +volumeVectorMaximum :: (NormedMax.C y yv, Ord y) => Sig.T yv -> y +volumeVectorMaximum = + NormedMax.norm +-- maximum . map NormedMax.norm + +{- | +Volume based on Energy norm. +-} +volumeVectorEuclidean :: (Algebraic.C y, NormedEuc.C y yv) => Sig.T yv -> y +volumeVectorEuclidean = + Algebraic.sqrt . volumeVectorEuclideanSqr + +volumeVectorEuclideanSqr :: (Field.C y, NormedEuc.Sqr y yv) => Sig.T yv -> y +volumeVectorEuclideanSqr = + average . map NormedEuc.normSqr + +{- | +Volume based on Sum norm. +-} +volumeVectorSum :: (NormedSum.C y yv, Field.C y) => Sig.T yv -> y +volumeVectorSum = + average . map NormedSum.norm + + + + +{- | +Compute minimum and maximum value of the stream the efficient way. +Input list must be non-empty and finite. +-} +bounds :: Ord y => Sig.T y -> (y,y) +bounds [] = error "Analysis.bounds: List must contain at least one element." +bounds (x:xs) = + foldl' (\(minX,maxX) y -> (min y minX, max y maxX)) (x,x) xs + + + + +{- * Miscellaneous -} + +{- +histogram: + length x = sum (histogramDiscrete x) + + units: + 1) histogram (amplify k x) = timestretch k (amplify (1/k) (histogram x)) + 2) histogram (timestretch k x) = amplify k (histogram x) + timestretch: k -> (s -> V) -> (k*s -> V) + amplify: k -> (s -> V) -> (s -> k*V) + histogram: (a -> b) -> (a^ia*b^ib -> a^ja*b^jb) + x: (s -> V) + 1) => (s^ia*(k*V)^ib -> s^ja*(k*V)^jb) + = (s^ia*V^ib*k -> s^ja*V^jb/k) + => ib=1, jb=-1 + 2) => ((k*s)^ia*V^ib -> (k*s)^ja*V^jb) + = (s^ia*V^ib -> s^ja*V^jb*k) + => ia=0, ja=1 + histogram: (s -> V) -> (V -> s/V) +histogram': + integral (histogram' x) = integral x + histogram' (amplify k x) = timestretch k (histogram' x) + histogram' (timestretch k x) = amplify k (histogram' x) + -> this does only apply if we slice the area horizontally + and sum the slice up at each level, + we must also restrict to the positive values, + this is not quite the usual histogram +-} + +{- | +Input list must be finite. +List is scanned twice, but counting may be faster. +-} +histogramDiscreteArray :: Sig.T Int -> (Int, Sig.T Int) +histogramDiscreteArray [] = + (error "histogramDiscreteArray: no bounds found", []) +histogramDiscreteArray x = + let hist = + accumArray (+) zero + (bounds x) (attachOne x) + in (fst (Array.bounds hist), Array.elems hist) + + +{- | +Input list must be finite. +If the input signal is empty, the offset is @undefined@. +List is scanned twice, but counting may be faster. +The sum of all histogram values is one less than the length of the signal. +-} +histogramLinearArray :: RealField.C y => Sig.T y -> (Int, Sig.T y) +histogramLinearArray [] = + (error "histogramLinearArray: no bounds found", []) +histogramLinearArray [x] = (floor x, []) +histogramLinearArray x = + let (xMin,xMax) = bounds x + hist = + accumArray (+) zero + (floor xMin, floor xMax) + (meanValues x) + in (fst (Array.bounds hist), Array.elems hist) + + +{- | +Input list must be finite. +If the input signal is empty, the offset is @undefined@. +List is scanned once, counting may be slower. +-} +histogramDiscreteIntMap :: Sig.T Int -> (Int, Sig.T Int) +histogramDiscreteIntMap [] = + (error "histogramDiscreteIntMap: no bounds found", []) +histogramDiscreteIntMap x = + let hist = IntMap.fromListWith (+) (attachOne x) + in case IntMap.toAscList hist of + [] -> error "histogramDiscreteIntMap: the list was non-empty before processing ..." + fAll@((fIndex,fHead):fs) -> (fIndex, fHead : + concat (zipWith + (\(i0,_) (i1,f1) -> replicate (i1-i0-1) zero ++ [f1]) + fAll fs)) + +histogramLinearIntMap :: RealField.C y => Sig.T y -> (Int, Sig.T y) +histogramLinearIntMap [] = + (error "histogramLinearIntMap: no bounds found", []) +histogramLinearIntMap [x] = (floor x, []) +histogramLinearIntMap x = + let hist = IntMap.fromListWith (+) (meanValues x) + -- we can rely on the fact that the keys are contiguous + (startKey:_, elems) = unzip (IntMap.toAscList hist) + in (startKey, elems) + -- This doesn't work, due to a bug in IntMap of GHC-6.4.1 + -- in (head (IntMap.keys hist), IntMap.elems hist) + +{- +The bug in IntMap GHC-6.4.1 is: + +*Synthesizer.Plain.Analysis> IntMap.keys $ IntMap.fromList $ [(0,0),(-1,-1::Int)] +[0,-1] +*Synthesizer.Plain.Analysis> IntMap.elems $ IntMap.fromList $ [(0,0),(-1,-1::Int)] +[0,-1] +*Synthesizer.Plain.Analysis> IntMap.assocs $ IntMap.fromList $ [(0,0),(-1,-1::Int)] +[(0,0),(-1,-1)] + +The bug has gone in IntMap as shipped with GHC-6.6. +-} + +histogramIntMap :: (RealField.C y) => y -> Sig.T y -> (Int, Sig.T Int) +histogramIntMap binsPerUnit = + histogramDiscreteIntMap . quantize binsPerUnit + +quantize :: (RealField.C y) => y -> Sig.T y -> Sig.T Int +quantize binsPerUnit = map (floor . (binsPerUnit*)) + +attachOne :: Sig.T i -> Sig.T (i,Int) +attachOne = map (\i -> (i,one)) + +meanValues :: RealField.C y => Sig.T y -> [(Int,y)] +meanValues x = concatMap spread (zip x (tail x)) + +spread :: RealField.C y => (y,y) -> [(Int,y)] +spread (l0,r0) = + let (l,r) = if l0<=r0 then (l0,r0) else (r0,l0) + (li,lf) = splitFraction l + (ri,rf) = splitFraction r + k = recip (r-l) + nodes = + (li,k*(1-lf)) : + zip [li+1 ..] (replicate (ri-li-1) k) ++ + (ri, k*rf) : + [] + in if li==ri + then [(li,one)] + else nodes + +{- | +Requires finite length. +This is identical to the arithmetic mean. +-} +directCurrentOffset :: Field.C y => Sig.T y -> y +directCurrentOffset = average + + +scalarProduct :: Ring.C y => Sig.T y -> Sig.T y -> y +scalarProduct xs ys = + sum (zipWith (*) xs ys) + +{- | +'directCurrentOffset' must be non-zero. +-} +centroid :: Field.C y => Sig.T y -> y +centroid xs = + firstMoment xs / sum xs + +centroidAlt :: Field.C y => Sig.T y -> y +centroidAlt xs = + sum (scanr (+) zero (tail xs)) / sum xs + +firstMoment :: Ring.C y => Sig.T y -> y +firstMoment = + scalarProduct (iterate (one+) zero) + + +average :: Field.C y => Sig.T y -> y +average x = + sum x / fromIntegral (length x) + +rectify :: Real.C y => Sig.T y -> Sig.T y +rectify = map abs + +{- | +Detects zeros (sign changes) in a signal. +This can be used as a simple measure of the portion +of high frequencies or noise in the signal. +It ca be used as voiced\/unvoiced detector in a vocoder. + +@zeros x !! n@ is @True@ if and only if +@(x !! n >= 0) \/= (x !! (n+1) >= 0)@. +The result will be one value shorter than the input. +-} +zeros :: (Ord y, Ring.C y) => Sig.T y -> Sig.T Bool +zeros xs = + let signs = map (>=zero) xs + in zipWith (/=) signs (tail signs) + + + +data BinaryLevel = Low | High + deriving (Eq, Show, Enum) + +binaryLevelFromBool :: Bool -> BinaryLevel +binaryLevelFromBool False = Low +binaryLevelFromBool True = High + +binaryLevelToNumber :: Ring.C a => BinaryLevel -> a +binaryLevelToNumber Low = negate one +binaryLevelToNumber High = one + + +{- | +Detect thresholds with a hysteresis. +-} +flipFlopHysteresis :: (Ord y) => + (y,y) -> BinaryLevel -> Sig.T y -> Sig.T BinaryLevel +flipFlopHysteresis (lower,upper) = + scanl + (\state x -> binaryLevelFromBool $ + case state of + High -> not(x 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 diff --git a/src/Synthesizer/Plain/Builder.hs b/src/Synthesizer/Plain/Builder.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Plain/Builder.hs @@ -0,0 +1,57 @@ +module Synthesizer.Plain.Builder ( + T, Put, put, run, + signalToBinary, signalToBinaryMono, signalToBinaryStereo, + ) where + +import qualified Synthesizer.Basic.Binary as BinSmp + +import Data.Monoid (Monoid, mempty, mappend, mconcat, Endo(Endo), appEndo, ) + +import qualified Algebra.ToInteger as ToInteger +import qualified Algebra.RealField as RealField + +import qualified Prelude as P98 + +import PreludeBase +import NumericPrelude + + + +newtype T a = Cons {decons :: Endo [a]} + +type Put a = a -> T a + + +instance Monoid (T a) where + mempty = Cons mempty + mappend x y = Cons $ decons x `mappend` decons y + +put :: Put a +put = Cons . Endo . (:) + +run :: T a -> [a] +run = flip appEndo [] . decons + + +{-# INLINE signalToBinary #-} +signalToBinary :: + (BinSmp.C v, ToInteger.C int, Bounded int) => + [v] -> [int] +signalToBinary = + run . mconcat . map (BinSmp.outputFromCanonical put) + +{-# INLINE signalToBinaryMono #-} +signalToBinaryMono :: + (RealField.C a, ToInteger.C int, Bounded int) => + [a] -> [int] +signalToBinaryMono = + map (BinSmp.fromCanonicalWith round) + +{-# INLINE signalToBinaryStereo #-} +signalToBinaryStereo :: + (RealField.C a, ToInteger.C int, Bounded int) => + [(a,a)] -> [int] +signalToBinaryStereo = + concatMap (\(l,r) -> + [BinSmp.fromCanonicalWith round l, + BinSmp.fromCanonicalWith round r]) diff --git a/src/Synthesizer/Plain/Control.hs b/src/Synthesizer/Plain/Control.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Plain/Control.hs @@ -0,0 +1,493 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +module Synthesizer.Plain.Control where + +import Synthesizer.Plain.Displacement (raise) + +import qualified Synthesizer.Plain.Signal as Sig + +import qualified Algebra.Module as Module +import qualified Algebra.Transcendental as Trans +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Algebra.Module((*>)) + +import Number.Complex (cis,real) +-- import qualified Number.Complex as Complex +import Data.List (zipWith4, tails, ) +import Data.List.HT (iterateAssociative, ) + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +{- * Control curve generation -} + +constant :: y -> Sig.T y +constant = repeat + + +linear :: Additive.C y => + y {-^ steepness -} + -> y {-^ initial value -} + -> Sig.T y {-^ linear progression -} +linear d y0 = iterate (d+) y0 + +{- | +Minimize rounding errors by reducing number of operations per element +to a logarithmuc number. +-} +linearMultiscale :: Additive.C y => + y + -> y + -> Sig.T y +linearMultiscale = curveMultiscale (+) + +{- | +Linear curve starting at zero. +-} +linearMultiscaleNeutral :: Additive.C y => + y + -> Sig.T y +linearMultiscaleNeutral slope = + curveMultiscaleNeutral (+) slope zero + +{- | +As stable as the addition of time values. +-} +linearStable :: Ring.C y => + y + -> y + -> Sig.T y +linearStable d y0 = + curveStable (d*) (+) 1 y0 + + +{- | +It computes the same like 'linear' but in a numerically more stable manner, +namely using a subdivision scheme. +The division needed is a division by two. + +0 4 8 +0 2 4 6 8 +0 1 2 3 4 5 6 7 8 +-} +linearMean :: Field.C y => + y + -> y + -> Sig.T y +linearMean d y0 = y0 : + foldr (\pow xs -> y0+pow : linearSubdivision xs) + unreachable (iterate (2*) d) + +{- | Intersperse linearly interpolated values. -} +linearSubdivision :: Field.C y => + Sig.T y + -> Sig.T y +linearSubdivision = subdivide (\x0 x1 -> (x0+x1)/2) + + +{- | +Linear curve of a fixed length. +The final value is not actually reached, +instead we stop one step before. +This way we can concatenate several lines +without duplicate adjacent values. +-} +line :: Field.C y => + Int {-^ length -} + -> (y,y) {-^ initial and final value -} + -> Sig.T y {-^ linear progression -} +line n (y0,y1) = + take n $ linear ((y1-y0) / fromIntegral n) y0 + + + +exponential, exponentialMultiscale, exponentialStable :: Trans.C y => + y {-^ time where the function reaches 1\/e of the initial value -} + -> y {-^ initial value -} + -> Sig.T y {-^ exponential decay -} +exponential time = iterate (* exp (- recip time)) +exponentialMultiscale time = curveMultiscale (*) (exp (- recip time)) +exponentialStable time = exponentialStableGen exp (- recip time) + +exponentialMultiscaleNeutral :: Trans.C y => + y {-^ time where the function reaches 1\/e of the initial value -} + -> Sig.T y {-^ exponential decay -} +exponentialMultiscaleNeutral time = + curveMultiscaleNeutral (*) (exp (- recip time)) one + +exponential2, exponential2Multiscale, exponential2Stable :: Trans.C y => + y {-^ half life -} + -> y {-^ initial value -} + -> Sig.T y {-^ exponential decay -} +exponential2 halfLife = iterate (* 0.5 ** recip halfLife) +exponential2Multiscale halfLife = curveMultiscale (*) (0.5 ** recip halfLife) +exponential2Stable halfLife = exponentialStableGen (0.5 **) (recip halfLife) + +exponential2MultiscaleNeutral :: Trans.C y => + y {-^ half life -} + -> Sig.T y {-^ exponential decay -} +exponential2MultiscaleNeutral halfLife = + curveMultiscaleNeutral (*) (0.5 ** recip halfLife) one + + +exponentialFromTo, exponentialFromToMultiscale :: Trans.C y => + y {-^ time where the function reaches 1\/e of the initial value -} + -> y {-^ initial value -} + -> y {-^ value after given time -} + -> Sig.T y {-^ exponential decay -} +exponentialFromTo time y0 y1 = + iterate (* (y1/y0) ** recip time) y0 +exponentialFromToMultiscale time y0 y1 = + curveMultiscale (*) ((y1/y0) ** recip time) y0 + + +exponentialStableGen :: (Ring.C y, Ring.C t) => + (t -> y) + -> t + -> y + -> Sig.T y +exponentialStableGen expFunc = curveStable expFunc (*) + + + + +{-| This is an extension of 'exponential' to vectors + which is straight-forward but requires more explicit signatures. + But since it is needed rarely I setup a separate function. -} +vectorExponential :: (Trans.C y, Module.C y v) => + y {-^ time where the function reaches 1\/e of the initial value -} + -> v {-^ initial value -} + -> Sig.T v {-^ exponential decay -} +vectorExponential time y0 = iterate (exp (-1/time) *>) y0 + +vectorExponential2 :: (Trans.C y, Module.C y v) => + y {-^ half life -} + -> v {-^ initial value -} + -> Sig.T v {-^ exponential decay -} +vectorExponential2 halfLife y0 = iterate (0.5**(1/halfLife) *>) y0 + + + +cosine, cosineMultiscale, cosineSubdiv, cosineStable :: Trans.C y => + y {-^ time t0 where 1 is approached -} + -> y {-^ time t1 where -1 is approached -} + -> Sig.T y {-^ a cosine wave where one half wave is between t0 and t1 -} +cosine = cosineWithSlope $ + \d x -> map cos (linear d x) + +cosineMultiscale = cosineWithSlope $ + \d x -> map real (curveMultiscale (*) (cis d) (cis x)) + + +{- + cos (a-b) = cos a * cos b + sin a * sin b + cos (a+b) = cos a * cos b - sin a * sin b + cos a = (cos (a-b) + cos (a+b)) / (2 * cos b) + + Problem: (cos b) might be close to zero, + example: Syn.cosineStable 1 (9::Double) +-} +cosineSubdiv = + let aux d y0 = + cos y0 : + foldr (\pow xs -> cos(y0+pow) : cosineSubdivision pow xs) + unreachable (iterate (2*) d) + in cosineWithSlope aux + +cosineSubdivision :: Trans.C y => + y + -> Sig.T y + -> Sig.T y +cosineSubdivision angle = + let k = recip (2 * cos angle) + in subdivide (\x0 x1 -> (x0+x1)*k) + +cosineStable = cosineWithSlope $ + \d x -> map real (exponentialStableGen cis d (cis x)) + + +cosineWithSlope :: Trans.C y => + (y -> y -> signal) + -> y + -> y + -> signal +cosineWithSlope c t0 t1 = + let inc = pi/(t1-t0) + in c inc (-t0*inc) + + +cubicHermite :: Field.C y => (y, (y,y)) -> (y, (y,y)) -> Sig.T y +cubicHermite node0 node1 = + map (cubicFunc node0 node1) (linear 1 0) + +{- | +0 16 +0 8 16 +0 4 8 12 16 +0 2 4 6 8 10 12 14 16 +0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 +-} +cubicFunc :: Field.C y => (y, (y,y)) -> (y, (y,y)) -> y -> y +cubicFunc (t0, (y0,dy0)) (t1, (y1,dy1)) t = + let dt = t0-t1 + dt0 = t-t0 + dt1 = t-t1 + x0 = dt1^2 + x1 = dt0^2 + in ((dy0*dt0 + y0 * (1-2/dt*dt0)) * x0 + + (dy1*dt1 + y1 * (1+2/dt*dt1)) * x1) / dt^2 +{- +cubic t0 (y0,dy0) t1 (y1,dy1) t = + let x0 = ((t-t1) / (t0-t1))^2 + x1 = ((t-t0) / (t1-t0))^2 + in y0 * x0 + y1 * x1 + + (dy0 - y0*2/(t0-t1)) * (t-t0)*x0 + + (dy1 - y1*2/(t1-t0)) * (t-t1)*x1 +-} + +cubicHermiteStable :: Field.C y => (y, (y,y)) -> (y, (y,y)) -> Sig.T y +cubicHermiteStable node0 node1 = + cubicFunc node0 node1 0 : + foldr (\pow xs -> + cubicFunc node0 node1 pow : head xs : + cubicFunc node0 node1 (3*pow) : cubicSubdivision xs) + unreachable (iterate (2*) 1) + +cubicSubdivision :: Field.C y => Sig.T y -> Sig.T y +cubicSubdivision xs = + let xs0:xs1:xs2:xs3:_ = tails xs + inter = zipWith4 (\x0 x1 x2 x3 -> (9*(x1+x2) - (x0+x3))/16) + xs0 xs1 xs2 xs3 + in head xs1 : flattenPairs (zip inter xs2) + +{- + foldr (\(pow0:pow1:_) ~(_:xs) -> + cos (y0+pow0) : cos (y0+pow1) : cos (y0+pow0+pow1) : + cosineSubdivision pow0 xs) + unreachable (tails (iterate (2*) d)) +-} + + +{- +maybe cubicHermite could also be implemented in a Multiscale manner +using a difference scheme. + +cubicHermiteMultiscale :: Field.C y => (y, (y,y)) -> (y, (y,y)) -> Sig.T y +cubicHermiteMultiscale node0@(t0,y0) node1@(t1,y1) = + let -- could be inlined and simplified + ys = map (cubicFunc node0 node1) [0,1,2,3] + (d0:d1:d2:d3:_) = iterate (zapWith substract) ys + +I thought multiplying difference schemes could help somehow, +but it doesn't. :-( + +cubicHermiteMultiscale + +Leibniz rule for differences + +D3(s+r) = D0(s)*D3(r) + 3*D1(s)*D2(r) + 3*D2(s)*D1(r) + D3(s)*D0(r) + + +mulDiffs4 :: Ring.C a => (a,a,a,a) -> (a,a,a,a) -> (a,a,a,a) +mulDiffs4 (r0,r1,r2,r3) (s0,s1,s2,s3) = + (r0*s0, + r0*s1 + r1*s0, + r0*s2 + 2*r1*s1 + r2*s0, + r0*s3 + 3*r1*s2 + 3*r2*s1 + r3*s0) + +mulDiffs4zero :: Ring.C a => (a,a,a) -> (a,a,a) -> (a,a,a) +mulDiffs4zero (r0,r1,r2,r3) (s0,s1,s2,s3) = + (r0*s0, + r0*s1 + r1*s0, + r0*s2 + 2*r1*s1 + r2*s0, + r0*s3 + 3*r1*s2 + 3*r2*s1 + r3*s0) + +mulDiffs3 :: Ring.C a => (a,a,a) -> (a,a,a) -> (a,a,a) +mulDiffs3 (r0,r1,r2) (s0,s1,s2) = + (r0*s0, + r0*s1 + r1*s0, + r0*s2 + 2*r1*s1 + r2*s0) + +mulDiffs3Karatsuba :: Ring.C a => (a,a,a) -> (a,a,a) -> (a,a,a) +mulDiffs3Karatsuba (r0,r1,r2) (s0,s1,s2) = + let r0s0 = r0*s0 + r1s1 = r1*s1 + in (r0s0, + (r0+r1)*(s0+s1) - r0s0 - r1s1, + r0*s2 + 2*r1s1 + r2*s0) +-} + + + +{- | +The curve type of a piece of a piecewise defined control curve. +-} +data Control y = + CtrlStep + | CtrlLin + | CtrlExp {ctrlExpSaturation :: y} + | CtrlCos + | CtrlCubic {ctrlCubicGradient0 :: y, + ctrlCubicGradient1 :: y} + deriving (Eq, Show) + +{- | +The full description of a control curve piece. +-} +data ControlPiece y = + ControlPiece {pieceType :: Control y, + pieceY0 :: y, + pieceY1 :: y, + pieceDur :: y} + deriving (Eq, Show) + + +newtype PieceRightSingle y = PRS y +newtype PieceRightDouble y = PRD y + +type ControlDist y = (y, Control y, y) + + +-- precedence and associativity like (:) +infixr 5 -|#, #|-, =|#, #|=, |#, #| + +{- | +The 6 operators simplify constructing a list of @ControlPiece a@. +The description consists of nodes (namely the curve values at nodes) +and the connecting curve types. +The naming scheme is as follows: +In the middle there is a bar @|@. +With respect to the bar, +the pad symbol @\#@ is at the side of the curve type, +at the other side there is nothing, a minus sign @-@, or an equality sign @=@. + + (1) Nothing means that here is the start or the end node of a curve. + + (2) Minus means that here is a node where left and right curve meet at the same value. + The node description is thus one value. + + (3) Equality sign means that here is a split node, + where left and right curve might have different ending and beginning values, respectively. + The node description consists of a pair of values. +-} + +-- the leading space is necessary for the Haddock parser + +( #|-) :: (y, Control y) -> (PieceRightSingle y, [ControlPiece y]) -> + (ControlDist y, [ControlPiece y]) +(d,c) #|- (PRS y1, xs) = ((d,c,y1), xs) + +(-|#) :: y -> (ControlDist y, [ControlPiece y]) -> + (PieceRightSingle y, [ControlPiece y]) +y0 -|# ((d,c,y1), xs) = (PRS y0, ControlPiece c y0 y1 d : xs) + +( #|=) :: (y, Control y) -> (PieceRightDouble y, [ControlPiece y]) -> + (ControlDist y, [ControlPiece y]) +(d,c) #|= (PRD y1, xs) = ((d,c,y1), xs) + +(=|#) :: (y,y) -> (ControlDist y, [ControlPiece y]) -> + (PieceRightDouble y, [ControlPiece y]) +(y01,y10) =|# ((d,c,y11), xs) = (PRD y01, ControlPiece c y10 y11 d : xs) + +( #|) :: (y, Control y) -> y -> + (ControlDist y, [ControlPiece y]) +(d,c) #| y1 = ((d,c,y1), []) + +(|#) :: y -> (ControlDist y, [ControlPiece y]) -> + [ControlPiece y] +y0 |# ((d,c,y1), xs) = ControlPiece c y0 y1 d : xs + + +piecewise :: (Trans.C y, RealField.C y) => + [ControlPiece y] -> Sig.T y +piecewise xs = + let ts = scanl (\(_,fr) d -> splitFraction (fr+d)) + (0,1) (map pieceDur xs) + in concat (zipWith3 + (\n t (ControlPiece c yi0 yi1 d) -> + piecewisePart yi0 yi1 t d n c) + (map fst (tail ts)) (map (subtract 1 . snd) ts) + xs) + + +piecewisePart :: (Trans.C y) => + y -> y -> y -> y -> Int -> Control y -> Sig.T y +piecewisePart y0 y1 t0 d n ctrl = + take n + (case ctrl of + CtrlStep -> constant y0 + CtrlLin -> let s = (y1-y0)/d in linearStable s (y0-t0*s) + CtrlExp s -> let y0' = y0-s; y1' = y1-s; yd = y0'/y1' + in raise s (exponentialStable (d / log yd) + (y0' * yd**(t0/d))) + CtrlCos -> map (\y -> (1+y)*(y0/2)+(1-y)*(y1/2)) + (cosineStable t0 (t0+d)) + CtrlCubic yd0 yd1 -> + cubicHermiteStable (t0,(y0,yd0)) (t0+d,(y1,yd1))) + +{- + exp (-1/time) == yd**(-1/d) + 1/time == log yd / d + time == d / log yd +-} + +{- + piecewise (0 |# (10.21, CtrlExp 1.1) #|- 1 -|# (10,CtrlExp 0.49) #|- 0.5 -|# (30, CtrlLin) #|- 0.5 -|# (20, CtrlCos) #| 0) + + piecewise (0 |# (10.21, CtrlExp 1.1) #|- 1 -|# (10,CtrlCubic (-0.1) 0) #|- 0.5 -|# (30, CtrlLin) #|- 0.5 -|# (20, CtrlCos) #| 0) +-} + + +{- * Auxiliary functions -} + +curveStable :: (Additive.C t) => + (t -> y) + -> (y -> y -> y) + -> t + -> y + -> Sig.T y +curveStable expFunc op time y0 = + y0 : map (op y0) + (foldr + (\e xs -> + let k = expFunc e + in k : concatMapPair (\x -> (x, op x k)) xs) + unreachable (iterate double time)) + +unreachable :: a +unreachable = error "only reachable in infinity" + +double :: Additive.C t => t -> t +double t = t+t + +concatMapPair :: (a -> (b,b)) -> Sig.T a -> Sig.T b +concatMapPair f = flattenPairs . map f + +flattenPairs :: Sig.T (a,a) -> Sig.T a +flattenPairs = foldr (\(a,b) xs -> a:b:xs) [] + +subdivide :: (y -> y -> y) -> Sig.T y -> Sig.T y +subdivide f xs0@(x:xs1) = + x : flattenPairs (zipWith (\x0 x1 -> (f x0 x1, x1)) xs0 xs1) +subdivide _ [] = [] + + +concatMapPair' :: (a -> (b,b)) -> Sig.T a -> Sig.T b +concatMapPair' f = concatMap ((\(x,y) -> [x,y]) . f) + + +curveMultiscale :: (y -> y -> y) -> y -> y -> Sig.T y +curveMultiscale op d y0 = + y0 : map (op y0) (iterateAssociative op d) + + +curveMultiscaleNeutral :: (y -> y -> y) -> y -> y -> Sig.T y +curveMultiscaleNeutral op d neutral = + neutral : iterateAssociative op d diff --git a/src/Synthesizer/Plain/Cut.hs b/src/Synthesizer/Plain/Cut.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Plain/Cut.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{- | +Copyright : (c) Henning Thielemann 2006 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes +-} +module Synthesizer.Plain.Cut ( + {- * dissection -} + takeUntilPause, + takeUntilInterval, + + {- * glueing -} + selectBool, + select, + arrange, + ) where + +import qualified Synthesizer.Plain.Signal as Sig + +import qualified Data.EventList.Relative.TimeBody as EventList + +import qualified MathObj.LaurentPolynomial as Laurent +import qualified Algebra.Real as Real +import qualified Algebra.Additive as Additive + +import Data.Array (Array, Ix, (!)) + +import qualified Number.NonNegative as NonNeg + +import PreludeBase +import NumericPrelude + + + +{- | +Take signal until it falls short of a certain amplitude for a given time. +-} +takeUntilPause :: (Real.C a) => a -> Int -> Sig.T a -> Sig.T a +takeUntilPause y = + takeUntilInterval ((<=y) . abs) + +{- | +Take values until the predicate p holds for n successive values. +The list is truncated at the beginning of the interval of matching values. +-} +takeUntilInterval :: (a -> Bool) -> Int -> Sig.T a -> Sig.T a +takeUntilInterval p n xs = + map fst $ + takeWhile (( if p x then succ acc else 0) 0 xs + ++ repeat 0 + + + +-- Better use zipWithMatch from NumericPrelude? +selectBool :: (Sig.T a, Sig.T a) -> Sig.T Bool -> Sig.T a +selectBool = + uncurry (zipWith3 (\xf xt c -> if c then xt else xf)) +{- + zipWithMatch (\(xf,xt) c -> if c then xt else xf) . + uncurry (zipWithMatch (,)) +-} + + +select :: Ix i => Array i (Sig.T a) -> Sig.T i -> Sig.T a +select arr = + zipWith (!) + (map (fmap head) $ iterate (fmap tail) arr) + + + +{- | +Given a list of signals with time stamps, +mix them into one signal as they occur in time. +Ideally for composing music. + +Cf. 'MathObj.LaurentPolynomial.series' +-} +arrange :: (Additive.C v) => + EventList.T NonNeg.Int (Sig.T v) + {-^ A list of pairs: (relative start time, signal part), + The start time is relative to the start time + of the previous event. -} + -> Sig.T v + {-^ The mixed signal. -} +arrange evs = + let xs = EventList.getBodies evs + in case map NonNeg.toNumber (EventList.getTimes evs) of + t:ts -> replicate t zero ++ Laurent.addShiftedMany ts xs + [] -> [] diff --git a/src/Synthesizer/Plain/Displacement.hs b/src/Synthesizer/Plain/Displacement.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Plain/Displacement.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{- | + +-} +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 diff --git a/src/Synthesizer/Plain/Effect.hs b/src/Synthesizer/Plain/Effect.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Plain/Effect.hs @@ -0,0 +1,120 @@ +module Synthesizer.Plain.Effect where + +import qualified Synthesizer.Plain.Noise as Noise +import qualified Synthesizer.Plain.Filter.Recursive as Filter +import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1 +-- import qualified Synthesizer.Plain.Filter.Recursive.Allpass as Allpass +-- import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilter +import qualified Synthesizer.Plain.Filter.Recursive.Moog as Moog +import qualified Synthesizer.Plain.Filter.Recursive.Comb as Comb +-- import qualified Synthesizer.Plain.Filter.Recursive.Integration as Integrate +import qualified Synthesizer.Plain.Filter.Recursive.Butterworth as Butter +import qualified Synthesizer.Plain.Filter.Recursive.Chebyshev as Cheby +import Synthesizer.Plain.Control(exponential2) +import Synthesizer.Plain.Instrument +import Synthesizer.Plain.Effect.Glass(glass) +import qualified Synthesizer.Plain.File as File +import Synthesizer.Filter.Example(guitarRaw, flangedSaw) +--import Interpolation(interpolate,interpolateConstant) +--import System.Random +import System.Exit(ExitCode) +import System.Cmd(rawSystem) + +main :: IO ExitCode +main = + let rate = 44100 + in do {- File.writeMono "test" rate + (take (round (3*rate)) (soundD rate)) -} + File.renderMonoToInt16 "test.aiff" rate soundE + rawSystem "play" ["test.aiff"] + + +soundE, soundD, + soundC, soundB, soundA, + sound9, sound8, sound7, + sound6, sound5, sound4, + sound3, sound2, sound1, + sound0, soundm0 :: Double -> [Double] + +soundE = glass + +soundD = flangedSaw + +soundC _ = guitarRaw + +cFreq :: Double +cFreq = 521.3417849066773 + +soundB sampleRate = + let baseFreq = cFreq/2 + chord = zipWith3 (\x y z -> (x+y+z)/5) + (choir sampleRate (baseFreq*1/1)) + (choir sampleRate (baseFreq*5/4)) + (choir sampleRate (baseFreq*3/2)) + filterFreqs = map (3000/sampleRate*) + (map sin (iterate (pi/(6*sampleRate)+) 0)) + in Butter.lowpassPole 8 (repeat (0.3::Double)) filterFreqs (chord::[Double]) + +soundA sampleRate = + choir sampleRate cFreq + +sound9 sampleRate = + map (*0.1) (accumulatedSaws sampleRate cFreq !! 20) + +sound8 sampleRate = + let filterFreqs = exponential2 (-0.5*sampleRate) (100/sampleRate) + -- Cheby.lowpassBPole + -- Cheby.highpassBPole + -- Cheby.lowpassAPole + -- Cheby.highpassAPole + in Cheby.lowpassBPole 8 (repeat (0.3::Double)) filterFreqs (Noise.white::[Double]) + +sound7 sampleRate = + let filterFreqs = exponential2 (-0.5*sampleRate) (100/sampleRate) + -- butterworthHighpass + in Butter.lowpassPole 8 (repeat (0.3::Double)) filterFreqs (Noise.white::[Double]) + +-- a moog filter which randomly changes the resonance frequency +sound6 sampleRate = + let order = 10 + {- unused + switchRates = repeat (8/sampleRate) + filterFreqs = map (\exp -> 100*2**exp/sampleRate) + ((randomRs (0,6) (mkStdGen 142857))::[Double]) + filterReso = 10 + -} + + control0 {-, control1, control2-} :: [Moog.Parameter Double] + -- constant control + control0 = repeat (Moog.parameter order (Filter.Pole 10 (400/sampleRate))) + -- apply moogFilterParam first then resample, fast + {- Need Additive and VectorSpace instances for MoogFilterParam + control1 = interpolateConstant 0 switchRates + (map (moogFilterParam order) + (map (Pole filterReso) filterFreqs)) + -- first resample then apply moogFilterParam, slow + control2 = map (moogFilterParam order) + (map (Pole filterReso) + (interpolateConstant 0 switchRates filterFreqs)) + -} + in Moog.lowpass order control0 + (map (0.5*) (fatSawChord sampleRate 220)) + +sound5 sampleRate = + Comb.runMulti + (map (\t -> round (t*sampleRate)) [0.08,0.13,0.21]) + (0.3::Double) (bell sampleRate 441) +sound4 sampleRate = + Comb.runProc + (round (0.3*sampleRate)) + (Filt1.lowpass + (repeat (Filt1.parameter (441/sampleRate::Double)))) + (bell sampleRate 441) + +sound3 sampleRate = allpassPlain sampleRate 0.3 1 441 +sound2 sampleRate = allpassDown sampleRate 10 0.5 1000 441 + +sound1 sampleRate = map (0.1*) (moogDown sampleRate 6 0.4 5000 441) +sound0 sampleRate = map (0.3*) (moogReso sampleRate 6 0.1 2000 441) + +soundm0 sampleRate = fatSawChordFilter sampleRate 110 diff --git a/src/Synthesizer/Plain/Effect/Fly.hs b/src/Synthesizer/Plain/Effect/Fly.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Plain/Effect/Fly.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Synthesizer.Plain.Effect.Fly where + +import qualified Synthesizer.Plain.Oscillator as Osci +import qualified Synthesizer.Plain.Filter.NonRecursive as FiltNR +import qualified Synthesizer.Plain.Interpolation as Interpolation +import qualified Synthesizer.Plain.Miscellaneous as Syn + +import qualified Synthesizer.Plain.File as File +import System.Exit(ExitCode) + +import System.Random + +import qualified Algebra.NormedSpace.Euclidean as Euc + +import PreludeBase +import NumericPrelude + + +{- + ghc -O -fvia-C -fglasgow-exts -fallow-undecidable-instances --make Fly.hs && echo start && time a.out +-} + +main :: IO ExitCode +main = + File.writeStereoToInt16 "Fly" sampleRate + (take (round (10*sampleRate)) fly) + +sampleRate :: Double +sampleRate = 44100 + +{-| stereo sound of a humming fly -} +fly :: [(Double,Double)] +fly = + let pinkNoise seed freq range = + Interpolation.multiRelativeZeroPadCubic (0::Double) + (repeat (freq/sampleRate)) + (randomRs (-range,range) (mkStdGen seed)) + {- the track of a fly is composed of a slow motion over a big range + and fast but small oscillations -} + flyCoord seed = zipWith (+) (pinkNoise seed 40 0.3) + (pinkNoise seed 1 10) + {- explicit signature required + because of multi-param type class NormedEuc -} + trajectory :: [(Double, Double, Double)] + trajectory = + zip3 (flyCoord 366210) + (flyCoord 234298) + (flyCoord 654891) + + channel ear = + let (phase,volumes) = Syn.receive3Dsound 1 0.1 ear trajectory + -- (*sampleRate) in 'speed' and + -- (/sampleRate) in 'freqs' neutralizes + speeds = map (\v -> 250/sampleRate+2*(Euc.norm v)) + (zipWith subtract (tail trajectory) trajectory) + freqs = zipWith (+) speeds (FiltNR.differentiate phase) + sound = Osci.freqModSaw 0 freqs + in zipWith (*) (map (10*) volumes) sound + + in zip (channel (-1,0,0)) (channel (1,0,0)) diff --git a/src/Synthesizer/Plain/Effect/Glass.hs b/src/Synthesizer/Plain/Effect/Glass.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Plain/Effect/Glass.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Synthesizer.Plain.Effect.Glass where + +import qualified Data.EventList.Relative.TimeBody as EventList +import qualified Number.NonNegative as NonNeg + +import qualified Synthesizer.Plain.Oscillator as Osci +import qualified Synthesizer.Basic.Wave as Wave +import qualified Synthesizer.Plain.Cut as Cut +import qualified Synthesizer.Plain.Control as Ctrl +import qualified Synthesizer.Plain.Noise as Noise +import qualified Synthesizer.Plain.Filter.NonRecursive as FiltNR + +import qualified Algebra.Transcendental as Trans +import qualified Algebra.RealField as RealField +import qualified Algebra.Additive as Additive +import qualified Algebra.Module as Module + +import System.Random(randomRs, mkStdGen) + +import PreludeBase +import NumericPrelude as NP + + +{- | We try to simulate the sound of broken glass + as a mixture of short percussive sounds with random pitch -} +glass :: Double -> [Double] +glass sampleRate = + Cut.arrange (particles sampleRate 1500) + +particles :: Double -> Double -> EventList.T NonNeg.Int [Double] +particles sampleRate freq = + let sampledDensity = + (2000/sampleRate) *> map densityHeavy [0, (1/sampleRate) ..] + pattern = take (round (0.8*sampleRate)) + (Noise.randomPeeks sampledDensity) + times = timeDiffs pattern + chirp = iterate (0.001+) 0 + pitches = map ((freq*) . (2**)) + (zipWith (+) chirp (randomRs (0,1) (mkStdGen 56))) + amps = map (0.4*) (map (2**) (randomRs (-2,0) (mkStdGen 721))) + in EventList.fromPairList $ zip times $ + zipWith (particle sampleRate) pitches amps + + +particle :: (RealField.C a, Trans.C a, Module.C a a) => a -> a -> a -> [a] +particle sampleRate freq amp = + let halfLife = 0.01 + in take (round (10*halfLife*sampleRate)) + (FiltNR.envelopeVector + (Osci.static Wave.square 0 (freq/sampleRate)) + (Ctrl.exponential2 (0.01*sampleRate) amp)) + +densitySmooth, densityHeavy :: Trans.C a => a -> a +densitySmooth x = x * exp(-10*x*x) +densityHeavy x = 0.4 * exp (-4*x) + +timeDiffsAlt :: [Bool] -> [NonNeg.Int] +timeDiffsAlt = + let diffs n (True : xs) = n : diffs 1 xs + diffs n (False : xs) = diffs (succ n) xs + diffs _ [] = [] + in diffs (NonNeg.fromNumber 0) + +timeDiffs :: [Bool] -> [NonNeg.Int] +timeDiffs = map (NonNeg.fromNumber . length) . segmentBefore id + +segmentBefore :: (a -> Bool) -> [a] -> [[a]] +segmentBefore p = + foldr (\ x ~(y:ys) -> (if p x then ([]:) else id) ((x:y):ys)) [[]] diff --git a/src/Synthesizer/Plain/File.hs b/src/Synthesizer/Plain/File.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Plain/File.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Synthesizer.Plain.File where + +import qualified Sound.Sox.Convert as Convert +import qualified Sound.Sox.Frame as Frame +import qualified Sound.Sox.Frame.Stereo as Stereo +import qualified Sound.Sox.Option.Format as SoxOpt +import qualified Sound.Sox.Write as Write +import qualified Sound.Sox.Read as Read +import qualified Sound.Sox.Signal.List as SoxList + +import qualified Synthesizer.Plain.IO as FileL +import qualified Synthesizer.Plain.Builder as Builder + +import qualified Data.ByteString.Lazy as B +import qualified Data.Binary.Get as Get +import qualified Synthesizer.Basic.Binary as BinSmp +import Foreign.Storable (Storable, ) +import Data.Int (Int16, ) + +import System.Cmd (rawSystem, ) +import System.Exit (ExitCode, ) +import Control.Monad (liftM2, ) +import Data.Monoid (mconcat, ) + +import qualified Algebra.ToInteger as ToInteger +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field + +import qualified System.FilePath as FilePath + +import PreludeBase +import NumericPrelude + + + +{- | +See 'write'. +-} +render :: + (Storable int, Frame.C int, ToInteger.C int, Bounded int, + RealField.C a, BinSmp.C v) => + Builder.Put int -> FilePath -> a -> (a -> [v]) -> IO ExitCode +render put fileName sampleRate renderer = + write put fileName sampleRate (renderer sampleRate) + +renderToInt16 :: (RealField.C a, BinSmp.C v) => + FilePath -> a -> (a -> [v]) -> IO ExitCode +renderToInt16 fileName sampleRate renderer = + writeToInt16 fileName sampleRate (renderer sampleRate) + +renderMonoToInt16 :: (RealField.C a) => + FilePath -> a -> (a -> [a]) -> IO ExitCode +renderMonoToInt16 fileName sampleRate renderer = + writeMonoToInt16 fileName sampleRate (renderer sampleRate) + +renderStereoToInt16 :: (RealField.C a) => + FilePath -> a -> (a -> [(a,a)]) -> IO ExitCode +renderStereoToInt16 fileName sampleRate renderer = + writeStereoToInt16 fileName sampleRate (renderer sampleRate) + + +{- | +The output format is determined by SoX by the file name extension. +The sample precision is determined by the provided 'Builder.Put' function. + +Example: + +> import qualified Synthesizer.Plain.Builder as Builder +> +> write (Builder.put :: Builder.Put Int16) "test.aiff" 44100 sound +-} +write :: + (Storable int, Frame.C int, ToInteger.C int, Bounded int, + RealField.C a, BinSmp.C v) => + Builder.Put int -> FilePath -> a -> [v] -> IO ExitCode +write put fileName sampleRate signal = + writeRaw + (SoxOpt.numberOfChannels (BinSmp.numberOfSignalChannels signal)) + fileName + sampleRate + (Builder.run . mconcat . map (BinSmp.outputFromCanonical put) $ + signal) + +writeToInt16 :: (RealField.C a, BinSmp.C v) => + FilePath -> a -> [v] -> IO ExitCode +writeToInt16 = + write (Builder.put :: Builder.Put Int16) + +writeMonoToInt16 :: (RealField.C a) => + FilePath -> a -> [a] -> IO ExitCode +writeMonoToInt16 fileName sampleRate signal = + writeRaw SoxOpt.none fileName sampleRate + (map BinSmp.int16FromCanonical signal) + +writeStereoToInt16 :: (RealField.C a) => + FilePath -> a -> [(a,a)] -> IO ExitCode +writeStereoToInt16 fileName sampleRate signal = + writeRaw SoxOpt.none fileName sampleRate + (map (fmap BinSmp.int16FromCanonical . uncurry Stereo.cons) signal) + +writeRaw :: (RealField.C a, Frame.C v, Storable v) => + SoxOpt.T -> FilePath -> a -> [v] -> IO ExitCode +writeRaw opts fileName sampleRate signal = + Write.extended SoxList.put opts SoxOpt.none fileName (round sampleRate) signal + +{- | +You hardly need this routine +since you can use a filename with @.mp3@ or @.ogg@ +extension for 'writeRaw' +and SoX will do the corresponding compression for you. +-} +writeRawCompressed :: (RealField.C a, Frame.C v, Storable v) => + SoxOpt.T -> FilePath -> a -> [v] -> IO ExitCode +writeRawCompressed opts fileName sampleRate signal = + do writeRaw opts fileName sampleRate signal + compress fileName + + +{-# DEPRECATED rawToAIFF "If you want to generate AIFF, then just write to files with .aiff filename extension. If you want to convert files to AIFF, use Sound.Sox.Convert." #-} +rawToAIFF :: (RealField.C a) => + FilePath -> SoxOpt.T -> a -> Int -> IO ExitCode +rawToAIFF fileName soxOptions sampleRate numChannels = + let fileNameRaw = fileName ++ ".sw" + fileNameAIFF = fileName ++ ".aiff" + in Convert.simple + (mconcat $ + soxOptions : + SoxOpt.sampleRate (round sampleRate) : + SoxOpt.numberOfChannels numChannels : + []) + fileNameRaw + SoxOpt.none fileNameAIFF + +compress :: FilePath -> IO ExitCode +compress fileName = + do rawSystem "oggenc" ["--quality", "5", fileName] + rawSystem "lame" + ["-h", fileName, FilePath.replaceExtension fileName "mp3"] + + +{-# DEPRECATED readAIFFMono "Use readMonoFromInt16 instead" #-} +{- +This implementation doesn't work properly. +It seems like readFile is run +after all system calls to Sox are performed. +Aren't the calls serialized? + +readAIFFMono :: (RealField.C a, Floating a) => FilePath -> IO [a] +readAIFFMono file = + do putStrLn ("sox "++file++" /tmp/sample.sw") + system ("sox "++file++" /tmp/sample.sw") + str <- readFile "/tmp/sample.sw" + return (binaryToSignalMono str) +-} +readAIFFMono :: (Field.C a) => FilePath -> IO [a] +readAIFFMono file = + do --putStrLn ("sox "++file++" "++tmp) + let tmp = FilePath.replaceExtension file "sw" + Convert.simple SoxOpt.none file SoxOpt.none tmp + fmap (map BinSmp.int16ToCanonical) (FileL.readInt16StreamStrict tmp) + + +{- | +I suspect we cannot handle file closing properly. +-} +readMonoFromInt16 :: (Field.C a) => FilePath -> IO [a] +readMonoFromInt16 fileName = + Read.open SoxOpt.none fileName >>= + Read.withHandle1 (fmap (Get.runGet getInt16List) . B.hGetContents) >>= + return . map BinSmp.int16ToCanonical + +getInt16List :: Get.Get [Int16] +getInt16List = + do b <- Get.isEmpty + if b + then return [] + else liftM2 (:) (fmap fromIntegral Get.getWord16host) getInt16List diff --git a/src/Synthesizer/Plain/Filter/Delay.hs b/src/Synthesizer/Plain/Filter/Delay.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Plain/Filter/Delay.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Synthesizer.Plain.Filter.Delay where + +import qualified Synthesizer.Plain.Filter.NonRecursive as FiltNR +import qualified Synthesizer.Plain.Displacement as Syn +import qualified Synthesizer.Plain.Control as Ctrl +import qualified Synthesizer.Plain.Noise as Noise +import System.Random (Random, randomRs, mkStdGen, ) + +import qualified Algebra.Module as Module +import qualified Algebra.RealField as RealField +import qualified Algebra.Additive as Additive + +import qualified Synthesizer.Plain.Interpolation as Interpolation + +import qualified Synthesizer.Plain.Filter.Delay.ST as DelayST +import qualified Synthesizer.Plain.Filter.Delay.List as DelayList +import qualified Synthesizer.Plain.Filter.Delay.Block as DelayBlock + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +phaser :: (Module.C a v, RealField.C a) => a -> [a] -> [v] -> [v] +phaser maxDelay ts xs = + FiltNR.amplifyVector (0.5 `asTypeOf` head ts) + (Syn.mix xs + (DelayBlock.modulated Interpolation.constant (ceiling maxDelay) ts xs)) + + +plane :: Double -> [Double] +plane sampleRate = + let maxDelay = 500 + in phaser + maxDelay + (map (maxDelay-) + (Ctrl.exponential2 (10*sampleRate) maxDelay)) + Noise.white + + +-- move to test suite *** +propSingle :: Interpolation.T Double Double -> [Bool] +propSingle ip = + let maxDelay = (5::Int) + xs = randomRs (-1,1) (mkStdGen 1037) + ts = take 20 (randomRs (0, fromIntegral maxDelay) (mkStdGen 2330)) + pm0 = DelayST.modulated ip maxDelay ts xs + pm1 = DelayList.modulatedRev ip maxDelay ts xs + pm2 = DelayList.modulated ip maxDelay ts xs + pm3 = DelayBlock.modulated ip maxDelay ts xs + approx x y = abs (x-y) < 1e-10 + -- equal as = and (zipWith (==) as (tail as)) + -- equal [pm0, pm1 {-, pm2-}] + in [pm0==pm1, pm2==pm3, and (zipWith approx pm1 pm2)] + +{- | +The test for constant interpolation will fail, +due to different point of views in forward and backward interpolation. +-} +propAll :: [[Bool]] +propAll = + map propSingle $ + Interpolation.constant : + Interpolation.linear : + Interpolation.cubic : + [] diff --git a/src/Synthesizer/Plain/Filter/Delay/Block.hs b/src/Synthesizer/Plain/Filter/Delay/Block.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Plain/Filter/Delay/Block.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{- | +Fast delay based on block lists. +Blocks are arrays. They are part of Haskell 98. +In contrast to ring buffers, +block lists allow infinite look ahead. +-} +module Synthesizer.Plain.Filter.Delay.Block where + +import qualified Synthesizer.Plain.Interpolation as Interpolation +import qualified Synthesizer.Plain.Signal as Sig + +import qualified Algebra.RealField as RealField +import qualified Algebra.Additive as Additive + +import Data.Array((!), Array, listArray, elems, bounds, indices, rangeSize) +import Data.List(tails) + +import Test.QuickCheck ((==>), Property) + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +modulatedCore :: (RealField.C a, Additive.C v) => + Interpolation.T a v -> Int -> Sig.T a -> Sig.T v -> Sig.T v +modulatedCore ip size ts = + zipWith + (\t (offset,bs) -> + let (ti,tf) = splitFraction (-t) + in Interpolation.func ip tf (dropBlocksToList (size+offset+ti) bs)) + ts . + suffixIndexes . + {- Using 'size' for the block size is a heuristics, + maybe it is not a good choice in many cases. -} + listToBlocks size + +modulated :: (RealField.C a, Additive.C v) => + Interpolation.T a v -> Int -> Sig.T a -> Sig.T v -> Sig.T v +modulated ip maxDelay ts xs = + let size = maxDelay + Interpolation.number ip + in modulatedCore ip + (size - Interpolation.offset ip) + ts + (replicate size zero ++ xs) + + +type BlockList a = [Array Int a] + + +listToBlocks :: Int -> Sig.T a -> BlockList a +listToBlocks blockSize = + map (listArray (0,blockSize-1)) . + takeWhile (not . null) . + iterate (drop blockSize) + + +dropBlocksToList :: Int -> BlockList a -> Sig.T a +dropBlocksToList number blocks = + let dropUntil remain (b:bs) = + if remain <= snd (bounds b) + then (remain, b, bs) + else dropUntil (remain - rangeSize (bounds b)) bs + dropUntil remain [] = (remain, listArray (0,-1) [], []) + (offset, lead, suffix) = dropUntil number blocks + in map (lead!) [offset .. (snd $ bounds lead)] ++ + concatMap elems suffix + +propDrop :: Int -> Int -> [Int] -> Property +propDrop size n xs = + let infXs = cycle xs + len = 1000 + in size>0 && n>=0 && not (null xs) ==> + take len (drop n infXs) == + take len (dropBlocksToList n (listToBlocks size infXs)) + +{- | +Drop elements from a blocked list. +The offset must lie in the leading block. +-} +dropSingleBlocksToList :: Int -> BlockList a -> Sig.T a +dropSingleBlocksToList number (arr:arrs) = + map (arr!) [number .. (snd $ bounds arr)] ++ + concatMap elems arrs +dropSingleBlocksToList _ [] = [] + + +suffixIndexes :: BlockList a -> [(Int, BlockList a)] +suffixIndexes xs = + do blockSuffix <- init $ tails xs + i <- indices $ head blockSuffix + return (i,blockSuffix) diff --git a/src/Synthesizer/Plain/Filter/Delay/List.hs b/src/Synthesizer/Plain/Filter/Delay/List.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Plain/Filter/Delay/List.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Synthesizer.Plain.Filter.Delay.List where + +import qualified Synthesizer.Plain.Interpolation as Interpolation + +import qualified Algebra.RealField as RealField +import qualified Algebra.Additive as Additive + +import Data.List(tails) + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +{- | +This function uses suffixes of the reversed signal. +This way small delays perform well +but the big drawback is that the garbage collector +can not deallocate old samples. +-} +modulatedRevCore :: (RealField.C a, Additive.C v) => + Interpolation.T a v -> Int -> [a] -> [v] -> [v] +modulatedRevCore ip size ts xs = + zipWith + (\t x -> + let (ti,tf) = splitFraction t + in Interpolation.func ip tf (drop ti x)) + ts (drop size (scanl (flip (:)) [] xs)) + +modulatedRev :: (RealField.C a, Additive.C v) => + Interpolation.T a v -> Int -> [a] -> [v] -> [v] +modulatedRev ip maxDelay ts xs = + let size = maxDelay + Interpolation.number ip + in modulatedRevCore ip + (size + 1 + Interpolation.offset ip) + ts + (replicate size zero ++ xs) + + + +modulatedCore :: (RealField.C a, Additive.C v) => + Interpolation.T a v -> Int -> [a] -> [v] -> [v] +modulatedCore ip size ts xs = + zipWith + (\t x -> + let (ti,tf) = splitFraction (-t) + in Interpolation.func ip tf (drop (size+ti) x)) + ts (tails xs) + +{- | +This is essentially different for constant interpolation, +because this function "looks forward" +whereas the other two variants "look backward". +For the symmetric interpolation functions +of linear and cubic interpolation, this does not really matter. +-} +modulated :: (RealField.C a, Additive.C v) => + Interpolation.T a v -> Int -> [a] -> [v] -> [v] +modulated ip maxDelay ts xs = + let size = maxDelay + Interpolation.number ip + in modulatedCore ip + (size - Interpolation.offset ip) + ts + (replicate size zero ++ xs) diff --git a/src/Synthesizer/Plain/Filter/Delay/ST.hs b/src/Synthesizer/Plain/Filter/Delay/ST.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Plain/Filter/Delay/ST.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{- | +An implementation of a Delay using a classical circular buffer +running in the State Thread monad. +-} +module Synthesizer.Plain.Filter.Delay.ST where + +import qualified Synthesizer.Plain.Interpolation as Interpolation + +import qualified Algebra.RealField as RealField +import qualified Algebra.Additive as Additive + +import Control.Monad.ST.Lazy(runST,strictToLazyST,ST) +import Data.Array.ST + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +{- +I had no success in hiding ST in the 'modulatedST' function. +The explicit type signature is crucial. +-} +modulatedAction :: (RealField.C a, Additive.C v) => + Interpolation.T a v -> Int -> [a] -> [v] -> ST s [v] +modulatedAction ip size ts xs = + let ipNum = Interpolation.number ip + ipFunc = Interpolation.func ip + in do arr <- strictToLazyST (newArray (0,2*size-1) zero) + :: Additive.C v => ST s (STArray s Int v) + mapM (\(n,t,x) -> strictToLazyST $ + do writeArray arr n x + writeArray arr (n+size) x + let (ti,tf) = splitFraction t + y <- mapM (readArray arr) (take ipNum [(n+ti) ..]) + return (if ti<0 + then error "negative delay" + else + if size < ti+ipNum + then error "too much delay" + else ipFunc tf y)) + (zip3 (cycle [(size-1),(size-2)..0]) ts xs) + +modulated :: (RealField.C a, Additive.C v) => + Interpolation.T a v -> Int -> [a] -> [v] -> [v] +modulated ip maxDelay ts xs = + let offset = Interpolation.offset ip + in drop offset + (runST + (modulatedAction + ip (maxDelay + Interpolation.number ip) + (replicate offset zero ++ ts) xs)) + + diff --git a/src/Synthesizer/Plain/Filter/LinearPredictive.hs b/src/Synthesizer/Plain/Filter/LinearPredictive.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Plain/Filter/LinearPredictive.hs @@ -0,0 +1,39 @@ +module Synthesizer.Plain.Filter.LinearPredictive where + +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive +import Synthesizer.Plain.Analysis (scalarProduct) + +import qualified Data.List.Match as ListMatch +import qualified Data.List as List + +import NumericPrelude +import PreludeBase +import Prelude () + + +{- | +Determine optimal filter coefficients and residue by adaptive approximation. +The number of initial filter coefficients is used as filter order. +-} +approxCoefficients :: Field.C a => + a -> [a] -> [a] -> [(a,[a])] +approxCoefficients k mask0 xs = + let infixes = map (ListMatch.take mask0) (List.tails xs) + targets = ListMatch.drop mask0 xs + in scanl + (\(_,mask) (infx,target) -> + let residue = target - scalarProduct mask infx + norm2 = scalarProduct infx infx + in (residue, + mask + map ((k*residue/norm2)*) infx)) + (zero,mask0) (zip infixes targets) +{- +mapM print $ take 20 $ drop 2000 $ approxCoefficients (1::Double) [0,0,0,0.1] (iterate (1+) 100) + + +mapM print $ take 20 $ drop 10000 $ approxCoefficients (0.2::Double) [0.1,0] (map sin (iterate (0.03+) 0)) + +must yield coefficients [-1, 2*cos(0.03::Double)] +-} diff --git a/src/Synthesizer/Plain/Filter/NonRecursive.hs b/src/Synthesizer/Plain/Filter/NonRecursive.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Plain/Filter/NonRecursive.hs @@ -0,0 +1,291 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{- | +Copyright : (c) Henning Thielemann 2006 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes +-} +module Synthesizer.Plain.Filter.NonRecursive where + +import qualified Synthesizer.Plain.Control as Ctrl +import qualified Synthesizer.Plain.Signal as Sig + +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Module as Module +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Algebra.Module(linearComb, (*>)) + +import Data.Function.HT (nest, ) +import Data.List (tails, ) + +-- import Control.Monad.Trans.State (StateT) +-- import Control.Monad.Trans.Writer (WriterT) + +import PreludeBase +import NumericPrelude + + +{- * Envelope application -} + +amplify :: (Ring.C a) => a -> Sig.T a -> Sig.T a +amplify v = map (v*) + +amplifyVector :: (Module.C a v) => a -> Sig.T v -> Sig.T v +amplifyVector = (*>) + + +envelope :: (Ring.C a) => + Sig.T a {-^ the envelope -} + -> Sig.T a {-^ the signal to be enveloped -} + -> Sig.T a +envelope = zipWith (*) + +envelopeVector :: (Module.C a v) => + Sig.T a {-^ the envelope -} + -> Sig.T v {-^ the signal to be enveloped -} + -> Sig.T v +envelopeVector = zipWith (*>) + + + +fadeInOut :: (Field.C a) => Int -> Int -> Int -> Sig.T a -> Sig.T a +fadeInOut tIn tHold tOut xs = + let leadIn = take tIn $ Ctrl.linearMultiscale ( recip (fromIntegral tIn)) 0 + leadOut = take tOut $ Ctrl.linearMultiscale (- recip (fromIntegral tOut)) 1 + (partIn, partHoldOut) = splitAt tIn xs + (partHold, partOut) = splitAt tHold partHoldOut + in envelope leadIn partIn ++ + partHold ++ + envelope leadOut partOut + + +fadeInOutAlt :: (Field.C a) => Int -> Int -> Int -> Sig.T a -> Sig.T a +fadeInOutAlt tIn tHold tOut = + zipWith id + ((map (\x y -> y * fromIntegral x / fromIntegral tIn) [0..tIn-1]) ++ + (replicate tHold id) ++ + (map (\x y -> y * fromIntegral x / fromIntegral tOut) [tOut-1,tOut-2..0])) + + + +{- * Shift -} + +delay :: Additive.C y => Int -> Sig.T y -> Sig.T y +delay = delayPad zero + +delayPad :: y -> Int -> Sig.T y -> Sig.T y +delayPad z n = + if n<0 + then drop (negate n) + else (replicate n z ++) + + +{- * Smoothing -} + + +{-| Unmodulated non-recursive filter -} +generic :: Module.C a v => + Sig.T a -> Sig.T v -> Sig.T v +generic m x = + let mr = reverse m + xp = delay (pred (length m)) x + in map (linearComb mr) (init (tails xp)) + +{-| +Unmodulated non-recursive filter +Output has same length as the input. + +It is elegant but leaks memory. + -} +genericAlt :: Module.C a v => + Sig.T a -> Sig.T v -> Sig.T v +genericAlt m x = + map (linearComb m) + (tail (scanl (flip (:)) [] x)) + + +propGeneric :: (Module.C a v, Eq v) => + Sig.T a -> Sig.T v -> Bool +propGeneric m x = +-- generic m x == genericAlt m x + and $ zipWith (==) (generic m x) (genericAlt m x) + + + +{- | +@eps@ is the threshold relatively to the maximum. +That is, if the gaussian falls below @eps * gaussian 0@, +then the function truncated. +-} +gaussian :: (Trans.C a, RealField.C a, Module.C a v) => a -> a -> a -> Sig.T v -> Sig.T v +gaussian eps ratio freq = + let var = ratioFreqToVariance ratio freq + area = var * sqrt (2*pi) + gau t = exp (-(t/var)^2/2) / area + width = ceiling (var * sqrt (-2 * log eps)) -- inverse gau + gauSmp = map (gau . fromIntegral) [-width .. width] + in drop width . generic gauSmp + +{- +GNUPlot.plotList [] (take 1000 $ gaussian 0.001 0.5 0.04 (Filter.Test.chirp 5000) :: [Double]) + +The filtered chirp must have amplitude 0.5 at 400 (0.04*10000). +-} + +{- + We want to approximate a Gaussian by a binomial filter. + The latter one can be implemented by a convolutional power. + However we still require a number of operations per sample + which is proportional to the variance. +-} +binomial :: (Trans.C a, RealField.C a, Module.C a v) => a -> a -> Sig.T v -> Sig.T v +binomial ratio freq = + let width = ceiling (2 * ratioFreqToVariance ratio freq ^ 2) + in drop width . nest (2*width) ((asTypeOf 0.5 freq *>) . binomial1) + +{- +exp (-(t/var)^2/2) / area *> cis (2*pi*f*t) + == exp (-(t/var)^2/2 +: 2*pi*f*t) / area + == exp ((-t^2 +: 2*var^2*2*pi*f*t) / (2*var^2)) / area + == exp ((t^2 - i*2*var^2*2*pi*f*t) / (-2*var^2)) / area + == exp (((t^2 - i*var^2*2*pi*f)^2 + (var^2*2*pi*f)^2) / (-2*var^2)) / area + == exp (((t^2 - i*var^2*2*pi*f)^2 / (-2*var^2) - (var*2*pi*f)^2/2)) / area + +sumMap (\t -> exp (-(t/var)^2/2) / area *> cis (2*pi*f*t)) + [-infinity..infinity] + ~ sumMap (\t -> exp (-(t/var)^2/2)) [-infinity..infinity] + * exp (-(var*2*pi*f)^2/2) / area + = exp (-(var*2*pi*f)^2/2) +-} +{- | + Compute the variance of the Gaussian + such that its Fourier transform has value @ratio@ at frequency @freq@. +-} +ratioFreqToVariance :: (Trans.C a) => a -> a -> a +ratioFreqToVariance ratio freq = + sqrt (-2 * log ratio) / (2*pi*freq) + -- inverse of the fourier transformed gaussian + +binomial1 :: (Additive.C v) => Sig.T v -> Sig.T v +binomial1 xt@(x:xs) = x : (xs + xt) +binomial1 [] = [] + + + + + + +{- | +Moving (uniformly weighted) average in the most trivial form. +This is very slow and needs about @n * length x@ operations. +-} +sums :: (Additive.C v) => Int -> Sig.T v -> Sig.T v +sums n = map (sum . take n) . init . tails + + + +sumsDownsample2 :: (Additive.C v) => Sig.T v -> Sig.T v +sumsDownsample2 (x0:x1:xs) = (x0+x1) : sumsDownsample2 xs +sumsDownsample2 xs = xs + +downsample2 :: Sig.T a -> Sig.T a +downsample2 (x0:_:xs) = x0 : downsample2 xs +downsample2 xs = xs + + +{- | +Given a list of numbers +and a list of sums of (2*k) of successive summands, +compute a list of the sums of (2*k+1) or (2*k+2) summands. + +Eample for 2*k+1 + +@ + [0+1+2+3, 2+3+4+5, 4+5+6+7, ...] -> + [0+1+2+3+4, 1+2+3+4+5, 2+3+4+5+6, 3+4+5+6+7, 4+5+6+7+8, ...] +@ + +Example for 2*k+2 + +@ + [0+1+2+3, 2+3+4+5, 4+5+6+7, ...] -> + [0+1+2+3+4+5, 1+2+3+4+5+6, 2+3+4+5+6+7, 3+4+5+6+7+8, 4+5+6+7+8+9, ...] +@ +-} +sumsUpsampleOdd :: (Additive.C v) => Int -> Sig.T v -> Sig.T v -> Sig.T v +sumsUpsampleOdd n {- 2*k -} xs ss = + let xs2k = drop n xs + in (head ss + head xs2k) : + concat (zipWith3 (\s x0 x2k -> [x0+s, s+x2k]) + (tail ss) + (downsample2 (tail xs)) + (tail (downsample2 xs2k))) + +sumsUpsampleEven :: (Additive.C v) => Int -> Sig.T v -> Sig.T v -> Sig.T v +sumsUpsampleEven n {- 2*k -} xs ss = + sumsUpsampleOdd (n+1) xs (zipWith (+) ss (downsample2 (drop n xs))) + +sumsPyramid :: (Additive.C v) => Int -> Sig.T v -> Sig.T v +sumsPyramid = + let aux 1 ys = ys + aux 2 ys = ys + tail ys -- binomial1 + aux m ys = + let ysd = sumsDownsample2 ys + in if even m + then sumsUpsampleEven (m-2) ys (aux (div (m-2) 2) ysd) + else sumsUpsampleOdd (m-1) ys (aux (div (m-1) 2) ysd) + in aux + + +{- +*Synthesizer.Plain.Filter.NonRecursive> movingAverageModulated 10 (replicate 10 (3::Double) ++ [1.1,2.2,2.6,0.7,0.1,0.1]) (repeat (1::Double)) +[0.5,0.6666666666666666,0.8333333333333333,1.0,1.0,1.0,1.0,1.0,1.0,1.0,0.9999999999999999,1.0,0.9999999999999998,0.999999999999999,0.9999999999999942,0.9999999999999942] +-} + + +{- * Filter operators from calculus -} + +{- | +Forward difference quotient. +Shortens the signal by one. +Inverts 'Synthesizer.Plain.Filter.Recursive.Integration.run' in the sense that +@differentiate (zero : integrate x) == x@. +The signal is shifted by a half time unit. +-} +differentiate :: Additive.C v => Sig.T v -> Sig.T v +differentiate x = zipWith subtract x (tail x) + +{- | +Central difference quotient. +Shortens the signal by two elements, +and shifts the signal by one element. +(Which can be fixed by prepending an appropriate value.) +For linear functions this will yield +essentially the same result as 'differentiate'. +You obtain the result of 'differentiateCenter' +if you smooth the one of 'differentiate' +by averaging pairs of adjacent values. + +ToDo: Vector variant +-} +differentiateCenter :: Field.C v => Sig.T v -> Sig.T v +differentiateCenter x = + map ((1/2)*) $ + zipWith subtract x (tail (tail x)) + +{- | +Second derivative. +It is @differentiate2 == differentiate . differentiate@ +but 'differentiate2' should be faster. +-} +differentiate2 :: Additive.C v => Sig.T v -> Sig.T v +differentiate2 xs0 = + let xs1 = tail xs0 + xs2 = tail xs1 + in zipWith3 (\x0 x1 x2 -> x0+x2-(x1+x1)) xs0 xs1 xs2 diff --git a/src/Synthesizer/Plain/Filter/Recursive.hs b/src/Synthesizer/Plain/Filter/Recursive.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Plain/Filter/Recursive.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes +-} +module Synthesizer.Plain.Filter.Recursive where + +import qualified Algebra.Module as Module +-- import qualified Algebra.Transcendental as Trans +-- import qualified Algebra.Field as Field +-- import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Algebra.Additive((+), (-), negate, ) +import Algebra.Module((*>)) + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +{- * Various Filters -} + + +{- ** Recursive filters with resonance -} + +{-| Description of a filter pole. -} +data Pole a = + Pole {poleResonance :: !a {- ^ Resonance, that is the amplification of the band center frequency. -} + , poleFrequency :: !a {- ^ Band center frequency. -} } + deriving (Eq, Show, Read) + +instance Additive.C v => Additive.C (Pole v) where + zero = Pole zero zero + (+) (Pole yr yf) (Pole xr xf) = Pole (yr + xr) (yf + xf) + (-) (Pole yr yf) (Pole xr xf) = Pole (yr - xr) (yf - xf) + negate (Pole xr xf) = Pole (negate xr) (negate xf) + +{- +An instance for Module.C of the Pole datatype +makes no sense in most cases, +but when it comes to interpolation +this is very handy. +-} +instance Module.C a v => Module.C a (Pole v) where + s *> (Pole xr xf) = Pole (s *> xr) (s *> xf) + + +data Passband = Lowpass | Highpass + deriving (Show, Eq, Enum) diff --git a/src/Synthesizer/Plain/Filter/Recursive/Allpass.hs b/src/Synthesizer/Plain/Filter/Recursive/Allpass.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Plain/Filter/Recursive/Allpass.hs @@ -0,0 +1,202 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes +-} +module Synthesizer.Plain.Filter.Recursive.Allpass where + +import qualified Synthesizer.Plain.Signal as Sig +import qualified Synthesizer.Plain.Modifier as Modifier +import qualified Synthesizer.Causal.Process as Causal +import qualified Synthesizer.Interpolation.Class as Interpol + +import qualified Algebra.Module as Module +import qualified Algebra.RealTranscendental as RealTrans +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Algebra.Module((*>)) + +import Number.Complex ((+:)) +import qualified Number.Complex as Complex +import Data.Tuple.HT (mapSnd, ) +import Data.Function.HT (nest, ) + +import Control.Monad.Trans.State (State, state, runState, evalState, ) + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + + +newtype Parameter a = + Parameter {getParameter :: a} {- ^ Feedback factor. -} + deriving Show + + +instance Interpol.C a v => Interpol.C a (Parameter v) where + {-# INLINE scaleAndAccumulate #-} + scaleAndAccumulate = Interpol.makeMac Parameter getParameter + + +{- +Shall the phase parameter be of type Phase? +I think no, because for the allpass cascade we divide by the order +and then there is a difference between phase pi and 3*pi. +-} +{-# INLINE parameter #-} +parameter :: Trans.C a => + Int {- ^ The number of equally designed 1st order allpasses. -} + -> a {- ^ The phase shift to be achieved for the given frequency. -} + -> a {- ^ The frequency we specified the phase shift for. -} + -> Parameter a +parameter order phase frequency = + let orderFloat = fromIntegral order + omega = frequency * 2 * pi + phi = phase / orderFloat + k = (cos phi - cos omega) / (1 - cos (phi - omega)) + in Parameter k + +{-# INLINE flangerPhase #-} +flangerPhase :: Trans.C a => a +flangerPhase = -2*pi + +{-# INLINE flangerParameter #-} +flangerParameter :: Trans.C a => Int -> a -> Parameter a +flangerParameter order frequency = + parameter order flangerPhase frequency + +{-# INLINE firstOrderStep #-} +firstOrderStep :: (Ring.C a, Module.C a v) => + Parameter a -> v -> State (v,v) v +firstOrderStep (Parameter k) u0 = + state (\(u1,y1) -> let y0 = u1 + k *> (u0-y1) in (y0,(u0,y0))) + +{-# INLINE firstOrderModifier #-} +firstOrderModifier :: (Ring.C a, Module.C a v) => + Modifier.Simple (v,v) (Parameter a) v v +firstOrderModifier = + Modifier.Simple (zero,zero) firstOrderStep + +{-# INLINE firstOrderCausal #-} +firstOrderCausal :: (Ring.C a, Module.C a v) => + Causal.T (Parameter a, v) v +firstOrderCausal = + Causal.fromSimpleModifier firstOrderModifier + +{-# INLINE firstOrder #-} +firstOrder :: (Ring.C a, Module.C a v) => + Sig.T (Parameter a) -> Sig.T v -> Sig.T v +firstOrder = Sig.modifyModulated firstOrderModifier + + +{-# INLINE makePhase #-} +makePhase :: RealTrans.C a => Parameter a -> a -> a +makePhase (Parameter k) frequency = + let omega = 2*pi * frequency + in 2 * Complex.phase ((k+cos omega)+:(- sin omega)) + omega + +{- +internal storage is not very efficient +because the second value of one pair is equal +to the first value of the subsequent value +-} +{-# INLINE cascadeStepStackPairs #-} +cascadeStepStackPairs :: (Ring.C a, Module.C a v) => + Parameter a -> v -> State [(v,v)] v +cascadeStepStackPairs k = + -- stackStatesR would work as well, but with reversed list of states + Modifier.stackStatesL (firstOrderStep k) + +{-# INLINE cascadeStepStack #-} +cascadeStepStack :: (Ring.C a, Module.C a v) => + Parameter a -> v -> State [v] v +cascadeStepStack k x = + state $ + mapSnd fromPairs . + runState (cascadeStepStackPairs k x) . + toPairs + +{-# INLINE fromPairs #-} +fromPairs :: [(a,a)] -> [a] +fromPairs xs@(x:_) = fst x : map snd xs +fromPairs [] = error "Allpass.fromPairs: empty list" + +{-# INLINE toPairs #-} +toPairs :: [a] -> [(a,a)] +toPairs xs = zip xs (tail xs) + +{-# INLINE cascadeStep #-} +{-# INLINE cascadeStepRec #-} +{-# INLINE cascadeStepRecAlt #-} +cascadeStep, cascadeStepRec, cascadeStepRecAlt :: + (Ring.C a, Module.C a v) => + Parameter a -> v -> State [v] v + +cascadeStep = cascadeStepRec + +cascadeStepRec (Parameter k) x = state $ \s -> + let crawl _ [] = error "Allpass.crawl needs at least one element in the list" + crawl u0 (_:[]) = u0:[] + crawl u0 (u1:y1:us) = + let y0 = u1 + k *> (u0-y1) + in u0 : crawl y0 (y1:us) + news = crawl x s + in (last news, news) + +cascadeStepRecAlt k x = state $ \s -> + let crawl _ [] = error "Allpass.crawl needs at least one element in the list" + crawl u0 (u1:u1s) = mapSnd (u0:) $ + case u1s of + [] -> (u0,[]) + (y1:_) -> + crawl (evalState (firstOrderStep k u0) (u1,y1)) u1s + in crawl x s + +{-# INLINE cascadeModifier #-} +cascadeModifier :: (Ring.C a, Module.C a v) => + Int -> Modifier.Simple [v] (Parameter a) v v +cascadeModifier order = + Modifier.Simple (replicate (succ order) zero) cascadeStep + +{-# INLINE cascadeCausal #-} +{-# INLINE cascadeCausalStacked #-} +{-# INLINE cascadeCausalModifier #-} +cascadeCausal, cascadeCausalStacked, cascadeCausalModifier :: + (Ring.C a, Module.C a v) => + Int -> Causal.T (Parameter a, v) v +cascadeCausal = cascadeCausalModifier + +cascadeCausalStacked order = + Causal.replicateControlled order firstOrderCausal + +cascadeCausalModifier order = + Causal.fromSimpleModifier (cascadeModifier order) + + +{-# INLINE cascade #-} +{-# INLINE cascadeState #-} +{-# INLINE cascadeIterative #-} +cascade, cascadeState, cascadeIterative :: + (Ring.C a, Module.C a v) => + Int -> Sig.T (Parameter a) -> Sig.T v -> Sig.T v + +{-| Choose one of the implementations below -} +cascade = cascadeState + +{-| Simulate the Allpass cascade by a list of states of the partial allpasses -} +cascadeState order = + Sig.modifyModulated (cascadeModifier order) + +{-| Directly implement the allpass cascade as multiple application of allpasses of 1st order -} +cascadeIterative order c = + nest order (firstOrder c) diff --git a/src/Synthesizer/Plain/Filter/Recursive/AllpassPoly.hs b/src/Synthesizer/Plain/Filter/Recursive/AllpassPoly.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Plain/Filter/Recursive/AllpassPoly.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes +-} +module Synthesizer.Plain.Filter.Recursive.AllpassPoly where + +-- import qualified Synthesizer.Plain.Signal as Sig +-- import qualified Synthesizer.Plain.Modifier as Modifier + +import qualified Algebra.Module as Module +import qualified Algebra.RealTranscendental as RealTrans +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Algebra.Module((*>)) + +import Number.Complex (cis,(+:),real,imag) +import qualified Number.Complex as Complex +import Orthogonals(Scalar,one_ket_solution) + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + + +newtype Parameter a = Parameter [a] + deriving Show + +{- | Compute coefficients for an allpass that shifts low frequencies + by approximately the shift you want. + To achieve this we solve a linear least squares problem, + where low frequencies are more weighted than high ones. + The output is a list of coefficients for an arbitrary order allpass. -} +shiftParam :: (Scalar a, P.Fractional a, Trans.C a) => + Int -> a -> a -> Parameter a +shiftParam order weight phase = + let {- construct matrix for normal equations -} + normalVector = map negate + (map (scalarProdScrewExp weight order phase 0) [1..order]) + normalMatrix = map (\j -> + map (scalarProdScrewExp weight order phase j) [1..order]) [1..order] + in Parameter (one_ket_solution normalMatrix normalVector) + +{- + GNUPlot.plotFunc (GNUPlot.linearScale 500 (0,1)) ((fwrap (-pi,pi)).(makePhase (shiftParam 6 (-6) (-pi/2::Double)))) +-} +makePhase :: RealTrans.C a => Parameter a -> a -> a +makePhase (Parameter ks) frequency = + let omega = 2*pi * frequency + omegas = iterate (omega+) omega + denom = 1+sum (zipWith (\k w -> k*cos w +: k*sin w) ks omegas) + in 2 * Complex.phase denom - omega*(fromIntegral (length ks)) + +{- integrate (0,2*pi) (\omega -> exp (r*omega) * screwProd order phase k j omega) -} +scalarProdScrewExp :: Trans.C a => a -> Int -> a -> Int -> Int -> a +scalarProdScrewExp r order phase k j = + let (intCos,intSin) = integrateScrewExp r (k+j-order) + in 2 * (fst (integrateScrewExp r (k-j)) - + (cos phase * intCos + sin phase * intSin)) + +screwProd :: Trans.C a => Int -> a -> Int -> Int -> a -> a +screwProd order phase k j omega = + let z0 = cis (fromIntegral k * omega) - + cis phase * cis (fromIntegral (order-k) * omega) + z1 = cis (fromIntegral j * omega) - + cis phase * cis (fromIntegral (order-j) * omega) + in real z0 * real z1 + imag z0 * imag z1 + +{- integrate (0,2*pi) (\omega -> (exp (r*omega) +: 0) * cis (k*omega)) -} +integrateScrewExp :: Trans.C a => a -> Int -> (a,a) +integrateScrewExp r kInt = + let k = fromIntegral kInt + q = (exp (2*pi*r) - 1) / (r^2 + k^2) + in (r*q, -k*q) + +{- Should be moved to NumericPrelude -} +integrateNum :: (Field.C a, Module.C a v) => Int -> (a,a) -> (a->v) -> v +integrateNum n (lo,hi) f = + let xs = map (\k -> lo + (hi-lo) * fromIntegral k / fromIntegral n) + [1..(n-1)] + in ((hi-lo) / fromIntegral n) *> + (foldl (+) ((1/2 `asTypeOf` lo) *> (f lo + f hi)) + (map f xs)) diff --git a/src/Synthesizer/Plain/Filter/Recursive/Butterworth.hs b/src/Synthesizer/Plain/Filter/Recursive/Butterworth.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Plain/Filter/Recursive/Butterworth.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +Butterworth lowpass and highpass +-} +module Synthesizer.Plain.Filter.Recursive.Butterworth where + +import Synthesizer.Plain.Filter.Recursive (Passband(Lowpass,Highpass), Pole(Pole)) +import qualified Synthesizer.Plain.Filter.Recursive.SecondOrderCascade as Cascade +import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2 +-- import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1 +import qualified Synthesizer.Plain.Signal as Sig +import qualified Synthesizer.Plain.Modifier as Modifier +import qualified Synthesizer.Causal.Process as Causal +import Control.Arrow ((>>>), ) + +import qualified Algebra.Module as Module +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import qualified Data.StorableVector as SV +import Foreign.Storable (Storable) + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + + +sineList, sineListSlow, sineListFast :: (Trans.C a) => a -> [a] +sineList = sineListFast + +sineListSlow x = + map sin $ map (x*) $ iterate (2+) 1 + +sineListFast x = + let sinx = sin x + cos2x = 2 - 4*sinx*sinx + --cos2x = 2 * cos (2*x) + sines = (-sinx) : sinx : + zipWith (\y1 y0 -> cos2x * y0 - y1) sines (tail sines) + in tail sines + +makeSines :: (Trans.C a) => + Int -> [a] +makeSines order = + take (checkedHalf "makeSines" order) (sineList (pi / fromIntegral (2*order))) + +partialRatio :: (Trans.C a) => + Int -> a -> a +partialRatio order ratio = + (1/ratio^2-1) ** (-1 / fromIntegral (2*order)) + + + +partialParameterInstable, partialParameter :: (Trans.C a) => + a -> a -> a -> Filt2.Parameter a + +{- must handle infinite values when 'freq' approaches 0.5 -} +partialParameterInstable ratio freq sinw = + let wc = ratio * tan (pi*freq) + sinw2 = 2 * wc * sinw + wc2 = wc * wc + denom = wc2 + sinw2 + 1 + c0 = wc2 / denom + in Filt2.Parameter c0 (2*c0) c0 + (2*(1-wc2)/denom) ((-wc2+sinw2-1)/denom) + +-- using ratio disallows simplification by trigonometric Pythagoras' theorem +partialParameter ratio freq = + let phi = pi*freq + rsin2phi = ratio * sin (2*phi) + cosphi2 = cos phi ^ 2 + c0d = (ratio * sin phi) ^ 2 + d1d = (cosphi2 - c0d) * 2 + ratsin = cosphi2 + c0d + in \sinw -> + let rsinsin = rsin2phi * sinw + denom = rsinsin + ratsin + d2d = rsinsin - ratsin + c0 = c0d / denom + d1 = d1d / denom + d2 = d2d / denom + in Filt2.Parameter c0 (2*c0) c0 d1 d2 + + +-- * use second order filter parameters for control + +type Parameter a = Cascade.Parameter a + +{-# INLINE parameter #-} +parameter :: + (Trans.C a, Storable a) => + Passband -> Int -> Pole a -> Parameter a +parameter kind order = + -- I hope that the 'let' is floated out of a 'map' + let sinesVec = SV.pack (makeSines order) + in \ (Pole ratio freq) -> + Cascade.Parameter $ + SV.map (\sinw -> + Filt2.adjustPassband kind + (flip (partialParameter (partialRatio order ratio)) sinw) freq) $ + sinesVec + +{-# INLINE modifier #-} +modifier :: + (Ring.C a, Module.C a v, Storable a, Storable v) => + Int -> + Modifier.Simple (Cascade.Status v) (Parameter a) v v +modifier = + Cascade.modifier + +{-# INLINE causal #-} +causal :: (Ring.C a, Module.C a v, Storable a, Storable v) => + Int -> + Causal.T (Parameter a, v) v +causal order = + Cascade.causal (checkedHalf "causal" order) + + +{-# INLINE checkedHalf #-} +checkedHalf :: String -> Int -> Int +checkedHalf funcName order = + let (order2,r) = divMod order 2 + in if r==0 + then order2 + else error $ "Butterworth."++funcName++": order must be even" + +{- +lowpassCausal, highpassCausal :: (Trans.C a, Module.C a v) => + Int -> Causal.T (Parameter a, v) v +lowpassCausal = causal Lowpass +highpassCausal = causal Highpass + +lowpass, highpass :: (Trans.C a, Module.C a v) => + Int -> Sig.T (Parameter a) -> Sig.T v -> Sig.T v +lowpass = run Lowpass +highpass = run Highpass +-} + + +-- * directly use frequency as control parameter + +{- | +When called as @runPole kind order ratio freqs@, +the filter amplifies frequency 0 with factor 1 +and frequency @freq@ with factor @ratio@. + +It uses the frequency and ratio information directly +and thus cannot benefit from efficient parameter interpolation +(asynchronous run of a ControlledProcess. +-} +runPole :: (Trans.C a, Module.C a v) => + Passband -> Int -> Sig.T a -> Sig.T a -> Sig.T v -> Sig.T v +runPole kind order ratios freqs = + let makePartialFilter s = + Filt2.run (zipWith (\ratio -> + Filt2.adjustPassband kind $ \freq -> + partialParameter (partialRatio order ratio) freq s) ratios freqs) + in foldl (.) id (map makePartialFilter (makeSines order)) + +causalPole :: (Trans.C a, Module.C a v) => + Passband -> Int -> Causal.T (Pole a, v) v +causalPole kind order = + let {-# INLINE makePartialFilter #-} + makePartialFilter s = + Causal.first (Causal.map (\(Pole ratio freq) -> + Filt2.adjustPassband kind + (flip (partialParameter (partialRatio order ratio)) s) freq)) >>> + Filt2.causal + in Causal.chainControlled $ map makePartialFilter $ makeSines order + + +lowpassCausalPole, highpassCausalPole :: (Trans.C a, Module.C a v) => + Int -> Causal.T (Pole a, v) v +lowpassCausalPole = causalPole Lowpass +highpassCausalPole = causalPole Highpass + +lowpassPole, highpassPole :: (Trans.C a, Module.C a v) => + Int -> Sig.T a -> Sig.T a -> Sig.T v -> Sig.T v +lowpassPole = runPole Lowpass +highpassPole = runPole Highpass diff --git a/src/Synthesizer/Plain/Filter/Recursive/Chebyshev.hs b/src/Synthesizer/Plain/Filter/Recursive/Chebyshev.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Plain/Filter/Recursive/Chebyshev.hs @@ -0,0 +1,385 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +Chebyshev lowpass and highpass +-} +module Synthesizer.Plain.Filter.Recursive.Chebyshev where + +import Synthesizer.Plain.Filter.Recursive (Passband(Lowpass,Highpass), Pole(Pole, poleResonance)) +import qualified Synthesizer.Plain.Filter.Recursive.SecondOrderCascade as Cascade +import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2 +-- import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1 +import qualified Synthesizer.Plain.Signal as Sig +-- import qualified Synthesizer.Plain.Modifier as Modifier +import qualified Synthesizer.Causal.Process as Causal +import Control.Arrow ((>>>), (^>>), (&&&), ) + +-- import qualified Algebra.VectorSpace as VectorSpace +import qualified Algebra.Module as Module +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Algebra.Module((*>)) + +import Number.Complex (real, imag, cis, ) +import qualified Number.Complex as Complex + +-- import Control.Monad.Trans.State (State(..), evalState) + +import qualified Data.StorableVector as SV +import Foreign.Storable (Storable) + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + + + +circleList, circleListSlow, circleListFast :: (Trans.C a) => a -> [Complex.T a] +circleList = circleListSlow + +circleListSlow x = + map cis $ map (x*) $ iterate (2+) 1 + +circleListFast x = + let z1 = cis x + z2 = z1^2 + in iterate (z2*) z1 + + +makeCirclePoints :: (Trans.C a) => Int -> [Complex.T a] +makeCirclePoints order = + take order (circleList (pi / (4 * fromIntegral order))) + +-- | compute the partial filter of the second order from the pole information +{- +It's worth to think it over whether this routine could be used for the Butterworth filter. +But whereas this function is specialized to the zeros of the denominator polynomial +for the Butterworth filter the quadratic factors of the polynomial can be determined +more efficiently than the zeros. +-} +partialParameterA, partialParameterB :: (Trans.C a) => + Int -> a -> a -> Complex.T a -> Filt2.Parameter a +{- +partialParameterA order ratio freq = + let {- if ratio == (sqrt 2) then the product of the normalization factors is + 2^(1-2*order) -} +-- bn = asinh (ratio/sqrt(1-ratio^2)) / fromIntegral (2*order) + bn = (log(1+ratio) - log(1-ratio^2)/2) / fromIntegral (2*order) + coshbn = cosh bn + sinhbn = sinh bn + + phi = pi*freq + sinphi = sin phi + cosphi = cos phi + sinphi2 = sinphi^2 + + in \c -> + let re = real c * coshbn; re2 = re^2 + im = - imag c * sinhbn; im2 = im^2 + cpims = cosphi + im*sinphi + cmims = cosphi - im*sinphi + resin2 = re2*sinphi2 + denom = - cmims^2 - resin2 + vol = sqrt ((1-re2-im2)^2 + 4*im2) + c0 = vol * sinphi2 / denom + in Filt2.Parameter + c0 (2*c0) c0 + (-2*(cpims*cmims - resin2)/denom) ((cpims^2 + resin2)/denom) +-} + +partialParameterA order ratio freq = + let {- if ratio == (sqrt 2) then the product of the normalization factors is + 2^(1-2*order) -} +-- bn = asinh (ratio/sqrt(1-ratio^2)) / fromIntegral (2*order) + bn = (log(1+ratio) - log(1-ratio^2)/2) / fromIntegral (2*order) + coshbn = cosh bn + sinhbn = sinh bn +-- cosh2bn = (cosh(2*bn)-1)/2 = sinhbn2 + coshbn2 = coshbn^2 + sinhbn2 = sinhbn^2 + + phi = pi*freq + sinphi = sin phi + cosphi = cos phi + sinphi2 = sinphi^2 + + sinhbnsinphi = sinhbn*sinphi +-- sinhbn2sinphi2 = sinhbn2*sinphi2 + coshbn2sinphi2 = coshbn2*sinphi2 + + in \c -> + let re = real c + im = imag c + imss = im * sinhbnsinphi + cpims = cosphi - imss + cmims = cosphi + imss + resin2 = re^2 * coshbn2sinphi2 + denom = - cmims^2 - resin2 + c0 = (im^2 + sinhbn2)*sinphi2 / denom + in Filt2.Parameter + c0 (2*c0) c0 + (-2*(cpims*cmims - resin2)/denom) ((cpims^2 + resin2)/denom) + +{- +partialParameterA order ratio freq = + let {- if ratio == (sqrt 2) then the product of the normalization factors is + 2^(1-2*order) -} + bn = asinh (ratio/sqrt(1-ratio^2)) / fromIntegral (2*order) + sinhbnd = 2 * sinh bn + cosh2bn = (cosh(2*bn)-1)/2 + + phi = pi*freq + sinphi = sin phi + cosphi = cos phi + sinphi2 = sinphi^2 +-- cosphi2 = cosphi^2 + sincosphi = sinphi*cosphi + + in \c -> + let imd = - imag c * sinhbnd + re2pim2 = cosh2bn + real c ^ 2 + ri2sp2 = (re2pim2-1)*sinphi2 + cpims2 = 1 + ri2sp2 + imd*sincosphi + cmims2 = 1 + ri2sp2 - imd*sincosphi + cpmims = 1 - (re2pim2+1)*sinphi2 + denom = - cmims2 + vol = sqrt (ri2sp2^2 + (imd*sinphi2)^2) + c0 = vol / denom + in Filt2.Parameter + c0 (2*c0) c0 + (-2*cpmims/denom) (cpims2/denom) +-} + +{- +partialParameterA order ratio freq = + let {- if ratio == (sqrt 2) then the product of the normalization factors is + 2^(1-2*order) -} + bn = asinh (ratio/sqrt(1-ratio^2)) / fromIntegral (2*order) + coshbn = cosh bn + sinhbn = sinh bn + + phi = pi*freq + sinphi = sin phi + cosphi = cos phi + sinphi2 = sinphi^2 +-- cosphi2 = cosphi^2 + sincosphi = sinphi*cosphi + + in \c -> + let re = real c * coshbn; re2 = re^2 + im = - imag c * sinhbn; im2 = im^2 + re2pim2 = re2+im2 + cpims2 = 1 + (re2pim2-1)*sinphi2 + 2*im*sincosphi + cmims2 = 1 + (re2pim2-1)*sinphi2 - 2*im*sincosphi + cpmims = 1 - (re2pim2+1)*sinphi2 + denom = - cmims2 + vol = sqrt ((re2pim2-1)^2 + 4*im2) + c0 = vol * sinphi2 / denom + in Filt2.Parameter + c0 (2*c0) c0 + (-2*cpmims/denom) (cpims2/denom) +-} + +{- +partialParameterB order ratio freq = + let -- bn = asinh (sqrt(1-ratio^2)/ratio) / fromIntegral (2*order) + bn = (log(1+sqrt(1-ratio^2)) - log ratio) / fromIntegral (2*order) + coshbn = cosh bn + sinhbn = sinh bn + coshbn2 = coshbn^2 + + phi = pi*freq + sinphi = sin phi + cosphi = cos phi + sinphi2 = sinphi^2 + cosphi2 = cosphi^2 + + in \c -> + let re = real c * coshbn + im = - imag c * sinhbn + spimc = sinphi + im*cosphi + smimc = sinphi - im*cosphi + recos2 = re^2 * cosphi2 + denom = smimc^2 + recos2 + a02cosphi2 = real c ^ 2 * cosphi2 + c0 = (sinphi2 + a02cosphi2) / denom + c1 = (sinphi2 - a02cosphi2) / denom + in Filt2.Parameter + c0 (2*c1) c0 + (-2*(spimc*smimc - recos2)/denom) (-(spimc^2 + recos2)/denom) +-} + +partialParameterB order ratio freq = + let -- bn = asinh (sqrt(1-ratio^2)/ratio) / fromIntegral (2*order) + bn = (log(1+sqrt(1-ratio^2)) - log ratio) / fromIntegral (2*order) + coshbn = cosh bn + sinhbn = sinh bn + coshbn2 = coshbn^2 + + phi = pi*freq + sinphi = sin phi + cosphi = cos phi + sinphi2 = sinphi^2 + cosphi2 = cosphi^2 + + sinhbncosphi = sinhbn*cosphi + + in \c -> + let a02cosphi2 = real c ^ 2 * cosphi2 + imsc = imag c * sinhbncosphi + spimc = sinphi - imsc + smimc = sinphi + imsc + recos2 = a02cosphi2 * coshbn2 + denom = smimc^2 + recos2 + c0 = (sinphi2 + a02cosphi2) / denom + c1 = (sinphi2 - a02cosphi2) / denom + in Filt2.Parameter + c0 (2*c1) c0 + (-2*(spimc*smimc - recos2)/denom) (-(spimc^2 + recos2)/denom) + + +-- * use second order filter parameters for control + +type ParameterA a = (a, Cascade.Parameter a) + +{-# INLINE parameterA #-} +parameterA :: + (Trans.C a, Storable a) => + Passband -> Int -> Pole a -> ParameterA a +parameterA kind order = + -- I hope that the 'let' is floated out of a 'map' + let circleVec = SV.pack (makeCirclePoints order) + in \ (Pole ratio freq) -> + (ratio, + Cascade.Parameter $ + SV.map (\c -> + Filt2.adjustPassband kind + (flip (partialParameterA order ratio) c) freq) $ + circleVec) + + +type ParameterB a = Cascade.Parameter a + +{-# INLINE parameterB #-} +parameterB :: + (Trans.C a, Storable a) => + Passband -> Int -> Pole a -> ParameterB a +parameterB kind order = + -- I hope that the 'let' is floated out of a 'map' + let circleVec = SV.pack (makeCirclePoints order) + in \ (Pole ratio freq) -> + Cascade.Parameter $ + SV.map (\c -> + Filt2.adjustPassband kind + (flip (partialParameterB order ratio) c) freq) $ + circleVec + +{- +{-# INLINE modifierB #-} +modifierB :: + (Ring.C a, Module.C a v, Storable a, Storable v) => + Int -> + Modifier.Simple (Cascade.Status v) (Cascade.Parameter a) v v +modifierB = + Cascade.modifierB +-} + +{-# INLINE causalA #-} +causalA :: (Ring.C a, Module.C a v, Storable a, Storable v) => + Int -> + Causal.T (ParameterA a, v) v +causalA order = + Causal.map (snd.fst) &&& Causal.map (\((ratio,_), y) -> ratio *> y) + >>> Cascade.causal order + +{-# INLINE causalB #-} +causalB :: (Ring.C a, Module.C a v, Storable a, Storable v) => + Int -> + Causal.T (ParameterB a, v) v +causalB = + Cascade.causal + + + + +-- * directly use frequency as control parameter + +runAPole, runBPole :: (Trans.C a, Module.C a v) => + Passband -> Int -> Sig.T a -> Sig.T a -> Sig.T v -> Sig.T v +runAPole kind order ratios freqs = + let makePartialFilter c = + Filt2.run + (zipWith + (\ratio -> Filt2.adjustPassband kind $ + \freq -> partialParameterA order ratio freq c) + ratios freqs) + in foldl (.) (zipWith (*>) ratios) + (map makePartialFilter (makeCirclePoints order)) + +runBPole kind order ratios freqs = + let makePartialFilter c = + Filt2.run + (zipWith + (\ratio -> Filt2.adjustPassband kind $ + \freq -> partialParameterB order ratio freq c) + ratios freqs) + in foldl (.) id (map makePartialFilter (makeCirclePoints order)) + + +causalAPole, causalBPole :: (Trans.C a, Module.C a v) => + Passband -> Int -> Causal.T (Pole a, v) v +causalAPole kind order = + let {-# INLINE makePartialFilter #-} + makePartialFilter c = + Causal.first (Causal.map (\(Pole ratio freq) -> + Filt2.adjustPassband kind + (flip (partialParameterA order ratio) c) freq)) >>> + Filt2.causal + in (\(p, y) -> (p, poleResonance p *> y)) ^>> + (Causal.chainControlled $ + map makePartialFilter $ + makeCirclePoints order) + +causalBPole kind order = + let {-# INLINE makePartialFilter #-} + makePartialFilter c = + Causal.first (Causal.map (\(Pole ratio freq) -> + Filt2.adjustPassband kind + (flip (partialParameterB order ratio) c) freq)) >>> + Filt2.causal + in Causal.chainControlled $ + map makePartialFilter $ + makeCirclePoints order + + +lowpassACausalPole, highpassACausalPole, + lowpassBCausalPole, highpassBCausalPole :: + (Trans.C a, Module.C a v) => + Int -> Causal.T (Pole a, v) v +lowpassACausalPole = causalAPole Lowpass +highpassACausalPole = causalAPole Highpass + +lowpassBCausalPole = causalBPole Lowpass +highpassBCausalPole = causalBPole Highpass + + +lowpassAPole, highpassAPole, lowpassBPole, highpassBPole :: + (Trans.C a, Module.C a v) => + Int -> Sig.T a -> Sig.T a -> Sig.T v -> Sig.T v +lowpassAPole = runAPole Lowpass +highpassAPole = runAPole Highpass + +lowpassBPole = runBPole Lowpass +highpassBPole = runBPole Highpass diff --git a/src/Synthesizer/Plain/Filter/Recursive/Comb.hs b/src/Synthesizer/Plain/Filter/Recursive/Comb.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Plain/Filter/Recursive/Comb.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +Comb filters, useful for emphasis of tones with harmonics +and for repeated echos. +-} +module Synthesizer.Plain.Filter.Recursive.Comb where + +import Synthesizer.Plain.Filter.NonRecursive (delay, ) +import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1 +import qualified Synthesizer.Plain.Signal as Sig +-- import qualified Synthesizer.Plain.Modifier as Modifier +import qualified Synthesizer.Plain.Control as Ctrl + +import qualified Algebra.Module as Module +-- import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Algebra.Module((*>)) + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +{- | +The most simple version of the Karplus-Strong algorithm +which is suitable to simulate a plucked string. +It is similar to the 'runProc' function. +-} +karplusStrong :: (Ring.C a, Module.C a v) => + Filt1.Parameter a -> Sig.T v -> Sig.T v +karplusStrong c wave = + let y = wave ++ Filt1.lowpass (Ctrl.constant c) y + in y + + +{- | +Infinitely many equi-delayed exponentially decaying echos. +The echos are clipped to the input length. +We think it is easier (and simpler to do efficiently) +to pad the input with zeros or whatever +instead of cutting the result according to the input length. +-} +run :: (Module.C a v) => Int -> a -> Sig.T v -> Sig.T v +run time gain x = + let y = zipWith (+) x (delay time (gain *> y)) + in y + +{- | Echos of different delays. -} +runMulti :: (Ring.C a, Module.C a v) => [Int] -> a -> Sig.T v -> Sig.T v +runMulti time gain x = + let y = foldl (zipWith (+)) x (map (flip delay (gain *> y)) time) + in y + +{- | Echos can be piped through an arbitrary signal processor. -} +runProc :: Additive.C v => Int -> (Sig.T v -> Sig.T v) -> Sig.T v -> Sig.T v +runProc time feedback x = + let y = zipWith (+) x (delay time (feedback y)) + in y diff --git a/src/Synthesizer/Plain/Filter/Recursive/FirstOrder.hs b/src/Synthesizer/Plain/Filter/Recursive/FirstOrder.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Plain/Filter/Recursive/FirstOrder.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +First order low pass and high pass filter. +-} +module Synthesizer.Plain.Filter.Recursive.FirstOrder where + +import qualified Synthesizer.Plain.Signal as Sig +import qualified Synthesizer.Plain.Modifier as Modifier +import qualified Synthesizer.Causal.Process as Causal +import qualified Synthesizer.Interpolation.Class as Interpol + +import qualified Algebra.Module as Module +import qualified Algebra.Transcendental as Trans +-- import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Algebra.Module((*>)) + +-- import qualified Number.Complex as Complex + +import Control.Monad.Trans.State (State, state, ) + +import PreludeBase +import NumericPrelude + + + +newtype Parameter a = Parameter {getParameter :: a} + deriving Show + + +instance Interpol.C a v => Interpol.C a (Parameter v) where + {-# INLINE scaleAndAccumulate #-} + scaleAndAccumulate = Interpol.makeMac Parameter getParameter + + +{-| Convert cut-off frequency to feedback factor. -} +{-# INLINE parameter #-} +parameter :: Trans.C a => a -> Parameter a +parameter freq = Parameter (exp (-2*pi*freq)) + + +{-# INLINE lowpassStep #-} +lowpassStep :: (Ring.C a, Module.C a v) => + Parameter a -> v -> State v v +lowpassStep (Parameter c) x = + state (\s -> let y = x + c *> (s-x) in (y,y)) + +{-# INLINE lowpassModifierInit #-} +lowpassModifierInit :: (Ring.C a, Module.C a v) => + Modifier.Initialized v v (Parameter a) v v +lowpassModifierInit = + Modifier.Initialized id lowpassStep + +{-# INLINE lowpassModifier #-} +lowpassModifier :: (Ring.C a, Module.C a v) => + Modifier.Simple v (Parameter a) v v +lowpassModifier = + Sig.modifierInitialize lowpassModifierInit zero + +{-# INLINE lowpassCausal #-} +lowpassCausal :: + (Ring.C a, Module.C a v) => + Causal.T (Parameter a, v) v +lowpassCausal = + Causal.fromSimpleModifier lowpassModifier + + +{-# INLINE lowpassInit #-} +lowpassInit :: (Ring.C a, Module.C a v) => + v -> Sig.T (Parameter a) -> Sig.T v -> Sig.T v +lowpassInit = + Sig.modifyModulatedInit lowpassModifierInit + +{-# INLINE lowpass #-} +lowpass :: (Ring.C a, Module.C a v) => + Sig.T (Parameter a) -> Sig.T v -> Sig.T v +lowpass = lowpassInit zero + + +{-# INLINE highpassStep #-} +highpassStep :: (Ring.C a, Module.C a v) => + Parameter a -> v -> State v v +highpassStep c x = + fmap (x-) (lowpassStep c x) + +{-# INLINE highpassModifierInit #-} +highpassModifierInit :: (Ring.C a, Module.C a v) => + Modifier.Initialized v v (Parameter a) v v +highpassModifierInit = + Modifier.Initialized negate highpassStep + +{-# INLINE highpassModifier #-} +highpassModifier :: (Ring.C a, Module.C a v) => + Modifier.Simple v (Parameter a) v v +highpassModifier = + Sig.modifierInitialize highpassModifierInit zero + +{-# INLINE highpassInit #-} +highpassInit :: (Ring.C a, Module.C a v) => + v -> Sig.T (Parameter a) -> Sig.T v -> Sig.T v +highpassInit = + Sig.modifyModulatedInit highpassModifierInit + +highpassInitAlt :: (Ring.C a, Module.C a v) => + v -> Sig.T (Parameter a) -> Sig.T v -> Sig.T v +highpassInitAlt y0 control x = + x - lowpassInit (-y0) control x + +{-# INLINE highpass #-} +highpass :: (Ring.C a, Module.C a v) => + Sig.T (Parameter a) -> Sig.T v -> Sig.T v +highpass = highpassInit zero + + + +data Result a = + Result {highpass_, lowpass_ :: !a} + +instance Additive.C v => Additive.C (Result v) where + {-# INLINE zero #-} + {-# INLINE (+) #-} + {-# INLINE (-) #-} + {-# INLINE negate #-} + zero = Result zero zero + (+) (Result xhp xlp) (Result yhp ylp) = Result (xhp + yhp) (xlp + ylp) + (-) (Result xhp xlp) (Result yhp ylp) = Result (xhp - yhp) (xlp - ylp) + negate (Result xhp xlp) = Result (negate xhp) (negate xlp) + + +instance Module.C a v => Module.C a (Result v) where + {-# INLINE (*>) #-} + s *> (Result hp lp) = Result (s *> hp) (s *> lp) + + +{-# INLINE step #-} +step :: (Ring.C a, Module.C a v) => + Parameter a -> v -> State v (Result v) +step c x = + fmap (\lp -> Result (x-lp) lp) (lowpassStep c x) diff --git a/src/Synthesizer/Plain/Filter/Recursive/FirstOrderComplex.hs b/src/Synthesizer/Plain/Filter/Recursive/FirstOrderComplex.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Plain/Filter/Recursive/FirstOrderComplex.hs @@ -0,0 +1,238 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +First order lowpass and highpass with complex valued feedback. +The complex feedback allows resonance. +-} +module Synthesizer.Plain.Filter.Recursive.FirstOrderComplex ( + Parameter, + parameter, + parameterFromPeakWidth, + parameterFromPeakToDCRatio, + step, + modifierInit, + modifier, + causal, + runInit, + run, + ) where + +import Synthesizer.Plain.Filter.Recursive (Pole(..)) +import qualified Synthesizer.Plain.Signal as Sig +import qualified Synthesizer.Plain.Modifier as Modifier +import qualified Synthesizer.Causal.Process as Causal + +import qualified Synthesizer.Interpolation.Class as Interpol + +import qualified Number.Complex as Complex +import Number.Complex ((+:)) + +import qualified Algebra.Module as Module +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Algebraic as Algebraic +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Algebra.Module((*>)) + +import Control.Monad.Trans.State (State, state, ) + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +data Parameter a = + Parameter {c, amp :: !(Complex.T a)} + + +instance Interpol.C a v => Interpol.C a (Parameter v) where + {-# INLINE scaleAndAccumulate #-} + scaleAndAccumulate = Interpol.makeMac2 Parameter c amp + + + +{- +y0 = u0 + k * cis w * y1 + +transfer function: + 1/(1 - k * cis w * z) + +frequency 0 amplified by @recip (1 - k * cis w)@. +resonance frequency amplified by 1+k+k^2+..., which equals @recip (1-k)@. +resonance frequency + half sample rate is amplified by @recip (1+k)@. +-} + + +{-| +The internal parameters are computed such that: + +* At the resonance frequency + the filter amplifies by the factor @resonance@ + with no phase shift. + +* At resonance frequency plus half sample rate + the filter amplifies by facter @recip $ 2 - recip resonance@ + with no phase shift, + but you cannot observe this immediately, + because it is outside the Nyquist band. +-} +{-# INLINE parameter #-} +parameter :: Trans.C a => Pole a -> Parameter a +parameter (Pole resonance frequency) = + let cisw = Complex.cis (2*pi*frequency) + k = 1 - recip resonance + kcisw = Complex.scale k cisw + in Parameter kcisw one + + +{- +Let resonance be the ratio +of the resonance amplification +to the amplification at another frequency, encoded by z. + +resonance = abs(1 - k * cis w * z) / (1 - k) + +Solution: Substitute @cis w * z@ by @cis a@ +and proceed as in parameterFromPeakToDCRatio. +-} +{-| +The internal parameters are computed such that: + +* At the resonance frequency + the filter amplifies by the factor @resonance@ + with no phase shift. + +* At resonance frequency plus and minus band width + the filter amplifies by facter 1 with a non-zero phase shift. +-} +{-# INLINE parameterFromPeakWidth #-} +parameterFromPeakWidth :: Trans.C a => a -> Pole a -> Parameter a +parameterFromPeakWidth width (Pole resonance frequency) = + let cisw = Complex.cis (2*pi*frequency) + k = solveRatio resonance (cos (2*pi*width)) + kcisw = Complex.scale k cisw + amp_ = Complex.fromReal ((1-k)*resonance) + in Parameter kcisw amp_ + +{-| +The internal parameters are computed such that: + +* At the resonance frequency + the filter amplifies by the factor @resonance@ + with a non-zero phase shift. + +* The filter amplifies the direct current (frequency zero) by factor 1 + with no phase shift. + +* The real component is a lowpass, + the imaginary component is a highpass. + You can interpolate between them using other complex projections. +-} +{- +If we want to interpret the resonance +as ratio of the peak height to direct current amplification, +we get: + +resonance = abs ((1 - k * cis w) / (1-k)) +resonance^2 * (1-k)^2 + = (1 - k * cis w) * (1 - k * cis (-w)) + = 1 + k^2 - 2*k*cos w +0 = 1-resonance^2 + 2 * (resonance^2 - cos w) * k + (1-resonance^2) * k^2 +0 = 1 + 2 * (resonance^2 - cos w) / (1-resonance^2) * k + k^2 +-} +{-# INLINE parameterFromPeakToDCRatio #-} +parameterFromPeakToDCRatio :: Trans.C a => Pole a -> Parameter a +parameterFromPeakToDCRatio (Pole resonance frequency) = + let cisw = Complex.cis (2*pi*frequency) + k = solveRatio resonance (Complex.real cisw) + kcisw = Complex.scale k cisw + amp_ = one - kcisw + in Parameter kcisw amp_ + +solveRatio :: (Algebraic.C a) => + a -> a -> a +solveRatio resonance cosine = + let r2 = resonance^2 + p = (r2 - cosine) / (r2 - 1) + {- no cancelation for p close to 1, + that is, big resonance or cosine close to 1 -} + in recip $ p + sqrt (p^2 - 1) + +{- +solveRatioAnalytic :: (Algebraic.C a) => + a -> a -> a +solveRatioAnalytic resonance cosine = + let r2 = resonance^2 + p = (r2 - cosine) / (r2 - 1) + in p - sqrt (p^2 - 1) +-} + + +{- | +We use complex numbers as result types, +since the particular filter type is determined by the parameter generator. +-} +type Result = Complex.T + + +{-| Universal filter: Computes high pass, band pass, low pass in one go -} +{-# INLINE step #-} +step :: (Module.C a v) => + Parameter a -> v -> State (Complex.T v) (Result v) +step p u = + state $ \s -> + let y = scale (amp p) u + mul (c p) s + in (y, y) +-- in (Result (Complex.imag y) (Complex.real y), y) + +scale :: (Module.C a v) => + Complex.T a -> v -> Complex.T v +scale s x = + Complex.real s *> x +: Complex.imag s *> x + +mul :: (Module.C a v) => + Complex.T a -> Complex.T v -> Complex.T v +mul x y = + (Complex.real x *> Complex.real y - Complex.imag x *> Complex.imag y) + +: + (Complex.real x *> Complex.imag y + Complex.imag x *> Complex.real y) + + +{-# INLINE modifierInit #-} +modifierInit :: (Ring.C a, Module.C a v) => + Modifier.Initialized (Complex.T v) (Complex.T v) (Parameter a) v (Result v) +modifierInit = + Modifier.Initialized id step + +{-# INLINE modifier #-} +modifier :: (Ring.C a, Module.C a v) => + Modifier.Simple (Complex.T v) (Parameter a) v (Result v) +modifier = Sig.modifierInitialize modifierInit zero + +{-# INLINE causal #-} +causal :: + (Ring.C a, Module.C a v) => + Causal.T (Parameter a, v) (Result v) +causal = + Causal.fromSimpleModifier modifier + + +{-# INLINE runInit #-} +runInit :: (Ring.C a, Module.C a v) => + Complex.T v -> Sig.T (Parameter a) -> Sig.T v -> Sig.T (Result v) +runInit = Sig.modifyModulatedInit modifierInit + +{-# INLINE run #-} +run :: (Ring.C a, Module.C a v) => + Sig.T (Parameter a) -> Sig.T v -> Sig.T (Result v) +run = runInit zero diff --git a/src/Synthesizer/Plain/Filter/Recursive/Integration.hs b/src/Synthesizer/Plain/Filter/Recursive/Integration.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Plain/Filter/Recursive/Integration.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +Filter operators from calculus +-} +module Synthesizer.Plain.Filter.Recursive.Integration where + +import qualified Synthesizer.Plain.Signal as Sig +-- import qualified Synthesizer.Plain.Modifier as Modifier + +-- import qualified Algebra.Field as Field +-- import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import PreludeBase +import NumericPrelude + + + +{- | +Integrate with initial value zero. +However the first emitted value is the value of the input signal. +It maintains the length of the signal. +-} +{-# INLINE run #-} +run :: Additive.C v => Sig.T v -> Sig.T v +run = scanl1 (+) + +{- | +Integrate with initial condition. +First emitted value is the initial condition. +The signal become one element longer. +-} +{-# INLINE runInit #-} +runInit :: Additive.C v => v -> Sig.T v -> Sig.T v +runInit = scanl (+) + +{- other quadrature methods may follow -} diff --git a/src/Synthesizer/Plain/Filter/Recursive/Moog.hs b/src/Synthesizer/Plain/Filter/Recursive/Moog.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Plain/Filter/Recursive/Moog.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +Moog cascade lowpass with resonance. +-} +module Synthesizer.Plain.Filter.Recursive.Moog where + +import Synthesizer.Plain.Filter.Recursive (Pole(..)) +import Synthesizer.Plain.Filter.NonRecursive (envelopeVector) +import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1 +import qualified Synthesizer.Plain.Signal as Sig +import qualified Synthesizer.Plain.Modifier as Modifier +import qualified Synthesizer.Causal.Process as Causal + +import qualified Synthesizer.Interpolation.Class as Interpol + +import qualified Algebra.Module as Module +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Algebra.Module((*>)) + +import Data.Function.HT (nest, ) + +import Control.Monad.Trans.State (State, state, evalState, gets) +import Control.Arrow ((&&&), (>>^), (^>>), ) + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +data Parameter a = + Parameter + {feedback :: !a + {- ^ Feedback of the lowpass cascade -} + ,lowpassParam :: !(Filt1.Parameter a) + {- ^ Feedback of each of the lowpasses of 1st order -} } + deriving Show + + +instance Interpol.C a v => Interpol.C a (Parameter v) where + {-# INLINE scaleAndAccumulate #-} + scaleAndAccumulate = Interpol.makeMac2 Parameter feedback lowpassParam + + +parameter :: Trans.C a => Int -> Pole a -> Parameter a +parameter order (Pole resonance frequency) = + let beta = frequency * 2 * pi + alpha = (pi-beta) / fromIntegral order + k = sin alpha / sin (alpha+beta) + + q = ((sin (alpha+beta) - sin alpha) / sin beta) ^ fromIntegral order + f = (resonance-1) / (resonance*q+1) + in Parameter f (Filt1.Parameter k) + +{- +Used for lowpassState, +list of internal values may be processed by Applicative.traverse. +-} +lowpassStepStack :: (Ring.C a, Module.C a v) => + Parameter a -> v -> State [v] v +lowpassStepStack (Parameter f k) x = + do y0 <- gets head + y1 <- Modifier.stackStatesR (Filt1.lowpassStep k) (x - f *> y0) + return ((1+f) *> y1) + +lowpassStepRev :: (Ring.C a, Module.C a v) => + Parameter a -> v -> State [v] v +lowpassStepRev (Parameter f k) x = state (\s -> + let news = + tail (scanl + (evalState . Filt1.lowpassStep k) + -- (\u0 y1 -> let Filt1.Parameter k0 = k in (1-k0) *> u0 + k0 *> y1) + (x - f *> last s) s) + in ((1+f) *> last news, news)) + + +lowpassModifier :: (Ring.C a, Module.C a v) => + Int -> Modifier.Simple [v] (Parameter a) v v +lowpassModifier order = + Modifier.Simple (replicate order zero) lowpassStepStack + + +{-# INLINE lowpassCausal #-} +{-# INLINE lowpassCausalStacked #-} +{-# INLINE lowpassCausalModifier #-} +lowpassCausal, lowpassCausalStacked, lowpassCausalModifier :: + (Ring.C a, Module.C a v) => + Int -> Causal.T (Parameter a, v) v +lowpassCausal = lowpassCausalStacked + +lowpassCausalStacked order = + Causal.map fst &&& + Causal.feedbackControlled + ((\(((Parameter f k),x),y0) -> (k, x - f *> y0)) ^>> + Causal.replicateControlled order Filt1.lowpassCausal) + (snd ^>> Causal.consInit zero) + >>^ (\((Parameter f _k),y1) -> (1+f) *> y1) + +lowpassCausalModifier order = + Causal.fromSimpleModifier (lowpassModifier order) + + +lowpass, lowpassState, lowpassRecursive :: + (Ring.C a, Module.C a v) => + Int -> Sig.T (Parameter a) -> Sig.T v -> Sig.T v + +{-| Choose one of the implementations below -} +lowpass = lowpassRecursive + +{-| Simulate the Moog cascade by a list of states of the partial lowpasses -} +lowpassState order = + Sig.modifyModulated (lowpassModifier order) + +{-| The elegant way of implementing the Moog cascade by recursion -} +lowpassRecursive order c x = + let k = map lowpassParam c + f = map feedback c + z = zipWith subtract (envelopeVector f (zero:y)) x + y = nest order (Filt1.lowpass k) z + in zipWith (*>) (map (1+) f) y diff --git a/src/Synthesizer/Plain/Filter/Recursive/MovingAverage.hs b/src/Synthesizer/Plain/Filter/Recursive/MovingAverage.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Plain/Filter/Recursive/MovingAverage.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes +-} +module Synthesizer.Plain.Filter.Recursive.MovingAverage + (sumsStaticInt, + modulatedFrac, + ) where + +import qualified Synthesizer.Plain.Signal as Sig +-- import qualified Synthesizer.Plain.Modifier as Modifier +import qualified Synthesizer.Plain.Filter.Recursive.Integration as Integration + +import Synthesizer.Plain.Filter.NonRecursive (delay, ) + +import qualified Algebra.Module as Module +import qualified Algebra.RealField as RealField + +-- import qualified Algebra.Field as Field +-- import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Control.Monad.Fix (fix) +import Data.List (tails) + +import PreludeBase +import NumericPrelude + + + +{- | +Like 'Synthesizer.Plain.Filter.NonRecursive.sums' but in a recursive form. +This needs only linear time (independent of the window size) +but may accumulate rounding errors. + +@ +ys = xs * (1,0,0,0,-1) \/ (1,-1) +ys * (1,-1) = xs * (1,0,0,0,-1) +ys = xs * (1,0,0,0,-1) + ys * (0,1) +@ +-} +sumsStaticInt :: (Additive.C v) => Int -> Sig.T v -> Sig.T v +sumsStaticInt n xs = + fix (\ys -> let (xs0,xs1) = splitAt n xs + in (xs0 ++ (xs1-xs)) + (zero:ys)) + +{- +staticInt :: (Module.C a v, Additive.C v) => Int -> Sig.T v -> Sig.T v +staticInt n xs = +-} + + +{- +Sum of a part of a vector with negative sign for reverse order. +It adds from @from@ (inclusively) to @to@ (exclusively), +that is, it sums up @abs (to-from)@ values +-} +sumFromTo :: (Additive.C v) => Int -> Int -> Sig.T v -> v +sumFromTo from to = + if from <= to + then sum . take (to-from) . drop from + else negate . sum . take (from-to) . drop to + +{- +It would be a nice approach to interpolate not just linearly at the borders +but in a way that the cut-off frequency is perfectly suppressed. +However suppression depends on the phase shift of the wave. +Actually, we could use a complex factor, but does this help? +-} +sumFromToFrac :: (RealField.C a, Module.C a v) => a -> a -> Sig.T v -> v +sumFromToFrac from to xs = + let (fromInt, fromFrac) = splitFraction from + (toInt, toFrac) = splitFraction to + in case compare fromInt toInt of + EQ -> (to-from) *> (xs !! fromInt) + LT -> + sum $ + zipWith id + (((1-fromFrac) *>) : + replicate (toInt-fromInt-1) id ++ + (toFrac *>) : + []) $ + drop fromInt xs + GT -> + negate $ sum $ + zipWith id + (((1-toFrac) *>) : + replicate (fromInt-toInt-1) id ++ + (fromFrac *>) : + []) $ + drop toInt xs + + + +{- | +Sig.T a must contain only non-negative elements. +-} +sumDiffsModulated :: (RealField.C a, Module.C a v) => + a -> Sig.T a -> Sig.T v -> Sig.T v +sumDiffsModulated d ds = + -- prevent negative d's since 'drop' cannot restore past values + zipWith3 sumFromToFrac ((d+1) : ds) (map (1+) ds) . + init . init . tails . (zero:) +{- + zipWith3 sumFromToFrac (d : map (subtract 1) ds) ds . + init . tails +-} + +sumsModulated :: (RealField.C a, Module.C a v) => + Int -> Sig.T a -> Sig.T v -> Sig.T v +sumsModulated maxDInt ds xs = + let maxD = fromIntegral maxDInt + posXs = sumDiffsModulated 0 ds xs + negXs = sumDiffsModulated maxD (map (maxD-) ds) (delay maxDInt xs) + in Integration.run (posXs - negXs) + +{- | +Shift sampling points by a half sample period +in order to preserve signals for window widths below 1. +-} +sumsModulatedHalf :: (RealField.C a, Module.C a v) => + Int -> Sig.T a -> Sig.T v -> Sig.T v +sumsModulatedHalf maxDInt ds xs = + let maxD = fromIntegral maxDInt + d0 = maxD+0.5 + delXs = delay maxDInt xs + posXs = sumDiffsModulated d0 (map (d0+) ds) delXs + negXs = sumDiffsModulated d0 (map (d0-) ds) delXs + in Integration.run (posXs - negXs) + +modulatedFrac :: (RealField.C a, Module.C a v) => + Int -> Sig.T a -> Sig.T v -> Sig.T v +modulatedFrac maxDInt ds xs = + zipWith (\d y -> recip (2*d) *> y) ds $ + sumsModulatedHalf maxDInt ds xs + diff --git a/src/Synthesizer/Plain/Filter/Recursive/SecondOrder.hs b/src/Synthesizer/Plain/Filter/Recursive/SecondOrder.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Plain/Filter/Recursive/SecondOrder.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +All recursive filters with real coefficients +can be decomposed into first order and second order filters with real coefficients. +This follows from the Fundamental theorem of algebra. +-} +module Synthesizer.Plain.Filter.Recursive.SecondOrder where + +import Synthesizer.Plain.Filter.Recursive (Passband(Lowpass,Highpass)) +import qualified Synthesizer.Plain.Signal as Sig +import qualified Synthesizer.Plain.Modifier as Modifier +-- import qualified Synthesizer.Plain.Control as Ctrl + +import qualified Synthesizer.Interpolation.Class as Interpol +import Synthesizer.ApplicativeUtility (liftA4, liftA5, ) + +import qualified Synthesizer.Causal.Process as Causal + +-- import qualified Algebra.VectorSpace as VectorSpace +import qualified Algebra.Module as Module +-- import qualified Algebra.Transcendental as Trans +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Algebra.Module((*>)) + +import Data.List (zipWith6) + +import Control.Monad.Trans.State (State, state, ) + +import Foreign.Storable (Storable(..)) +import qualified Foreign.Storable.Record as Store + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +{- | Parameters for a general recursive filter of 2nd order. -} +data Parameter a = + Parameter {c0, c1, c2, d1, d2 :: !a} + deriving Show + +data Status a = + Status {u1, u2, y1, y2 :: !a} + deriving Show + +zeroStatus :: Additive.C a => Status a +zeroStatus = + Status + {u1 = zero, u2 = zero, + y1 = zero, y2 = zero} + + +instance Interpol.C a v => Interpol.C a (Parameter v) where + {-# INLINE scaleAndAccumulate #-} + scaleAndAccumulate = + Interpol.runMac $ + liftA5 Parameter + (Interpol.element c0) + (Interpol.element c1) + (Interpol.element c2) + (Interpol.element d1) + (Interpol.element d2) + + + +instance Storable a => Storable (Parameter a) where + sizeOf = Store.sizeOf storeParameter + alignment = Store.alignment storeParameter + peek = Store.peek storeParameter + poke = Store.poke storeParameter + +storeParameter :: + Storable a => Store.Dictionary (Parameter a) +storeParameter = + Store.run $ + liftA5 Parameter + (Store.element c0) + (Store.element c1) + (Store.element c2) + (Store.element d1) + (Store.element d2) + + +instance Storable a => Storable (Status a) where + sizeOf = Store.sizeOf storeStatus + alignment = Store.alignment storeStatus + peek = Store.peek storeStatus + poke = Store.poke storeStatus + +storeStatus :: + Storable a => Store.Dictionary (Status a) +storeStatus = + Store.run $ + liftA4 Status + (Store.element u1) + (Store.element u2) + (Store.element y1) + (Store.element y2) + + +{- | +Given a function which computes the filter parameters of a lowpass filter +for a given frequency, +turn that into a function which generates highpass parameters, +if requested filter type is Highpass. +-} +{-# INLINE adjustPassband #-} +adjustPassband :: (Field.C a) => + Passband -> (a -> Parameter a) -> (a -> Parameter a) +adjustPassband kind comp f = + case kind of + Lowpass -> comp f + Highpass -> + let p = comp (0.5-f) + in Parameter (c0 p) (- c1 p) (c2 p) (- d1 p) (d2 p) + +{-# INLINE step #-} +step :: (Ring.C a, Module.C a v) => + Parameter a -> v -> State (Status v) v +step c u0 = state $ \s -> + let y0 = + c0 c *> u0 + + c1 c *> u1 s + d1 c *> y1 s + + c2 c *> u2 s + d2 c *> y2 s + in (y0, Status + {u1 = u0, u2 = u1 s, + y1 = y0, y2 = y1 s}) + + +{-# INLINE modifierInit #-} +modifierInit :: (Ring.C a, Module.C a v) => + Modifier.Initialized (Status v) (Status v) (Parameter a) v v +modifierInit = + Modifier.Initialized id step + +{-# INLINE modifier #-} +modifier :: (Ring.C a, Module.C a v) => + Modifier.Simple (Status v) (Parameter a) v v +modifier = + Sig.modifierInitialize modifierInit zeroStatus + +{-# INLINE causal #-} +causal :: (Ring.C a, Module.C a v) => + Causal.T (Parameter a, v) v +causal = + Causal.fromSimpleModifier modifier + + +{-# INLINE runInit #-} +runInit :: (Ring.C a, Module.C a v) => + Status v -> Sig.T (Parameter a) -> Sig.T v -> Sig.T v +runInit sInit control input = + let u0s = input + u1s = u1 sInit : u0s + u2s = u2 sInit : u1s + y1s = y1 sInit : y0s + y2s = y2 sInit : y1s + y0s = zipWith6 + (\c u0_ u1_ u2_ y1_ y2_ -> + c0 c *> u0_ + + c1 c *> u1_ + d1 c *> y1_ + + c2 c *> u2_ + d2 c *> y2_) + control u0s u1s u2s y1s y2s + in y0s + +{-# INLINE run #-} +run :: (Ring.C a, Module.C a v) => + Sig.T (Parameter a) -> Sig.T v -> Sig.T v +run = + runInit zeroStatus diff --git a/src/Synthesizer/Plain/Filter/Recursive/SecondOrderCascade.hs b/src/Synthesizer/Plain/Filter/Recursive/SecondOrderCascade.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Plain/Filter/Recursive/SecondOrderCascade.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +All recursive filters with real coefficients +can be decomposed into first order and second order filters with real coefficients. +This follows from the Fundamental theorem of algebra. + +This implements a cascade of second order filters +using StorableVectors for state and filter parameters. +-} +module Synthesizer.Plain.Filter.Recursive.SecondOrderCascade where + +import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2 +-- import Synthesizer.Plain.Filter.Recursive (Passband(Lowpass,Highpass)) +import qualified Synthesizer.Plain.Signal as Sig +import qualified Synthesizer.Plain.Modifier as Modifier +-- import qualified Synthesizer.Plain.Control as Ctrl +import qualified Synthesizer.Interpolation.Class as Interpol + +import qualified Synthesizer.Causal.Process as Causal + +-- import qualified Algebra.VectorSpace as VectorSpace +import qualified Algebra.Module as Module +-- import qualified Algebra.Transcendental as Trans +-- import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +-- import qualified Algebra.Additive as Additive + +-- import Algebra.Module((*>)) + +import Control.Monad.Trans.State (State, ) + +import qualified Data.StorableVector as SV +import Foreign.Storable (Storable(..)) + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +{- +Maybe there is no need to make the parameter vector +a StorableVector or an Array. +We could also make Paramter a State.Signal, +which reads from a StorableVector or Array buffer. +This way we would not need to create many StorableVectors +when interpolating filter parameters. +-} +newtype Parameter a = + Parameter (SV.Vector (Filt2.Parameter a)) + +{- +If Causal.Process would support ST operations, +then we could use a writeable storable vector for the status. +This would save us many allocations. +-} +type Status a = + SV.Vector (Filt2.Status a) + + +{-# INLINE checkSizes #-} +checkSizes :: String -> SV.Vector a -> SV.Vector b -> c -> c +checkSizes opName x y act = + if SV.length x == SV.length y + then act + else error $ opName ++ ": incompatible sizes of cascades of second order filters" + +{-# INLINE withSizeCheck #-} +withSizeCheck :: + String -> + (SV.Vector a -> SV.Vector b -> c) -> + (SV.Vector a -> SV.Vector b -> c) +withSizeCheck opName f x y = + checkSizes opName x y (f x y) + + +instance (Interpol.C a v, Storable v) => Interpol.C a (Parameter v) where + {-# INLINE scaleAndAccumulate #-} + scaleAndAccumulate (a, Parameter x) = + (Parameter $ SV.map (curry Interpol.scale a) x, + \ (Parameter y) -> + Parameter $ withSizeCheck "mac" + (SV.zipWith (curry Interpol.scaleAccumulate a)) x y) + + +{-# INLINE step #-} +step :: + (Ring.C a, Module.C a v, Storable a, Storable v) => + Parameter a -> v -> State (Status v) v +step (Parameter p) = + Modifier.stackStatesStorableVaryL Filt2.step p + +{-# INLINE modifierInit #-} +modifierInit :: + (Ring.C a, Module.C a v, Storable a, Storable v) => + Modifier.Initialized (Status v) (Status v) (Parameter a) v v +modifierInit = + Modifier.Initialized id step + + +{-# INLINE modifier #-} +modifier :: + (Ring.C a, Module.C a v, Storable a, Storable v) => + Int -> + Modifier.Simple (Status v) (Parameter a) v v +modifier order = + Sig.modifierInitialize modifierInit + (SV.replicate order Filt2.zeroStatus) + +{-# INLINE causal #-} +causal :: (Ring.C a, Module.C a v, Storable a, Storable v) => + Int -> + Causal.T (Parameter a, v) v +causal order = + Causal.fromSimpleModifier (modifier order) + diff --git a/src/Synthesizer/Plain/Filter/Recursive/Test.hs b/src/Synthesizer/Plain/Filter/Recursive/Test.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Plain/Filter/Recursive/Test.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Synthesizer.Plain.Filter.Recursive.Test where + +import qualified Synthesizer.Plain.Oscillator as Osci +import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2 +import qualified Synthesizer.Plain.Filter.Recursive.Butterworth as Butter +import qualified Synthesizer.Plain.Filter.Recursive.Chebyshev as Cheby +import qualified Synthesizer.Plain.Filter.Recursive.Moog as Moog +import qualified Synthesizer.Plain.Filter.Recursive.Universal as Uni +import qualified Synthesizer.Plain.Filter.Recursive.FirstOrderComplex as C1 +import qualified Synthesizer.Basic.Wave as Wave + +import Synthesizer.Plain.Filter.Recursive (Pole(..)) + +import Number.Complex ((+:), real, imag, ) +import qualified Number.Complex as Complex + +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Ring as Ring + +import PreludeBase +import NumericPrelude + + +sampleRate :: Ring.C a => a +--sampleRate = 44100 +sampleRate = 22050 +--sampleRate = 11025 + + +chirp :: Double -> [Double] +chirp len = Osci.freqModSine 0 (iterate (+0.5/len) 0) + +filter2ndOrderTest :: [Double] +filter2ndOrderTest = + take 10 + (Filt2.run + (repeat (Filt2.Parameter 1 0 0 0 (1::Double))) + (1 : repeat 0)) + + +butterworthLowpassTest0 :: [Double] +butterworthLowpassTest0 = + take 30 (Butter.lowpassPole 2 (repeat 0.2) (repeat (0.1::Double)) (repeat 1)) + +butterworthLowpassTest1 :: Double +butterworthLowpassTest1 = + maximum (take 300 (drop 500 + (Butter.lowpassPole 6 (repeat 0.1) (repeat (0.05::Double)) + (map sin (iterate (+2*pi*0.05) 0))))) + +butterworthLowpassTest2 :: [Double] +butterworthLowpassTest2 = + let len = 1*sampleRate + in take (round len) (Butter.lowpassPole 20 (repeat 0.3) (repeat (0.2::Double)) (chirp len)) + +chebyParameterA, chebyParameterB :: (Trans.C a) => + a -> Complex.T a -> a -> Filt2.Parameter a +chebyParameterA vol z freq = + let re = real z + im = imag z + phi = pi*freq + sinphi = sin phi + cosphi = cos phi + cpims = cosphi + im*sinphi + cmims = cosphi - im*sinphi + resin2 = (re*sinphi)^2 + denom = - cmims^2 - resin2 + c0 = vol * sinphi^2 / denom + in Filt2.Parameter + c0 (2*c0) c0 + (-2*(cpims*cmims - resin2)/denom) ((cpims^2 + resin2)/denom) + +chebyParameterB a0 z freq = + let re = real z + im = imag z + phi = pi*freq + sinphi = sin phi + cosphi = cos phi + spimc = sinphi + im*cosphi + smimc = sinphi - im*cosphi + recos2 = (re*cosphi)^2 + denom = smimc^2 + recos2 + c0 = (sinphi^2 + a0^2*cosphi^2) / denom + c1 = (sinphi^2 - a0^2*cosphi^2) / denom + in Filt2.Parameter + c0 (2*c1) c0 + (-2*(spimc*smimc - recos2)/denom) (-(spimc^2 + recos2)/denom) + +-- cf. makeZero +chebyshevALowpassTest0 :: Filt2.Parameter Double +chebyshevALowpassTest0 = + let beta = asinh 1 / 4 + in chebyParameterA 1 (12/13 * cosh beta +: (-5/13 * sinh beta)) 0.1 + +chebyshevBLowpassTest0 :: Filt2.Parameter Double +chebyshevBLowpassTest0 = + let beta = asinh 1 / 4 + in chebyParameterB (12/13) (12/13 * cosh beta +: (-5/13 * sinh beta)) 0.1 + +chebyshevLowpassTest1 :: [Double] +chebyshevLowpassTest1 = + let len = 1*sampleRate + in take (round len) (Filt2.run (repeat chebyshevALowpassTest0) (chirp len)) + +chebyshevALowpassTest2 :: [Double] +chebyshevALowpassTest2 = + let len = 1*sampleRate + in take (round len) $ + Cheby.lowpassAPole 10 (repeat 0.25) (repeat (0.3::Double)) (chirp len) + +chebyshevBLowpassTest2 :: [Double] +chebyshevBLowpassTest2 = + let len = 1*sampleRate + in take (round len) $ + Cheby.lowpassBPole 10 (repeat 0.25) (repeat (0.1::Double)) (chirp len) + + + +moogLowpassTest :: [Double] +moogLowpassTest = + Moog.lowpass 10 + (repeat (Moog.parameter 10 (Pole 10 (0.05::Double)))) + (1:repeat 0) + +universalTest :: [Uni.Result Double] +universalTest = + let len = 1*sampleRate + in take (round len) $ + Uni.run + (repeat (Uni.parameter (Pole 5 (0.1::Double)))) + (chirp len) + + +complexRealTest :: [Complex.T Double] +complexRealTest = + let len = 1*sampleRate + in take (round len) $ + C1.run + (repeat (C1.parameterFromPeakWidth 0.025 (Pole 5 (0.1::Double)))) + (chirp len) + +chirpComplex :: Double -> [Complex.T Double] +chirpComplex len = + Osci.freqMod Wave.helix 0 (iterate (+0.5/len) 0) + +complexTest :: [Complex.T Double] +complexTest = + let len = 1*sampleRate + in take (round len) $ + map + (\x -> Complex.real x + Complex.quarterLeft (Complex.imag x)) $ + C1.run + (repeat (C1.parameterFromPeakWidth 0.025 (Pole 5 (0.1::Double)))) + (chirpComplex len) diff --git a/src/Synthesizer/Plain/Filter/Recursive/Universal.hs b/src/Synthesizer/Plain/Filter/Recursive/Universal.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Plain/Filter/Recursive/Universal.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +State variable filter. +One filter that generates lowpass, bandpass, highpass, bandlimit at once. +-} +module Synthesizer.Plain.Filter.Recursive.Universal where + +import Synthesizer.Plain.Filter.Recursive (Pole(..)) +import qualified Synthesizer.Plain.Signal as Sig +import qualified Synthesizer.Plain.Modifier as Modifier +import qualified Synthesizer.Causal.Process as Causal + +import qualified Synthesizer.Interpolation.Class as Interpol +import Synthesizer.ApplicativeUtility (liftA4, liftA6, ) + +import Foreign.Storable (Storable(..)) +import qualified Foreign.Storable.Record as Store + +import qualified Algebra.Module as Module +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Algebra.Module((*>)) + +import Control.Monad.Trans.State (State, state, ) + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +data Parameter a = + Parameter {k1, k2, ampIn, ampI1, ampI2, ampLimit :: !a} + + +instance Interpol.C a v => Interpol.C a (Parameter v) where + {-# INLINE scaleAndAccumulate #-} + scaleAndAccumulate = + Interpol.runMac $ liftA6 Parameter + (Interpol.element k1) + (Interpol.element k2) + (Interpol.element ampIn) + (Interpol.element ampI1) + (Interpol.element ampI2) + (Interpol.element ampLimit) + +instance Storable a => Storable (Parameter a) where + sizeOf = Store.sizeOf storeParameter + alignment = Store.alignment storeParameter + peek = Store.peek storeParameter + poke = Store.poke storeParameter + +storeParameter :: + Storable a => Store.Dictionary (Parameter a) +storeParameter = + Store.run $ + liftA6 Parameter + (Store.element k1) + (Store.element k2) + (Store.element ampIn) + (Store.element ampI1) + (Store.element ampI2) + (Store.element ampLimit) + + +data Result a = + Result {highpass, bandpass, lowpass, bandlimit :: !a} + +instance Additive.C v => Additive.C (Result v) where + {-# INLINE zero #-} + {-# INLINE (+) #-} + {-# INLINE (-) #-} + {-# INLINE negate #-} + zero = Result zero zero zero zero + (+) (Result xhp xbp xlp xbl) (Result yhp ybp ylp ybl) = + Result (xhp + yhp) (xbp + ybp) (xlp + ylp) (xbl + ybl) + (-) (Result xhp xbp xlp xbl) (Result yhp ybp ylp ybl) = + Result (xhp - yhp) (xbp - ybp) (xlp - ylp) (xbl - ybl) + negate (Result xhp xbp xlp xbl) = + Result (negate xhp) (negate xbp) (negate xlp) (negate xbl) + +instance Module.C a v => Module.C a (Result v) where + {-# INLINE (*>) #-} + s *> (Result hp bp lp bl) = + Result (s *> hp) (s *> bp) (s *> lp) (s *> bl) + +instance Storable a => Storable (Result a) where + sizeOf = Store.sizeOf storeResult + alignment = Store.alignment storeResult + peek = Store.peek storeResult + poke = Store.poke storeResult + +storeResult :: + Storable a => Store.Dictionary (Result a) +storeResult = + Store.run $ + liftA4 Result + (Store.element highpass) + (Store.element bandpass) + (Store.element lowpass) + (Store.element bandlimit) + + + +{-| +The computation of the internal parameters is a bit complicated, +but it fulfills the following properties: + +* At the resonance frequency the band pass has 180 degree phase shift. + This is also approximately the frequency + where the filter has maximum output. + Even more important, this is the frequency where the band limit filter works. + +* At the resonance frequency highpass, lowpass, and bandpass + amplify by the factor @resonance@. + +* The lowpass amplifies the frequency zero by factor 1. + +* The highpass amplifies the highest representable (Nyquist) frequency by the factor 1. + +* The bandlimit amplifies both frequency zero and Nyquist frequency + by factor one and cancels the resonance frequency. +-} +{-# INLINE parameter #-} +parameter :: Trans.C a => Pole a -> Parameter a +parameter (Pole resonance frequency) = + let zr = cos (2*pi*frequency) + zr1 = zr-1 + q2 = resonance^2 + sqrtQZ = sqrt (zr1*(-8*q2+zr1-4*q2*zr1)) + pk1 = (-zr1+sqrtQZ) / (2*q2-zr1+sqrtQZ) + q21zr = 4*q2*zr + a = 2 * (zr1*zr1-q21zr*zr) / (zr1+q21zr+(1+2*zr1)*sqrtQZ) + pk2 = a+2-pk1 + volHP = (4-2*pk1-pk2) / 4 + volLP = pk2 + volBP = sqrt (volHP*volLP) + in Parameter + (pk1*volHP/volBP) (pk2*volHP/volLP) + volHP (volBP/volHP) (volLP/volBP) (recip resonance) + +{-| Universal filter: Computes high pass, band pass, low pass in one go -} +{-# INLINE step #-} +step :: (Ring.C a, Module.C a v) => + Parameter a -> v -> State (v,v) (Result v) +step p u = + state $ \(i1,i2) -> + let newsum = ampIn p *> u + k1 p *> i1 - k2 p *> i2 + newi1 = i1 - ampI1 p *> newsum + newi2 = i2 - ampI2 p *> newi1 + out = Result newsum newi1 newi2 (u + ampLimit p *> newi1) + in (out, (newi1, newi2)) + +{-# INLINE modifierInit #-} +modifierInit :: (Ring.C a, Module.C a v) => + Modifier.Initialized (v,v) (v,v) (Parameter a) v (Result v) +modifierInit = + Modifier.Initialized id step + +{-# INLINE modifier #-} +modifier :: (Ring.C a, Module.C a v) => + Modifier.Simple (v,v) (Parameter a) v (Result v) +modifier = Sig.modifierInitialize modifierInit (zero, zero) + +{-# INLINE causal #-} +causal :: + (Ring.C a, Module.C a v) => + Causal.T (Parameter a, v) (Result v) +causal = + Causal.fromSimpleModifier modifier + + +{-# INLINE runInit #-} +runInit :: (Ring.C a, Module.C a v) => + (v,v) -> Sig.T (Parameter a) -> Sig.T v -> Sig.T (Result v) +runInit = Sig.modifyModulatedInit modifierInit + +{-# INLINE run #-} +run :: (Ring.C a, Module.C a v) => + Sig.T (Parameter a) -> Sig.T v -> Sig.T (Result v) +run = runInit (zero, zero) diff --git a/src/Synthesizer/Plain/IO.hs b/src/Synthesizer/Plain/IO.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Plain/IO.hs @@ -0,0 +1,142 @@ +{- | +This is old code, handling Int16 using two characters. +-} +module Synthesizer.Plain.IO + {-# DEPRECATED "Use Sound.Sox.Signal.List instead." #-} + ( + writeInt16Stream, readInt16StreamStrict, + writeLEInt16Stream, readLEInt16Stream, + putInt16Stream, putInt16StreamChunky, + -- historical functions + intToTwoLEChars, twoLECharsToInt, + ) where + +import Foreign (Int16, Ptr, alloca, sizeOf, poke, peek) +import System.IO + (openBinaryFile, IOMode(WriteMode,ReadMode), hClose, + Handle, hPutBuf, hGetBuf) +import Control.Exception (bracket, ) +import Control.Monad (liftM, ) + +import Data.Monoid (Monoid, mconcat, ) + +import qualified Data.ByteString.Lazy as B +import qualified Data.Binary.Builder as Builder + +import qualified Algebra.Ring as Ring + +import Data.Char (ord, ) + +import qualified Prelude as P98 + +import PreludeBase +import NumericPrelude + + + +-- | little endian (Intel) +{-# INLINE leCharsToInt16 #-} +leCharsToInt16 :: Char -> Char -> Int16 +leCharsToInt16 hi lo = + P98.fromIntegral $ ord lo + 256 * ord hi + +twoLECharsToInt :: Char -> Char -> Int +twoLECharsToInt hi lo = + let unsigned = ord lo + 256 * ord hi + in mod (unsigned + 32768) 65536 - 32768 + + +-- | little endian (Intel) +{-# INLINE int16ToLEChars #-} +int16ToLEChars :: Int16 -> [Char] +int16ToLEChars x = + let (hi,lo) = divMod (P98.fromIntegral x) 256 + in [toEnum lo, toEnum (mod hi 256)] + +intToTwoLEChars :: Int -> [Char] +intToTwoLEChars x = + let (hi,lo) = divMod x 256 + in [toEnum lo, toEnum (mod hi 256)] + + + +{-# INLINE binaryToIntsMono16 #-} +binaryToIntsMono16 :: [Char] -> [Int16] +binaryToIntsMono16 sig = + case sig of + (lo:hi:xs) -> + leCharsToInt16 hi lo : binaryToIntsMono16 xs + (_:[]) -> + error "binaryToIntsMono16: 16 bit sample files must have even length" + [] -> [] + + +{- | +Write a little endian 16 bit integer stream +via String data and 'writeFile'. +-} +writeLEInt16Stream :: FilePath -> [Int16] -> IO () +writeLEInt16Stream fileName = + writeFile fileName . concatMap int16ToLEChars + +{- | +Uses endianess of the machine, like Sox does. +-} +writeInt16Stream :: FilePath -> [Int16] -> IO () +writeInt16Stream fileName stream = + bracket (openBinaryFile fileName WriteMode) hClose + (flip putInt16Stream stream) + +putInt16StreamChunky :: Handle -> [Int16] -> IO () +putInt16StreamChunky h = + B.hPut h . Builder.toLazyByteString . + mconcat . map (Builder.putWord16host . P98.fromIntegral) + +putInt16Stream :: Handle -> [Int16] -> IO () +putInt16Stream h stream = + alloca $ + \p -> mapM_ (putInt16 h p) stream + +putInt16 :: Handle -> Ptr Int16 -> Int16 -> IO () +putInt16 h p n = + poke p n >> hPutBuf h p (sizeOf n) + + +{- | +The end of the list is undefined, +if the file has odd length. +It would be better if it throws an exception. +-} +readLEInt16Stream :: FilePath -> IO [Int16] +readLEInt16Stream fileName = + fmap binaryToIntsMono16 (readFile fileName) + +{- | +The end of the list is undefined, +if the file has odd length. +It would be better if it throws an exception. +-} +readInt16StreamStrict :: FilePath -> IO [Int16] +readInt16StreamStrict fileName = + bracket (openBinaryFile fileName ReadMode) hClose + getInt16StreamStrict + +getInt16StreamStrict :: Handle -> IO [Int16] +getInt16StreamStrict h = + alloca $ + \p -> fmap (map P98.fromIntegral) + (unfoldM (getInt16 h p)) + +-- candidate for Utility +unfoldM :: Monad m => m (Maybe a) -> m [a] +unfoldM act = + let listM = maybe (return []) (\x -> liftM (x:) listM) =<< act + in listM + +getInt16 :: Handle -> Ptr Int16 -> IO (Maybe Int16) +getInt16 h p = + do cnt <- hGetBuf h p (sizeOf (undefined::Int16)) + case cnt of + 0 -> return Nothing + 2 -> fmap Just (peek p) + _ -> return (error "getInt16: only one byte found") diff --git a/src/Synthesizer/Plain/Instrument.hs b/src/Synthesizer/Plain/Instrument.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Plain/Instrument.hs @@ -0,0 +1,304 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +module Synthesizer.Plain.Instrument where + +import Synthesizer.Plain.Displacement (mixMulti, ) +import Synthesizer.Plain.Control (exponential2) +import qualified Synthesizer.Plain.Oscillator as Osci +import qualified Synthesizer.Basic.Wave as Wave +import qualified Synthesizer.Plain.Noise as Noise +import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1 +import qualified Synthesizer.Plain.Filter.Recursive.Allpass as Allpass +import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilter +import qualified Synthesizer.Plain.Filter.Recursive.Moog as Moog +import qualified Synthesizer.Plain.Filter.Recursive.Comb as Comb +import qualified Synthesizer.Plain.Filter.Recursive as FiltR +import qualified Synthesizer.Plain.Filter.NonRecursive as FiltNR +import qualified Synthesizer.Plain.Interpolation as Interpolation +import Data.List(zipWith4) + +import System.Random + +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Module as Module +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring + +import PreludeBase +import NumericPrelude + + + +{-| Create a sound of a slightly changed frequency + just as needed for a simple stereo sound. -} +stereoPhaser :: Ring.C a => + (a -> [b]) {- ^ A function mapping a frequency to a signal. -} + -> a {- ^ The factor to the frequency, should be close to 1. -} + -> a {- ^ The base (undeviated) frequency of the sound. -} + -> [b] +stereoPhaser sound dif freq = sound (freq*dif) + + + +allpassPlain :: (RealField.C a, Trans.C a, Module.C a a) => + a -> a -> a -> a -> [a] +allpassPlain sampleRate halfLife k freq = + Allpass.cascade 10 + (map Allpass.Parameter (exponential2 (halfLife*sampleRate) k)) + (simpleSaw sampleRate freq) + +allpassDown :: (RealField.C a, Trans.C a, Module.C a a) => + a -> Int -> a -> a -> a -> [a] +allpassDown sampleRate order halfLife filterfreq freq = + let x = simpleSaw sampleRate freq + in map (0.3*) (zipWith (+) x + (Allpass.cascade order + (map (Allpass.flangerParameter order) + (exponential2 (halfLife*sampleRate) (filterfreq/sampleRate))) + x)) + + +moogDown, moogReso :: + (RealField.C a, Trans.C a, Module.C a a) => + a -> Int -> a -> a -> a -> [a] +moogDown sampleRate order halfLife filterfreq freq = + Moog.lowpass order + (map (Moog.parameter order) (map (FiltR.Pole 10) + (exponential2 (halfLife*sampleRate) (filterfreq/sampleRate)))) + (simpleSaw sampleRate freq) + +moogReso sampleRate order halfLife filterfreq freq = + Moog.lowpass order + (map (Moog.parameter order) (zipWith FiltR.Pole + (exponential2 (halfLife*sampleRate) 100) + (repeat (filterfreq/sampleRate)))) + (simpleSaw sampleRate freq) + +bell :: (Trans.C a, RealField.C a) => a -> a -> [a] +bell sampleRate freq = + let halfLife = 0.5 + in zipWith3 (\x y z -> (x+y+z)/3) + (bellHarmonic sampleRate 1 halfLife freq) + (bellHarmonic sampleRate 4 halfLife freq) + (bellHarmonic sampleRate 7 halfLife freq) + +bellHarmonic :: (Trans.C a, RealField.C a) => a -> a -> a -> a -> [a] +bellHarmonic sampleRate n halfLife freq = + zipWith (*) (Osci.freqModSine 0 (map (\modu -> freq/sampleRate*n*(1+0.005*modu)) + (Osci.staticSine 0 (5.0/sampleRate)))) + (exponential2 (halfLife/n*sampleRate) 1) + + +fastBell, squareBell, moogGuitar, moogGuitarSoft, simpleSaw, fatSaw :: + (RealField.C a, Trans.C a, Module.C a a) => a -> a -> [a] + +fastBell sampleRate freq = + zipWith (*) (Osci.staticSine 0 (freq/sampleRate)) + (exponential2 (0.2*sampleRate) 1) + +filterSaw :: (Module.C a a, Trans.C a, RealField.C a) => + a -> a -> a -> [a] +filterSaw sampleRate filterFreq freq = + map (\r -> UniFilter.lowpass r * 0.1) + (UniFilter.run (map (UniFilter.parameter . FiltR.Pole 10) + (exponential2 (0.1*sampleRate) (filterFreq/sampleRate))) + (Osci.staticSaw 0 (freq/sampleRate))) + +squareBell sampleRate freq = Filt1.lowpass + (map Filt1.parameter + (exponential2 (sampleRate/10) (4000/sampleRate))) +-- (Osci.freqModSample Interpolation.cubic [0, 0.7, -0.3, 0.7, 0, -0.7, 0.3, -0.7] 0 + (Osci.freqModSample Interpolation.linear [0, 0.5, 0.6, 0.8, 0, -0.5, -0.6, -0.8] 0 + (map (\modu -> freq/sampleRate*(1+modu/100)) + (Osci.staticSine 0 (5.0/sampleRate)))) + +fmBell :: (RealField.C a, Trans.C a) => a -> a -> a -> a -> [a] +fmBell sampleRate depth freqRatio freq = + let modul = FiltNR.envelope (exponential2 (0.2*sampleRate) depth) + (Osci.staticSine 0 (freqRatio*freq/sampleRate)) + env = exponential2 (0.5*sampleRate) 1 + in FiltNR.envelope env (Osci.phaseModSine (freq/sampleRate) modul) + +moogGuitar sampleRate freq = + let moogOrder = 4 + filterControl = + map (Moog.parameter moogOrder) + (map (FiltR.Pole 10) (exponential2 + (0.5*sampleRate) + (4000/sampleRate))) + tone = Osci.freqModSaw 0 (map (\modu -> freq/sampleRate*(1+0.005*modu)) + (Osci.staticSine 0 (5.0/sampleRate))) + in Moog.lowpass moogOrder filterControl tone + +moogGuitarSoft sampleRate freq = + FiltNR.envelope (map (1-) (exponential2 (0.003*sampleRate) 1)) + (moogGuitar sampleRate freq) + + + +{-| low pass with resonance -} +filterSweep :: (Field.C v, Module.C a v, Trans.C a, RealField.C a) => + a -> a -> [v] -> [v] +filterSweep sampleRate phase = + map (\r -> UniFilter.lowpass r / 2) . + UniFilter.run + (map (\freq -> + UniFilter.parameter (FiltR.Pole 10 ((1800/sampleRate)*2**freq))) + (Osci.staticSine phase (1/16/sampleRate)) + ) + + +fatSawChordFilter, fatSawChord :: + (RealField.C a, Trans.C a, Module.C a a) => a -> a -> [a] + +fatSawChordFilter sampleRate freq = + map (\r -> UniFilter.lowpass r / 2) + (UniFilter.run (filterDown sampleRate) + (fatSawChord sampleRate freq)) + +fatSawChord sampleRate freq = + zipWith3 (\x y z -> (x+y+z)/3) + (fatSaw sampleRate (1 *freq)) + (fatSaw sampleRate (5/4*freq)) + (fatSaw sampleRate (3/2*freq)) + +filterDown :: (RealField.C a, Trans.C a) => a -> [UniFilter.Parameter a] + +filterDown sampleRate = + map UniFilter.parameter $ + map (FiltR.Pole 10) $ + exponential2 (sampleRate/3) (4000/sampleRate) + +simpleSaw sampleRate freq = + Osci.staticSaw 0 (freq/sampleRate) + +{-| accumulate multiple similar saw sounds and observe the increase of volume + The oscillator @osc@ must accept relative frequencies. -} +modulatedWave :: (Trans.C a, RealField.C a) => + a -> (a -> [a] -> [a]) -> a -> a -> a -> a -> a -> [a] +modulatedWave sampleRate osc freq start depth phase speed = + osc start (map (\x -> freq/sampleRate*(1+x*depth)) + (Osci.staticSine phase (speed/sampleRate))) + +accumulatedSaws :: (Random a, Trans.C a, RealField.C a) => a -> a -> [[a]] +accumulatedSaws sampleRate freq = + let starts = randomRs (0,1) (mkStdGen 48251) + depths = randomRs (0,0.02) (mkStdGen 12354) + phases = randomRs (0,1) (mkStdGen 74389) + speeds = randomRs (0.1,0.3) (mkStdGen 03445) + saws = zipWith4 (modulatedWave sampleRate Osci.freqModSaw freq) + starts depths phases speeds + in scanl1 (zipWith (+)) saws + +choirWave :: Field.C a => [a] +choirWave = + [0.702727421560071, 0.7378359559947721, 0.7826845805704197, 0.6755514176072053, + 0.4513448069764686, 0.3272995923197175, 0.3404887595570093, 0.41416011004660863, + 0.44593673999775735, 0.4803528740412951, 0.48761174828621334, 0.44076701468836754, + 0.39642906530439503, 0.35467843549395706, 0.38054627445988315, 0.3888748481589558, + 0.35303993804564215, 0.3725196582177455, 0.44980257249714667, 0.5421204370443772, + 0.627630436752643, 0.6589491426946169, 0.619819155051891, 0.5821754728547365, + 0.5495877076869761, 0.5324446834830168, 0.47242861142812065, 0.3686685958119909, + 0.2781440436733245, 0.2582500464201269, 0.1955614176372372, 0.038373557320540604, + -0.13132155046556182, -0.21867394831598339, -0.24302145520904606, -0.3096437514614372, + -0.44774961666697943, -0.5889830267579028, -0.7168993833444837, -0.816723038671071, + -0.8330283834679535, -0.8384077057999397, -0.8834813451725689, -0.9159391171556484, + -0.9189751669797644, -0.8932026446626791, -0.8909164153221475, -0.9716732300637536, + -1, -0.9253833606736654, -0.8568630538844477, -0.863932337623625, + -0.857811827480001, -0.8131204084064676, -0.7839286071242304, -0.7036632045472225, + -0.5824648346845637, -0.46123726085299827, -0.41391985851146285, -0.45323938111069567, + -0.5336689022602625, -0.5831307769323063, -0.5693896103843189, -0.48596981886424745, + -0.35791155598992863, -0.2661471984133689, -0.24158092840946802, -0.23965213828744264, + -0.23421368394531547, -0.25130667896294306, -0.3116359503337366, -0.31263345635966144, + -0.1879031874103659, -0.00020936838180399674, 0.18567090309156153, 0.2713525359068149, + 0.2979908042971701, 0.2957704726566382, 0.28820375086489286, 0.364513508557745, + 0.4520234711163569, 0.43210542988077005, 0.4064955825278379, 0.4416784798648095, + 0.5240917981530765, 0.6496469543088884, 0.7658103369723797, 0.8012776441058732, + 0.7824042138292476, 0.752678361663059, 0.760211176708886, 0.7308266231622353] + + +choir :: (Random a, Trans.C a, RealField.C a) => a -> a -> [a] +choir sampleRate freq = + let starts = randomRs (0,1) (mkStdGen 48251) + depths = randomRs (0,0.02) (mkStdGen 12354) + phases = randomRs (0,1) (mkStdGen 74389) + speeds = randomRs (0.1,0.3) (mkStdGen 03445) + voices = zipWith4 (modulatedWave sampleRate + (Osci.freqModSample Interpolation.constant choirWave) freq) + starts depths phases speeds + in map (*0.2) ((scanl1 (zipWith (+)) voices) !! 10) + + +fatSaw sampleRate freq = + {- a simplified version of modulatedWave -} + let partial depth modPhase modFreq = + osciDoubleSaw sampleRate + (map (\x -> freq*(1+x*depth)) + (Osci.staticSine modPhase (modFreq/sampleRate))) + in zipWith3 (((((/3).).(+)).).(+)) + (partial 0.00311 0.0 20) + (partial 0.00532 0.3 17) + (partial 0.00981 0.9 6) + +osciDoubleSaw :: (RealField.C a, Module.C a a) => a -> [a] -> [a] +osciDoubleSaw sampleRate = + Osci.freqModSample Interpolation.linear [-1, -0.2, 0.5, -0.5, 0.2, 1.0] 0 + . map (/sampleRate) + + +{-| A tone with a waveform with roughly the dependency x -> x**p, + where the waveform is normalized to constant quadratic norm -} +osciSharp :: (RealField.C a, Trans.C a) => a -> a -> [a] +osciSharp sampleRate freq = + let --control = iterate (+ (-1/sampleRate)) 4 + control = exponential2 (0.01*sampleRate) 10 + in Osci.shapeMod Wave.powerNormed 0 (freq/sampleRate) control + +{-| Build a saw sound from its harmonics and modulate it. + Different to normal modulation + I modulate each harmonic with the same depth rather than a proportional one. -} +osciAbsModSaw :: (RealField.C a, Trans.C a) => a -> a -> [a] +osciAbsModSaw sampleRate freq = + let ratios = map fromIntegral [(1::Int)..20] + harmonic n = FiltNR.amplify (0.25/n) + (Osci.freqModSine 0 (map (\x -> (n+0.03*x)*freq/sampleRate) + (Osci.staticSine 0 (1/sampleRate)))) + in mixMulti (map harmonic ratios) + +{-| Short pulsed Noise.white, + i.e. Noise.white amplified with pulses of varying H\/L ratio. -} +pulsedNoise :: (Ring.C a, Random a, RealField.C a, Trans.C a) => + a + -> a {-^ frequency of the pulses, interesting ones are around 100 Hz and below -} + -> [a] +pulsedNoise sampleRate freq = + zipWith3 (\thr0 thr1 x -> if thr0+1 < (thr1+1)*0.2 then x else 0) + (Osci.staticSine 0 (freq/sampleRate)) (Osci.staticSine 0 (0.1/sampleRate)) Noise.white + +noiseBass :: (Ring.C a, Random a, RealField.C a, Trans.C a, Module.C a a) => + a + -> a + -> [a] +noiseBass sampleRate freq = + let y = FiltNR.envelope (exponential2 (0.1*sampleRate) 1) Noise.white + ks = Comb.runProc (round (sampleRate/freq)) + (Filt1.lowpass + (repeat (Filt1.parameter (2000/sampleRate)))) y + in ks + +{-| Drum sound using the Karplus-Strong-Algorithm + This is a Noise.white enveloped by an exponential2 + which is piped through the Karplus-Strong machine + for generating some frequency. + The whole thing is then frequency modulated + to give a falling frequency. -} +electroTom :: (Ring.C a, Random a, RealField.C a, Trans.C a, Module.C a a) => + a -> [a] +electroTom sampleRate = + let y = FiltNR.envelope (exponential2 (0.1*sampleRate) 1) Noise.white + ks = Comb.runProc (round (sampleRate/30)) + (Filt1.lowpass + (repeat $ Filt1.parameter (1000/sampleRate))) y + in Interpolation.multiRelativeZeroPadLinear 0 (exponential2 (0.3*sampleRate) 1) ks diff --git a/src/Synthesizer/Plain/Interpolation.hs b/src/Synthesizer/Plain/Interpolation.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Plain/Interpolation.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Synthesizer.Plain.Interpolation ( + T, func, offset, number, + zeroPad, constantPad, cyclicPad, extrapolationPad, + single, + multiRelative, + multiRelativeZeroPad, multiRelativeConstantPad, + multiRelativeCyclicPad, multiRelativeExtrapolationPad, + multiRelativeZeroPadConstant, multiRelativeZeroPadLinear, + multiRelativeZeroPadCubic, + + constant, linear, cubic, + piecewise, function, + + Interpolation.Margin, Interpolation.margin, + + singleRec, -- for testing + ) where + +import qualified Synthesizer.Interpolation as Interpolation +import Synthesizer.Interpolation (T, offset, number, ) +import Synthesizer.Interpolation.Module + (constant, linear, cubic, piecewise, function, ) + +import qualified Synthesizer.State.Signal as SigS + +import qualified Synthesizer.Plain.Signal as Sig +import qualified Synthesizer.Plain.Filter.NonRecursive as FiltNR + +import qualified Algebra.Module as Module +import qualified Algebra.RealField as RealField +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Algebra.Additive(zero) +import Data.Maybe (fromMaybe) +import qualified Data.List.HT as ListHT + +import Control.Monad (guard, ) + +import PreludeBase +import NumericPrelude + + +{-* Interpolation with various padding methods -} + +zeroPad :: (RealField.C t) => + (T t y -> t -> Sig.T y -> a) -> + y -> T t y -> t -> Sig.T y -> a +zeroPad interpolate z ip phase x = + let (phInt, phFrac) = splitFraction phase + in interpolate ip phFrac + (FiltNR.delayPad z (offset ip - phInt) (x ++ repeat z)) + +constantPad :: (RealField.C t) => + (T t y -> t -> Sig.T y -> a) -> + T t y -> t -> Sig.T y -> a +constantPad interpolate ip phase x = + let (phInt, phFrac) = splitFraction phase + xPad = + do (xFirst,_) <- ListHT.viewL x + (xBody,xLast) <- ListHT.viewR x + return (FiltNR.delayPad xFirst (offset ip - phInt) (xBody ++ repeat xLast)) + in interpolate ip phFrac + (fromMaybe [] xPad) + + +{- | +Only for finite input signals. +-} +cyclicPad :: (RealField.C t) => + (T t y -> t -> Sig.T y -> a) -> + T t y -> t -> Sig.T y -> a +cyclicPad interpolate ip phase x = + let (phInt, phFrac) = splitFraction phase + in interpolate ip phFrac + (drop (mod (phInt - offset ip) (length x)) (cycle x)) + +{- | +The extrapolation may miss some of the first and some of the last points +-} +extrapolationPad :: (RealField.C t) => + (T t y -> t -> Sig.T y -> a) -> + T t y -> t -> Sig.T y -> a +extrapolationPad interpolate ip phase = + interpolate ip (phase - fromIntegral (offset ip)) +{- + This example shows pikes, although there shouldn't be any: + plotList (take 100 $ interpolate (Zero (0::Double)) ipCubic (-0.9::Double) (repeat 0.03) [1,0,1,0.8]) +-} + + +{-* Interpolation of multiple values with various padding methods -} + +func :: + T t y -> t -> Sig.T y -> y +func ip phase = + Interpolation.func ip phase . SigS.fromList + +skip :: (RealField.C t) => + T t y -> (t, Sig.T y) -> (t, Sig.T y) +skip ip (phase0, x0) = + let (n, frac) = splitFraction phase0 + (m, x1) = Sig.dropMarginRem (number ip) n x0 + in (fromIntegral m + frac, x1) + +single :: (RealField.C t) => + T t y -> t -> Sig.T y -> y +single ip phase0 x0 = + uncurry (func ip) $ skip ip (phase0, x0) +-- curry (uncurry (func ip) . skip ip) +{- +GNUPlot.plotFunc [] (GNUPlot.linearScale 1000 (0,2)) (\t -> single linear (t::Double) [0,4,1::Double]) +-} + +-- | alternative implementation of 'single' +singleRec :: (Ord t, Ring.C t) => + T t y -> t -> Sig.T y -> y +singleRec ip phase x = + -- check if we are leaving the current interval + maybe + (func ip phase x) + (singleRec ip (phase - 1)) + (do (_,xs) <- ListHT.viewL x + guard (phase >= 1 && Sig.lengthAtLeast (number ip) xs) + return xs) + + +{-* Interpolation of multiple values with various padding methods -} + +{- | All values of frequency control must be non-negative. -} +multiRelative :: (RealField.C t) => + T t y -> t -> Sig.T y -> Sig.T t -> Sig.T y +multiRelative ip phase0 x0 = + map (uncurry (func ip)) . + scanl + (\(phase,x) freq -> skip ip (phase + freq, x)) + (skip ip (phase0,x0)) + + +multiRelativeZeroPad :: (RealField.C t) => + y -> T t y -> t -> Sig.T t -> Sig.T y -> Sig.T y +multiRelativeZeroPad z ip phase fs x = + zeroPad multiRelative z ip phase x fs + +multiRelativeConstantPad :: (RealField.C t) => + T t y -> t -> Sig.T t -> Sig.T y -> Sig.T y +multiRelativeConstantPad ip phase fs x = + constantPad multiRelative ip phase x fs + +multiRelativeCyclicPad :: (RealField.C t) => + T t y -> t -> Sig.T t -> Sig.T y -> Sig.T y +multiRelativeCyclicPad ip phase fs x = + cyclicPad multiRelative ip phase x fs + +{- | +The extrapolation may miss some of the first and some of the last points +-} +multiRelativeExtrapolationPad :: (RealField.C t) => + T t y -> t -> Sig.T t -> Sig.T y -> Sig.T y +multiRelativeExtrapolationPad ip phase fs x = + extrapolationPad multiRelative ip phase x fs +{- + This example shows pikes, although there shouldn't be any: + plotList (take 100 $ interpolate (Zero (0::Double)) ipCubic (-0.9::Double) (repeat 0.03) [1,0,1,0.8]) +-} + +{-* All-in-one interpolation functions -} + +multiRelativeZeroPadConstant :: + (RealField.C t, Additive.C y) => t -> Sig.T t -> Sig.T y -> Sig.T y +multiRelativeZeroPadConstant = multiRelativeZeroPad zero constant + +multiRelativeZeroPadLinear :: + (RealField.C t, Module.C t y) => t -> Sig.T t -> Sig.T y -> Sig.T y +multiRelativeZeroPadLinear = multiRelativeZeroPad zero linear + +multiRelativeZeroPadCubic :: + (RealField.C t, Module.C t y) => t -> Sig.T t -> Sig.T y -> Sig.T y +multiRelativeZeroPadCubic = multiRelativeZeroPad zero cubic diff --git a/src/Synthesizer/Plain/LorenzAttractor.hs b/src/Synthesizer/Plain/LorenzAttractor.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Plain/LorenzAttractor.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Synthesizer.Plain.LorenzAttractor where + +import qualified Algebra.Module as Module +import qualified Algebra.Ring as Ring + +import PreludeBase +import NumericPrelude + + +computeDerivatives :: (Ring.C y) => + (y, y, y) -> (y, y, y) -> (y, y, y) +computeDerivatives (a,b,c) (x,y,z) = + let x' = a*(y-x) + y' = x*(b-z) - y + z' = x*y -c*z + in (x',y',z') + +explicitEuler :: (Module.C a v) => + a -> (v -> v) -> v -> [v] +explicitEuler h phi s = + let ys = s : map (\y -> y + h *> phi y) ys + in ys + + +equilibrium :: (Double, Double, Double) +equilibrium = (sqrt 72, sqrt 72, 27.001) + +example0 :: [(Double, Double, Double)] +example0 = + explicitEuler (0.01::Double) + (computeDerivatives (10, 28, 8/3)) equilibrium + +example :: [(Double, Double, Double)] +example = + explicitEuler (0.01::Double) + (computeDerivatives (10, 28, 8/3)) (8.5, 8.6, 27) diff --git a/src/Synthesizer/Plain/Miscellaneous.hs b/src/Synthesizer/Plain/Miscellaneous.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Plain/Miscellaneous.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Synthesizer.Plain.Miscellaneous where + +import qualified Algebra.NormedSpace.Euclidean as Euc +import qualified Algebra.Field as Field +-- import qualified Algebra.Ring as Ring +-- import qualified Algebra.Additive as Additive + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +{- * Spatial effects -} + +{-| simulate an moving sounding object + convert the way of the object through 3D space + into a delay and attenuation information, + sonicDelay is the reciprocal of the sonic velocity -} +receive3Dsound :: (Field.C a, Euc.C a v) => a -> a -> v -> [v] -> ([a],[a]) +receive3Dsound att sonicDelay ear way = + let dists = map (Euc.norm) (map (subtract ear) way) + phase = map (sonicDelay*) dists + volumes = map (\x -> 1/(att+x)^2) dists + in (phase, volumes) diff --git a/src/Synthesizer/Plain/Modifier.hs b/src/Synthesizer/Plain/Modifier.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Plain/Modifier.hs @@ -0,0 +1,134 @@ +{- | +Support for stateful modifiers like controlled filters. +This is similar to "Synthesizer.Causal.Process" +but we cannot replace the Modifier structure by the Causal structure +because the Modifier structure exhibits the state +which allows stacking of modifiers +using an efficient storage for the stacked state. +More precisely, because Modifiers exhibits the type of the state, +we can ensure that the state type of several modifiers is equal +and thus the individual states can be stored in an array or a StorableVector. +-} +module Synthesizer.Plain.Modifier where + +import Control.Monad.Trans.State (State, state, runState, evalState, ) +import Control.Monad (zipWithM, ) + +import qualified Data.StorableVector as SV +import Foreign.Storable (Storable(..)) + +import qualified Data.List as List + +import Prelude hiding (init) + + +-- Signal.T, re-defined here in order to avoid module cycle +type T a = [a] + + +data Simple s ctrl a b = + Simple { + init :: s, + step :: ctrl -> a -> State s b + } + +{-| +modif is a process controlled by values of type c +with an internal state of type s, +it converts an input value of type a into an output value of type b +while turning into a new state + +ToDo: +Shall finite signals be padded with zeros? +-} +static :: + Simple s ctrl a b -> ctrl -> T a -> T b +static modif control x = + evalState (mapM (step modif control) x) (init modif) + +{-| Here the control may vary over the time. -} +modulated :: + Simple s ctrl a b -> T ctrl -> T a -> T b +modulated modif control x = + evalState (zipWithM (step modif) control x) (init modif) + + +data Initialized s init ctrl a b = + Initialized { + initInit :: init -> s, + initStep :: ctrl -> a -> State s b + } + + +initialize :: + Initialized s init ctrl a b -> init -> Simple s ctrl a b +initialize modif stateInit = + Simple (initInit modif stateInit) (initStep modif) + +staticInit :: + Initialized s init ctrl a b -> init -> ctrl -> T a -> T b +staticInit modif state_ = + static (initialize modif state_) + +{-| Here the control may vary over the time. -} +modulatedInit :: + Initialized s init ctrl a b -> init -> T ctrl -> T a -> T b +modulatedInit modif state_ = + modulated (initialize modif state_) + + + +{- | +The number of stacked state monads +depends on the size of the list of state values. +This is like a dynamically nested StateT. +-} +stackStatesR :: (a -> State s a) -> (a -> State [s] a) +stackStatesR m = + state . List.mapAccumR (runState . m) + +stackStatesL :: (a -> State s a) -> (a -> State [s] a) +stackStatesL m = + state . List.mapAccumL (runState . m) + + +{-# INLINE stackStatesStorableR #-} +stackStatesStorableR :: (Storable s) => + (a -> State s a) -> (a -> State (SV.Vector s) a) +stackStatesStorableR m = + state . SV.mapAccumR (runState . m) + +{-# INLINE stackStatesStorableL #-} +stackStatesStorableL :: (Storable s) => + (a -> State s a) -> (a -> State (SV.Vector s) a) +stackStatesStorableL m = + state . SV.mapAccumL (runState . m) + + +{- +{-# INLINE stackStatesStorableVaryR #-} +stackStatesStorableVaryR :: (Storable s, Storable c) => + (c -> a -> State s a) -> (SV.Vector c -> a -> State (SV.Vector s) a) +stackStatesStorableVaryR m cv a = + State . SV.mapAccumL (runState . m) +-} + +{-# INLINE stackStatesStorableVaryL #-} +stackStatesStorableVaryL :: (Storable s, Storable c) => + (c -> a -> State s a) -> (SV.Vector c -> a -> State (SV.Vector s) a) +stackStatesStorableVaryL m cv a = state $ \sv -> + -- emulate SV.zipWith with minimal use of Storable functionality + let (svFinal, mcsa) = + SV.unfoldrN (SV.length sv) + (\(cv0,sv0,a0) -> + do (c,cv1) <- SV.viewL cv0 + (s,sv1) <- SV.viewL sv0 + let (a1,sNew) = runState (m c a0) s + return (sNew,(cv1,sv1,a1))) + (cv,sv,a) + in (case mcsa of + Just (_, _, aFinal) -> aFinal + _ -> error $ "Modifier: control vector too short - " + ++ "status size " ++ show (SV.length sv) ++ " vs. " + ++ "control size " ++ show (SV.length cv), + svFinal) diff --git a/src/Synthesizer/Plain/Noise.hs b/src/Synthesizer/Plain/Noise.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Plain/Noise.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{- | Noise and random processes. -} +module Synthesizer.Plain.Noise where + +import qualified Synthesizer.Plain.Signal as Sig + +import qualified Algebra.Real as Real +import qualified Algebra.Ring as Ring + +import System.Random (Random, RandomGen, randomRs, mkStdGen, ) + +import Data.List.HT (sliceVertical, ) + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +{-| +Deterministic white noise, uniformly distributed between -1 and 1. +That is, variance is 1\/3. +-} +white :: (Ring.C y, Random y) => + Sig.T y +white = whiteGen (mkStdGen 12354) + +whiteGen :: (Ring.C y, Random y, RandomGen g) => + g -> Sig.T y +whiteGen = randomRs (-1,1) + +{- | +Approximates normal distribution with variance 1 +by a quadratic B-spline distribution. +-} +whiteQuadraticBSplineGen :: (Ring.C y, Random y, RandomGen g) => + g -> Sig.T y +whiteQuadraticBSplineGen = + map sum . sliceVertical 3 . randomRs (-1,1) + + +randomPeeks :: (Real.C y, Random y) => + Sig.T y {- ^ momentary densities, @p@ means that there is about one peak + in the time range of @1\/p@ samples -} + -> Sig.T Bool {- ^ Every occurence of 'True' represents a peak. -} +randomPeeks = + randomPeeksGen (mkStdGen 876) + +randomPeeksGen :: (Real.C y, Random y, RandomGen g) => + g + -> Sig.T y + -> Sig.T Bool +randomPeeksGen = + zipWith (<) . randomRs (0,1) diff --git a/src/Synthesizer/Plain/Oscillator.hs b/src/Synthesizer/Plain/Oscillator.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Plain/Oscillator.hs @@ -0,0 +1,235 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{- | +Copyright : (c) Henning Thielemann 2006 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +Tone generators + +Frequencies are always specified in ratios of the sample rate, +e.g. the frequency 0.01 for the sample rate 44100 Hz +means a physical frequency of 441 Hz. +-} +module Synthesizer.Plain.Oscillator where + +import qualified Synthesizer.Plain.ToneModulation as ToneMod +import qualified Synthesizer.Basic.Wave as Wave +import qualified Synthesizer.Basic.Phase as Phase +import qualified Synthesizer.Plain.Interpolation as Interpolation +import qualified Synthesizer.Plain.Signal as Sig + +import Synthesizer.Plain.ToneModulation (freqsToPhases, ) + +{- +import qualified Algebra.RealTranscendental as RealTrans +import qualified Algebra.Module as Module +import qualified Algebra.VectorSpace as VectorSpace + +import Algebra.Module((*>)) +-} +import qualified Algebra.Transcendental as Trans +import qualified Algebra.RealField as RealField +-- import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +-- import qualified Number.NonNegative as NonNeg + +import Data.Tuple.HT (mapFst, mapSnd, ) + +import NumericPrelude + +-- import qualified Prelude as P +import PreludeBase + + +type Phase a = a + + +{- * Oscillators with arbitrary but constant waveforms -} + +{- | oscillator with constant frequency -} +static :: (RealField.C a) => Wave.T a b -> (Phase a -> a -> Sig.T b) +static wave phase freq = + map (Wave.apply wave) + (iterate (Phase.increment freq) (Phase.fromRepresentative phase)) + +{- | oscillator with modulated frequency -} +freqMod :: (RealField.C a) => Wave.T a b -> Phase a -> Sig.T a -> Sig.T b +freqMod wave phase freqs = + map (Wave.apply wave) + (freqsToPhases (Phase.fromRepresentative phase) freqs) + +{- | oscillator with modulated phase -} +phaseMod :: (RealField.C a) => Wave.T a b -> a -> Sig.T (Phase a) -> Sig.T b +phaseMod wave freq phases = + map (Wave.apply wave) $ + zipWith Phase.increment phases (iterate (Phase.increment freq) zero) + +{- | oscillator with modulated shape -} +shapeMod :: (RealField.C a) => (c -> Wave.T a b) -> (Phase a) -> a -> Sig.T c -> Sig.T b +shapeMod wave phase freq parameters = + zipWith (Wave.apply . wave) parameters $ + iterate (Phase.increment freq) (Phase.fromRepresentative phase) + +{- | oscillator with both phase and frequency modulation -} +phaseFreqMod :: (RealField.C a) => Wave.T a b -> Sig.T (Phase a) -> Sig.T a -> Sig.T b +phaseFreqMod wave phases freqs = + map (Wave.apply wave) + (zipWith Phase.increment phases (freqsToPhases zero freqs)) + +{- | oscillator with both shape and frequency modulation -} +shapeFreqMod :: (RealField.C a) => (c -> Wave.T a b) -> Phase a -> Sig.T c -> Sig.T a -> Sig.T b +shapeFreqMod wave phase parameters freqs = + zipWith (Wave.apply . wave) parameters $ + freqsToPhases (Phase.fromRepresentative phase) freqs + + +{- | oscillator with a sampled waveform with constant frequency + This is essentially an interpolation with cyclic padding. -} +staticSample :: RealField.C a => Interpolation.T a b -> [b] -> Phase a -> a -> Sig.T b +staticSample ip wave phase freq = + freqModSample ip wave phase (repeat freq) + +{- | oscillator with a sampled waveform with modulated frequency + Should behave homogenously for different types of interpolation. -} +freqModSample :: RealField.C a => Interpolation.T a b -> [b] -> Phase a -> Sig.T a -> Sig.T b +freqModSample ip wave phase freqs = + let len = fromIntegral (length wave) + in Interpolation.multiRelativeCyclicPad + ip (phase*len) (map (len*) freqs) wave + +{- | +Shape control is a list of relative changes, +each of which must be non-negative in order to allow lazy processing. +'1' advances by one wave. +Frequency control can be negative. +If you want to use sampled waveforms as well +then use 'Wave.sample' in the list of waveforms. +With sampled waves this function is identical to HunkTranspose in Assampler. + +Example: interpolate different versions +of 'Wave.oddCosine' and 'Wave.oddTriangle'. + +You could also chop a tone into single waves +and use the waves as input for this function +but you certainly want to use +'Wave.sampledTone' or 'shapeFreqModFromSampledTone' instead, +because in the wave information for 'shapeFreqModSample' +shape and phase are strictly separated. +-} +shapeFreqModSample :: (RealField.C c, RealField.C b) => + Interpolation.T c (Wave.T b a) -> [Wave.T b a] -> c -> Phase b -> Sig.T c -> Sig.T b -> Sig.T a +shapeFreqModSample ip waves shape0 phase shapes freqs = + zipWith Wave.apply + (Interpolation.multiRelativeConstantPad ip shape0 shapes waves) + (freqsToPhases (Phase.fromRepresentative phase) freqs) +{- +GNUPlot.plotList [] $ take 500 $ shapeFreqModSample Interpolation.cubic (map Wave.truncOddCosine [0..3]) (0.1::Double) (0::Double) (repeat 0.005) (repeat 0.02) +-} + +shapePhaseFreqModSample :: (RealField.C c, RealField.C b) => + Interpolation.T c (Wave.T b a) -> [Wave.T b a] -> c -> Sig.T c -> Sig.T (Phase b) -> Sig.T b -> Sig.T a +shapePhaseFreqModSample ip waves shape0 shapes phases freqs = + zipWith Wave.apply + (Interpolation.multiRelativeConstantPad ip shape0 shapes waves) + (zipWith Phase.increment phases (freqsToPhases zero freqs)) + +{- | +Time stretching and frequency modulation of a pure tone. + +We consider a tone as the result of a shape modulated oscillator, +and virtually reconstruct the waveform function +(a function of time and phase) by interpolation and resample it. +This way we can alter frequency and time progress of the tone independently. + +This function is identical to using 'shapeFreqMod' +with a wave function constructed by 'Wave.sampledTone' +but it consumes the sampled source tone lazily +and thus allows only relative shape control with non-negative control steps. + +The function is similar to 'shapeFreqModSample' but respects +that in a sampled tone, phase and shape control advance synchronously. +Actually we could re-use 'shapeFreqModSample' with modified phase values. +But we would have to cope with negative shape control jumps, +and waves would be padded locally cyclically. +The latter one is not wanted +since we want padding according to the adjacencies in the source tone. +Note that differently from 'shapeFreqModSample' +the shape control difference @1@ does not mean to skip to the next wave, +since this oscillator has no discrete waveforms. +Instead @1@ means that the shape alters as fast as in the prototype signal. + +Although the shape difference values must be non-negative +I hesitate to give them the type @Number.NonNegative.T t@ +because then you cannot call this function with other types +of non-negative numbers like 'Number.NonNegativeChunky.T'. + +The prototype tone signal is reproduced if +@freqs == repeat (1\/period)@ and @shapes == repeat 1@. +-} +shapeFreqModFromSampledTone :: (RealField.C t) => + Interpolation.T t y -> + Interpolation.T t y -> + t -> Sig.T y -> t -> t -> Sig.T t -> Sig.T t -> Sig.T y +shapeFreqModFromSampledTone + ipLeap ipStep period sampledTone + shape0 phase shapes freqs = + let periodInt = round period + in map + (uncurry (ToneMod.interpolateCell ipLeap ipStep)) + (ToneMod.oscillatorCells + (Interpolation.margin ipLeap) (Interpolation.margin ipStep) + periodInt period sampledTone + (shape0, shapes) (Phase.fromRepresentative phase, freqs)) +{- +GNUPlot.plotList [] $ take 1000 $ shapeFreqModFromSampledTone Interpolation.linear Interpolation.linear (1/0.07::Double) (staticSine (0::Double) 0.07) 0 0 (repeat 0.1) (repeat 0.01) +GNUPlot.plotList [] $ take 1000 $ shapeFreqModFromSampledTone Interpolation.linear Interpolation.linear (1/0.07::Double) (staticSine (0::Double) 0.07) 0 0 (repeat 0.1) (iterate (*(1-2e-3)) 0.01) +GNUPlot.plotList [] $ take 101 $ shapeFreqModFromSampledTone Interpolation.linear Interpolation.linear (1/0.07::Double) (iterate (1+) (0::Double)) 0 0 (repeat 1) (repeat 0.7) +-} + +shapePhaseFreqModFromSampledTone :: (RealField.C t) => + Interpolation.T t y -> + Interpolation.T t y -> + t -> Sig.T y -> t -> t -> Sig.T t -> Sig.T t -> Sig.T t -> Sig.T y +shapePhaseFreqModFromSampledTone + ipLeap ipStep period sampledTone + shape0 phase shapes phases freqs = + let periodInt = round period + marginLeap = Interpolation.margin ipLeap + marginStep = Interpolation.margin ipStep + in map + (uncurry (ToneMod.interpolateCell ipLeap ipStep) . + ToneMod.seekCell periodInt period) $ + zipWith (\p -> mapFst (mapSnd (Phase.increment p))) phases $ + ToneMod.oscillatorSuffixes + marginLeap marginStep + periodInt period sampledTone + (shape0, shapes) + (Phase.fromRepresentative phase, freqs) + + +{- * Oscillators with specific waveforms -} + +{- | sine oscillator with static frequency -} +staticSine :: (Trans.C a, RealField.C a) => a -> a -> Sig.T a +staticSine = static Wave.sine + +{- | sine oscillator with modulated frequency -} +freqModSine :: (Trans.C a, RealField.C a) => a -> Sig.T a -> Sig.T a +freqModSine = freqMod Wave.sine + +{- | sine oscillator with modulated phase, useful for FM synthesis -} +phaseModSine :: (Trans.C a, RealField.C a) => a -> Sig.T a -> Sig.T a +phaseModSine = phaseMod Wave.sine + +{- | saw tooth oscillator with modulated frequency -} +staticSaw :: RealField.C a => a -> a -> Sig.T a +staticSaw = static Wave.saw + +{- | saw tooth oscillator with modulated frequency -} +freqModSaw :: RealField.C a => a -> Sig.T a -> Sig.T a +freqModSaw = freqMod Wave.saw diff --git a/src/Synthesizer/Plain/Play.hs b/src/Synthesizer/Plain/Play.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Plain/Play.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Synthesizer.Plain.Play where + +import qualified Synthesizer.Plain.Builder as Builder +import qualified Synthesizer.Basic.Binary as BinSmp + +import qualified Sound.Sox.Frame as Frame +import qualified Sound.Sox.Frame.Stereo as Stereo +import qualified Sound.Sox.Option.Format as SoxOpt +import qualified Sound.Sox.Play as Play +import qualified Sound.Sox.Signal.List as SoxList + +import Foreign.Storable (Storable, ) +import Data.Int (Int16, ) + +import Data.Monoid (mconcat, ) + +-- import qualified Synthesizer.Frame.Stereo as Stereo + +import qualified Algebra.ToInteger as ToInteger +import qualified Algebra.RealField as RealField + +import System.Exit (ExitCode, ) + +import PreludeBase +import NumericPrelude + + +{- | +See 'Synthesizer.Plain.File.write'. +-} +render :: + (Storable int, Frame.C int, ToInteger.C int, Bounded int, + RealField.C a, BinSmp.C v) => + Builder.Put int -> a -> (a -> [v]) -> IO ExitCode +render put sampleRate renderer = + auto put sampleRate (renderer sampleRate) + +renderToInt16 :: (RealField.C a, BinSmp.C v) => a -> (a -> [v]) -> IO ExitCode +renderToInt16 sampleRate renderer = + toInt16 sampleRate (renderer sampleRate) + +renderMonoToInt16 :: (RealField.C a) => a -> (a -> [a]) -> IO ExitCode +renderMonoToInt16 sampleRate renderer = + monoToInt16 sampleRate (renderer sampleRate) + +renderStereoToInt16 :: (RealField.C a) => a -> (a -> [(a,a)]) -> IO ExitCode +renderStereoToInt16 sampleRate renderer = + stereoToInt16 sampleRate (renderer sampleRate) + + +{- | +See 'Synthesizer.Plain.File.write'. +-} +auto :: + (Storable int, Frame.C int, ToInteger.C int, Bounded int, + RealField.C a, BinSmp.C v) => + Builder.Put int -> a -> [v] -> IO ExitCode +auto put sampleRate signal = + raw + (SoxOpt.numberOfChannels (BinSmp.numberOfSignalChannels signal)) + sampleRate + (Builder.run . mconcat . map (BinSmp.outputFromCanonical put) $ + signal) + +toInt16 :: (RealField.C a, BinSmp.C v) => a -> [v] -> IO ExitCode +toInt16 = + auto (Builder.put :: Builder.Put Int16) + +monoToInt16 :: (RealField.C a) => a -> [a] -> IO ExitCode +monoToInt16 sampleRate signal = + raw SoxOpt.none sampleRate + (map BinSmp.int16FromCanonical signal) + +stereoToInt16 :: (RealField.C a) => a -> [(a,a)] -> IO ExitCode +stereoToInt16 sampleRate signal = + raw SoxOpt.none sampleRate + (map (fmap BinSmp.int16FromCanonical . uncurry Stereo.cons) signal) + + +raw :: (RealField.C a, Frame.C v, Storable v) => + SoxOpt.T -> a -> [v] -> IO ExitCode +raw opts sampleRate signal = + Play.extended SoxList.put opts SoxOpt.none (round sampleRate) signal + + +exampleMono :: IO ExitCode +exampleMono = + monoToInt16 (11025::Double) (map sin [0::Double,0.2..]) + +exampleStereo :: IO ExitCode +exampleStereo = + stereoToInt16 (11025::Double) $ + zip + (map sin [0::Double,0.199..]) + (map sin [0::Double,0.201..]) diff --git a/src/Synthesizer/Plain/Signal.hs b/src/Synthesizer/Plain/Signal.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Plain/Signal.hs @@ -0,0 +1,208 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +{- glasgow-exts are for the rules -} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : portable +-} +module Synthesizer.Plain.Signal where + +import qualified Number.Peano as Peano + +import qualified Synthesizer.Plain.Modifier as Modifier + +import qualified Data.List.Match as ListMatch +import qualified Data.List as List + +import Data.Tuple.HT (forcePair, mapFst, mapSnd, ) + + +type T a = [a] + + +{- * Generic routines that are useful for filters -} + +type Modifier s ctrl a b = Modifier.Simple s ctrl a b + +{-| +modif is a process controlled by values of type c +with an internal state of type s, +it converts an input value of type a into an output value of type b +while turning into a new state + +ToDo: +Shall finite signals be padded with zeros? +-} +modifyStatic :: + Modifier s ctrl a b -> ctrl -> T a -> T b +modifyStatic = Modifier.static + +{-| Here the control may vary over the time. -} +modifyModulated :: + Modifier s ctrl a b -> T ctrl -> T a -> T b +modifyModulated = Modifier.modulated + + +type ModifierInit s init ctrl a b = Modifier.Initialized s init ctrl a b + + +modifierInitialize :: + ModifierInit s init ctrl a b -> init -> Modifier s ctrl a b +modifierInitialize = Modifier.initialize + +modifyStaticInit :: + ModifierInit s init ctrl a b -> init -> ctrl -> T a -> T b +modifyStaticInit = Modifier.staticInit + +{-| Here the control may vary over the time. -} +modifyModulatedInit :: + ModifierInit s init ctrl a b -> init -> T ctrl -> T a -> T b +modifyModulatedInit = Modifier.modulatedInit + + + +unfoldR :: (acc -> Maybe (y, acc)) -> acc -> (acc, T y) +unfoldR f = + let recourse acc0 = + forcePair $ + maybe + (acc0,[]) + (\(y,acc1) -> + mapSnd (y:) $ recourse acc1) + (f acc0) + in recourse + +reduceL :: (x -> acc -> Maybe acc) -> acc -> T x -> acc +reduceL f = + let recourse a xt = + case xt of + [] -> a + (x:xs) -> + maybe a + (\ a' -> seq a' (recourse a' xs)) + (f x a) + in recourse + +mapAccumL :: (x -> acc -> Maybe (y, acc)) -> acc -> T x -> (acc, T y) +mapAccumL f = + let recourse acc0 xt = + forcePair $ + case xt of + [] -> (acc0,[]) + (x:xs) -> + maybe + (acc0,[]) + (\(y,acc1) -> + mapSnd (y:) $ recourse acc1 xs) + (f x acc0) + in recourse + +crochetL :: (x -> acc -> Maybe (y, acc)) -> acc -> T x -> T y +crochetL f a = snd . mapAccumL f a + + +{- | +Feed back signal into signal processor, +and apply a delay by one value. +'fix1' is a kind of 'Signal.generate'. +-} +fix1 :: y -> (T y -> T y) -> T y +fix1 pad f = + let y = f (pad:y) + in y + +{-# RULES + "fix1/crochetL" forall f a b. + fix1 a (crochetL f b) = + snd $ unfoldR (\(a0,b0) -> + do yb1@(y0,_) <- f a0 b0 + return (y0, yb1)) (a,b) ; + #-} + + + +{- +instance SigG.Data [] y where + +instance SigG.C [] where + add = (Additive.+) + map = List.map + zipWith = List.zipWith +-} + + +{- | +@dropMarginRem n m xs@ +drops at most the first @m@ elements of @xs@ +and ensures that @xs@ still contains @n@ elements. +Additionally returns the number of elements that could not be dropped +due to the margin constraint. +That is @dropMarginRem n m xs == (k,ys)@ implies @length xs - m == length ys - k@. +Requires @length xs >= n@. +-} +dropMarginRem :: Int -> Int -> T a -> (Int, T a) +dropMarginRem n m = + head . + dropMargin n m . + zipWithTails (,) (iterate pred m) + +dropMargin :: Int -> Int -> T a -> T a +dropMargin n m xs = + ListMatch.drop (take m (drop n xs)) xs + + +{- | +Test whether a list has at least @n@ elements. +-} +lengthAtLeast :: Int -> T a -> Bool +lengthAtLeast n xs = + n<=0 || not (null (drop (n-1) xs)) + + +{- | +Can be implemented more efficiently +than just by 'zipWith' and 'List.tails' +for other data structures. +-} +zipWithTails :: + (y0 -> T y1 -> y2) -> T y0 -> T y1 -> T y2 +zipWithTails f xs = + zipWith f xs . init . List.tails + +zipWithRest :: + (y0 -> y0 -> y1) -> + T y0 -> T y0 -> + (T y1, (Bool, T y0)) +zipWithRest f xs ys = + let len = min (List.genericLength xs) (List.genericLength ys) :: Peano.T + (prefixX,suffixX) = List.genericSplitAt len xs + (prefixY,suffixY) = List.genericSplitAt len ys + second = null suffixX + in (zipWith f prefixX prefixY, + (second, if second then suffixY else suffixX)) + +zipWithRest' :: + (y0 -> y0 -> y1) -> + T y0 -> T y0 -> + (T y1, (Bool, T y0)) +zipWithRest' f = + let recourse xt yt = + forcePair $ + case (xt,yt) of + (x:xs, y:ys) -> + mapFst (f x y :) (recourse xs ys) + ([], _) -> ([], (True, yt)) + (_, []) -> ([], (False, xt)) + in recourse +{- +Test.QuickCheck.test (\xs ys -> zipWithRest (,) xs ys == zipWithRest' (,) xs (ys::[Int])) +-} + +zipWithAppend :: + (y -> y -> y) -> + T y -> T y -> T y +zipWithAppend f xs ys = + uncurry (++) $ mapSnd snd $ zipWithRest f xs ys diff --git a/src/Synthesizer/Plain/ToneModulation.hs b/src/Synthesizer/Plain/ToneModulation.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Plain/ToneModulation.hs @@ -0,0 +1,413 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{- | +Copyright : (c) Henning Thielemann 2006 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + + +Avoid importing this module. +Better use functions from +"Synthesizer.Plain.Oscillator" and +"Synthesizer.Basic.Wave" + +Input data is interpreted as samples of data on a cylinder +in the following form: + +> |* | +> | * | +> | * | +> | * | +> | * | +> | * | +> | * | +> | *| +> | * | +> | * | +> | * | + + +> ----------- +> * +> * +> * +> * +> * +> * +> * +> * +> * +> * +> * +> ----------- + +We have to interpolate in the parallelograms. + +-} +module Synthesizer.Plain.ToneModulation where + +import qualified Synthesizer.Basic.ToneModulation as ToneMod +import qualified Synthesizer.Basic.Phase as Phase + +import qualified Synthesizer.Plain.Signal as Sig +import qualified Synthesizer.Plain.Interpolation as Interpolation +import Synthesizer.Interpolation (Margin, ) +-- import qualified Data.Array as Array +import Data.Array (Array, (!), listArray, ) + +-- import qualified Algebra.Transcendental as Trans +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +-- import qualified Algebra.Real as Real +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import qualified Number.NonNegative as NonNeg +import qualified Number.NonNegativeChunky as Chunky + +import Control.Monad (guard, ) + +import qualified Data.List as List +import qualified Data.List.HT as ListHT +import qualified Data.List.Match as ListMatch +import Data.Ord.HT (limit, ) +import Data.Tuple.HT (mapPair, mapSnd, forcePair, ) + +import NumericPrelude + +-- import qualified Prelude as P +import PreludeBase + + + +-- * general helpers + +type Cell y = Sig.T (Sig.T y) + +interpolateCell :: + Interpolation.T a y -> + Interpolation.T b y -> + (a, b) -> + Cell y -> y +interpolateCell ipLeap ipStep (qLeap,qStep) = + Interpolation.func ipStep qStep . + map (Interpolation.func ipLeap qLeap) + + +-- * array based shape variable wave + +data Prototype t y = + Prototype { + protoMarginLeap, + protoMarginStep :: Margin, + protoIpOffset :: Int, + protoPeriod :: t, + protoPeriodInt :: Int, + protoShapeLimits :: (t,t), + protoArray :: Array Int y + } + + +makePrototype :: (RealField.C t) => + Margin -> + Margin -> + Int -> t -> Sig.T y -> Prototype t y +makePrototype marginLeap marginStep periodInt period tone = + let ipOffset = + ToneMod.interpolationOffset marginLeap marginStep periodInt + len = length tone + (lower,upper) = + ToneMod.shapeLimits marginLeap marginStep periodInt len + limits = + if lower > upper + then error "min>max" + else + (fromIntegral lower, fromIntegral upper) + + arr = listArray (0, pred len) tone + + in Prototype { + protoMarginLeap = marginLeap, + protoMarginStep = marginStep, + protoIpOffset = ipOffset, + protoPeriod = period, + protoPeriodInt = periodInt, + protoShapeLimits = limits, + protoArray = arr + } + +sampledToneCell :: (RealField.C t) => + Prototype t y -> t -> Phase.T t -> ((t,t), Cell y) +sampledToneCell p shape phase = + let (n, q) = + ToneMod.flattenShapePhase (protoPeriodInt p) (protoPeriod p) + (limit (protoShapeLimits p) shape, phase) + in (q, + map (map (protoArray p ! ) . iterate (protoPeriodInt p +)) $ + enumFrom (n - protoIpOffset p)) + + +{- + M = ((1,1)^T, (periodRound, period-periodRound)^T) + + equation for the line + 0 = (nStep - offset ipStep) + + (nLeap - offset ipLeap) * periodInt + + <(1,periodInt), (offset ipStep, offset ipLeap)> + = <(1,periodInt), (nStep,nLeap)> + d = + = + = <(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 = } converted to (shape,phase) coordinates + has constant shape and meets all phases. +-} + + + +-- * lazy oscillator + + +oscillatorCells :: (RealField.C t) => + Margin -> + Margin -> + Int -> t -> + Sig.T y -> (t, Sig.T t) -> (Phase.T t, Sig.T t) -> Sig.T ((t,t), Cell y) +oscillatorCells + marginLeap marginStep periodInt period sampledTone shapes freqs = + map (seekCell periodInt period) $ + oscillatorSuffixes + marginLeap marginStep periodInt period sampledTone shapes freqs + +seekCell :: (RealField.C t) => + Int -> t -> + ((t, Phase.T t), Cell y) -> ((t,t), Cell y) +seekCell periodInt period = + {- n will be zero within the data. + We would need it only for extrapolation at the end. + But this does not happen, since we limit the shape control parameter accordingly. + -} + (\(coords, ptr) -> + let (k,q) = ToneMod.flattenShapePhase periodInt period coords + in if k>0 + then error "ToneModulation.oscillatorCells: k>0" + else (q, drop (periodInt+k) ptr)) + +oscillatorSuffixes :: (RealField.C t) => + Margin -> + Margin -> + Int -> t -> Sig.T y -> + (t, Sig.T t) -> (Phase.T t, Sig.T t) -> + Sig.T ((t, Phase.T t), Cell y) +oscillatorSuffixes + marginLeap marginStep periodInt period sampledTone shapes freqs = + let ptrs = + List.transpose $ + takeWhile (not . null) $ + iterate (drop periodInt) sampledTone + ipOffset = + periodInt + + ToneMod.interpolationOffset marginLeap marginStep periodInt +{- I tried to switch integrateFractional and limitRelativeShapes + in order to have a position where I can easily add phase distortion. + However, limitting skip values after integrateFractional + does not work this way, since once we start setting skip values to zero, + we had to clear the fractional parts of the shape coordinate, too. + (firstSkip:allSkips,coords) = + unzip $ + integrateFractional period shapes freqs + (skip,skips) = + limitRelativeShapes marginLeap marginStep + periodInt sampledTone (firstSkip,allSkips) +-} + (skip:skips,coords) = + unzip $ + integrateFractional period + (limitRelativeShapes marginLeap marginStep periodInt sampledTone shapes) + freqs + in zip coords $ + map (\(n,ptr) -> + if n>0 + then error $ "ToneModulation.oscillatorCells: " ++ + "limit of shape parameter is buggy" + else ptr) $ + tail $ + scanl + {- since we clip the coordinates before calling oscillatorCells + we do not need 'dropRem', since 'drop' would never go beyond the list end -} + (\ (n,ptr0) d0 -> dropRem (n+d0) ptr0) + (0,ptrs) + ((skip - ipOffset) : skips) + +dropFrac :: RealField.C i => i -> Sig.T a -> (Int, i, Sig.T a) +dropFrac = + let recourse acc n xt = + if n>=1 + then + case xt of + _:xs -> recourse (succ acc) (n-1) xs + [] -> (acc, n, []) + else (acc,n,xt) + in recourse 0 + +dropFrac' :: RealField.C i => i -> Sig.T a -> (Int, i, Sig.T a) +dropFrac' = + let recourse acc n xt = + maybe + (acc,n,xt) + (recourse (succ acc) (n-1) . snd) + (guard (n>=1) >> ListHT.viewL xt) + in recourse 0 + +propDropFrac :: (RealField.C i, Eq a) => i -> Sig.T a -> Bool +propDropFrac n xs = + dropFrac n xs == dropFrac' n xs + + + +dropRem :: Int -> Sig.T a -> (Int, Sig.T a) +dropRem = + let recourse n xt = + if n>0 + then + case xt of + _:xs -> recourse (pred n) xs + [] -> (n, []) + else (n,xt) + in recourse + +dropRem' :: Int -> Sig.T a -> (Int, Sig.T a) +dropRem' = + let recourse n xt = + maybe + (n,xt) + (recourse (pred n) . snd) + (guard (n>0) >> ListHT.viewL xt) + in recourse + +propDropRem :: (Eq a) => Int -> Sig.T a -> Bool +propDropRem n xs = + dropRem n xs == dropRem' n xs + +{- +*Synthesizer.Plain.ToneModulation> Test.QuickCheck.quickCheck (\n xs -> propDropRem n (xs::[Int])) +OK, passed 100 tests. +*Synthesizer.Plain.ToneModulation> Test.QuickCheck.quickCheck (\n xs -> propDropFrac (n::Rational) (xs::[Int])) +OK, passed 100 tests. +-} + + +oscillatorCoords :: (RealField.C t) => + Int -> t -> (t, Sig.T t) -> (Phase.T t, Sig.T t) -> Sig.T (ToneMod.Coords t) +oscillatorCoords periodInt period shapes freqs = + map (mapSnd (ToneMod.flattenShapePhase periodInt period)) $ + integrateFractional period shapes freqs +{- +mapM print $ take 30 $ let period = 1/0.07::Double in oscillatorCoords (round period) period 0 0 (repeat 0.1) (repeat 0.01) + +*Synthesizer.Plain.Oscillator> mapM print $ take 30 $ let period = 1/0.07::Rational in oscillatorCoords (round period) period 0 0 (repeat 1) (repeat 0.07) + +*Synthesizer.Plain.Oscillator> mapM print $ take 30 $ let period = 1/0.07::Rational in oscillatorCoords (round period) period 0 0 (repeat 0.25) (repeat 0.0175) +-} + + +integrateFractional :: (RealField.C t) => + t -> (t, Sig.T t) -> (Phase.T t, Sig.T t) -> Sig.T (ToneMod.Skip t) +integrateFractional period (shape0, shapes) (phase, freqs) = + let shapeOffsets = + scanl + (\(_,s) c -> splitFraction (s+c)) + (splitFraction shape0) shapes + phases = + let (s:ss) = map (\(n,_) -> fromIntegral n / period) shapeOffsets + in freqsToPhases + (Phase.decrement s phase) -- phase - s + (zipWith (-) freqs ss) + in zipWith + (\(d,s) p -> (d, (s,p))) + shapeOffsets + phases + + +-- this function fits better in the Oscillator module +{- | +Convert a list of phase steps into a list of momentum phases +phase is a number in the interval [0,1) +freq contains the phase steps +-} +freqsToPhases :: RealField.C a => Phase.T a -> Sig.T a -> Sig.T (Phase.T a) +freqsToPhases phase freq = scanl (flip Phase.increment) phase freq + + + +limitRelativeShapes :: (Ring.C t, Ord t) => + Margin -> + Margin -> + Int -> Sig.T y -> (t, Sig.T t) -> (t, Sig.T t) +limitRelativeShapes marginLeap marginStep periodInt sampledTone = + let -- len = List.genericLength sampledTone + len = Chunky.fromChunks (ListMatch.replicate sampledTone one) + (minShape, maxShape) = + ToneMod.shapeLimits marginLeap marginStep periodInt len + fromChunky = NonNeg.toNumber . Chunky.toNumber + toChunky = Chunky.fromNumber . NonNeg.fromNumber + in mapPair (fromChunky, map fromChunky) . + uncurry (limitMaxRelativeValuesNonNeg maxShape) . + mapPair (toChunky, map toChunky) . + uncurry (limitMinRelativeValues (fromChunky minShape)) +{- +*Synthesizer.Plain.Oscillator> let ip = Interpolation.linear in limitRelativeShapes ip ip 13 (take 100 $ iterate (1+) (0::Double)) (0::Double, cycle [0.5,1.5]) +(13.0,[0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,1.0,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5*** Exception: Numeric.NonNegative.Chunky.-: negative number +-} + + +limitMinRelativeValues :: (Additive.C a, Ord a) => + a -> a -> Sig.T a -> (a, Sig.T a) +limitMinRelativeValues xMin x0 xs = + let (ys,zs) = + span (( (x0,xs) + (_:yr) -> (xMin, ListMatch.replicate yr zero ++ + case zs of + [] -> [] + (z:zr) -> fst z : map snd zr) + +limitMaxRelativeValues :: (Additive.C a, Ord a) => + a -> a -> Sig.T a -> (a, Sig.T a) +limitMaxRelativeValues xMax x0 xs = + let (ys,zs) = + span (>zero) (scanl (-) (xMax-x0) xs) + in forcePair $ + ListHT.switchR + (xMax, ListMatch.replicate xs zero) + (\ yl yr -> (x0, ListMatch.take yl xs ++ ListMatch.take zs (yr : repeat zero))) + ys + +{- | +Avoids negative numbers and thus can be used with Chunky numbers. +-} +limitMaxRelativeValuesNonNeg :: (Additive.C a, Ord a) => + a -> a -> Sig.T a -> (a, Sig.T a) +limitMaxRelativeValuesNonNeg xMax x0 xs = + let (ys,zs) = + span fst (scanl (\(_,acc) d -> safeSub acc d) (safeSub xMax x0) xs) + in forcePair $ + ListHT.switchR + (xMax, ListMatch.replicate xs zero) + (\ yl ~(_,yr) -> (x0, ListMatch.take yl xs ++ ListMatch.take zs (yr : repeat zero))) + ys +{- +*Synthesizer.Plain.Oscillator> limitMaxRelativeValuesNonNeg (let inf = 1+inf in inf) (0::Chunky.T NonNeg.Rational) (repeat 2.5) +-} + +safeSub :: (Additive.C a, Ord a) => a -> a -> (Bool, a) +safeSub a b = (a>=b, a-b) diff --git a/src/Synthesizer/Plain/Tutorial.hs b/src/Synthesizer/Plain/Tutorial.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Plain/Tutorial.hs @@ -0,0 +1,208 @@ +{- | +This module gives some introductory examples to signal processing +with plain Haskell lists. +For more complex examples +see "Synthesizer.Plain.Instrument" +and "Synthesizer.Plain.Effect". +The examples require a basic understanding of audio signal processing. + +In the Haddock documentation you will only see the API. +In order to view the example code, +please use the \"Source code\" links beside the function documentation. +This requires however, +that the Haddock was executed with @hyperlink-source@ option. + +Using plain lists is not very fast, +particularly not fast enough for serious real-time applications. +It is however the most flexible data structure, +which you can also use without knowledge of low level programming. +For real-time applications see "Synthesizer.Generic.Tutorial". +-} +module Synthesizer.Plain.Tutorial +{-# DEPRECATED "do not import that module, it is only intended for demonstration" #-} + where + +import qualified Synthesizer.Plain.Play as Play +import qualified Synthesizer.Plain.File as File +import qualified Synthesizer.Plain.Signal as Sig +import qualified Synthesizer.Plain.Control as Ctrl +import qualified Synthesizer.Plain.Oscillator as Osci +import qualified Synthesizer.Plain.Filter.NonRecursive as Filt +import qualified Synthesizer.Plain.Filter.Recursive as FiltRec +import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilter +import qualified Synthesizer.Basic.Wave as Wave + +import qualified Algebra.Module as Module -- needed for Haddock + +import System.Exit (ExitCode, ) +import NumericPrelude +import PreludeBase +import Prelude () + + +{- | +Play a simple sine tone at 44100 sample rate and 16 bit. +These are the parameters used for compact disks. +The period of the tone is @2*pi*10@. +Playing at sample rate 44100 Hz results in a tone of @44100 / (20*pi) Hz@, +that is about @702 Hz@. +This is simple enough to be performed in real-time, +at least on my machine. +For playback we use @SoX@. +-} +sine :: IO ExitCode +sine = + Play.monoToInt16 (44100::Double) (map sin [0::Double,0.1..]) + +{- | +Now the same for a stereo signal. +Both stereo channels are slightly detuned +in order to achieve a stereophonic phasing effect. +In principle there is no limit of the number of channels, +but with more channels playback becomes difficult. +Many signal processes in our package +support any tuple and even nested tuples +using the notion of an algebraic @module@ (see 'Module.C'). +A module is a vector space where the scalar numbers +do not need to support division. +A vector space is often also called a linear space, +because all we require of vectors is that they can be added and scaled +and these two operations fulfill some natural laws. +-} +sineStereo :: IO ExitCode +sineStereo = + Play.stereoToInt16 (44100::Double) $ zip (map sin [0::Double,0.0998..]) (map sin [0::Double,0.1002..]) + +{- | +Of course we can also write a tone to disk using @sox@. +-} +writeSine :: IO ExitCode +writeSine = + File.writeToInt16 "sine.aiff" (44100::Double) (take 50000 $ map sin [0::Double,0.1..]) + + +{- | +For the following examples we will stick to monophonic sounds played at 44100 Hz. +Thus we define a function for convenience. +-} +play :: Sig.T Double -> IO ExitCode +play = Play.monoToInt16 (44100::Double) + +{- | +Now, let's repeat the 'sine' example in a higher level style. +We use the oscillator 'Osci.static' that does not allow any modulation. +We can however use any waveform. +The waveform is essentially a function +which maps from the phase to the displacement. +Functional programming proves to be very useful here, +since anonymous functions as waveforms are optimally supported by the language. +We can also expect, that in compiled form +the oscillator does not have to call back the waveform function +by an expensive explicit function call, +but that the compiler will inline both oscillator and waveform +such that the oscillator is turned into a simple loop +which handles both oscillation and waveform computation. + +Using the oscillator with 'Wave.sine' also has the advantage +that we do not have to cope with 'pi's any longer. +The frequency is given as ratio of the sample rate. +That is, @0.01@ at @44100 Hz@ sample rate means @441 Hz@. +This way all frequencies are given in the low-level signal processing. + +It is not optimal to handle frequencies this way, +since all frequency values are bound to the sample rate. +For overcoming this problem, see the high level routines using physical dimensions. +For examples see "Synthesizer.Dimensional.RateAmplitude.Demonstration". +-} +oscillator :: IO ExitCode +oscillator = + play (Osci.static Wave.sine 0 (0.01::Double)) + +{- | +It is very simple to switch to another waveform like a saw tooth wave. +Instead of a sharp saw tooth, +we use an extreme asymmetric triangle. +This is a poor man's band-limiting approach +that shall reduce aliasing at high oscillation frequencies. +We should really work on band-limited oscillators, +but this is hard in the general case. +-} +saw :: IO ExitCode +saw = + play (Osci.static (Wave.triangleAsymmetric 0.9) 0 (0.01::Double)) + +{- | +When we apply a third power to each value of the saw tooths +we get an oscillator with cubic polynomial functions as waveform. +The distortion function applied to a saw wave can be used +to turn every function on the interval [-1,1] into a waveform. +-} +cubic :: IO ExitCode +cubic = + play (Osci.static (Wave.distort (^3) Wave.saw) 0 (0.01::Double)) + +{- | +Now let's start with modulated tones. +The first simple example is changing the degree of asymmetry +according to a slow oscillator (LFO = low frequency oscillator). +-} +sawMorph :: IO ExitCode +sawMorph = + play (Osci.shapeMod Wave.triangleAsymmetric 0 (0.01::Double) (Osci.static Wave.sine 0 (0.00001::Double))) + +{- | +It's also very common to modulate the frequency of a tone. +-} +laser :: IO ExitCode +laser = + play (Osci.freqMod Wave.saw 0 $ map (\f -> 0.02+0.01*f) $ Osci.static Wave.saw 0 (0.0001::Double)) + +pingSig :: Sig.T Double +pingSig = + Filt.envelope (Ctrl.exponential 50000 1) (Osci.static Wave.sine 0 (0.01::Double)) + +{- | +A simple sine wave with exponentially decaying amplitude. +-} +ping :: IO ExitCode +ping = + play pingSig + +{- | +The 'ping' sound can also be used +to modulate the phase another oscillator. +This is a well-known effect used excessively in FM synthesis, +that was introduced by the Yamaha DX-7 synthesizer. +-} +fmPing :: IO ExitCode +fmPing = + play (Osci.phaseMod Wave.sine (0.01::Double) $ map (2*) pingSig) + +{- | +One of the most impressive sounds effects is certainly frequency filtering, +especially when the filter parameters are modulated. +In this example we use a resonant lowpass +whose resonance frequency is controlled by a slow sine wave. +The frequency filters usually use internal filter parameters +that are not very intuitive to use directly. +Thus we apply a function (here 'UniFilter.parameter') +in order to turn the intuitive parameters \"resonance frequency\" and \"resonance\" +(resonance frequency amplification while frequency zero is left unchanged) +into internal filter parameters. +We have not merged these two steps +since the computation of internal filter parameters +is more expensive then the filtering itself +and you may want to reduce the computation +by computing the internal filter parameters at a low sample rate +and interpolate them. +However, in the list implementation +this will not save you much time, if at all, +since the list operations are too expensive. + +Now this is the example where my machine is no longer able to produce +a constant audio stream in real-time. +For tackling this problem, please continue with "Synthesizer.Generic.Tutorial". +-} +filterSaw :: IO ExitCode +filterSaw = + play (map UniFilter.lowpass $ UniFilter.run (map (\f -> UniFilter.parameter $ FiltRec.Pole 10 (0.04+0.02*f)) $ Osci.static Wave.sine 0 (0.00001::Double)) $ Osci.static Wave.saw 0 (0.002::Double)) diff --git a/src/Synthesizer/Plain/Wave.hs b/src/Synthesizer/Plain/Wave.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Plain/Wave.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +module Synthesizer.Plain.Wave where + +import qualified Synthesizer.Basic.Wave as Wave + +import qualified Synthesizer.Plain.ToneModulation as ToneMod +import qualified Synthesizer.Plain.Interpolation as Interpolation +import qualified Synthesizer.Plain.Signal as Sig +import Data.Array ((!), listArray) + +-- import qualified Synthesizer.Basic.Phase as Phase + +import qualified Algebra.RealField as RealField +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import NumericPrelude + +-- import qualified Prelude as P +import PreludeBase + + +sample :: (RealField.C a) => + Interpolation.T a v -> Sig.T v -> Wave.T a v +sample ip wave = + let len = length wave + arr = listArray (0, pred len) wave + in Wave.fromFunction $ \ phase -> + let (n,q) = splitFraction (phase * fromIntegral len) + xs = map (arr!) (map (flip mod len) + (enumFrom (n - Interpolation.offset ip))) +-- map (arr!) (enumFromTo (n - Interpolation.offset ip)) ++ cycle wave + in Interpolation.func ip q xs + +{- | +We assume that a tone was generated by a shape modulated oscillator. +We try to reconstruct the wave function +(with parameters shape control and phase) +from a tone by interpolation. + +The unit for the shape control parameter is the sampling period. +That is the shape parameter is a time parameter +pointing to a momentary shape of the prototype signal. +Of course this momentary shape does not exist +and we can only guess it using interpolation. + +At the boundaries we repeat the outermost shapes +that can be reconstructed entirely from interpolated data +(that is, no extrapolation is needed). +This way we cannot reproduce the shape at the boundaries +because we have no data for cyclically extending it. +On the other hand this method guarantees a nice wave shape +with the required fractional period. + +It must be + @length tone >= + Interpolation.number ipStep + + Interpolation.number ipLeap * ceiling period@. +-} +sampledTone :: (RealField.C a) => + Interpolation.T a v -> + Interpolation.T a v -> + a -> Sig.T v -> a -> Wave.T a v +sampledTone ipLeap ipStep period tone shape = Wave.Cons $ \phase -> + uncurry (ToneMod.interpolateCell ipLeap ipStep) $ + ToneMod.sampledToneCell + (ToneMod.makePrototype + (Interpolation.margin ipLeap) (Interpolation.margin ipStep) + (round period) period tone) + shape phase +{- +*Synthesizer.Basic.Wave> +GNUPlot.plotFunc [] (GNUPlot.linearScale 1000 (0,12)) (\t -> sampledTone Interpolation.linear Interpolation.linear (6::Double) ([-5,-3,-1,1,3,5,-4,-4,-4,4,4,4]++replicate 20 0) t (t/6)) + +*Synthesizer.Plain.Oscillator> +let period = 6.3::Double in GNUPlot.plotFunc [] (GNUPlot.linearScale 1000 (-10,20)) (\t -> Wave.sampledTone Interpolation.linear Interpolation.cubic period (take 20 $ staticSine 0 (1/period)) t (t/period)) +-} + diff --git a/src/Synthesizer/RandomKnuth.hs b/src/Synthesizer/RandomKnuth.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/RandomKnuth.hs @@ -0,0 +1,52 @@ +{- | +Very simple random number generator +which should be fast and should suffice for generating just noise. + +-} +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) +-} diff --git a/src/Synthesizer/State/Analysis.hs b/src/Synthesizer/State/Analysis.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/State/Analysis.hs @@ -0,0 +1,375 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +module Synthesizer.State.Analysis where + +import qualified Synthesizer.State.Control as Ctrl +import qualified Synthesizer.State.Signal as Sig + +-- import qualified Algebra.Module as Module +-- import qualified Algebra.Transcendental as Trans +import qualified Algebra.Algebraic as Algebraic +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Real as Real +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import qualified Algebra.NormedSpace.Maximum as NormedMax +import qualified Algebra.NormedSpace.Euclidean as NormedEuc +import qualified Algebra.NormedSpace.Sum as NormedSum + +import qualified Data.Array as Array + +import qualified Data.IntMap as IntMap + +-- import Algebra.Module((*>)) + +import Data.Array (accumArray) +-- import Data.List (foldl', ) + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +{- * Notions of volume -} + +{- | +Volume based on Manhattan norm. +-} +{-# INLINE volumeMaximum #-} +volumeMaximum :: (Real.C y) => Sig.T y -> y +volumeMaximum = + Sig.foldL max zero . rectify +-- maximum . rectify + +{- | +Volume based on Energy norm. +-} +{-# INLINE volumeEuclidean #-} +volumeEuclidean :: (Algebraic.C y) => Sig.T y -> y +volumeEuclidean = + Algebraic.sqrt . volumeEuclideanSqr + +{-# INLINE volumeEuclideanSqr #-} +volumeEuclideanSqr :: (Field.C y) => Sig.T y -> y +volumeEuclideanSqr = + average . Sig.map sqr + +{- | +Volume based on Sum norm. +-} +{-# INLINE volumeSum #-} +volumeSum :: (Field.C y, Real.C y) => Sig.T y -> y +volumeSum = average . rectify + + + +{- | +Volume based on Manhattan norm. +-} +{-# INLINE volumeVectorMaximum #-} +volumeVectorMaximum :: (NormedMax.C y yv, Ord y) => Sig.T yv -> y +volumeVectorMaximum = + Sig.foldL max zero . Sig.map NormedMax.norm +-- NormedMax.norm +-- maximum . Sig.map NormedMax.norm + +{- | +Volume based on Energy norm. +-} +{-# INLINE volumeVectorEuclidean #-} +volumeVectorEuclidean :: (Algebraic.C y, NormedEuc.C y yv) => Sig.T yv -> y +volumeVectorEuclidean = + Algebraic.sqrt . volumeVectorEuclideanSqr + +{-# INLINE volumeVectorEuclideanSqr #-} +volumeVectorEuclideanSqr :: (Field.C y, NormedEuc.Sqr y yv) => Sig.T yv -> y +volumeVectorEuclideanSqr = + average . Sig.map NormedEuc.normSqr + +{- | +Volume based on Sum norm. +-} +{-# INLINE volumeVectorSum #-} +volumeVectorSum :: (NormedSum.C y yv, Field.C y) => Sig.T yv -> y +volumeVectorSum = + average . Sig.map NormedSum.norm + + + + +{- | +Compute minimum and maximum value of the stream the efficient way. +Input list must be non-empty and finite. +-} +{-# INLINE bounds #-} +bounds :: (Ord y) => Sig.T y -> (y,y) +bounds = + Sig.switchL + (error "Analysis.bounds: List must contain at least one element.") + (\x xs -> + Sig.foldL (\(minX,maxX) y -> (min y minX, max y maxX)) (x,x) xs) + + + +{- * Miscellaneous -} + +{- +histogram: + length x = sum (histogramDiscrete x) + + units: + 1) histogram (amplify k x) = timestretch k (amplify (1/k) (histogram x)) + 2) histogram (timestretch k x) = amplify k (histogram x) + timestretch: k -> (s -> V) -> (k*s -> V) + amplify: k -> (s -> V) -> (s -> k*V) + histogram: (a -> b) -> (a^ia*b^ib -> a^ja*b^jb) + x: (s -> V) + 1) => (s^ia*(k*V)^ib -> s^ja*(k*V)^jb) + = (s^ia*V^ib*k -> s^ja*V^jb/k) + => ib=1, jb=-1 + 2) => ((k*s)^ia*V^ib -> (k*s)^ja*V^jb) + = (s^ia*V^ib -> s^ja*V^jb*k) + => ia=0, ja=1 + histogram: (s -> V) -> (V -> s/V) +histogram': + integral (histogram' x) = integral x + histogram' (amplify k x) = timestretch k (histogram' x) + histogram' (timestretch k x) = amplify k (histogram' x) + -> this does only apply if we slice the area horizontally + and sum the slice up at each level, + we must also restrict to the positive values, + this is not quite the usual histogram +-} + +{- | +Input list must be finite. +List is scanned twice, but counting may be faster. +-} +{-# INLINE histogramDiscreteArray #-} +histogramDiscreteArray :: Sig.T Int -> (Int, Sig.T Int) +histogramDiscreteArray = + withAtLeast1 "histogramDiscreteArray" $ \ x -> + let hist = + accumArray (+) zero + (bounds x) (attachOne x) + in (fst (Array.bounds hist), Sig.fromList (Array.elems hist)) + + +{- | +Input list must be finite. +If the input signal is empty, the offset is @undefined@. +List is scanned twice, but counting may be faster. +The sum of all histogram values is one less than the length of the signal. +-} +{-# INLINE histogramLinearArray #-} +histogramLinearArray :: RealField.C y => Sig.T y -> (Int, Sig.T y) +histogramLinearArray = + withAtLeast2 "histogramLinearArray" $ \ x -> + let (xMin,xMax) = bounds x + hist = + accumArray (+) zero + (floor xMin, floor xMax) + (meanValues x) + in (fst (Array.bounds hist), Sig.fromList (Array.elems hist)) + +{- | +Input list must be finite. +If the input signal is empty, the offset is @undefined@. +List is scanned once, counting may be slower. +-} +{-# INLINE histogramDiscreteIntMap #-} +histogramDiscreteIntMap :: Sig.T Int -> (Int, Sig.T Int) +histogramDiscreteIntMap = + withAtLeast1 "histogramDiscreteIntMap" $ \ x -> + let hist = IntMap.fromListWith (+) (attachOne x) + in case IntMap.toAscList hist of + [] -> error "histogramDiscreteIntMap: the list was non-empty before processing ..." + fAll@((fIndex,fHead):fs) -> (fIndex, + Sig.fromList $ + fHead : + concat (zipWith + (\(i0,_) (i1,f1) -> replicate (i1-i0-1) zero ++ [f1]) + fAll fs)) + +{-# INLINE histogramLinearIntMap #-} +histogramLinearIntMap :: RealField.C y => Sig.T y -> (Int, Sig.T y) +histogramLinearIntMap = + withAtLeast2 "histogramLinearIntMap" $ \ x -> + let hist = IntMap.fromListWith (+) (meanValues x) + -- we can rely on the fact that the keys are contiguous + (startKey:_, elems) = unzip (IntMap.toAscList hist) + in (startKey, Sig.fromList elems) + -- This doesn't work, due to a bug in IntMap of GHC-6.4.1 + -- in (head (IntMap.keys hist), IntMap.elems hist) + +{-# INLINE withAtLeast1 #-} +withAtLeast1 :: + String -> + (Sig.T y -> (Int, Sig.T y)) -> + Sig.T y -> + (Int, Sig.T y) +withAtLeast1 name f x = + maybe + (error (name ++ ": no bounds found"), Sig.empty) + (const (f x)) $ + Sig.viewL x + +{-# INLINE withAtLeast2 #-} +withAtLeast2 :: (RealField.C y) => + String -> + (Sig.T y -> (Int, Sig.T y)) -> + Sig.T y -> + (Int, Sig.T y) +withAtLeast2 name f x = + maybe + (error (name ++ ": no bounds found"), Sig.empty) + (\(y,ys) -> + if Sig.null ys + then (floor y, Sig.empty) + else f x) $ + Sig.viewL x + +{- +The bug in IntMap GHC-6.4.1 is: + +*Synthesizer.Plain.Analysis> IntMap.keys $ IntMap.fromList $ [(0,0),(-1,-1::Int)] +[0,-1] +*Synthesizer.Plain.Analysis> IntMap.elems $ IntMap.fromList $ [(0,0),(-1,-1::Int)] +[0,-1] +*Synthesizer.Plain.Analysis> IntMap.assocs $ IntMap.fromList $ [(0,0),(-1,-1::Int)] +[(0,0),(-1,-1)] + +The bug has gone in IntMap as shipped with GHC-6.6. +-} + +{-# INLINE histogramIntMap #-} +histogramIntMap :: (RealField.C y) => y -> Sig.T y -> (Int, Sig.T Int) +histogramIntMap binsPerUnit = + histogramDiscreteIntMap . quantize binsPerUnit + +{-# INLINE quantize #-} +quantize :: (RealField.C y) => y -> Sig.T y -> Sig.T Int +quantize binsPerUnit = Sig.map (floor . (binsPerUnit*)) + +{-# INLINE attachOne #-} +attachOne :: Sig.T i -> [(i,Int)] +attachOne = Sig.toList . Sig.map (\i -> (i,one)) + +{-# INLINE meanValues #-} +meanValues :: RealField.C y => Sig.T y -> [(Int,y)] +meanValues x = concatMap spread (Sig.toList (Sig.zapWith (,) x)) + +{-# INLINE spread #-} +spread :: RealField.C y => (y,y) -> [(Int,y)] +spread (l0,r0) = + let (l,r) = if l0<=r0 then (l0,r0) else (r0,l0) + (li,lf) = splitFraction l + (ri,rf) = splitFraction r + k = recip (r-l) + nodes = + (li,k*(1-lf)) : + zip [li+1 ..] (replicate (ri-li-1) k) ++ + (ri, k*rf) : + [] + in if li==ri + then [(li,one)] + else nodes + +{- | +Requires finite length. +This is identical to the arithmetic mean. +-} +{-# INLINE directCurrentOffset #-} +directCurrentOffset :: Field.C y => Sig.T y -> y +directCurrentOffset = average + + +{-# INLINE scalarProduct #-} +scalarProduct :: Ring.C y => Sig.T y -> Sig.T y -> y +scalarProduct xs ys = + Sig.sum (Sig.zipWith (*) xs ys) + +{- | +'directCurrentOffset' must be non-zero. +-} +{-# INLINE centroid #-} +centroid :: Field.C y => Sig.T y -> y +centroid = + uncurry (/) . + Sig.sum . + Sig.zipWith + (\k x -> (k*x, x)) + (Sig.iterate (one+) zero) + +centroidRecompute :: Field.C y => Sig.T y -> y +centroidRecompute xs = + firstMoment xs / Sig.sum xs + +{-# INLINE firstMoment #-} +firstMoment :: Field.C y => Sig.T y -> y +firstMoment xs = + scalarProduct (Sig.iterate (one+) zero) xs + + +{-# INLINE average #-} +average :: Field.C y => Sig.T y -> y +average = + uncurry (/) . + Sig.sum . + Sig.map (flip (,) one) + +averageRecompute :: Field.C y => Sig.T y -> y +averageRecompute x = + Sig.sum x / fromIntegral (Sig.length x) + +{-# INLINE rectify #-} +rectify :: Real.C y => Sig.T y -> Sig.T y +rectify = Sig.map abs + +{- | +Detects zeros (sign changes) in a signal. +This can be used as a simple measure of the portion +of high frequencies or noise in the signal. +It ca be used as voiced\/unvoiced detector in a vocoder. + +@zeros x !! n@ is @True@ if and only if +@(x !! n >= 0) \/= (x !! (n+1) >= 0)@. +The result will be one value shorter than the input. +-} +{-# INLINE zeros #-} +zeros :: (Ord y, Additive.C y) => Sig.T y -> Sig.T Bool +zeros = + Sig.zapWith (/=) . Sig.map (>=zero) + + + +{- | +Detect thresholds with a hysteresis. +-} +{-# INLINE flipFlopHysteresis #-} +flipFlopHysteresis :: (Ord y) => + (y,y) -> Bool -> Sig.T y -> Sig.T Bool +flipFlopHysteresis (lower,upper) = + Sig.scanL + (\state x -> + if state + then not(xupper) + +{- | +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 diff --git a/src/Synthesizer/State/Control.hs b/src/Synthesizer/State/Control.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/State/Control.hs @@ -0,0 +1,266 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes +-} +module Synthesizer.State.Control where + +import qualified Synthesizer.Plain.Control as Ctrl +import qualified Synthesizer.Piecewise as Piecewise +import Synthesizer.State.Displacement (raise) + +import qualified Synthesizer.State.Signal as Sig + +import qualified Algebra.Module as Module +import qualified Algebra.Transcendental as Trans +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Algebra.Module((*>)) + +-- import Number.Complex (cis,real) +-- import qualified Number.Complex as Complex + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +{- * Control curve generation -} + +{-# INLINE constant #-} +constant :: a -> Sig.T a +constant = Sig.repeat + +{-# INLINE linear #-} +linear :: Additive.C a => + a {-^ steepness -} + -> a {-^ initial value -} + -> Sig.T a + {-^ linear progression -} +linear d y0 = Sig.iterate (d+) y0 + +{- | +As stable as the addition of time values. +-} +{-# INLINE linearMultiscale #-} +linearMultiscale :: Additive.C y => + y + -> y + -> Sig.T y +linearMultiscale = curveMultiscale (+) + +{- | +Linear curve starting at zero. +-} +{-# INLINE linearMultiscaleNeutral #-} +linearMultiscaleNeutral :: Additive.C y => + y + -> Sig.T y +linearMultiscaleNeutral slope = + curveMultiscaleNeutral (+) slope zero + +{- | +Linear curve of a fixed length. +The final value is not actually reached, +instead we stop one step before. +This way we can concatenate several lines +without duplicate adjacent values. +-} +{-# INLINE line #-} +line :: Field.C y => + Int {-^ length -} + -> (y,y) {-^ initial and final value -} + -> Sig.T y {-^ linear progression -} +line n (y0,y1) = + Sig.take n $ linear ((y1-y0) / fromIntegral n) y0 + + +{-# INLINE exponential #-} +{-# INLINE exponentialMultiscale #-} +exponential, exponentialMultiscale :: Trans.C a => + a {-^ time where the function reaches 1\/e of the initial value -} + -> a {-^ initial value -} + -> Sig.T a + {-^ exponential decay -} +exponential time = + Sig.iterate (exp (- recip time) *) + +exponentialMultiscale time = curveMultiscale (*) (exp (- recip time)) + +{-# INLINE exponentialMultiscaleNeutral #-} +exponentialMultiscaleNeutral :: Trans.C y => + y {-^ time where the function reaches 1\/e of the initial value -} + -> Sig.T y {-^ exponential decay -} +exponentialMultiscaleNeutral time = + curveMultiscaleNeutral (*) (exp (- recip time)) one + + +{-# INLINE exponential2 #-} +{-# INLINE exponential2Multiscale #-} +exponential2, exponential2Multiscale :: Trans.C a => + a {-^ half life -} + -> a {-^ initial value -} + -> Sig.T a + {-^ exponential decay -} +exponential2 halfLife = + Sig.iterate (((Ring.one+Ring.one) ** (- recip halfLife)) *) +-- Sig.iterate (((Ring.one/(Ring.one+Ring.one)) ** recip halfLife) *) + +exponential2Multiscale halfLife = curveMultiscale (*) (0.5 ** recip halfLife) + +{- the 0.5 constant seems to block fusion + Sig.iterate ((0.5 ** recip halfLife) *) +-} +{- dito fromInteger + Sig.iterate ((fromInteger 2 ** (- recip halfLife)) *) +-} + +{-# INLINE exponential2MultiscaleNeutral #-} +exponential2MultiscaleNeutral :: Trans.C y => + y {-^ half life -} + -> Sig.T y {-^ exponential decay -} +exponential2MultiscaleNeutral halfLife = + curveMultiscaleNeutral (*) (0.5 ** recip halfLife) one + + +{-# INLINE exponentialFromTo #-} +{-# INLINE exponentialFromToMultiscale #-} +exponentialFromTo, exponentialFromToMultiscale :: Trans.C y => + y {-^ time where the function reaches 1\/e of the initial value -} + -> y {-^ initial value -} + -> y {-^ value after given time -} + -> Sig.T y {-^ exponential decay -} +exponentialFromTo time y0 y1 = + Sig.iterate (* (y1/y0) ** recip time) y0 +exponentialFromToMultiscale time y0 y1 = + curveMultiscale (*) ((y1/y0) ** recip time) y0 + + + + +{-| This is an extension of 'exponential' to vectors + which is straight-forward but requires more explicit signatures. + But since it is needed rarely I setup a separate function. -} +{-# INLINE vectorExponential #-} +vectorExponential :: (Trans.C a, Module.C a v) => + a {-^ time where the function reaches 1\/e of the initial value -} + -> v {-^ initial value -} + -> Sig.T v + {-^ exponential decay -} +vectorExponential time y0 = + Sig.iterate (exp (-1/time) *>) y0 + +{-# INLINE vectorExponential2 #-} +vectorExponential2 :: (Trans.C a, Module.C a v) => + a {-^ half life -} + -> v {-^ initial value -} + -> Sig.T v + {-^ exponential decay -} +vectorExponential2 halfLife y0 = + Sig.iterate (0.5**(1/halfLife) *>) y0 + + + +{-# INLINE cosine #-} +cosine :: Trans.C a => + a {-^ time t0 where 1 is approached -} + -> a {-^ time t1 where -1 is approached -} + -> Sig.T a + {-^ a cosine wave where one half wave is between t0 and t1 -} +cosine = Ctrl.cosineWithSlope $ + \d x -> Sig.map cos (linear d x) + + + +{-# INLINE cubicHermite #-} +cubicHermite :: Field.C a => (a, (a,a)) -> (a, (a,a)) -> Sig.T a +cubicHermite node0 node1 = + Sig.map (Ctrl.cubicFunc node0 node1) (linear 1 0) + + + +-- * piecewise curves + + +splitDurations :: (RealField.C t) => + [t] -> [(Int, t)] +splitDurations ts0 = + let (ds,ts) = + unzip $ scanl + (\(_,fr) d -> splitFraction (fr+d)) + (0,1) ts0 + in zip (tail ds) (map (subtract 1) ts) + +{-# INLINE piecewise #-} +piecewise :: (RealField.C a) => + Piecewise.T a a (a -> Sig.T a) -> Sig.T a +piecewise xs = + Sig.concat $ zipWith + (\(n, t) (Piecewise.PieceData c yi0 yi1 d) -> + Sig.take n $ Piecewise.computePiece c yi0 yi1 d t) + (splitDurations $ map Piecewise.pieceDur xs) + xs + + +type Piece a = + Piecewise.Piece a a + (a {- fractional start time -} -> Sig.T a) + + +{-# INLINE stepPiece #-} +stepPiece :: Piece a +stepPiece = + Piecewise.pieceFromFunction $ \ y0 _y1 _d _t0 -> + constant y0 + +{-# INLINE linearPiece #-} +linearPiece :: (Field.C a) => Piece a +linearPiece = + Piecewise.pieceFromFunction $ \ y0 y1 d t0 -> + let s = (y1-y0)/d in linear s (y0-t0*s) + +{-# INLINE exponentialPiece #-} +exponentialPiece :: (Trans.C a) => a -> Piece a +exponentialPiece saturation = + Piecewise.pieceFromFunction $ \ y0 y1 d t0 -> + let y0' = y0-saturation + y1' = y1-saturation + yd = y0'/y1' + in raise saturation + (exponential (d / log yd) (y0' * yd**(t0/d))) + +{-# INLINE cosinePiece #-} +cosinePiece :: (Trans.C a) => Piece a +cosinePiece = + Piecewise.pieceFromFunction $ \ y0 y1 d t0 -> + Sig.map + (\y -> (1+y)*(y0/2)+(1-y)*(y1/2)) + (cosine t0 (t0+d)) + +{-# INLINE cubicPiece #-} +cubicPiece :: (Field.C a) => a -> a -> Piece a +cubicPiece yd0 yd1 = + Piecewise.pieceFromFunction $ \ y0 y1 d t0 -> + cubicHermite (t0,(y0,yd0)) (t0+d,(y1,yd1)) + + +-- * auxiliary functions + +{-# INLINE curveMultiscale #-} +curveMultiscale :: (y -> y -> y) -> y -> y -> Sig.T y +curveMultiscale op d y0 = + Sig.cons y0 (Sig.map (op y0) (Sig.iterateAssociative op d)) + +{-# INLINE curveMultiscaleNeutral #-} +curveMultiscaleNeutral :: (y -> y -> y) -> y -> y -> Sig.T y +curveMultiscaleNeutral op d neutral = + Sig.cons neutral (Sig.iterateAssociative op d) diff --git a/src/Synthesizer/State/Cut.hs b/src/Synthesizer/State/Cut.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/State/Cut.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{- | +Copyright : (c) Henning Thielemann 2006 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes +-} +module Synthesizer.State.Cut ( + {- * dissection -} + takeUntilPause, + takeUntilInterval, + + {- * glueing -} + selectBool, + select, + arrange, + arrangeList, + ) where + +import qualified Synthesizer.State.Signal as Sig + +import qualified Data.EventList.Relative.TimeBody as EventList + +import qualified MathObj.LaurentPolynomial as Laurent +import qualified Algebra.Real as Real +import qualified Algebra.Additive as Additive + +import qualified Data.Array as Array +import Data.Array (Array, Ix, (!), elems, ) +import Control.Applicative (Applicative, ) +import Data.Traversable (sequenceA, ) + +import Data.Tuple.HT (mapSnd, ) + +import qualified Number.NonNegative as NonNeg + +import PreludeBase +import NumericPrelude + + + +{- | +Take signal until it falls short of a certain amplitude for a given time. +-} +{-# INLINE takeUntilPause #-} +takeUntilPause :: (Real.C a) => a -> Int -> Sig.T a -> Sig.T a +takeUntilPause y = + takeUntilInterval ((<=y) . abs) + +{- | +Take values until the predicate p holds for n successive values. +The list is truncated at the beginning of the interval of matching values. +-} +{-# INLINE takeUntilInterval #-} +takeUntilInterval :: (a -> Bool) -> Int -> Sig.T a -> Sig.T a +takeUntilInterval p n xs = + Sig.map fst $ + Sig.takeWhile (( if p x then succ acc else 0) 0 xs) $ + Sig.repeat 0 + + + +{-# INLINE selectBool #-} +selectBool :: (Sig.T a, Sig.T a) -> Sig.T Bool -> Sig.T a +selectBool = + Sig.zipWith (\(xf,xt) c -> if c then xt else xf) . + uncurry Sig.zip + + +{-# INLINE select #-} +select :: Ix i => Array i (Sig.T a) -> Sig.T i -> Sig.T a +select = + Sig.crochetL + (\xi arr -> + do arr0 <- sequenceArray (fmap Sig.viewL arr) + return (fst (arr0!xi), fmap snd arr0)) + +{-# INLINE sequenceArray #-} +sequenceArray :: + (Applicative f, Ix i) => + Array i (f a) -> f (Array i a) +sequenceArray arr = + fmap (Array.listArray (Array.bounds arr)) $ + sequenceA (Array.elems arr) + + +{- | +Given a list of signals with time stamps, +mix them into one signal as they occur in time. +Ideally for composing music. + +Cf. 'MathObj.LaurentPolynomial.series' +-} +{-# INLINE arrangeList #-} +arrangeList :: (Additive.C v) => + EventList.T NonNeg.Int (Sig.T v) + {-^ A list of pairs: (relative start time, signal part), + The start time is relative to the start time + of the previous event. -} + -> Sig.T v + {-^ The mixed signal. -} +arrangeList evs = + let xs = map Sig.toList (EventList.getBodies evs) + in case map NonNeg.toNumber (EventList.getTimes evs) of + t:ts -> Sig.replicate t zero `Sig.append` + Sig.fromList (Laurent.addShiftedMany ts xs) + [] -> Sig.empty + + + + +{-# INLINE arrange #-} +arrange :: (Additive.C v) => + EventList.T NonNeg.Int (Sig.T v) + {-^ A list of pairs: (relative start time, signal part), + The start time is relative to the start time + of the previous event. -} + -> Sig.T v + {-^ The mixed signal. -} +arrange evs = + let xs = EventList.getBodies evs + in case map NonNeg.toNumber (EventList.getTimes evs) of + t:ts -> Sig.replicate t zero `Sig.append` + addShiftedMany ts xs + [] -> Sig.empty + + +{-# INLINE addShiftedMany #-} +addShiftedMany :: (Additive.C a) => [Int] -> [Sig.T a] -> Sig.T a +addShiftedMany ds xss = + foldr (uncurry addShifted) Sig.empty (zip (ds++[zero]) xss) + + + +{-# INLINE addShifted #-} +addShifted :: Additive.C a => Int -> Sig.T a -> Sig.T a -> Sig.T a +addShifted del xs ys = + if del < 0 + then error "State.Signal.addShifted: negative shift" + else + Sig.unfoldR + (\((d,ys0),xs0) -> + -- d<0 cannot happen + if d==zero + then + fmap + (mapSnd (\(xs1,ys1) -> ((zero,ys1),xs1))) + (Sig.zipStep (+) (xs0, ys0)) + else + Just $ mapSnd ((,) (pred d, ys0)) $ + Sig.switchL (zero, xs0) (,) xs0) + ((del,ys),xs) diff --git a/src/Synthesizer/State/Displacement.hs b/src/Synthesizer/State/Displacement.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/State/Displacement.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Synthesizer.State.Displacement where + +import qualified Synthesizer.State.Signal as Sig + +-- import qualified Algebra.Module as Module +-- import qualified Algebra.Transcendental as Trans +-- import qualified Algebra.Field as Field +-- import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +{- * Mixing -} + +{-| +Mix two signals. +In opposition to 'zipWith' the result has the length of the longer signal. +-} +{-# INLINE mix #-} +mix :: (Additive.C v) => Sig.T v -> Sig.T v -> Sig.T v +mix = Sig.mix + +{-| Mix an arbitrary number of signals. -} +{-# INLINE mixMulti #-} +mixMulti :: (Additive.C v) => [Sig.T v] -> Sig.T v +mixMulti = foldl mix Sig.empty + + +{-| +Add a number to all of the signal values. +This is useful for adjusting the center of a modulation. +-} +{-# INLINE raise #-} +raise :: (Additive.C v) => v -> Sig.T v -> Sig.T v +raise x = Sig.map ((+) x) + + +{- * Distortion -} +{-| +In "Synthesizer.Basic.Distortion" you find a collection +of appropriate distortion functions. +-} +{-# INLINE distort #-} +distort :: (c -> a -> a) -> Sig.T c -> Sig.T a -> Sig.T a +distort = Sig.zipWith diff --git a/src/Synthesizer/State/Filter/Delay.hs b/src/Synthesizer/State/Filter/Delay.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/State/Filter/Delay.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Synthesizer.State.Filter.Delay where + +import qualified Synthesizer.Interpolation as Interpolation +import qualified Synthesizer.State.Interpolation as InterpolationS +import qualified Synthesizer.State.Signal as Sig + +import qualified Algebra.RealField as RealField +import qualified Algebra.Additive as Additive + +-- import qualified Prelude as P +-- import PreludeBase +import NumericPrelude + + + +{- * Shift -} + +{-# INLINE static #-} +static :: Additive.C y => Int -> Sig.T y -> Sig.T y +static = staticPad zero + +{-# INLINE staticPad #-} +staticPad :: y -> Int -> Sig.T y -> Sig.T y +staticPad = InterpolationS.delayPad + +{-# INLINE staticPos #-} +staticPos :: Additive.C y => Int -> Sig.T y -> Sig.T y +staticPos n = Sig.append (Sig.replicate n zero) + +{-# INLINE staticNeg #-} +staticNeg :: Int -> Sig.T y -> Sig.T y +staticNeg = Sig.drop + + + +{-# INLINE modulatedCore #-} +modulatedCore :: (RealField.C a, Additive.C v) => + Interpolation.T a v -> Int -> Sig.T a -> Sig.T v -> Sig.T v +modulatedCore ip size = + Sig.zipWithTails + (\t -> InterpolationS.single ip (fromIntegral size + t)) + +{- +modulatedCoreSlow :: (RealField.C a, Additive.C v) => + Interpolation.T a v -> Int -> Sig.T a -> Sig.T v -> Sig.T v +modulatedCoreSlow ip size ts xs = + Sig.fromList $ zipWith + (\t -> Interpolation.single ip (fromIntegral size - t)) + (Sig.toList ts) (Sig.tails xs) +-} + +{- | +This is essentially different for constant interpolation, +because this function "looks forward" +whereas the other two variants "look backward". +For the symmetric interpolation functions +of linear and cubic interpolation, this does not really matter. +-} +{-# INLINE modulated #-} +modulated :: (RealField.C a, Additive.C v) => + Interpolation.T a v -> Int -> Sig.T a -> Sig.T v -> Sig.T v +modulated ip minDev ts xs = + let size = Interpolation.number ip - minDev + in modulatedCore ip + (size - Interpolation.offset ip) + ts + (staticPos size xs) diff --git a/src/Synthesizer/State/Filter/NonRecursive.hs b/src/Synthesizer/State/Filter/NonRecursive.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/State/Filter/NonRecursive.hs @@ -0,0 +1,291 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes +-} +module Synthesizer.State.Filter.NonRecursive where + +import qualified Synthesizer.State.Signal as Sig + +import qualified Synthesizer.State.Filter.Delay as Delay +import qualified Synthesizer.State.Control as Ctrl + +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Module as Module +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Algebra.Module( {- linearComb, -} (*>)) + +import Data.Function.HT (nest, ) + +import PreludeBase +import NumericPrelude + + + +{- * Envelope application -} + +{-# INLINE amplify #-} +amplify :: (Ring.C a) => a -> Sig.T a -> Sig.T a +amplify v = Sig.map (v*) + +{-# INLINE amplifyVector #-} +amplifyVector :: (Module.C a v) => a -> Sig.T v -> Sig.T v +amplifyVector v = Sig.map (v*>) + + +{-# INLINE envelope #-} +envelope :: (Ring.C a) => + Sig.T a {-^ the envelope -} + -> Sig.T a {-^ the signal to be enveloped -} + -> Sig.T a +envelope = Sig.zipWith (*) + +{-# INLINE envelopeVector #-} +envelopeVector :: (Module.C a v) => + Sig.T a {-^ the envelope -} + -> Sig.T v {-^ the signal to be enveloped -} + -> Sig.T v +envelopeVector = Sig.zipWith (*>) + + + +{-# INLINE fadeInOut #-} +fadeInOut :: (Field.C a) => + Int -> Int -> Int -> Sig.T a -> Sig.T a +fadeInOut tIn tHold tOut = + let leadIn = Sig.take tIn $ Ctrl.linear ( recip (fromIntegral tIn)) zero + leadOut = Sig.take tOut $ Ctrl.linear (- recip (fromIntegral tOut)) one + hold = Sig.replicate tHold one + in envelope (leadIn `Sig.append` hold `Sig.append` leadOut) + + +{- * Smoothing -} + + +{-| Unmodulated non-recursive filter -} +{-# INLINE generic #-} +generic :: (Module.C a v) => + Sig.T a -> Sig.T v -> Sig.T v +generic m x = + let mr = Sig.reverse m + xp = Delay.staticPos (pred (Sig.length m)) x + in Sig.mapTails (Sig.linearComb mr) xp + +{- +genericSlow :: Module.C a v => + Sig.T a -> Sig.T v -> Sig.T v +genericSlow m x = + let mr = Sig.reverse m + xp = delay (pred (Sig.length m)) x + in Sig.fromList (map (Sig.linearComb mr) (init (Sig.tails xp))) +-} + +{- +{- | +@eps@ is the threshold relatively to the maximum. +That is, if the gaussian falls below @eps * gaussian 0@, +then the function truncated. +-} +gaussian :: + (Trans.C a, RealField.C a, Module.C a v) => + a -> a -> a -> Sig.T v -> Sig.T v +gaussian eps ratio freq = + let var = ratioFreqToVariance ratio freq + area = var * sqrt (2*pi) + gau t = exp (-(t/var)^2/2) / area + width = ceiling (var * sqrt (-2 * log eps)) -- inverse gau + gauSmp = map (gau . fromIntegral) [-width .. width] + in drop width . generic gauSmp +-} + +{- +GNUPlot.plotList [] (take 1000 $ gaussian 0.001 0.5 0.04 (Filter.Test.chirp 5000) :: [Double]) + +The filtered chirp must have amplitude 0.5 at 400 (0.04*10000). +-} + +{- + We want to approximate a Gaussian by a binomial filter. + The latter one can be implemented by a convolutional power. + However we still require a number of operations per sample + which is proportional to the variance. +-} +{-# INLINE binomial #-} +binomial :: + (Trans.C a, RealField.C a, Module.C a v) => + a -> a -> Sig.T v -> Sig.T v +binomial ratio freq = + let width = ceiling (2 * ratioFreqToVariance ratio freq ^ 2) + in Sig.drop width . nest (2*width) ((asTypeOf 0.5 freq *>) . binomial1) + +{- +exp (-(t/var)^2/2) / area *> cis (2*pi*f*t) + == exp (-(t/var)^2/2 +: 2*pi*f*t) / area + == exp ((-t^2 +: 2*var^2*2*pi*f*t) / (2*var^2)) / area + == exp ((t^2 - i*2*var^2*2*pi*f*t) / (-2*var^2)) / area + == exp (((t^2 - i*var^2*2*pi*f)^2 + (var^2*2*pi*f)^2) / (-2*var^2)) / area + == exp (((t^2 - i*var^2*2*pi*f)^2 / (-2*var^2) - (var*2*pi*f)^2/2)) / area + +sumMap (\t -> exp (-(t/var)^2/2) / area *> cis (2*pi*f*t)) + [-infinity..infinity] + ~ sumMap (\t -> exp (-(t/var)^2/2)) [-infinity..infinity] + * exp (-(var*2*pi*f)^2/2) / area + = exp (-(var*2*pi*f)^2/2) +-} +{- | + Compute the variance of the Gaussian + such that its Fourier transform has value @ratio@ at frequency @freq@. +-} +{-# INLINE ratioFreqToVariance #-} +ratioFreqToVariance :: (Trans.C a) => a -> a -> a +ratioFreqToVariance ratio freq = + sqrt (-2 * log ratio) / (2*pi*freq) + -- inverse of the fourier transformed gaussian + +{-# INLINE binomial1 #-} +binomial1 :: (Additive.C v) => Sig.T v -> Sig.T v +binomial1 = Sig.zapWith (+) + + + + + +{- | +Moving (uniformly weighted) average in the most trivial form. +This is very slow and needs about @n * length x@ operations. +-} +{-# INLINE sums #-} +sums :: (Additive.C v) => Int -> Sig.T v -> Sig.T v +sums n = Sig.mapTails (Sig.sum . Sig.take n) + + +{- +sumsDownsample2 :: (Additive.C v) => Sig.T v -> Sig.T v +sumsDownsample2 (x0:x1:xs) = (x0+x1) : sumsDownsample2 xs +sumsDownsample2 xs = xs + +downsample2 :: Sig.T a -> Sig.T a +downsample2 (x0:_:xs) = x0 : downsample2 xs +downsample2 xs = xs + + +{- | +Given a list of numbers +and a list of sums of (2*k) of successive summands, +compute a list of the sums of (2*k+1) or (2*k+2) summands. + +Eample for 2*k+1 + +@ + [0+1+2+3, 2+3+4+5, 4+5+6+7, ...] -> + [0+1+2+3+4, 1+2+3+4+5, 2+3+4+5+6, 3+4+5+6+7, 4+5+6+7+8, ...] +@ + +Example for 2*k+2 + +@ + [0+1+2+3, 2+3+4+5, 4+5+6+7, ...] -> + [0+1+2+3+4+5, 1+2+3+4+5+6, 2+3+4+5+6+7, 3+4+5+6+7+8, 4+5+6+7+8+9, ...] +@ +-} +sumsUpsampleOdd :: (Additive.C v) => Int -> Sig.T v -> Sig.T v -> Sig.T v +sumsUpsampleOdd n {- 2*k -} xs ss = + let xs2k = drop n xs + in (head ss + head xs2k) : + concat (zipWith3 (\s x0 x2k -> [x0+s, s+x2k]) + (tail ss) + (downsample2 (tail xs)) + (tail (downsample2 xs2k))) + +sumsUpsampleEven :: (Additive.C v) => Int -> Sig.T v -> Sig.T v -> Sig.T v +sumsUpsampleEven n {- 2*k -} xs ss = + sumsUpsampleOdd (n+1) xs (zipWith (+) ss (downsample2 (drop n xs))) + +sumsPyramid :: (Additive.C v) => Int -> Sig.T v -> Sig.T v +sumsPyramid n xs = + let aux 1 ys = ys + aux 2 ys = ys + tail ys + aux m ys = + let ysd = sumsDownsample2 ys + in if even m + then sumsUpsampleEven (m-2) ys (aux (div (m-2) 2) ysd) + else sumsUpsampleOdd (m-1) ys (aux (div (m-1) 2) ysd) + in aux n xs + + +propSums :: Bool +propSums = + let n = 1000 + xs = [0::Double ..] + naive = sums n xs + rec = drop (n-1) $ sumsRec n xs + pyramid = sumsPyramid n xs + in and $ take 1000 $ + zipWith3 (\x y z -> x==y && y==z) naive rec pyramid + +-} + + + +{- * Filter operators from calculus -} + +{- | +Forward difference quotient. +Shortens the signal by one. +Inverts 'Synthesizer.State.Filter.Recursive.Integration.run' in the sense that +@differentiate (zero : integrate x) == x@. +The signal is shifted by a half time unit. +-} +{-# INLINE differentiate #-} +differentiate :: Additive.C v => Sig.T v -> Sig.T v +differentiate x = Sig.zapWith subtract x + +{- | +Central difference quotient. +Shortens the signal by two elements, +and shifts the signal by one element. +(Which can be fixed by prepending an appropriate value.) +For linear functions this will yield +essentially the same result as 'differentiate'. +You obtain the result of 'differentiateCenter' +if you smooth the one of 'differentiate' +by averaging pairs of adjacent values. + +ToDo: Vector variant +-} +{- We use zapWith in order to avoid recomputation of the input signal -} +{-# INLINE differentiateCenter #-} +differentiateCenter :: Field.C v => Sig.T v -> Sig.T v +differentiateCenter = + Sig.zapWith (\(x0,_) (_,x1) -> (x1 - x0) * (1/2)) . + Sig.zapWith (,) +{- +differentiateCenter :: Field.C v => Sig.T v -> Sig.T v +differentiateCenter x = + Sig.map ((1/2)*) $ + Sig.zipWith subtract x (Sig.tail (Sig.tail x)) +-} + +{- | +Second derivative. +It is @differentiate2 == differentiate . differentiate@ +but 'differentiate2' should be faster. +-} +{-# INLINE differentiate2 #-} +differentiate2 :: Additive.C v => Sig.T v -> Sig.T v +differentiate2 = differentiate . differentiate +{- +differentiate2 :: Additive.C v => Sig.T v -> Sig.T v +differentiate2 xs0 = + let xs1 = Sig.tail xs0 + xs2 = Sig.tail xs1 + in Sig.zipWith3 (\x0 x1 x2 -> x0+x2-(x1+x1)) xs0 xs1 xs2 +-} diff --git a/src/Synthesizer/State/Filter/Recursive/Comb.hs b/src/Synthesizer/State/Filter/Recursive/Comb.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/State/Filter/Recursive/Comb.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +Comb filters, useful for emphasis of tones with harmonics +and for repeated echos. +-} +module Synthesizer.State.Filter.Recursive.Comb where + +import qualified Synthesizer.State.Signal as Sig +import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1 + +import qualified Synthesizer.State.Filter.Delay as Delay + +import qualified Algebra.Module as Module +-- import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Algebra.Module((*>)) + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +{- | +The most simple version of the Karplus-Strong algorithm +which is suitable to simulate a plucked string. +It is similar to the 'runProc' function. +-} +{-# INLINE karplusStrong #-} +karplusStrong :: (Ring.C a, Module.C a v) => + Filt1.Parameter a -> Sig.T v -> Sig.T v +karplusStrong c wave = + Sig.delayLoop (Sig.modifyStatic Filt1.lowpassModifier c) wave + + +{- | +Infinitely many equi-delayed exponentially decaying echos. +The echos are clipped to the input length. +We think it is easier (and simpler to do efficiently) +to pad the input with zeros or whatever +instead of cutting the result according to the input length. +-} +{-# INLINE run #-} +run :: (Module.C a v) => Int -> a -> Sig.T v -> Sig.T v +run time gain = Sig.delayLoopOverlap time (gain *>) + +{- | Echos of different delays. -} +{-# INLINE runMulti #-} +runMulti :: (Ring.C a, Module.C a v) => [Int] -> a -> Sig.T v -> Sig.T v +runMulti times gain x = + let y = Sig.fromList $ Sig.toList $ + foldl + (Sig.zipWith (+)) x + (map (flip Delay.staticPos (gain *> y)) times) + in y + +{- | Echos can be piped through an arbitrary signal processor. -} +{-# INLINE runProc #-} +runProc :: Additive.C v => Int -> (Sig.T v -> Sig.T v) -> Sig.T v -> Sig.T v +runProc = Sig.delayLoopOverlap diff --git a/src/Synthesizer/State/Filter/Recursive/Integration.hs b/src/Synthesizer/State/Filter/Recursive/Integration.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/State/Filter/Recursive/Integration.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +Filter operators from calculus +-} +module Synthesizer.State.Filter.Recursive.Integration where + +import qualified Synthesizer.State.Signal as Sig +import qualified Synthesizer.Causal.Process as Causal + +-- import qualified Algebra.Field as Field +-- import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import PreludeBase +import NumericPrelude + + + +{- | +Integrate with initial value zero. +However the first emitted value is the value of the input signal. +It maintains the length of the signal. +-} +{-# INLINE run #-} +run :: Additive.C v => Sig.T v -> Sig.T v +run = + Sig.crochetL (\x acc -> let y = x+acc in Just (y,y)) zero + -- scanl1 (+) + +{- | +Integrate with initial condition. +First emitted value is the initial condition. +The signal become one element longer. +-} +{-# INLINE runInit #-} +runInit :: Additive.C v => v -> Sig.T v -> Sig.T v +runInit = Sig.scanL (+) + + +{-# INLINE causal #-} +causal :: Additive.C v => Causal.T v v +causal = Causal.scanL1 (+) + +{- | +Integrate with initial condition. +First emitted value is the initial condition. +The signal become one element longer. +-} +{-# INLINE causalInit #-} +causalInit :: Additive.C v => v -> Causal.T v v +causalInit = Causal.scanL (+) + +{- other quadrature methods may follow -} diff --git a/src/Synthesizer/State/Filter/Recursive/MovingAverage.hs b/src/Synthesizer/State/Filter/Recursive/MovingAverage.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/State/Filter/Recursive/MovingAverage.hs @@ -0,0 +1,183 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +-} +module Synthesizer.State.Filter.Recursive.MovingAverage + (sumsStaticInt, + modulatedFrac, + ) where + +import qualified Synthesizer.State.Signal as Sig +import qualified Synthesizer.State.Filter.Recursive.Integration as Integration + +import qualified Synthesizer.State.Filter.Delay as Delay + +import qualified Algebra.Module as Module +import qualified Algebra.RealField as RealField + +-- import qualified Algebra.Field as Field +-- import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import PreludeBase +import NumericPrelude + + + +{- | +Like 'Synthesizer.State.Filter.NonRecursive.sums' but in a recursive form. +This needs only linear time (independent of the window size) +but may accumulate rounding errors. + +@ +ys = xs * (1,0,0,0,-1) \/ (1,-1) +ys * (1,-1) = xs * (1,0,0,0,-1) +ys = xs * (1,0,0,0,-1) + ys * (0,1) +@ +-} +{-# INLINE sumsStaticInt #-} +sumsStaticInt :: (Additive.C v) => Int -> Sig.T v -> Sig.T v +sumsStaticInt n xs = + Integration.run (xs - Delay.staticPos n xs) + +{- +staticInt :: (Module.C a v, Additive.C v) => Int -> Sig.T v -> Sig.T v +staticInt n xs = +-} + + +{- +Sum of a part of a vector with negative sign for reverse order. +It adds from @from@ (inclusively) to @to@ (exclusively), +that is, it sums up @abs (to-from)@ values + +sumFromTo :: (Additive.C v) => Int -> Int -> Sig.T v -> v +sumFromTo from to = + if from <= to + then Sig.sum . Sig.take (to-from) . Sig.drop from + else negate . Sig.sum . Sig.take (from-to) . Sig.drop to +-} + +{-# INLINE sumFromToFrac #-} +sumFromToFrac :: (RealField.C a, Module.C a v) => a -> a -> Sig.T v -> v +sumFromToFrac from to xs = + let (fromInt, fromFrac) = splitFraction from + (toInt, toFrac) = splitFraction to + in case compare fromInt toInt of + EQ -> (to-from) *> Sig.index fromInt xs + LT -> + Sig.sum $ + Sig.zipWith id + (((1-fromFrac) *>) `Sig.cons` + Sig.replicate (toInt-fromInt-1) id `Sig.append` + Sig.singleton (toFrac *>)) $ + Sig.drop fromInt xs + GT -> + negate $ Sig.sum $ + Sig.zipWith id + (((1-toFrac) *>) `Sig.cons` + Sig.replicate (fromInt-toInt-1) id `Sig.append` + Sig.singleton (fromFrac *>)) $ + Sig.drop toInt xs + + +{- + run $ + addNextWeighted (1-toFrac) >> + replicateM_ (fromInt-toInt-1) addNext >> + addNextWeighted (fromFrac) + +type Accumulator v a = + WriterT (Dual (Endo v)) (StateT (Sig.T v) Maybe a) + +getNext :: Accumulator v a +getNext = + lift $ StateT $ ListHT.viewL + +addAccum :: Additive.C v => v -> Accumulator v () +addAccum x = tell ((x+) $!) + +addNext :: Additive.C v => Accumulator v () +addNext w = + addAccum =<< getNext + +addNextWeighted :: Module.C a v => a -> Accumulator v () +addNextWeighted w = + addAccum . (w *>) =<< getNext +-} + +{- +newtype Accumulator v = + Accumulator ((v, Sig.T v) -> v -> (Sig.T v, v)) + +addNext :: Additive.C v => Accumulator v +addNext = + Accumulator $ \(x,xs) s -> (xs, x+s) + +addNextWeighted :: Module.C a v => a -> Accumulator v +addNextWeighted a = + Accumulator $ \(x,xs) s -> (xs, a*>x + s) + +bindAccum :: Accumulator v -> Accumulator v -> Accumulator v +bindAccum (Accumulator f) (Accumulator g) = + Accumulator $ \x s0 -> + let (ys,s1) = f x s0 + in maybe s1 () (ListHT.viewL ys) +-} + + +{- | +Sig.T a must contain only non-negative elements. +-} +{-# INLINE sumDiffsModulated #-} +sumDiffsModulated :: (RealField.C a, Module.C a v) => + a -> Sig.T a -> Sig.T v -> Sig.T v +sumDiffsModulated d ds = + Sig.init . + -- prevent negative d's since 'drop' cannot restore past values + Sig.zipWithTails (uncurry sumFromToFrac) + (Sig.zip (Sig.cons (d+1) ds) (Sig.map (1+) ds)) . + Sig.cons zero +{- + Sig.zipWithTails (uncurry sumFromToFrac) + (Sig.zip (Sig.cons d (Sig.map (subtract 1) ds)) ds) +-} + +{- +sumsModulated :: (RealField.C a, Module.C a v) => + Int -> Sig.T a -> Sig.T v -> Sig.T v +sumsModulated maxDInt ds xs = + let maxD = fromIntegral maxDInt + posXs = sumDiffsModulated 0 ds xs + negXs = sumDiffsModulated maxD (Sig.map (maxD-) ds) (Delay.static maxDInt xs) + in Integration.run (posXs - negXs) +-} + +{- | +Shift sampling points by a half sample period +in order to preserve signals for window widths below 1. +-} +{-# INLINE sumsModulatedHalf #-} +sumsModulatedHalf :: (RealField.C a, Module.C a v) => + Int -> Sig.T a -> Sig.T v -> Sig.T v +sumsModulatedHalf maxDInt ds xs = + let maxD = fromIntegral maxDInt + d0 = maxD+0.5 + delXs = Delay.staticPos maxDInt xs + posXs = sumDiffsModulated d0 (Sig.map (d0+) ds) delXs + negXs = sumDiffsModulated d0 (Sig.map (d0-) ds) delXs + in Integration.run (posXs - negXs) + +{-# INLINE modulatedFrac #-} +modulatedFrac :: (RealField.C a, Module.C a v) => + Int -> Sig.T a -> Sig.T v -> Sig.T v +modulatedFrac maxDInt ds xs = + Sig.zipWith (\d y -> recip (2*d) *> y) ds $ + sumsModulatedHalf maxDInt ds xs + diff --git a/src/Synthesizer/State/Interpolation.hs b/src/Synthesizer/State/Interpolation.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/State/Interpolation.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Synthesizer.State.Interpolation where + +import qualified Synthesizer.Interpolation as Interpolation +import Synthesizer.Interpolation + (T, offset, number, func, ) + +import qualified Synthesizer.State.Signal as Sig + +-- import qualified Algebra.Module as Module +import qualified Algebra.RealField as RealField +-- import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Data.Maybe (fromMaybe) + +import PreludeBase +import NumericPrelude + + +{-* Interpolation with various padding methods -} + +{-# INLINE zeroPad #-} +zeroPad :: (RealField.C t) => + (T t y -> t -> Sig.T y -> a) -> + y -> T t y -> t -> Sig.T y -> a +zeroPad interpolate z ip phase x = + let (phInt, phFrac) = splitFraction phase + in interpolate ip phFrac + (delayPad z (offset ip - phInt) (Sig.append x (Sig.repeat z))) + +{-# INLINE constantPad #-} +constantPad :: (RealField.C t) => + (T t y -> t -> Sig.T y -> a) -> + T t y -> t -> Sig.T y -> a +constantPad interpolate ip phase x = + let (phInt, phFrac) = splitFraction phase + xPad = + do (xFirst,_) <- Sig.viewL x + return (delayPad xFirst (offset ip - phInt) (Sig.extendConstant x)) + in interpolate ip phFrac + (fromMaybe Sig.empty xPad) + + +{- | +Only for finite input signals. +-} +{-# INLINE cyclicPad #-} +cyclicPad :: (RealField.C t) => + (T t y -> t -> Sig.T y -> a) -> + T t y -> t -> Sig.T y -> a +cyclicPad interpolate ip phase x = + let (phInt, phFrac) = splitFraction phase + in interpolate ip phFrac + (Sig.drop (mod (phInt - offset ip) (Sig.length x)) (Sig.cycle x)) + +{- | +The extrapolation may miss some of the first and some of the last points +-} +{-# INLINE extrapolationPad #-} +extrapolationPad :: (RealField.C t) => + (T t y -> t -> Sig.T y -> a) -> + T t y -> t -> Sig.T y -> a +extrapolationPad interpolate ip phase = + interpolate ip (phase - fromIntegral (offset ip)) +{- + This example shows pikes, although there shouldn't be any: + plotList (take 100 $ interpolate (Zero (0::Double)) ipCubic (-0.9::Double) (repeat 0.03) [1,0,1,0.8]) +-} + + +{-* Helper methods for interpolation of multiple nodes -} + +{-# INLINE skip #-} +skip :: (RealField.C t) => + T t y -> (t, Sig.T y) -> (t, Sig.T y) +skip ip (phase0, x0) = + let (n, frac) = splitFraction phase0 + (m, x1) = Sig.dropMarginRem (number ip) n x0 + in (fromIntegral m + frac, x1) + +{-# INLINE single #-} +single :: (RealField.C t) => + T t y -> t -> Sig.T y -> y +single ip phase0 x0 = + uncurry (func ip) $ skip ip (phase0, x0) +-- curry (uncurry (func ip) . skip ip) +{- +GNUPlot.plotFunc [] (GNUPlot.linearScale 1000 (0,2)) (\t -> single linear (t::Double) [0,4,1::Double]) +-} + + +{-* Helper functions -} + +{-# INLINE delayPad #-} +delayPad :: y -> Int -> Sig.T y -> Sig.T y +delayPad z n = + if n<0 + then Sig.drop (negate n) + else Sig.append (Sig.replicate n z) diff --git a/src/Synthesizer/State/Miscellaneous.hs b/src/Synthesizer/State/Miscellaneous.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/State/Miscellaneous.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Synthesizer.State.Miscellaneous where + +import qualified Synthesizer.State.Signal as Signal + +import qualified Algebra.NormedSpace.Euclidean as Euc +-- import qualified Algebra.Module as Module +-- import qualified Algebra.Transcendental as Trans +import qualified Algebra.Field as Field +-- import qualified Algebra.Ring as Ring +-- import qualified Algebra.Additive as Additive + +-- import qualified Prelude as P +-- import PreludeBase +import NumericPrelude + +{- * Spatial effects -} + +{-| simulate an moving sounding object + convert the way of the object through 3D space + into a delay and attenuation information, + sonicDelay is the reciprocal of the sonic velocity -} +{-# INLINE receive3Dsound #-} +receive3Dsound :: (Field.C a, Euc.C a v) => + a -> a -> v -> Signal.T v -> (Signal.T a,Signal.T a) +receive3Dsound att sonicDelay ear way = + let dists = Signal.map Euc.norm (Signal.map (subtract ear) way) + phase = Signal.map (sonicDelay*) dists + volumes = Signal.map (\x -> 1/(att+x)^2) dists + in (phase, volumes) diff --git a/src/Synthesizer/State/Noise.hs b/src/Synthesizer/State/Noise.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/State/Noise.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{- | Noise and random processes. -} +module Synthesizer.State.Noise where + +import qualified Synthesizer.State.Signal as Sig + +import qualified Algebra.Real as Real +import qualified Algebra.Ring as Ring + +import System.Random (Random, RandomGen, randomR, mkStdGen, ) +import qualified System.Random as Rnd + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +{-| +Deterministic white noise, uniformly distributed between -1 and 1. +That is, variance is 1\/3. +-} +{-# INLINE white #-} +white :: (Ring.C y, Random y) => + Sig.T y +white = whiteGen (mkStdGen 12354) + +{-# INLINE whiteGen #-} +whiteGen :: + (Ring.C y, Random y, RandomGen g) => + g -> Sig.T y +whiteGen = randomRs (-1,1) + + +{- | +Approximates normal distribution with variance 1 +by a quadratic B-spline distribution. +-} +{-# INLINE whiteQuadraticBSplineGen #-} +whiteQuadraticBSplineGen :: + (Ring.C y, Random y, RandomGen g) => + g -> Sig.T y +whiteQuadraticBSplineGen g = + let (g0,gr) = Rnd.split g + (g1,g2) = Rnd.split gr + in whiteGen g0 `Sig.mix` + whiteGen g1 `Sig.mix` + whiteGen g2 + + +{-# INLINE randomPeeks #-} +randomPeeks :: (Real.C y, Random y) => + Sig.T y {- ^ momentary densities, @p@ means that there is about one peak + in the time range of @1\/p@ samples -} + -> Sig.T Bool {- ^ Every occurence of 'True' represents a peak. -} +randomPeeks = + randomPeeksGen (mkStdGen 876) + +{-# INLINE randomPeeksGen #-} +randomPeeksGen :: (Real.C y, Random y, RandomGen g) => + g + -> Sig.T y + -> Sig.T Bool +randomPeeksGen = + Sig.zipWith (<) . randomRs (0,1) + + + +{-# INLINE randomRs #-} +randomRs :: + (Ring.C y, Random y, RandomGen g) => + (y,y) -> g -> Sig.T y +randomRs bnd = Sig.unfoldR (Just . randomR bnd) diff --git a/src/Synthesizer/State/NoiseCustom.hs b/src/Synthesizer/State/NoiseCustom.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/State/NoiseCustom.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{- | +Noise and random processes. +This uses a fast reimplementation of 'System.Random.randomR' +since the standard function seems not to be inlined (at least in GHC-6.8.2). +-} +module Synthesizer.State.NoiseCustom where + +import qualified Synthesizer.State.Signal as Sig + +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field + +import qualified Synthesizer.RandomKnuth as Knuth + +import System.Random (Random, RandomGen, ) +import qualified System.Random as Rnd + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +{-| +Deterministic white noise, uniformly distributed between -1 and 1. +That is, variance is 1\/3. +-} +{-# INLINE white #-} +white :: (Field.C y, Random y) => + Sig.T y +white = whiteGen (Knuth.cons 12354) + +{-# INLINE whiteGen #-} +whiteGen :: + (Field.C y, Random y, RandomGen g) => + g -> Sig.T y +whiteGen = randomRs (-1,1) + + +{- | +Approximates normal distribution with variance 1 +by a quadratic B-spline distribution. +-} +{-# INLINE whiteQuadraticBSplineGen #-} +whiteQuadraticBSplineGen :: + (Field.C y, Random y, RandomGen g) => + g -> Sig.T y +whiteQuadraticBSplineGen g = + let (g0,gr) = Rnd.split g + (g1,g2) = Rnd.split gr + in whiteGen g0 `Sig.mix` + whiteGen g1 `Sig.mix` + whiteGen g2 + + +{-# INLINE randomPeeks #-} +randomPeeks :: (RealField.C y, Random y) => + Sig.T y {- ^ momentary densities, @p@ means that there is about one peak + in the time range of @1\/p@ samples -} + -> Sig.T Bool {- ^ Every occurence of 'True' represents a peak. -} +randomPeeks = + randomPeeksGen (Knuth.cons 876) + +{-# INLINE randomPeeksGen #-} +randomPeeksGen :: (RealField.C y, Random y, RandomGen g) => + g + -> Sig.T y + -> Sig.T Bool +randomPeeksGen = + Sig.zipWith (<) . randomRs (0,1) + + +{-# INLINE randomRs #-} +randomRs :: + (Field.C y, Random y, RandomGen g) => + (y,y) -> g -> Sig.T y +randomRs bnd = Sig.unfoldR (Just . randomR bnd) + +{-# INLINE randomR #-} +randomR :: + (RandomGen g, Field.C y) => + (y, y) -> g -> (y, g) +randomR (lower,upper) g0 = + let (n,g1) = Rnd.next g0 + (l,u) = Rnd.genRange g0 + nd = fromIntegral n + ld = fromIntegral l + ud = fromIntegral u + x01 = (nd-ld)/(ud-ld) + in ((1-x01)*lower + x01*upper, g1) diff --git a/src/Synthesizer/State/Oscillator.hs b/src/Synthesizer/State/Oscillator.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/State/Oscillator.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{- | +Copyright : (c) Henning Thielemann 2006 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +Tone generators +-} +module Synthesizer.State.Oscillator where + +import qualified Synthesizer.Causal.Oscillator as Osci +import qualified Synthesizer.Basic.WaveSmoothed as WaveSmooth +import qualified Synthesizer.Basic.Wave as Wave +import qualified Synthesizer.Basic.Phase as Phase + +import qualified Synthesizer.Causal.Process as Causal +import qualified Synthesizer.State.Signal as Sig + +import qualified Synthesizer.Generic.Signal as SigG + +import qualified Synthesizer.Interpolation as Interpolation + + +import qualified Algebra.Transcendental as Trans +import qualified Algebra.RealField as RealField + +-- import qualified Prelude as P +-- import NumericPrelude +-- import PreludeBase + + + +{- * Oscillators with arbitrary but constant waveforms -} + +{-# INLINE static #-} +{- | +Oscillator with constant frequency. +It causes aliasing effects for sharp waveforms and high frequencies. +-} +static :: (RealField.C a) => Wave.T a b -> (Phase.T a -> a -> Sig.T b) +static wave phase freq = + Sig.map (Wave.apply wave) (Osci.freqToPhases phase freq) + +{-# INLINE staticAntiAlias #-} +{- | +Oscillator with constant frequency +that suppresses aliasing effects using waveforms with controllable smoothness. +-} +staticAntiAlias :: (RealField.C a) => + WaveSmooth.T a b -> (Phase.T a -> a -> Sig.T b) +staticAntiAlias wave phase freq = + Sig.map (WaveSmooth.apply wave freq) (Osci.freqToPhases phase freq) + +{-# INLINE phaseMod #-} +{- | oscillator with modulated phase -} +phaseMod :: (RealField.C a) => Wave.T a b -> a -> Sig.T a -> Sig.T b +phaseMod wave freq = + Causal.apply (Osci.phaseMod wave freq) + +{-# INLINE shapeMod #-} +{- | oscillator with modulated shape -} +shapeMod :: (RealField.C a) => + (c -> Wave.T a b) -> Phase.T a -> a -> Sig.T c -> Sig.T b +shapeMod wave phase freq = + Causal.apply (Osci.shapeMod wave phase freq) + +{-# INLINE freqMod #-} +{- | oscillator with modulated frequency -} +freqMod :: (RealField.C a) => Wave.T a b -> Phase.T a -> Sig.T a -> Sig.T b +freqMod wave phase = + Causal.apply (Osci.freqMod wave phase) + +{-# INLINE freqModAntiAlias #-} +{- | oscillator with modulated frequency -} +freqModAntiAlias :: (RealField.C a) => + WaveSmooth.T a b -> Phase.T a -> Sig.T a -> Sig.T b +freqModAntiAlias wave phase = + Causal.apply (Osci.freqModAntiAlias wave phase) + +{-# INLINE phaseFreqMod #-} +{- | oscillator with both phase and frequency modulation -} +phaseFreqMod :: (RealField.C a) => + Wave.T a b -> Sig.T a -> Sig.T a -> Sig.T b +phaseFreqMod wave = + Causal.apply2 (Osci.phaseFreqMod wave) + +{-# INLINE shapeFreqMod #-} +{- | oscillator with both shape and frequency modulation -} +shapeFreqMod :: (RealField.C a) => + (c -> Wave.T a b) -> Phase.T a -> Sig.T c -> Sig.T a -> Sig.T b +shapeFreqMod wave phase = + Causal.apply2 (Osci.shapeFreqMod wave phase) + + +{- | oscillator with a sampled waveform with constant frequency + This essentially an interpolation with cyclic padding. -} +{-# INLINE staticSample #-} +staticSample :: RealField.C a => + Interpolation.T a b -> Sig.T b -> Phase.T a -> a -> Sig.T b +staticSample ip wave phase freq = + Causal.apply (Osci.freqModSample ip wave phase) (Sig.repeat freq) + +{- | oscillator with a sampled waveform with modulated frequency + Should behave homogenously for different types of interpolation. -} +{-# INLINE freqModSample #-} +freqModSample :: RealField.C a => + Interpolation.T a b -> Sig.T b -> Phase.T a -> Sig.T a -> Sig.T b +freqModSample ip wave phase = + Causal.apply (Osci.freqModSample ip wave phase) + +{-# INLINE shapeFreqModSample #-} +shapeFreqModSample :: (RealField.C c, RealField.C a) => + Interpolation.T c (Wave.T a b) -> Sig.T (Wave.T a b) -> + c -> Phase.T a -> + Sig.T c -> Sig.T a -> Sig.T b +shapeFreqModSample ip waves shape0 phase = + Causal.apply2 (Osci.shapeFreqModSample ip waves shape0 phase) + +{-# INLINE shapeFreqModFromSampledTone #-} +shapeFreqModFromSampledTone :: + (RealField.C a, SigG.Transform sig b) => + Interpolation.T a b -> + Interpolation.T a b -> + a -> sig b -> + a -> Phase.T a -> + Sig.T a -> Sig.T a -> Sig.T b +shapeFreqModFromSampledTone + ipLeap ipStep period sampledTone shape0 phase = + Causal.apply2 + (Osci.shapeFreqModFromSampledTone + ipLeap ipStep period sampledTone shape0 phase) + +{-# INLINE shapePhaseFreqModFromSampledTone #-} +shapePhaseFreqModFromSampledTone :: + (RealField.C a, SigG.Transform sig b) => + Interpolation.T a b -> + Interpolation.T a b -> + a -> sig b -> + a -> Phase.T a -> + Sig.T a -> Sig.T a -> Sig.T a -> Sig.T b +shapePhaseFreqModFromSampledTone + ipLeap ipStep period sampledTone shape0 phase = + Causal.apply3 + (Osci.shapePhaseFreqModFromSampledTone + ipLeap ipStep period sampledTone shape0 phase) + + + +{- * Oscillators with specific waveforms -} + +{-# INLINE staticSine #-} +{- | sine oscillator with static frequency -} +staticSine :: (Trans.C a, RealField.C a) => Phase.T a -> a -> Sig.T a +staticSine = static Wave.sine + +{-# INLINE freqModSine #-} +{- | sine oscillator with modulated frequency -} +freqModSine :: (Trans.C a, RealField.C a) => Phase.T a -> Sig.T a -> Sig.T a +freqModSine = freqMod Wave.sine + +{-# INLINE phaseModSine #-} +{- | sine oscillator with modulated phase, useful for FM synthesis -} +phaseModSine :: (Trans.C a, RealField.C a) => a -> Sig.T a -> Sig.T a +phaseModSine = phaseMod Wave.sine + +{-# INLINE staticSaw #-} +{- | saw tooth oscillator with modulated frequency -} +staticSaw :: RealField.C a => Phase.T a -> a -> Sig.T a +staticSaw = static Wave.saw + +{-# INLINE freqModSaw #-} +{- | saw tooth oscillator with modulated frequency -} +freqModSaw :: RealField.C a => Phase.T a -> Sig.T a -> Sig.T a +freqModSaw = freqMod Wave.saw diff --git a/src/Synthesizer/State/Signal.hs b/src/Synthesizer/State/Signal.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/State/Signal.hs @@ -0,0 +1,728 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ExistentialQuantification #-} +{- | +ToDo: +Better name for the module is certainly + Synthesizer.Generator.Signal +-} +module Synthesizer.State.Signal where + +-- import qualified Synthesizer.Plain.Signal as Sig +import qualified Synthesizer.Plain.Modifier as Modifier +import qualified Data.List as List + +import qualified Algebra.Module as Module +import qualified Algebra.Additive as Additive +import Algebra.Additive (zero) + +import Algebra.Module ((*>)) + +import qualified Synthesizer.Format as Format + +import Control.Monad.Trans.State + (runState, StateT(StateT), runStateT, ) +import Control.Monad (Monad, mplus, msum, + (>>), (>>=), fail, return, (=<<), + liftM2, + Functor, fmap, ) + +import Data.Monoid (Monoid, mappend, mempty, ) + +import qualified Synthesizer.Storable.Signal as SigSt +import qualified Data.StorableVector.Lazy.Pattern as SVL +import Foreign.Storable (Storable) + +import qualified Data.List.HT as ListHT +import Data.Tuple.HT (mapFst, mapSnd, mapPair, fst3, snd3, thd3, ) +import Data.Function.HT (nest, ) +import Data.Maybe.HT (toMaybe, ) +import NumericPrelude (fromInteger, ) + +import Text.Show (Show(showsPrec), showParen, showString, ) +import Data.Maybe (Maybe(Just, Nothing), maybe, fromMaybe, ) +import Prelude + ((.), ($), ($!), id, const, flip, curry, uncurry, fst, snd, error, + (>), (>=), max, Ord, + succ, pred, Bool(True,False), not, Int, +-- fromInteger, + ) + + +-- | Cf. StreamFusion Data.Stream +data T a = + forall s. -- Seq s => + Cons !(StateT s Maybe a) -- compute next value + !s -- initial state + + +instance (Show y) => Show (T y) where + showsPrec p x = + showParen (p >= 10) + (showString "StateSignal.fromList " . showsPrec 11 (toList x)) + +instance Format.C T where + format = showsPrec + +instance Functor T where + fmap = map + + + +{-# INLINE generate #-} +generate :: (acc -> Maybe (y, acc)) -> acc -> T y +generate f = Cons (StateT f) + +{-# INLINE unfoldR #-} +unfoldR :: (acc -> Maybe (y, acc)) -> acc -> T y +unfoldR = generate + +{-# INLINE generateInfinite #-} +generateInfinite :: (acc -> (y, acc)) -> acc -> T y +generateInfinite f = generate (Just . f) + +{-# INLINE fromList #-} +fromList :: [y] -> T y +fromList = generate ListHT.viewL + +{-# INLINE toList #-} +toList :: T y -> [y] +toList (Cons f x0) = + List.unfoldr (runStateT f) x0 + + +{-# INLINE fromStorableSignal #-} +fromStorableSignal :: + (Storable a) => + SigSt.T a -> T a +fromStorableSignal = + generate SigSt.viewL + +{-# INLINE toStorableSignal #-} +toStorableSignal :: + (Storable a) => + SigSt.ChunkSize -> T a -> SigSt.T a +toStorableSignal size (Cons f a) = + SigSt.unfoldr size (runStateT f) a + +-- needed in synthesizer-alsa +{-# INLINE toStorableSignalVary #-} +toStorableSignalVary :: + (Storable a) => + SVL.LazySize -> T a -> SigSt.T a +toStorableSignalVary size (Cons f a) = + fst $ SVL.unfoldrN size (runStateT f) a + + + +{-# INLINE iterate #-} +iterate :: (a -> a) -> a -> T a +iterate f = generateInfinite (\x -> (x, f x)) + +{-# INLINE iterateAssociative #-} +iterateAssociative :: (a -> a -> a) -> a -> T a +iterateAssociative op x = iterate (op x) x -- should be optimized + +{-# INLINE repeat #-} +repeat :: a -> T a +repeat = iterate id + + + + +{-# INLINE crochetL #-} +crochetL :: (x -> acc -> Maybe (y, acc)) -> acc -> T x -> T y +crochetL g b (Cons f a) = + Cons + (StateT (\(a0,b0) -> + do (x0,a1) <- runStateT f a0 + (y0,b1) <- g x0 b0 + Just (y0, (a1,b1)))) + (a,b) + + +{-# INLINE scanL #-} +scanL :: (acc -> x -> acc) -> acc -> T x -> T acc +scanL f start = + cons start . + crochetL (\x acc -> let y = f acc x in Just (y, y)) start + + +{-# INLINE scanLClip #-} +-- | input and output have equal length, that's better for fusion +scanLClip :: (acc -> x -> acc) -> acc -> T x -> T acc +scanLClip f start = + crochetL (\x acc -> Just (acc, f acc x)) start + +{-# INLINE map #-} +map :: (a -> b) -> (T a -> T b) +map f = crochetL (\x _ -> Just (f x, ())) () + + +{- | +This function will recompute the input lists +and is thus probably not what you want. +If you want to avoid recomputation please consider Causal.Process. +-} +{-# INLINE unzip #-} +unzip :: T (a,b) -> (T a, T b) +unzip x = (map fst x, map snd x) + +{-# INLINE unzip3 #-} +unzip3 :: T (a,b,c) -> (T a, T b, T c) +unzip3 xs = (map fst3 xs, map snd3 xs, map thd3 xs) + + +{-# INLINE delay1 #-} +{- | +This is a fusion friendly implementation of delay. +However, in order to be a 'crochetL' +the output has the same length as the input, +that is, the last element is removed - at least for finite input. +-} +delay1 :: a -> T a -> T a +delay1 = crochetL (flip (curry Just)) + +{-# INLINE delay #-} +delay :: y -> Int -> T y -> T y +delay z n = append (replicate n z) + +{-# INLINE take #-} +take :: Int -> T a -> T a +take = crochetL (\x n -> toMaybe (n>zero) (x, pred n)) + +{-# INLINE takeWhile #-} +takeWhile :: (a -> Bool) -> T a -> T a +takeWhile p = crochetL (\x _ -> toMaybe (p x) (x, ())) () + +{-# INLINE replicate #-} +replicate :: Int -> a -> T a +replicate n = take n . repeat + + +{- * functions consuming multiple lists -} + +{-# INLINE zipWith #-} +zipWith :: (a -> b -> c) -> (T a -> T b -> T c) +zipWith h (Cons f a) = + crochetL + (\x0 a0 -> + do (y0,a1) <- runStateT f a0 + Just (h y0 x0, a1)) + a + +{-# INLINE zipWithStorable #-} +zipWithStorable :: (Storable b, Storable c) => + (a -> b -> c) -> (T a -> SigSt.T b -> SigSt.T c) +zipWithStorable h (Cons f a) = + SigSt.crochetL + (\x0 a0 -> + do (y0,a1) <- runStateT f a0 + Just (h y0 x0, a1)) + a + +{-# INLINE zipWith3 #-} +zipWith3 :: (a -> b -> c -> d) -> (T a -> T b -> T c -> T d) +zipWith3 f s0 s1 = + zipWith (uncurry f) (zip s0 s1) + +{-# INLINE zipWith4 #-} +zipWith4 :: (a -> b -> c -> d -> e) -> (T a -> T b -> T c -> T d -> T e) +zipWith4 f s0 s1 = + zipWith3 (uncurry f) (zip s0 s1) + + +{-# INLINE zip #-} +zip :: T a -> T b -> T (a,b) +zip = zipWith (,) + +{-# INLINE zip3 #-} +zip3 :: T a -> T b -> T c -> T (a,b,c) +zip3 = zipWith3 (,,) + +{-# INLINE zip4 #-} +zip4 :: T a -> T b -> T c -> T d -> T (a,b,c,d) +zip4 = zipWith4 (,,,) + + +{- * functions based on 'foldL' -} + +{-# INLINE foldL' #-} +foldL' :: (x -> acc -> acc) -> acc -> T x -> acc +foldL' g b = + switchL b (\ x xs -> foldL' g (g x $! b) xs) + +{-# INLINE foldL #-} +foldL :: (acc -> x -> acc) -> acc -> T x -> acc +foldL f = foldL' (flip f) + +{-# INLINE length #-} +length :: T a -> Int +length = foldL' (const succ) zero + + +{- * functions based on 'foldR' -} + +foldR :: (x -> acc -> acc) -> acc -> T x -> acc +foldR g b = + switchL b (\ x xs -> g x (foldR g b xs)) + + +{- * Other functions -} + +{-# INLINE null #-} +null :: T a -> Bool +null = + switchL True (const (const False)) + -- foldR (const (const False)) True + +{-# INLINE empty #-} +empty :: T a +empty = generate (const Nothing) () + +{-# INLINE singleton #-} +singleton :: a -> T a +singleton = + generate (fmap (\x -> (x, Nothing))) . Just + +{-# INLINE cons #-} +{- | +This is expensive and should not be used to construct lists iteratively! +-} +cons :: a -> T a -> T a +cons x xs = + generate + (\(mx0,xs0) -> + fmap (mapSnd ((,) Nothing)) $ + maybe + (viewL xs0) + (\x0 -> Just (x0, xs0)) + mx0) $ + (Just x, xs) + +{-# INLINE viewL #-} +viewL :: T a -> Maybe (a, T a) +viewL (Cons f a0) = + fmap + (mapSnd (Cons f)) + (runStateT f a0) + +{- iterated 'cons' is very inefficient +viewR :: T a -> Maybe (T a, a) +viewR = + foldR (\x mxs -> Just (maybe (empty,x) (mapFst (cons x)) mxs)) Nothing +-} + +{-# INLINE viewR #-} +viewR :: Storable a => T a -> Maybe (T a, a) +viewR = viewRSize SigSt.defaultChunkSize + +{-# INLINE viewRSize #-} +viewRSize :: Storable a => SigSt.ChunkSize -> T a -> Maybe (T a, a) +viewRSize size = + fmap (mapFst fromStorableSignal) . + SigSt.viewR . + toStorableSignal size + + +{-# INLINE switchL #-} +switchL :: b -> (a -> T a -> b) -> T a -> b +switchL n j = + maybe n (uncurry j) . viewL + +{-# INLINE switchR #-} +switchR :: Storable a => b -> (T a -> a -> b) -> T a -> b +switchR n j = + maybe n (uncurry j) . viewR + + +{- | +This implementation requires +that the input generator has to check repeatedly whether it is finished. +-} +{-# INLINE extendConstant #-} +extendConstant :: T a -> T a +extendConstant xt0 = + switchL + empty + (\ x0 _ -> + generate + (\xt1@(x1,xs1) -> + Just $ switchL + (x1,xt1) + (\x xs -> (x, (x,xs))) + xs1) + (x0,xt0)) $ + xt0 + + +{- +{-# INLINE tail #-} +tail :: T a -> T a +tail = Cons . List.tail . decons + +{-# INLINE head #-} +head :: T a -> a +head = List.head . decons +-} + +{-# INLINE drop #-} +drop :: Int -> T a -> T a +drop n = + fromMaybe empty . + nest n (fmap snd . viewL =<<) . + Just + +{-# INLINE dropMarginRem #-} +{- | +This implementation expects that looking ahead is cheap. +-} +dropMarginRem :: Int -> Int -> T a -> (Int, T a) +dropMarginRem n m = + switchL (error "StateSignal.dropMaringRem: length xs < n") const . + dropMargin n m . + zipWithTails (,) (iterate pred m) + +{-# INLINE dropMargin #-} +dropMargin :: Int -> Int -> T a -> T a +dropMargin n m xs = + dropMatch (take m (drop n xs)) xs + + +dropMatch :: T b -> T a -> T a +dropMatch xs ys = + fromMaybe ys $ + liftM2 dropMatch + (fmap snd $ viewL xs) + (fmap snd $ viewL ys) + + +index :: Int -> T a -> a +index n = + switchL (error "State.Signal: index too large") const . drop n + + +{- +splitAt :: Int -> T a -> (T a, T a) +splitAt n = mapPair (Cons, Cons) . List.splitAt n . decons +-} + +{-# INLINE splitAt #-} +splitAt :: Storable a => + Int -> T a -> (T a, T a) +splitAt = splitAtSize SigSt.defaultChunkSize + +{-# INLINE splitAtSize #-} +splitAtSize :: Storable a => + SigSt.ChunkSize -> Int -> T a -> (T a, T a) +splitAtSize size n = + mapPair (fromStorableSignal, fromStorableSignal) . + SigSt.splitAt n . + toStorableSignal size + + +{-# INLINE dropWhile #-} +dropWhile :: (a -> Bool) -> T a -> T a +dropWhile p xt = + switchL empty (\ x xs -> if p x then dropWhile p xs else xt) xt + +{- +span :: (a -> Bool) -> T a -> (T a, T a) +span p = mapPair (Cons, Cons) . List.span p . decons +-} + +{-# INLINE span #-} +span :: Storable a => + (a -> Bool) -> T a -> (T a, T a) +span = spanSize SigSt.defaultChunkSize + +{-# INLINE spanSize #-} +spanSize :: Storable a => + SigSt.ChunkSize -> (a -> Bool) -> T a -> (T a, T a) +spanSize size p = + mapPair (fromStorableSignal, fromStorableSignal) . + SigSt.span p . + toStorableSignal size + + +{-# INLINE cycle #-} +cycle :: T a -> T a +cycle xs = + switchL + (error "StateSignal.cycle: empty input") + (curry $ \yt -> generate (Just . fromMaybe yt . viewL) xs) + xs + +{-# INLINE mix #-} +mix :: Additive.C a => T a -> T a -> T a +mix = zipWithAppend (Additive.+) + + +{-# INLINE sub #-} +sub :: Additive.C a => T a -> T a -> T a +sub xs ys = mix xs (neg ys) + +{-# INLINE neg #-} +neg :: Additive.C a => T a -> T a +neg = map Additive.negate + +instance Additive.C y => Additive.C (T y) where + zero = empty + (+) = mix + (-) = sub + negate = neg + +instance Module.C y yv => Module.C y (T yv) where + (*>) x y = map (x*>) y + + +infixr 5 `append` + +{-# INLINE append #-} +append :: T a -> T a -> T a +append xs ys = + generate + (\(b,xs0) -> + mplus + (fmap (mapSnd ((,) b)) $ viewL xs0) + (if b + then Nothing + else fmap (mapSnd ((,) True)) $ viewL ys)) + (False,xs) + +{-# INLINE appendStored #-} +appendStored :: Storable a => + T a -> T a -> T a +appendStored = appendStoredSize SigSt.defaultChunkSize + +{-# INLINE appendStoredSize #-} +appendStoredSize :: Storable a => + SigSt.ChunkSize -> T a -> T a -> T a +appendStoredSize size xs ys = + fromStorableSignal $ + SigSt.append + (toStorableSignal size xs) + (toStorableSignal size ys) + +{-# INLINE concat #-} +-- | certainly inefficient because of frequent list deconstruction +concat :: [T a] -> T a +concat = + generate + (msum . + List.map + (\ x -> ListHT.viewL x >>= + \(y,ys) -> viewL y >>= + \(z,zs) -> Just (z,zs:ys)) . + List.init . List.tails) + + +{-# INLINE concatStored #-} +concatStored :: Storable a => + [T a] -> T a +concatStored = concatStoredSize SigSt.defaultChunkSize + +{-# INLINE concatStoredSize #-} +concatStoredSize :: Storable a => + SigSt.ChunkSize -> [T a] -> T a +concatStoredSize size = + fromStorableSignal . + SigSt.concat . + List.map (toStorableSignal size) + +{-# INLINE reverse #-} +reverse :: + T a -> T a +reverse = + fromList . List.reverse . toList + +{-# INLINE reverseStored #-} +reverseStored :: Storable a => + T a -> T a +reverseStored = reverseStoredSize SigSt.defaultChunkSize + +{-# INLINE reverseStoredSize #-} +reverseStoredSize :: Storable a => + SigSt.ChunkSize -> T a -> T a +reverseStoredSize size = + fromStorableSignal . + SigSt.reverse . + toStorableSignal size + + +{-# INLINE sum #-} +sum :: (Additive.C a) => T a -> a +sum = foldL' (Additive.+) Additive.zero + +{-# INLINE maximum #-} +maximum :: (Ord a) => T a -> a +maximum = + switchL + (error "StateSignal.maximum: empty list") + (foldL' max) + +{- +{-# INLINE tails #-} +tails :: T y -> [T y] +tails = List.map Cons . List.tails . decons +-} + +{-# INLINE init #-} +init :: T y -> T y +init = + switchL + (error "StateSignal.init: empty list") + (crochetL (\x acc -> Just (acc,x))) + +{-# INLINE sliceVert #-} +-- inefficient since it computes some things twice +sliceVert :: Int -> T y -> [T y] +sliceVert n = +-- map fromList . Sig.sliceVert n . toList + List.map (take n) . List.takeWhile (not . null) . List.iterate (drop n) + +{-# INLINE zapWith #-} +zapWith :: (a -> a -> b) -> T a -> T b +zapWith f = + switchL empty + (crochetL (\y x -> Just (f x y, y))) + +zapWithAlt :: (a -> a -> b) -> T a -> T b +zapWithAlt f xs = + zipWith f xs (switchL empty (curry snd) xs) + +{-# INLINE modifyStatic #-} +modifyStatic :: Modifier.Simple s ctrl a b -> ctrl -> T a -> T b +modifyStatic modif control x = + crochetL + (\a acc -> + Just (runState (Modifier.step modif control a) acc)) + (Modifier.init modif) x + +{-| Here the control may vary over the time. -} +{-# INLINE modifyModulated #-} +modifyModulated :: Modifier.Simple s ctrl a b -> T ctrl -> T a -> T b +modifyModulated modif control x = + crochetL + (\ca acc -> + Just (runState (uncurry (Modifier.step modif) ca) acc)) + (Modifier.init modif) + (zip control x) + + +-- cf. Module.linearComb +{-# INLINE linearComb #-} +linearComb :: + (Module.C t y) => + T t -> T y -> y +linearComb ts ys = + sum $ zipWith (*>) ts ys + + +-- comonadic 'bind' +-- only non-empty suffixes are processed +{-# INLINE mapTails #-} +mapTails :: + (T y0 -> y1) -> T y0 -> T y1 +mapTails f = + generate (\xs -> + do (_,ys) <- viewL xs + return (f xs, ys)) + +-- only non-empty suffixes are processed +{-# INLINE zipWithTails #-} +zipWithTails :: + (y0 -> T y1 -> y2) -> T y0 -> T y1 -> T y2 +zipWithTails f = + curry $ generate (\(xs0,ys0) -> + do (x,xs) <- viewL xs0 + (_,ys) <- viewL ys0 + return (f x ys0, (xs,ys))) + +{- +This can hardly be implemented in an efficient way. +But this means, we cannot implement the Generic.Transform class. + +zipWithRest :: + (y0 -> y0 -> y1) -> + T y0 -> T y0 -> + (T y1, (Bool, T y0)) +zipWithRest f = + curry $ generate (\(xs0,ys0) -> + do (x,xs) <- viewL xs0 + (y,ys) <- viewL ys0 + return (f x y, (xs,ys))) +-} + + +{-# INLINE zipWithAppend #-} +zipWithAppend :: + (y -> y -> y) -> + T y -> T y -> T y +zipWithAppend f = + curry (unfoldR (zipStep f)) + +{-# INLINE zipStep #-} +zipStep :: + (a -> a -> a) -> (T a, T a) -> Maybe (a, (T a, T a)) +zipStep f (xt,yt) = + case (viewL xt, viewL yt) of + (Just (x,xs), Just (y,ys)) -> Just (f x y, (xs,ys)) + (Nothing, Just (y,ys)) -> Just (y, (xt,ys)) + (Just (x,xs), Nothing) -> Just (x, (xs,yt)) + (Nothing, Nothing) -> Nothing + + + +delayLoop :: + (T y -> T y) + -- ^ processor that shall be run in a feedback loop + -> T y -- ^ prefix of the output, its length determines the delay + -> T y +delayLoop proc prefix = + -- the temporary list is need for sharing the output + let ys = fromList (toList prefix List.++ toList (proc ys)) + in ys + +delayLoopOverlap :: + (Additive.C y) => + Int + -> (T y -> T y) + -- ^ processor that shall be run in a feedback loop + -> T y -- ^ input + -> T y -- ^ output has the same length as the input +delayLoopOverlap time proc xs = + -- the temporary list is need for sharing the output + let ys = zipWith (Additive.+) xs (delay zero time (proc (fromList (toList ys)))) + in ys + + +{- +A traversable instance is hardly useful, +because 'cons' is so expensive. + +instance Traversable T where +-} +{-# INLINE sequence_ #-} +sequence_ :: Monad m => T (m a) -> m () +sequence_ = + switchL (return ()) (\x xs -> x >> sequence_ xs) + +{-# INLINE mapM_ #-} +mapM_ :: Monad m => (a -> m ()) -> T a -> m () +mapM_ f = sequence_ . map f + + +{- | +Counterpart to 'Data.Monoid.mconcat'. +-} +monoidConcat :: Monoid m => T m -> m +monoidConcat = foldR mappend mempty + +monoidConcatMap :: Monoid m => (a -> m) -> T a -> m +monoidConcatMap f = monoidConcat . map f + +instance Monoid (T y) where + mempty = empty + mappend = append diff --git a/src/Synthesizer/State/ToneModulation.hs b/src/Synthesizer/State/ToneModulation.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/State/ToneModulation.hs @@ -0,0 +1,233 @@ +module Synthesizer.State.ToneModulation where + +import qualified Synthesizer.Basic.ToneModulation as ToneMod + +import qualified Synthesizer.Causal.Process as Causal +import qualified Synthesizer.Interpolation as Interpolation + +import qualified Synthesizer.Generic.Signal as SigG + +import qualified Synthesizer.State.Signal as SigS + +import qualified Synthesizer.Basic.Phase as Phase + +-- import qualified Algebra.Transcendental as Trans +import qualified Algebra.RealField as RealField +-- import qualified Algebra.Field as Field +-- import qualified Algebra.Real as Real +-- import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Data.Ord.HT (limit, ) + +import NumericPrelude +-- import qualified Prelude as P +import PreludeBase +import Prelude () + + +type Cell sig y = SigS.T (sig y) + +-- cells are organised in a transposed style, when compared with Plain.ToneModulation +interpolateCell :: + (SigG.Read sig y) => + Interpolation.T a y -> + Interpolation.T b y -> + (a, b) -> + Cell sig y -> y +interpolateCell ipLeap ipStep (qLeap,qStep) = + Interpolation.func ipLeap qLeap . + SigS.map (Interpolation.func ipStep qStep . SigG.toState) + + + +data Prototype sig a v = + Prototype { + protoMarginLeap, + protoMarginStep :: Interpolation.Margin, + protoIpOffset :: Int, + protoPeriod :: a, + protoPeriodInt :: Int, + protoShapeLimits :: (a,a), + protoSignal :: sig v + } + + +makePrototype :: + (RealField.C a, SigG.Read sig v) => + Interpolation.Margin -> + Interpolation.Margin -> + a -> sig v -> Prototype sig a v +makePrototype marginLeap marginStep period tone = + let periodInt = round period + ipOffset = + ToneMod.interpolationOffset marginLeap marginStep periodInt + len = SigG.length tone + (lower,upper) = + ToneMod.shapeLimits marginLeap marginStep periodInt len + limits = + if lower > upper + then error "min>max" + else + (fromIntegral lower, fromIntegral upper) + + in Prototype { + protoMarginLeap = marginLeap, + protoMarginStep = marginStep, + protoIpOffset = ipOffset, + protoPeriod = period, + protoPeriodInt = periodInt, + protoShapeLimits = limits, + protoSignal = tone + } + +sampledToneCell :: + (RealField.C a, SigG.Transform sig v) => + Prototype sig a v -> a -> Phase.T a -> ((a,a), Cell sig v) +sampledToneCell p shape phase = + let (n, q) = + ToneMod.flattenShapePhase (protoPeriodInt p) (protoPeriod p) + (limit (protoShapeLimits p) shape, phase) + in (q, + SigS.iterate (SigG.drop (protoPeriodInt p)) $ + SigG.drop (n - protoIpOffset p) $ + protoSignal p) + + +-- * lazy oscillator + +{-# DEPRECATED oscillatorCells "This function recomputes the shape and phase signals. Better use Causal.ToneModulation.oscillatorCells" #-} +{- | +This function should not be used, +since it requires recomputation of @shapes@ and @freqs@ lists. +-} +oscillatorCells :: (RealField.C t, SigG.Transform sig y) => + Interpolation.Margin -> + Interpolation.Margin -> + t -> sig y -> (t, SigS.T t) -> (Phase.T t, SigS.T t) -> + SigS.T ((t,t), Cell sig y) +oscillatorCells + marginLeap marginStep period sampledTone shapes freqs = + let periodInt = round period + margin = + ToneMod.interpolationNumber marginLeap marginStep periodInt + ipOffset = + ToneMod.interpolationOffset marginLeap marginStep periodInt + (skips,coords) = + -- unzip requires recomputation + SigS.unzip $ + oscillatorCoords periodInt period + (limitRelativeShapes marginLeap marginStep periodInt shapes) + freqs + in SigS.zipWith + {- + n will be zero within the data body. + It's only needed for extrapolation at the end. + Is it really needed? + -} + (\(k,q) (_n,ptr) -> + (q, makeCell periodInt $ + SigG.drop (checkNonNeg $ periodInt+k) ptr)) + coords $ + SigS.switchL (error "list of pointers must not be empty") (flip const) $ + SigS.scanL + (\ (n,ptr) d -> SigG.dropMarginRem margin (n+d) ptr) + (0, sampledTone) + (SigS.switchL skips + (\s -> SigS.cons (s - (ipOffset + periodInt))) + skips) +{- +*Synthesizer.Generic.ToneModulation> let shapes = [0.3,0.4,0.2::Double]; phases = [0.43,0.72,0.91::Double] +*Synthesizer.Generic.ToneModulation> let marginLeap = Interpolation.Margin 1 3; marginStep = Interpolation.Margin 2 2 +*Synthesizer.Generic.ToneModulation> List.map (Data.Tuple.HT.mapSnd List.transpose) $ ToneMod.oscillatorCells marginLeap marginStep 9 ['a'..'z'] (2.3,shapes) (Phase.fromRepresentative 0.6, phases) +[((0.28888888888888875,0.40000000000000124),["ghijklmnopqrstuvwxyz","pqrstuvwxyz","yz"]),((0.8588888888888888,0.27000000000000046),["bcdefghijklmnopqrstuvwxyz","klmnopqrstuvwxyz","tuvwxyz"]),((0.13888888888888884,0.7500000000000004),["hijklmnopqrstuvwxyz","qrstuvwxyz","z"]),((0.2288888888888887,0.9400000000000017),["ghijklmnopqrstuvwxyz","pqrstuvwxyz","yz"])] +*Synthesizer.Generic.ToneModulation> oscillatorCells marginLeap marginStep 9 ['a'..'z'] (2.3, SigS.fromList shapes) (Phase.fromRepresentative 0.6, SigS.fromList phases) +StateSignal.fromList [((0.4,0.3999999999999999),StateSignal.fromList ["fghijklmnopqrstuvwxyz","opqrstuvwxyz","xyz"]),((0.97,0.2699999999999996),StateSignal.fromList ["abcdefghijklmnopqrstuvwxyz","jklmnopqrstuvwxyz","stuvwxyz"]),((0.25,0.75),StateSignal.fromList ["ghijklmnopqrstuvwxyz","pqrstuvwxyz","yz"])] + +They do only match when input list is large enough +-} + +checkNonNeg :: (Ord a, Additive.C a, Show a) => a -> a +checkNonNeg x = + if x Int -> sig y -> Cell sig y +makeCell periodInt = + SigS.takeWhile (not . SigG.null) . + SigS.iterate (SigG.drop periodInt) + + +oscillatorCoords :: (RealField.C t) => + Int -> t -> + (t, SigS.T t) -> (Phase.T t, SigS.T t) -> + SigS.T (ToneMod.Coords t) +oscillatorCoords periodInt period + (shape0, shapes) (phase, freqs) = + let shapeOffsets = + SigS.scanL + (\(_,s) c -> splitFraction (s+c)) + (splitFraction shape0) shapes + phases = + -- FIXME: could be made without the dangerous irrefutable pattern + let Just (s,ss) = + SigS.viewL $ + SigS.map (\(n,_) -> fromIntegral n / period) $ + shapeOffsets + in freqsToPhases + (Phase.decrement s phase) -- phase - s + `Causal.apply` + (SigS.zipWith (-) freqs ss) + in SigS.zipWith + (\(d,s) p -> (d, ToneMod.flattenShapePhase periodInt period (s,p))) + shapeOffsets + phases + +limitRelativeShapes :: (RealField.C t) => + Interpolation.Margin -> + Interpolation.Margin -> + Int -> (t, SigS.T t) -> (t, SigS.T t) +limitRelativeShapes marginLeap marginStep periodInt = + limitMinRelativeValues $ fromIntegral $ + ToneMod.interpolationOffset marginLeap marginStep periodInt + periodInt + +limitMinRelativeValues :: (Additive.C t, Ord t) => + t -> (t, SigS.T t) -> (t, SigS.T t) +limitMinRelativeValues xMin (x0, xs) = + let x1 = xMin-x0 + in if x1<=zero + then (x0, xs) + else (xMin, + SigS.crochetL + (\x lim -> + let d = x-lim + in Just $ if d>=zero + then (d,zero) else (zero, negate d)) x1 xs) +{- +Test.QuickCheck.test (\x (y,zi) -> let z=List.map abs zi in Data.Tuple.HT.mapSnd SigS.toList (limitMinRelativeValues x (y, SigS.fromList z)) == ToneMod.limitMinRelativeValues (x::Int) y z) +-} + +-- * handling of phases as needed for oscillators + +{-# INLINE freqsToPhases #-} +{- | +Convert a list of phase steps into a list of momentum phases. +phase is a number in the interval [0,1). +freq contains the phase steps. +The last element is omitted. +-} +freqsToPhases :: RealField.C a => + Phase.T a -> Causal.T a (Phase.T a) +freqsToPhases = + Causal.scanL (flip Phase.increment) + +{- | +Like 'freqsToPhases' but the first element is omitted. +-} +{-# INLINE freqsToPhasesSync #-} +freqsToPhasesSync :: RealField.C a => + Phase.T a -> Causal.T a (Phase.T a) +freqsToPhasesSync = + Causal.crochetL + (\f p0 -> let p1 = Phase.increment f p0 in Just (p1,p1)) diff --git a/src/Synthesizer/Storable/Cut.hs b/src/Synthesizer/Storable/Cut.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Storable/Cut.hs @@ -0,0 +1,137 @@ +module Synthesizer.Storable.Cut where + +import qualified Synthesizer.Storable.Signal as Sig + +import qualified Data.StorableVector.Lazy as SVL +import qualified Data.StorableVector.ST.Strict as SVST + +import Control.Monad.ST.Strict (ST, runST, ) + +import qualified Data.EventList.Relative.TimeBody as EventList +import qualified Data.EventList.Relative.TimeMixed as EventListTM +import qualified Data.EventList.Absolute.TimeBody as AbsEventList +import Control.Monad.Trans.State (runState, modify, gets, put, ) +-- import Control.Monad (mapM, ) +import Data.Tuple.HT (mapSnd, ) + +-- import qualified Algebra.Real as Real +import qualified Algebra.Additive as Additive +import qualified Number.NonNegative as NonNeg + +import Foreign.Storable (Storable) + +import PreludeBase +import NumericPrelude + + +{- | +ChunkSize is only required for zero padding. +-} +{-# INLINE arrange #-} +arrange :: (Storable v, Additive.C v) => + Sig.ChunkSize + -> EventList.T NonNeg.Int (Sig.T v) + {-^ A list of pairs: (relative start time, signal part), + The start time is relative to the start time + of the previous event. -} + -> Sig.T v + {-^ The mixed signal. -} +arrange size = + uncurry Sig.append . + flip runState Sig.empty . + fmap (Sig.concat . EventList.getTimes) . + EventList.mapM + (\timeNN -> + let time = NonNeg.toNumber timeNN + in do (prefix,suffix) <- gets (Sig.splitAtPad size time) + put suffix + return prefix) + (\body -> + modify (Sig.mix body)) + + +arrangeList :: (Storable v, Additive.C v) => + Sig.ChunkSize + -> EventList.T NonNeg.Int (Sig.T v) + {-^ A list of pairs: (relative start time, signal part), + The start time is relative to the start time + of the previous event. -} + -> Sig.T v + {-^ The mixed signal. -} +arrangeList size evs = + let xs = EventList.getBodies evs + in case EventList.getTimes evs of + t:ts -> Sig.replicate size (NonNeg.toNumber t) zero `Sig.append` + addShiftedMany size ts xs + [] -> Sig.empty + + +addShiftedMany :: (Storable a, Additive.C a) => + Sig.ChunkSize -> [NonNeg.Int] -> [Sig.T a] -> Sig.T a +addShiftedMany size ds xss = + foldr (uncurry (addShifted size)) Sig.empty (zip (ds++[0]) xss) + + +{- +It is crucial that 'mix' uses the chunk size structure of the second operand. +This way we avoid unnecessary and even infinite look-ahead. +-} +addShifted :: (Storable a, Additive.C a) => + Sig.ChunkSize -> NonNeg.Int -> Sig.T a -> Sig.T a -> Sig.T a +addShifted size delNN px py = + let del = NonNeg.toNumber delNN + in uncurry Sig.append $ + mapSnd (flip Sig.mix py) $ + Sig.splitAtPad size del px + + +{- | +The result is a Lazy StorableVector with chunks of the given size. +-} +{-# INLINE arrangeEquidist #-} +arrangeEquidist :: (Storable v, Additive.C v) => + Sig.ChunkSize + -> EventList.T NonNeg.Int (Sig.T v) + {-^ A list of pairs: (relative start time, signal part), + The start time is relative to the start time + of the previous event. -} + -> Sig.T v + {-^ The mixed signal. -} +arrangeEquidist (SVL.ChunkSize sz) = + let sznn = NonNeg.fromNumberMsg "arrangeEquidist" sz + go acc evs = + let (now,future) = EventListTM.splitAtTime sznn evs + xs = + AbsEventList.toPairList $ + EventList.toAbsoluteEventList 0 $ + EventListTM.switchTimeR (const) now + (chunk,newAcc) = + runST + (do v <- SVST.new sz zero + newAcc0 <- mapM (addToBuffer v 0) acc +-- newAcc1 <- AbsEventList.mapM (addToBuffer v) xs + newAcc1 <- + mapM (\(i,s) -> addToBuffer v (NonNeg.toNumber i) s) xs + vf <- SVST.freeze v + return + (vf, filter (not . Sig.null) (newAcc0++newAcc1))) + in chunk : go newAcc future + in Sig.fromChunks . go [] + + + +addToBuffer :: (Storable a, Additive.C a) => + SVST.Vector s a -> Int -> Sig.T a -> ST s (Sig.T a) +addToBuffer v start = + let n = SVST.length v + {-# INLINE go #-} + go i = + if i>=n + then return + else + Sig.switchL + (return Sig.empty) + (\x xs -> + SVST.modify v i (x Additive.+) >> + go (succ i) xs) + in go start diff --git a/src/Synthesizer/Storable/Oscillator.hs b/src/Synthesizer/Storable/Oscillator.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Storable/Oscillator.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{- | +Copyright : (c) Henning Thielemann 2006 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +Tone generators +-} +module Synthesizer.Storable.Oscillator where + +import qualified Synthesizer.Basic.Wave as Wave +import qualified Synthesizer.Basic.Phase as Phase + +import qualified Synthesizer.Storable.Signal as Signal +import Synthesizer.Storable.Signal (ChunkSize) +import Foreign.Storable (Storable) + +-- import qualified Synthesizer.Plain.Interpolation as Interpolation + +{- +import qualified Algebra.RealTranscendental as RealTrans +import qualified Algebra.Module as Module +import qualified Algebra.VectorSpace as VectorSpace + +import Algebra.Module((*>)) +-} +import qualified Algebra.Transcendental as Trans +import qualified Algebra.RealField as RealField +-- import qualified Algebra.Field as Field +-- import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import NumericPrelude + +import qualified Prelude as P +import PreludeBase + + + +{- * Oscillators with arbitrary but constant waveforms -} + +{-# INLINE freqToPhase #-} +{- | Convert a list of phase steps into a list of momentum phases + phase is a number in the interval [0,1) + freq contains the phase steps -} +freqToPhase :: (RealField.C a, Storable a) => + Phase.T a -> Signal.T a -> Signal.T (Phase.T a) +freqToPhase phase freq = Signal.scanL (flip Phase.increment) phase freq + + +{-# INLINE static #-} +{-# SPECULATE static :: Storable b => ChunkSize -> (Double -> b) -> (Double -> Double -> Signal.T b) #-} +{- | oscillator with constant frequency -} +static :: (RealField.C a, Storable a, Storable b) => + ChunkSize -> Wave.T a b -> (Phase.T a -> a -> Signal.T b) +static size wave phase freq = + Signal.map (Wave.apply wave) (Signal.iterate size (Phase.increment freq) phase) + +{- | oscillator with modulated phase -} +phaseMod :: (RealField.C a, Storable a, Storable b) => + ChunkSize -> Wave.T a b -> a -> Signal.T a -> Signal.T b +phaseMod size wave = shapeMod size (Wave.phaseOffset wave) zero + +{-# ONLINE shapeMod #-} +{- | oscillator with modulated shape -} +shapeMod :: (RealField.C a, Storable a, Storable b, Storable c) => + ChunkSize -> (c -> Wave.T a b) -> Phase.T a -> a -> Signal.T c -> Signal.T b +shapeMod size wave phase freq parameters = + Signal.zipWith (Wave.apply . wave) parameters + (Signal.iterate size (Phase.increment freq) phase) + +{- | oscillator with modulated frequency -} +freqMod :: (RealField.C a, Storable a, Storable b) => + ChunkSize -> Wave.T a b -> Phase.T a -> Signal.T a -> Signal.T b +freqMod _size wave phase freqs = + Signal.map (Wave.apply wave) (freqToPhase phase freqs) + +{- | oscillator with both phase and frequency modulation -} +phaseFreqMod :: (RealField.C a, Storable a, Storable b) => + ChunkSize -> Wave.T a b -> Signal.T a -> Signal.T a -> Signal.T b +phaseFreqMod size wave = + shapeFreqMod size (Wave.phaseOffset wave) zero + +{- | oscillator with both shape and frequency modulation -} +shapeFreqMod :: (RealField.C a, Storable a, Storable b, Storable c) => + ChunkSize -> (c -> Wave.T a b) -> + Phase.T a -> Signal.T c -> Signal.T a -> Signal.T b +shapeFreqMod _size wave phase parameters freqs = + Signal.zipWith (Wave.apply . wave) parameters (freqToPhase phase freqs) + + +{- +{- | oscillator with a sampled waveform with constant frequency + This essentially an interpolation with cyclic padding. -} +staticSample :: RealField.C a => Interpolation.T a b -> Signal.T b -> a -> a -> Signal.T b +staticSample ip wave phase freq = + freqModSample ip wave phase (repeat freq) + +{- | oscillator with a sampled waveform with modulated frequency + Should behave homogenously for different types of interpolation. -} +freqModSample :: RealField.C a => Interpolation.T a b -> Signal.T b -> a -> Signal.T a -> Signal.T b +freqModSample ip wave phase freqs = + let len = fromIntegral (length wave) + in Interpolation.multiRelativeCyclicPad + ip (phase*len) (Signal.map (*len) freqs) wave +-} + + + +{- * Oscillators with specific waveforms -} + +{-# INLINE staticSine #-} +{-# SPECULATE staticSine :: ChunkSize -> Double -> Double -> Signal.T Double #-} +{- | sine oscillator with static frequency -} +staticSine :: (Trans.C a, RealField.C a, Storable a) => + ChunkSize -> Phase.T a -> a -> Signal.T a +staticSine size = static size Wave.sine + +{-# INLINE freqModSine #-} +{-# SPECULATE freqModSine :: ChunkSize -> Double -> Signal.T Double -> Signal.T Double #-} +{- | sine oscillator with modulated frequency -} +freqModSine :: (Trans.C a, RealField.C a, Storable a) => + ChunkSize -> Phase.T a -> Signal.T a -> Signal.T a +freqModSine size = freqMod size Wave.sine + +{-# INLINE phaseModSine #-} +{-# SPECULATE phaseModSine :: ChunkSize -> Double -> Signal.T Double -> Signal.T Double #-} +{- | sine oscillator with modulated phase, useful for FM synthesis -} +phaseModSine :: (Trans.C a, RealField.C a, Storable a) => + ChunkSize -> a -> Signal.T a -> Signal.T a +phaseModSine size = phaseMod size Wave.sine + +{-# INLINE staticSaw #-} +{-# SPECULATE staticSaw :: ChunkSize -> Double -> Double -> Signal.T Double #-} +{- | saw tooth oscillator with modulated frequency -} +staticSaw :: (RealField.C a, Storable a) => + ChunkSize -> Phase.T a -> a -> Signal.T a +staticSaw size = static size Wave.saw + +{-# INLINE freqModSaw #-} +{-# SPECULATE freqModSaw :: ChunkSize -> Double -> Signal.T Double -> Signal.T Double #-} +{- | saw tooth oscillator with modulated frequency -} +freqModSaw :: (RealField.C a, Storable a) => + ChunkSize -> Phase.T a -> Signal.T a -> Signal.T a +freqModSaw size = freqMod size Wave.saw + + +{- Test whether Fusion takes place. +For the following code the simplifier can't resist! + +testLength :: (Storable a, Enum a) => a -> Int +testLength x = + Signal.length (Signal.map succ (Signal.fromList (Signal.ChunkSize 100) [x,x,x])) +-} diff --git a/src/Synthesizer/Storable/Signal.hs b/src/Synthesizer/Storable/Signal.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Storable/Signal.hs @@ -0,0 +1,1271 @@ +{- OPTIONS_GHC -fglasgow-exts -} +{- glasgow-exts are for the rules -} +{- | +Chunky signal stream build on StorableVector. + +Hints for fusion: + - Higher order functions should always be inlined in the end + in order to turn them into machine loops + instead of calling a function in an inner loop. +-} +module Synthesizer.Storable.Signal ( + T, + Vector.hPut, + ChunkSize, Vector.chunkSize, defaultChunkSize, + -- for Storable.Oscillator + scanL, + Vector.map, + Vector.iterate, + Vector.zipWith, + -- for State.Signal + Vector.append, + Vector.concat, + Vector.span, + Vector.splitAt, + Vector.viewL, + Vector.viewR, + Vector.switchL, + Vector.unfoldr, + Vector.reverse, + Vector.crochetL, + -- for Dimensional.File + Vector.writeFile, + -- for Storable.Cut + splitAtPad, + Vector.null, + Vector.fromChunks, + -- for Storable.Filter.Comb + delay, + delayLoop, + delayLoopOverlap, + -- for FusionTest + mix, mixSize, + Vector.empty, + Vector.replicate, + Vector.repeat, + Vector.drop, + Vector.take, + takeCrochet, + fromList, + appendFromFusionList, + appendFusionList, + -- for Generic.Signal + zipWithRest, + zipWithAppend, + -- for Storable.ALSA.MIDI + Vector.switchR, + + -- just for fun + fromFusionList, + genericLength, + ) where + +-- import qualified Sound.Signal as Signal + +import qualified Synthesizer.FusionList.Signal as FList + +import qualified Data.List as List +import qualified Data.StorableVector.Lazy as Vector +import qualified Data.StorableVector as V +import Data.StorableVector.Lazy (ChunkSize(..)) + +-- import Data.Maybe (Maybe(Just,Nothing), maybe, fromMaybe) + +-- import Data.StorableVector(Vector) +import Foreign.Storable (Storable) + +-- import qualified Synthesizer.Format as Format + +-- import Control.Arrow ((***)) +-- import Control.Monad (liftM, liftM2, {- guard, -} ) + +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive +import qualified Algebra.ToInteger as ToInteger + +import qualified Number.NonNegativeChunky as Chunky +import qualified Number.NonNegative as NonNeg + +import qualified Data.List.HT as ListHT +import Data.Maybe.HT (toMaybe, ) +import Data.Tuple.HT (mapFst, mapSnd, mapPair, forcePair, ) + +-- import qualified Algebra.Additive as Additive + + +-- import System.IO (openBinaryFile, hClose, hPutBuf, IOMode(WriteMode), Handle) + + +import NumericPrelude +import PreludeBase +import Prelude () + + +{- +import NumericPrelude + (sum, (+), (-), divMod, fromIntegral, fromInteger, toInteger, isZero, zero, ) + +import Prelude hiding + (length, (++), iterate, foldl, map, repeat, replicate, null, + zip, zipWith, zipWith3, drop, take, splitAt, takeWhile, reverse) +-} + +{- +import qualified Prelude as P +import Prelude + (IO, ($), (.), fst, snd, id, + Int, Double, Float, + Char, Num, Show, showsPrec, FilePath, + Bool(True,False), not, + flip, curry, uncurry, + Ord, (<), (>), (<=), {- (>=), (==), -} min, max, + mapM_, fmap, (=<<), return, + Enum, succ, pred, ) +-} + + +-- this form is needed for Storable signal embed in amplitude signal +type T = Vector.Vector +-- type T a = Vector.Vector a + +instance (Show a, Storable a) => Show (Vector.Vector a) where + showsPrec p = showsPrec p . Vector.unpack + +{- +instance (Storable a) => Format.C T where + format = showsPrec +-} + + +defaultChunkSize :: ChunkSize +defaultChunkSize = ChunkSize 1024 + + +{- +{- * Helper functions for StorableVector -} + +cancelNullVector :: (Vector a, b) -> Maybe (Vector a, b) +cancelNullVector y = + toMaybe (not (Vector.null (fst y))) y + +viewLVector :: Storable a => + Vector a -> Maybe (a, Vector a) +viewLVector = Vector.viewL +{- + toMaybe + (not (Vector.null x)) + (Vector.head x, Vector.tail x) +-} + +crochetLVector :: (Storable x, Storable y) => + (x -> acc -> Maybe (y, acc)) + -> acc + -> Vector x + -> (Vector y, Maybe acc) +crochetLVector f acc0 x0 = + mapSnd (fmap fst) $ + Vector.unfoldrN + (Vector.length x0) + (\(acc,xt) -> + do (x,xs) <- viewLVector xt + (y,acc') <- f x acc + return (y, (acc',xs))) + (acc0, x0) + +reduceLVector :: Storable x => + (x -> acc -> Maybe acc) -> acc -> Vector x -> (acc, Bool) +reduceLVector f acc0 x = + let recourse i acc = + if i < Vector.length x + then (acc, True) + else + maybe + (acc, False) + (recourse (succ i)) + (f (Vector.index x i) acc) + in recourse 0 acc0 + + + + +{- * Fundamental functions -} + +{- | +Sophisticated implementation where chunks always have size bigger than 0. +-} +{-# INLINE [0] unfoldr #-} +unfoldr :: (Storable b) => + ChunkSize + -> (a -> Maybe (b,a)) + -> a + -> T b +unfoldr (ChunkSize size) f = + Cons . + List.unfoldr + (cancelNullVector . Vector.unfoldrN size f =<<) . + Just + +{- | +Simple implementation where chunks can have size 0 in the first run. +Then they are filtered out. +This separation might reduce laziness. +-} +unfoldr0 :: (Storable b) => + ChunkSize + -> (a -> Maybe (b,a)) + -> a + -> T b +unfoldr0 (ChunkSize size) f = + Cons . + List.filter (not . Vector.null) . + List.unfoldr (fmap (Vector.unfoldrN size f)) . + Just + + +unfoldr1 :: (Storable b) => + ChunkSize + -> (a -> (b, Maybe a)) + -> Maybe a + -> T b +unfoldr1 size f = unfoldr size (liftM f) + +{-# INLINE [0] crochetL #-} +crochetL :: (Storable x, Storable y) => + (x -> acc -> Maybe (y, acc)) + -> acc + -> T x + -> T y +crochetL f acc0 = + Cons . List.unfoldr (\(xt,acc) -> + do (x,xs) <- ListHT.viewL xt + acc' <- acc + return $ mapSnd ((,) xs) $ crochetLVector f acc' x) . + flip (,) (Just acc0) . + decons + +{- +Usage of 'unfoldr' seems to be clumsy but that covers all cases, +like different block sizes in source and destination list. +-} +crochetLSize :: (Storable x, Storable y) => + ChunkSize + -> (x -> acc -> Maybe (y, acc)) + -> acc + -> T x + -> T y +crochetLSize size f = + curry (unfoldr size (\(acc,xt) -> + do (x,xs) <- viewL xt + (y,acc') <- f x acc + return (y, (acc',xs)))) + +viewL :: Storable a => T a -> Maybe (a, T a) +viewL (Cons xs0) = + -- dropWhile would be unnecessary if we require that all chunks are non-empty + do (x,xs) <- ListHT.viewL (List.dropWhile Vector.null xs0) + (y,ys) <- viewLVector x + return (y, append (fromChunk ys) (Cons xs)) + +viewR :: Storable a => T a -> Maybe (T a, a) +viewR (Cons xs0) = + -- dropWhile would be unnecessary if we require that all chunks are non-empty + do (xs,x) <- ListHT.viewR (dropWhileRev Vector.null xs0) + (ys,y) <- Vector.viewR x + return (append (Cons xs) (fromChunk ys), y) + +crochetListL :: (Storable y) => + ChunkSize + -> (x -> acc -> Maybe (y, acc)) + -> acc + -> [x] + -> T y +crochetListL size f = + curry (unfoldr size (\(acc,xt) -> + do (x,xs) <- ListHT.viewL xt + (y,acc') <- f x acc + return (y, (acc',xs)))) +-} + + +{-# INLINE fromList #-} +fromList :: (Storable a) => ChunkSize -> [a] -> T a +fromList = Vector.pack + + +{- +-- should start fusion +fromListCrochetL :: (Storable a) => ChunkSize -> [a] -> T a +fromListCrochetL size = + crochetListL size (\x _ -> Just (x, ())) () + +fromListUnfoldr :: (Storable a) => ChunkSize -> [a] -> T a +fromListUnfoldr size = unfoldr size ListHT.viewL + +fromListPack :: (Storable a) => ChunkSize -> [a] -> T a +fromListPack (ChunkSize size) = + Cons . + List.map Vector.pack . + sliceVert size + +toList :: (Storable a) => T a -> [a] +toList = List.concatMap Vector.unpack . decons + +-- if the chunk has length zero, an empty sequence is generated +fromChunk :: (Storable a) => Vector a -> T a +fromChunk x = + if Vector.null x + then empty + else Cons [x] + + + + +{-# NOINLINE [0] crochetFusionListL #-} +crochetFusionListL :: (Storable y) => + ChunkSize + -> (x -> acc -> Maybe (y, acc)) + -> acc + -> FList.T x + -> T y +crochetFusionListL size f = + curry (unfoldr size (\(acc,xt) -> + do (x,xs) <- FList.viewL xt + (y,acc') <- f x acc + return (y, (acc',xs)))) +-} + +{-# NOINLINE [0] fromFusionList #-} +fromFusionList :: (Storable a) => ChunkSize -> FList.T a -> T a +fromFusionList size = fromList size . FList.toList + -- fromFusionListCrochetL + +{- +{-# INLINE fromFusionListCrochetL #-} +fromFusionListCrochetL :: (Storable a) => ChunkSize -> FList.T a -> T a +fromFusionListCrochetL size = + crochetFusionListL size (\x _ -> Just (x, ())) () + +fromFusionListUnfoldr :: (Storable a) => ChunkSize -> FList.T a -> T a +fromFusionListUnfoldr size = + unfoldr size FList.viewL + + +{-# NOINLINE [0] toFusionList #-} +toFusionList :: (Storable a) => T a -> FList.T a +toFusionList = FList.Cons . List.concatMap Vector.unpack . decons + + +{- | +Converts from and to 'FList.T' +in order to speedup computation, +especially because it tells the optimizer about the 'Storable' constraint +and thus allows for more fusion, +where fusion would break otherwise. +-} +{-# INLINE chop #-} +chop :: (Storable a) => ChunkSize -> FList.T a -> FList.T a +chop size = toFusionList . fromFusionList size + + + +{-# INLINE [0] reduceL #-} +reduceL :: Storable x => + (x -> acc -> Maybe acc) -> acc -> T x -> acc +reduceL f acc0 = + let recourse acc xt = + case xt of + [] -> acc + (x:xs) -> + let (acc',continue) = reduceLVector f acc x + in if continue + then recourse acc' xs + else acc' + in recourse acc0 . decons + + + +{- * Basic functions -} + +empty :: Storable a => T a +empty = Cons [] + +null :: Storable a => T a -> Bool +null = List.null . decons + + +{-# NOINLINE [0] cons #-} +cons :: Storable a => a -> T a -> T a +cons x = Cons . (Vector.singleton x :) . decons + + +length :: T a -> Int +length = sum . List.map Vector.length . decons + + +reverse :: Storable a => T a -> T a +reverse = + Cons . List.reverse . List.map Vector.reverse . decons + + +{-# INLINE [0] foldl #-} +foldl :: Storable b => (a -> b -> a) -> a -> T b -> a +foldl f x0 = List.foldl (Vector.foldl f) x0 . decons + + +{-# INLINE [0] map #-} +map :: (Storable x, Storable y) => + (x -> y) + -> T x + -> T y +map f = mapInline f -- Cons . List.map (Vector.map f) . decons + +{-# INLINE mapInline #-} +mapInline :: (Storable x, Storable y) => + (x -> y) + -> T x + -> T y +mapInline f = + let mapVec = Vector.map f + in Cons . List.map mapVec . decons + + + +{-# NOINLINE [0] drop #-} +drop :: (Storable a) => Int -> T a -> T a +drop _ (Cons []) = empty +drop n (Cons (x:xs)) = + let m = Vector.length x + in if m<=n + then drop (n-m) (Cons xs) + else Cons (Vector.drop n x : xs) + +{-# NOINLINE [0] take #-} +take :: (Storable a) => Int -> T a -> T a +take _ (Cons []) = empty +take 0 _ = empty +take n (Cons (x:xs)) = + let m = Vector.length x + in if m<=n + then Cons $ (x:) $ decons $ take (n-m) $ Cons xs + else fromChunk (Vector.take n x) + + + +{-# NOINLINE [0] splitAt #-} +splitAt :: (Storable a) => Int -> T a -> (T a, T a) +splitAt n0 = + let recourse _ [] = ([], []) + recourse 0 xs = ([], xs) + recourse n (x:xs) = + let m = Vector.length x + in if m<=n + then mapFst (x:) $ recourse (n-m) xs + else mapPair ((:[]), (:xs)) $ Vector.splitAt n x + in mapPair (Cons, Cons) . recourse n0 . decons + + +dropMarginRem :: (Storable a) => Int -> Int -> T a -> (Int, T a) +dropMarginRem n m xs = + List.foldl' + (\(mi,xsi) k -> (mi-k, drop k xsi)) + (m,xs) + (List.map Vector.length $ decons $ take m $ drop n xs) + +{- +This implementation does only walk once through the dropped prefix. +It is maximally lazy and minimally space consuming. +-} +dropMargin :: (Storable a) => Int -> Int -> T a -> T a +dropMargin n m xs = + List.foldl' (flip drop) xs + (List.map Vector.length $ decons $ take m $ drop n xs) + + +{-# NOINLINE [0] dropWhile #-} +dropWhile :: (Storable a) => (a -> Bool) -> T a -> T a +dropWhile _ (Cons []) = empty +dropWhile p (Cons (x:xs)) = + let y = Vector.dropWhile p x + in if Vector.null y + then dropWhile p (Cons xs) + else Cons (y:xs) + +{-# NOINLINE [0] takeWhile #-} +takeWhile :: (Storable a) => (a -> Bool) -> T a -> T a +takeWhile _ (Cons []) = empty +takeWhile p (Cons (x:xs)) = + let y = Vector.takeWhile p x + in if Vector.length y < Vector.length x + then fromChunk y + else Cons (x : decons (takeWhile p (Cons xs))) + + +{-# NOINLINE [0] span #-} +span :: (Storable a) => (a -> Bool) -> T a -> (T a, T a) +span p = + let recourse [] = ([],[]) + recourse (x:xs) = + let (y,z) = Vector.span p x + in if Vector.null z + then mapFst (x:) (recourse xs) + else (decons $ fromChunk y, (z:xs)) + in mapPair (Cons, Cons) . recourse . decons +{- +span _ (Cons []) = (empty, empty) +span p (Cons (x:xs)) = + let (y,z) = Vector.span p x + in if Vector.length y == 0 + then mapFst (Cons . (x:) . decons) (span p (Cons xs)) + else (Cons [y], Cons (z:xs)) +-} + +concat :: (Storable a) => [T a] -> T a +concat = Cons . List.concat . List.map decons + + +{- | +Ensure a minimal length of the list by appending pad values. +-} +{-# NOINLINE [0] pad #-} +pad :: (Storable a) => ChunkSize -> a -> Int -> T a -> T a +pad size y n0 = + let recourse n xt = + if n<=0 + then xt + else + case xt of + [] -> decons $ replicate size n y + x:xs -> x : recourse (n - Vector.length x) xs + in Cons . recourse n0 . decons + +padAlt :: (Storable a) => ChunkSize -> a -> Int -> T a -> T a +padAlt size x n xs = + append xs + (let m = length xs + in if n>m + then replicate size (n-m) x + else empty) + + +infixr 5 `append` + +{-# NOINLINE [0] append #-} +append :: T a -> T a -> T a +append (Cons xs) (Cons ys) = Cons (xs List.++ ys) +-} + +{-# INLINE appendFromFusionList #-} +appendFromFusionList :: Storable a => + ChunkSize -> FList.T a -> FList.T a -> T a +appendFromFusionList size xs ys = + Vector.append (FList.toStorableSignal size xs) (FList.toStorableSignal size ys) + +{- | +Like 'appendFromFusionList' but returns a 'FList.T' +for more flexible following processing. +-} +{-# INLINE appendFusionList #-} +appendFusionList :: Storable a => + ChunkSize -> FList.T a -> FList.T a -> FList.T a +appendFusionList size xs ys = + FList.fromStorableSignal (appendFromFusionList size xs ys) + + +{- +{-# INLINE iterate #-} +iterate :: Storable a => ChunkSize -> (a -> a) -> a -> T a +iterate size f = unfoldr size (\x -> Just (x, f x)) + +repeat :: Storable a => ChunkSize -> a -> T a +repeat (ChunkSize size) = + Cons . List.repeat . Vector.replicate size + +cycle :: Storable a => T a -> T a +cycle = + Cons . List.cycle . decons + +replicate :: Storable a => ChunkSize -> Int -> a -> T a +replicate (ChunkSize size) n x = + let (numChunks, rest) = divMod n size + in append + (Cons (List.replicate numChunks (Vector.replicate size x))) + (fromChunk (Vector.replicate rest x)) +-} + +{-# INLINE scanL #-} +scanL :: (Storable a, Storable b) => + (a -> b -> a) -> a -> T b -> T a +scanL = Vector.scanl + + +{- +{-# INLINE [0] mapAccumL #-} +mapAccumL :: (Storable a, Storable b) => + (acc -> a -> (acc, b)) -> acc -> T a -> (acc, T b) +mapAccumL f start = + mapSnd Cons . + List.mapAccumL (Vector.mapAccumL f) start . + decons + +{-# INLINE [0] mapAccumR #-} +mapAccumR :: (Storable a, Storable b) => + (acc -> a -> (acc, b)) -> acc -> T a -> (acc, T b) +mapAccumR f start = + mapSnd Cons . + List.mapAccumR (Vector.mapAccumR f) start . + decons + +{-# RULEZ + "Storable.append/repeat/repeat" forall size x. + append (repeat size x) (repeat size x) = repeat size x ; + + "Storable.append/repeat/replicate" forall size n x. + append (repeat size x) (replicate size n x) = repeat size x ; + + "Storable.append/replicate/repeat" forall size n x. + append (replicate size n x) (repeat size x) = repeat size x ; + + "Storable.append/replicate/replicate" forall size n m x. + append (replicate size n x) (replicate size m x) = + replicate size (n+m) x ; + + "Storable.mix/repeat/repeat" forall size x y. + mix (repeat size x) (repeat size y) = repeat size (x+y) ; + + #-} + +{-# RULES + "Storable.length/cons" forall x xs. + length (cons x xs) = 1 + length xs ; + + "Storable.length/map" forall f xs. + length (map f xs) = length xs ; + + "Storable.map/cons" forall f x xs. + map f (cons x xs) = cons (f x) (map f xs) ; + + "Storable.map/repeat" forall size f x. + map f (repeat size x) = repeat size (f x) ; + + "Storable.map/replicate" forall size f x n. + map f (replicate size n x) = replicate size n (f x) ; + + "Storable.map/repeat" forall size f x. + map f (repeat size x) = repeat size (f x) ; + + {- + This can make things worse, if 'map' is applied to replicate, + since this can use of sharing. + It can also destroy the more important map/unfoldr fusion in + take n . map f . unfoldr g + + "Storable.take/map" forall n f x. + take n (map f x) = map f (take n x) ; + -} + + "Storable.take/repeat" forall size n x. + take n (repeat size x) = replicate size n x ; + + "Storable.take/take" forall n m xs. + take n (take m xs) = take (min n m) xs ; + + "Storable.drop/drop" forall n m xs. + drop n (drop m xs) = drop (n+m) xs ; + + "Storable.drop/take" forall n m xs. + drop n (take m xs) = take (max 0 (m-n)) (drop n xs) ; + + "Storable.map/mapAccumL/snd" forall g f acc0 xs. + map g (snd (mapAccumL f acc0 xs)) = + snd (mapAccumL (\acc a -> mapSnd g (f acc a)) acc0 xs) ; + + #-} + +{- GHC says this is an orphaned rule + "Storable.map/mapAccumL/mapSnd" forall g f acc0 xs. + mapSnd (map g) (mapAccumL f acc0 xs) = + mapAccumL (\acc a -> mapSnd g (f acc a)) acc0 xs ; +-} +-} + +{-# SPECULATE mix :: T Double -> T Double -> T Double #-} +{-# SPECULATE mix :: T Float -> T Float -> T Float #-} +{-# SPECULATE mix :: T (Double,Double) -> T (Double,Double) -> T (Double,Double) #-} +{-# SPECULATE mix :: T (Float,Float) -> T (Float,Float) -> T (Float,Float) #-} +{- +'mix' is more efficient +since it appends the rest of the longer signal without copying. +It also preserves the chunk structure of the second signal, +which is essential if you want to limit look-ahead. +-} +mix :: (Additive.C x, Storable x) => + T x + -> T x + -> T x +mix = zipWithAppend (+) +{- +List.map V.unpack $ Vector.chunks $ mix (fromList defaultChunkSize [1,2,3,4,5::P.Double]) (fromList defaultChunkSize [1,2,3,4]) +-} + +zipWithAppend :: + (Storable x) => + (x -> x -> x) -> + T x -> T x -> T x +zipWithAppend f xs ys = + uncurry Vector.append $ mapSnd snd $ zipWithRest f xs ys + +zipWithRest :: + (Storable c, Storable x) => + (x -> x -> c) -> + T x -> + T x -> + (Vector.Vector c, (Bool, T x)) +zipWithRest f xs ys = + let len = min (lazyLength xs) (lazyLength ys) :: Chunky.T NonNeg.Int + (prefixX,suffixX) = genericSplitAt len xs + (prefixY,suffixY) = genericSplitAt len ys + second = Vector.null suffixX + in (Vector.zipWith f prefixX prefixY, + (second, if second then suffixY else suffixX)) + +{- +We should move that to StorableVector package, +but we cannot, since that's Haskell 98. +-} +genericSplitAt :: + (Additive.C i, Ord i, ToInteger.C i, Storable x) => + i -> T x -> (T x, T x) +genericSplitAt n0 = + let recourse n xs0 = + forcePair $ + maybe + ([], []) + (\(x,xs) -> + if isZero n + then ([], xs0) + else + let m = fromIntegral $ V.length x + in if m<=n + then mapFst (x:) $ recourse (n-m) xs + else mapPair ((:[]), (:xs)) $ + V.splitAt (fromInteger $ toInteger n) x) + $ ListHT.viewL xs0 + in mapPair (Vector.fromChunks, Vector.fromChunks) . + recourse n0 . Vector.chunks + + +-- cf. Data.StorableVector.Lazy.Pattern.length +lazyLength :: (Ring.C i) => + T x -> i +lazyLength = + List.foldr (+) zero . List.map (fromIntegral . V.length) . Vector.chunks + +genericLength :: (Ring.C i) => + T x -> i +genericLength = + sum . List.map (fromIntegral . V.length) . Vector.chunks + + +splitAtPad :: + (Additive.C x, Storable x) => + ChunkSize -> Int -> T x -> (T x, T x) +splitAtPad size n = + mapFst (Vector.pad size Additive.zero n) . Vector.splitAt n + + +{-# SPECULATE mixSize :: ChunkSize -> T Double -> T Double -> T Double #-} +{-# SPECULATE mixSize :: ChunkSize -> T Float -> T Float -> T Float #-} +{-# SPECULATE mixSize :: ChunkSize -> T (Double,Double) -> T (Double,Double) -> T (Double,Double) #-} +{-# SPECULATE mixSize :: ChunkSize -> T (Float,Float) -> T (Float,Float) -> T (Float,Float) #-} +{-# INLINE mixSize #-} +mixSize :: (Additive.C x, Storable x) => + ChunkSize + -> T x + -> T x + -> T x +mixSize size = + curry (Vector.unfoldr size mixStep) + + +{-# INLINE mixStep #-} +mixStep :: (Additive.C x, Storable x) => + (T x, T x) -> + Maybe (x, (T x, T x)) +mixStep (xt,yt) = + case (Vector.viewL xt, Vector.viewL yt) of + (Just (x,xs), Just (y,ys)) -> Just (x+y, (xs,ys)) + (Nothing, Just (y,ys)) -> Just (y, (xt,ys)) + (Just (x,xs), Nothing) -> Just (x, (xs,yt)) + (Nothing, Nothing) -> Nothing + + + +{-# INLINE delay #-} +delay :: (Storable y) => + ChunkSize -> y -> Int -> T y -> T y +delay size z n = Vector.append (Vector.replicate size n z) + +{-# INLINE delayLoop #-} +delayLoop :: + (Storable y) => + (T y -> T y) + -- ^ processor that shall be run in a feedback loop + -> T y -- ^ prefix of the output, its length determines the delay + -> T y +delayLoop proc prefix = + let ys = Vector.append prefix (proc ys) + in ys + + +{-# INLINE delayLoopOverlap #-} +delayLoopOverlap :: + (Additive.C y, Storable y) => + Int + -> (T y -> T y) + {- ^ Processor that shall be run in a feedback loop. + It's absolutely necessary that this function preserves the chunk structure + and that it does not look a chunk ahead. + That's guaranteed for processes that do not look ahead at all, + like 'Vector.map', 'Vector.crochetL' and + all of type @Causal.Process@. -} + -> T y -- ^ input + -> T y -- ^ output has the same length as the input +delayLoopOverlap time proc xs = + let ys = Vector.zipWith (Additive.+) xs + (delay (Vector.chunkSize time) Additive.zero time (proc ys)) + in ys + + + +{- +{-# INLINE zip #-} +zip :: (Storable a, Storable b) => + ChunkSize -> (T a -> T b -> T (a,b)) +zip size = zipWith size (,) + +{-# INLINE zipWith3 #-} +zipWith3 :: (Storable a, Storable b, Storable c, Storable d) => + ChunkSize -> (a -> b -> c -> d) -> (T a -> T b -> T c -> T d) +zipWith3 size f s0 s1 = + zipWith size (uncurry f) (zip size s0 s1) + +{-# INLINE zipWith4 #-} +zipWith4 :: (Storable a, Storable b, Storable c, Storable d, Storable e) => + ChunkSize -> (a -> b -> c -> d -> e) -> (T a -> T b -> T c -> T d -> T e) +zipWith4 size f s0 s1 = + zipWith3 size (uncurry f) (zip size s0 s1) + + +{- * Fusable functions -} + +{-# INLINE [0] zipWith #-} +zipWith :: (Storable x, Storable y, Storable z) => + ChunkSize + -> (x -> y -> z) + -> T x + -> T y + -> T z +zipWith size f = + curry (unfoldr size (\(xt,yt) -> + liftM2 + (\(x,xs) (y,ys) -> (f x y, (xs,ys))) + (viewL xt) + (viewL yt))) + + + +scanLCrochet :: (Storable a, Storable b) => + (a -> b -> a) -> a -> T b -> T a +scanLCrochet f start = + cons start . + crochetL (\x acc -> let y = f acc x in Just (y, y)) start + +{-# INLINE mapCrochet #-} +mapCrochet :: (Storable a, Storable b) => (a -> b) -> (T a -> T b) +mapCrochet f = crochetL (\x _ -> Just (f x, ())) () +-} + +{-# INLINE takeCrochet #-} +takeCrochet :: Storable a => Int -> T a -> T a +takeCrochet = Vector.crochetL (\x n -> toMaybe (n>0) (x, pred n)) + +{- +{-# INLINE repeatUnfoldr #-} +repeatUnfoldr :: Storable a => ChunkSize -> a -> T a +repeatUnfoldr size = iterate size id + +{-# INLINE replicateCrochet #-} +replicateCrochet :: Storable a => ChunkSize -> Int -> a -> T a +replicateCrochet size n = takeCrochet n . repeat size + + + +{- +crochetFusionListLGenerate size g b f a = + unfoldr size (\(a0,b0) -> + do (y0,a1) <- f a0 + (z0,b1) <- g y0 b0 + Just (z0, (a1,b1))) (a,b) ; + +-} + + +{-# RULES + "Storable.crochetFusionListL/crochetL" forall size f g a b x. + crochetFusionListL size g b (FList.crochetL f a x) = + crochetFusionListL size (\x0 (a0,b0) -> + do (y0,a1) <- f x0 a0 + (z0,b1) <- g y0 b0 + Just (z0, (a1,b1))) (a,b) x ; + + "Storable.crochetFusionListL/generate" forall size f g a b. + crochetFusionListL size g b (FList.generate f a) = + unfoldr size (\(a0,b0) -> + do (y0,a1) <- f a0 + (z0,b1) <- g y0 b0 + Just (z0, (a1,b1))) (a,b) ; + +{- + "Storable.fromFusionList/crochetL" + forall size f a (x :: Storable a => FList.T a) . + fromFusionList size (FList.crochetL f a x) = + crochetL f a (fromFusionList size x) ; +-} + + "Storable.fromFusionList/generate" forall size f a. + fromFusionList size (FList.generate f a) = + unfoldr size f a ; + + "Storable.fromFusionList/cons" forall size x xs. + fromFusionList size (FList.cons x xs) = + cons x (fromFusionList size xs) ; + + "Storable.fromFusionList/empty" forall size. + fromFusionList size (FList.empty) = + empty ; + + "Storable.fromFusionList/append" forall size xs ys. + fromFusionList size (FList.append xs ys) = + append (fromFusionList size xs) (fromFusionList size ys) ; + + "Storable.fromFusionList/maybe" forall size f x y. + fromFusionList size (maybe x f y) = + maybe (fromFusionList size x) + (fromFusionList size . f) y ; + + "Storable.fromFusionList/fromMaybe" forall size x y. + fromFusionList size (fromMaybe x y) = + maybe (fromFusionList size x) (fromFusionList size) y ; + #-} + + +{- +The "fromList/drop" rule is not quite accurate +because the chunk borders are moved. +Maybe 'ChunkSize' better is a list of chunks sizes. +-} + +{-# RULEZ + "fromList/zipWith" + forall size f (as :: Storable a => [a]) (bs :: Storable a => [a]). + fromList size (List.zipWith f as bs) = + zipWith size f (fromList size as) (fromList size bs) ; + + "fromList/drop" forall as n size. + fromList size (List.drop n as) = + drop n (fromList size as) ; + #-} + + + +{- * Fused functions -} + +type Unfoldr s a = (s -> Maybe (a,s), s) + +{-# INLINE zipWithUnfoldr2 #-} +zipWithUnfoldr2 :: Storable z => + ChunkSize + -> (x -> y -> z) + -> Unfoldr a x + -> Unfoldr b y + -> T z +zipWithUnfoldr2 size h (f,a) (g,b) = + unfoldr size + (\(a0,b0) -> liftM2 (\(x,a1) (y,b1) -> (h x y, (a1,b1))) (f a0) (g b0)) +-- (uncurry (liftM2 (\(x,a1) (y,b1) -> (h x y, (a1,b1)))) . (f *** g)) + (a,b) + +{- done by takeCrochet +{-# INLINE mapUnfoldr #-} +mapUnfoldr :: (Storable x, Storable y) => + ChunkSize + -> (x -> y) + -> Unfoldr a x + -> T y +mapUnfoldr size g (f,a) = + unfoldr size (fmap (mapFst g) . f) a +-} + +{-# INLINE dropUnfoldr #-} +dropUnfoldr :: Storable x => + ChunkSize + -> Int + -> Unfoldr a x + -> T x +dropUnfoldr size n (f,a0) = + maybe + empty + (unfoldr size f) + (nest n (\a -> fmap snd . f =<< a) (Just a0)) + + +{- done by takeCrochet +{-# INLINE takeUnfoldr #-} +takeUnfoldr :: Storable x => + ChunkSize + -> Int + -> Unfoldr a x + -> T x +takeUnfoldr size n0 (f,a0) = + unfoldr size + (\(a,n) -> + do guard (n>0) + (x,a') <- f a + return (x, (a', pred n))) + (a0,n0) +-} + + +lengthUnfoldr :: Storable x => + Unfoldr a x + -> Int +lengthUnfoldr (f,a0) = + let recourse n a = + maybe n (recourse (succ n) . snd) (f a) + in recourse 0 a0 + + +{-# INLINE zipWithUnfoldr #-} +zipWithUnfoldr :: + (Storable b, Storable c) => + (acc -> Maybe (a, acc)) + -> (a -> b -> c) + -> acc + -> T b -> T c +zipWithUnfoldr f h a y = + crochetL (\y0 a0 -> + do (x0,a1) <- f a0 + Just (h x0 y0, a1)) a y + +{-# INLINE zipWithCrochetL #-} +zipWithCrochetL :: + (Storable x, Storable b, Storable c) => + ChunkSize + -> (x -> acc -> Maybe (a, acc)) + -> (a -> b -> c) + -> acc + -> T x -> T b -> T c +zipWithCrochetL size f h a x y = + crochetL (\(x0,y0) a0 -> + do (z0,a1) <- f x0 a0 + Just (h z0 y0, a1)) + a (zip size x y) + + +{-# INLINE crochetLCons #-} +crochetLCons :: + (Storable a, Storable b) => + (a -> acc -> Maybe (b, acc)) + -> acc + -> a -> T a -> T b +crochetLCons f a0 x xs = + maybe + empty + (\(y,a1) -> cons y (crochetL f a1 xs)) + (f x a0) + +{-# INLINE reduceLCons #-} +reduceLCons :: + (Storable a) => + (a -> acc -> Maybe acc) + -> acc + -> a -> T a -> acc +reduceLCons f a0 x xs = + maybe a0 (flip (reduceL f) xs) (f x a0) + + + + + +{-# RULES + "Storable.zipWith/share" forall size (h :: a->a->b) (x :: T a). + zipWith size h x x = map (\xi -> h xi xi) x ; + +-- "Storable.map/zipWith" forall size (f::c->d) (g::a->b->c) (x::T a) (y::T b). + "Storable.map/zipWith" forall size f g x y. + map f (zipWith size g x y) = + zipWith size (\xi yi -> f (g xi yi)) x y ; + + -- this rule lets map run on a different block structure + "Storable.zipWith/map,*" forall size f g x y. + zipWith size g (map f x) y = + zipWith size (\xi yi -> g (f xi) yi) x y ; + + "Storable.zipWith/*,map" forall size f g x y. + zipWith size g x (map f y) = + zipWith size (\xi yi -> g xi (f yi)) x y ; + + + "Storable.drop/unfoldr" forall size f a n. + drop n (unfoldr size f a) = + dropUnfoldr size n (f,a) ; + + "Storable.take/unfoldr" forall size f a n. + take n (unfoldr size f a) = +-- takeUnfoldr size n (f,a) ; + takeCrochet n (unfoldr size f a) ; + + "Storable.length/unfoldr" forall size f a. + length (unfoldr size f a) = lengthUnfoldr (f,a) ; + + "Storable.map/unfoldr" forall size g f a. + map g (unfoldr size f a) = +-- mapUnfoldr size g (f,a) ; + mapCrochet g (unfoldr size f a) ; + + "Storable.map/iterate" forall size g f a. + map g (iterate size f a) = + mapCrochet g (iterate size f a) ; + +{- + "Storable.zipWith/unfoldr,unfoldr" forall sizeA sizeB f g h a b n. + zipWith n h (unfoldr sizeA f a) (unfoldr sizeB g b) = + zipWithUnfoldr2 n h (f,a) (g,b) ; +-} + + -- block boundaries are changed here, so it changes lazy behaviour + "Storable.zipWith/unfoldr,*" forall sizeA sizeB f h a y. + zipWith sizeA h (unfoldr sizeB f a) y = + zipWithUnfoldr f h a y ; + + -- block boundaries are changed here, so it changes lazy behaviour + "Storable.zipWith/*,unfoldr" forall sizeA sizeB f h a y. + zipWith sizeA h y (unfoldr sizeB f a) = + zipWithUnfoldr f (flip h) a y ; + + "Storable.crochetL/unfoldr" forall size f g a b. + crochetL g b (unfoldr size f a) = + unfoldr size (\(a0,b0) -> + do (y0,a1) <- f a0 + (z0,b1) <- g y0 b0 + Just (z0, (a1,b1))) (a,b) ; + + "Storable.reduceL/unfoldr" forall size f g a b. + reduceL g b (unfoldr size f a) = + snd + (FList.recourse (\(a0,b0) -> + do (y,a1) <- f a0 + b1 <- g y b0 + Just (a1, b1)) (a,b)) ; + + "Storable.crochetL/cons" forall g b x xs. + crochetL g b (cons x xs) = + crochetLCons g b x xs ; + + "Storable.reduceL/cons" forall g b x xs. + reduceL g b (cons x xs) = + reduceLCons g b x xs ; + + + + + "Storable.take/crochetL" forall f a x n. + take n (crochetL f a x) = + takeCrochet n (crochetL f a x) ; + + "Storable.length/crochetL" forall f a x. + length (crochetL f a x) = length x ; + + "Storable.map/crochetL" forall g f a x. + map g (crochetL f a x) = + mapCrochet g (crochetL f a x) ; + + "Storable.zipWith/crochetL,*" forall size f h a x y. + zipWith size h (crochetL f a x) y = + zipWithCrochetL size f h a x y ; + + "Storable.zipWith/*,crochetL" forall size f h a x y. + zipWith size h y (crochetL f a x) = + zipWithCrochetL size f (flip h) a x y ; + + "Storable.crochetL/crochetL" forall f g a b x. + crochetL g b (crochetL f a x) = + crochetL (\x0 (a0,b0) -> + do (y0,a1) <- f x0 a0 + (z0,b1) <- g y0 b0 + Just (z0, (a1,b1))) (a,b) x ; + + "Storable.reduceL/crochetL" forall f g a b x. + reduceL g b (crochetL f a x) = + snd + (reduceL (\x0 (a0,b0) -> + do (y,a1) <- f x0 a0 + b1 <- g y b0 + Just (a1, b1)) (a,b) x) ; + #-} + + + +{- * Fusion tests -} + + +fromMapList :: (Storable y) => ChunkSize -> (x -> y) -> [x] -> T y +fromMapList size f = + unfoldr size (fmap (mapFst f) . ListHT.viewL) + +{-# RULES + "Storable.fromList/map" forall size f xs. + fromList size (List.map f xs) = fromMapList size f xs ; + #-} + + +fromMapFusionList :: (Storable y) => + ChunkSize -> (x -> y) -> FList.T x -> T y +fromMapFusionList size f = + unfoldr size (fmap (mapFst f) . FList.viewL) + +{-# RULES + "Storable.fromFusionList/map" forall size f xs. + fromFusionList size (FList.map f xs) = fromMapFusionList size f xs ; + + "Storable.fromFusionList/replicate" forall size n x. + fromFusionList size (FList.replicate n x) = replicate size n x ; + #-} + + + + +testLength :: (Storable a, Enum a) => a -> Int +testLength x = length (map succ (fromList (ChunkSize 100) [x,x,x])) + +testMapZip :: (Storable a, Enum a, Num a) => + ChunkSize -> T a -> T a -> T a +-- testMapZip size x y = map snd (zipWith size (,) x y) +testMapZip size x y = map succ (zipWith size (P.+) x y) + +testMapCons :: (Storable a, Enum a) => + a -> T a -> T a +testMapCons x xs = map succ (cons x xs) + +{-# INLINE testMapIterate #-} +{-# SPECIALISE testMapIterate :: + ChunkSize -> Char -> T Char #-} +testMapIterate :: (Storable a, Enum a) => + ChunkSize -> a -> T a +testMapIterate size y = map pred $ iterate size succ y + +testMapIterateInt :: + ChunkSize -> Int -> T Int +testMapIterateInt = testMapIterate + +-} diff --git a/src/Synthesizer/Storage.hs b/src/Synthesizer/Storage.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Storage.hs @@ -0,0 +1,152 @@ +{- | +Rendering sound effects off-line has its virtue, +but really cool is real-time signal generation. +For a long time I thought that it is the compiler's responsibility +to make list based signal processing fast enough. +However, the compiler has to respect correctness first. +That is, it cannot do too fancy optimization, +since the optimized program must still do the same as the unoptimized program. +So, when we write functions that rely on the maximal flexibility, +the compiler cannot turn it to something less flexible. +Actually, a list as in "Synthesizer.Plain.Signal" +is the best representation of a signal +in terms of flexibility: +It allows free choice of the element type, even functions, +it is element-wise lazy, allowing for short feedback, +it allows sharing of computed data. +The drawback is, that it is slow and memory inefficient. +In most cases we don't need this full flexibility, +but the compiler has no chance to find this out automatically. +It can merge several operations on a list +to a single operation by the fusion technique, +however even a single list operation is hard to get in real-time. + +How do real-time software synthesizer achieve real-time performance? +They get the popular fast inner loops +by processing signals in chunks of raw data. +This way, they lose flexibility, because they cannot do quick feedback. +We can do the same in Haskell, getting the same restrictions. +Additionally, in order to store raw data +we must restrict the element types +e.g. to the @Storable@ class, +since we use @StorableVector@ in "Synthesizer.Storable.Signal". +With this technique single signal operations are fast, +but their combination cannot be optimized in many cases. +This is so, again, because top priority in optimization is correctness. +Consider @mix x (cons 0 x)@ +where @cons 0 x@ means @0:x@ for our chunky signal data. +This expression is a perfect candidate for optimization. +But in this case it must not be applied since the chunk structures of +@x@ and @cons 0 x@ do not match. +In such cases we would not gain anything over SuperCollider and CSound. + +Remember that we introduced the chunky signal representation +entirely because of efficiency concerns. +Actually we are not interested in a special chunk structure, +so this should not be a reason for disabling optimization. +Of course, we could ignore the correctness +and write incorrect optimizer rules +that are based on correct ideas. +However, experience shows that wrong optimization +leads to surprise and infelicities sooner or later. +The later the worse, +because the later the more code you have written +relying on invalid optimization. + +What we can try is to use list representation, +enjoy the optimization that GHC already provides for it, +and then let fusion rules jump in +that make lists disappear when they are used in connection with chunky sequences. +E.g. @Chunky.fromList (List.oscillator freq)@ +could be turned into @Chunky.oscillator freq@. +This approach would be really cool, but works only in theory. +In practice it is hard to predict how GHC transforms various operations. +Additionally to optimizer rule application +it also expands functions to their definitions (known as inlining/unfolding) +or specializes functions to fixed types. +We cannot rely on our optimizer rules being actually applied. +This means however, that in unpredictable cases +the optimization fails and the efficiency drops from real-time to non-real-time. +This is unacceptable. + +The solution is a third signal representation, +see "Synthesizer.State.Signal". +(Already got tired?) +It consists of no actual data +but it is a function that generates elements. +Its type is @s -> Maybe (a,s)@ or short @StateT s Maybe a@. +Given a state of type @s@ it produces @Nothing@ when the list terminates +or @Just@ the next element and the updated state. +This can be easily converted from and to lists +while preserving laziness. +We convert to lists by @List.unfoldr@ and from lists using @viewL@. +Actually this signal representation is very close +to the list representation used in the streams package. +The main differences are: +Firstly, we do not use a list storage that is fused away when only used temporarily. +Thus we do not need a fusion rule (that could be skipped by the compiler). +Secondly, we have no notion of 'Skip', +since operations like 'filter' are uncommon in signal processing. +If we write our signal processing in terms of these virtual signals +and then convert the result to regular lists or chunky sequences, +then only one data structure will be built +and GHC does it's best to generate efficient inner loops. + +We cannot use these virtual signals for sharing and feedback, +because there is no data structure that stores the data. +If we try to do so anyway, data will be recomputed. +Thus we still need chunky sequences or lists +for sharing of interim results and for feedback. +Actually, an expression like @mix x (reverse x)@ +would definitely benefit from interim conversion to a chunky sequence, +but for @mix x (cons 0 x)@ this is overkill. + +In order to get processes like the last one efficient +we have a new data type (no, not another one!) +but this time it is not a signal data type +but a signal processor type. +It is the result of thinking about +which processes allow sharing on a per-sample basis at all. +We come to the conclusion that these can be only causal processes, +i.e. processes that depend only on current and past data, +not on data from the future. +So, we already have a good name: "Synthesizer.Causal.Process". +Causal processes are "Control.Arrow"s, +however the higher level variant does no longer fit into the Arrow type class. +This means that there are various combinations +that turn causal processes into larger causal processes. +It needs a bit experience in pointfree coding style +in order to use the arrow combinators, +but there is no way around it, +when you want to use physical dimensions. +GHC's arrow notation does only support types of the Arrow class. +E.g. the expression @mix x (cons 0 x)@ +becomes @Causal.mix <<< (Causal.id &&& Causal.cons 0)@. +When you manage this burden +you get processes that are warranted to be causal. +They can not only be used to make something efficient, +but they also allow to process data from the outside world +in a streaming way without 'unsafeInterleaveIO' +as required e.g. in JACK plugins. + +For historical reasons there is also "Synthesizer.FusionList.Signal" +which is a wrapper around lists. +I used this data type to disable GHC's default list optimizer rules +and use my own ones. +The fusion is based on @unfoldr@ and @crochetL@ +which is quite similar to the @stream-fusion@ package. +The @stream-fusion@ uses internally a @Skip@ constructor, +which, as far as I understand, +is better for the @filter@ function. +We do not need it, +because the @filter@ function is very uncommon in signal processing. +I think, @FusionList@ can be replaced by @stream-fusion@ functions. + +We have now a pretty big set of signal storage types +that differ considerably in performance +but not in the set of operations. +This calls for a type class! +You find it in "Synthesizer.Generic.Signal" +and "Synthesizer.Generic.Signal2". +-} +module Synthesizer.Storage where diff --git a/src/Synthesizer/Utility.hs b/src/Synthesizer/Utility.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Utility.hs @@ -0,0 +1,61 @@ +module Synthesizer.Utility where + +import qualified Algebra.Module as Module +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field + +import System.Random (Random, RandomGen, randomRs, ) + +import Prelude () +import PreludeBase +import NumericPrelude + + +{-| +If two values are equal, then return one of them, +otherwise raise an error. +-} +{-# INLINE common #-} +common :: (Eq a) => String -> a -> a -> a +common errorMsg x y = + if x == y + then x + else error errorMsg + + +-- * arithmetic + + +{-# INLINE fwrap #-} +fwrap :: RealField.C a => (a,a) -> a -> a +fwrap (lo,hi) x = lo + fmod (x-lo) (hi-lo) + +{-# INLINE fmod #-} +fmod :: RealField.C a => a -> a -> a +fmod x y = fraction (x/y) * y + +{-# INLINE fmodAlt #-} +fmodAlt :: RealField.C a => a -> a -> a +fmodAlt x y = x - fromInteger (floor (x/y)) * y + +propFMod :: RealField.C a => a -> a -> Bool +propFMod x y = +-- y /= 0 ==> + fmod x y == fmodAlt x y + +{-# INLINE affineComb #-} +affineComb :: (Module.C t y) => t -> (y,y) -> y +affineComb phase (x0,x1) = x0 + phase *> (x1-x0) + +{-# INLINE balanceLevel #-} +balanceLevel :: (Field.C y) => + y -> [y] -> [y] +balanceLevel center xs = + let d = center - sum xs / fromIntegral (length xs) + in map (d+) xs + +{-# INLINE randomRsBalanced #-} +randomRsBalanced :: (RandomGen g, Random y, Field.C y) => + g -> Int -> y -> y -> [y] +randomRsBalanced g n center width = + balanceLevel center (take n $ randomRs (zero,width) g) diff --git a/src/Test/Main.hs b/src/Test/Main.hs new file mode 100644 --- /dev/null +++ b/src/Test/Main.hs @@ -0,0 +1,33 @@ +module Main where + +import qualified Test.Sound.Synthesizer.Plain.Analysis as Analysis +import qualified Test.Sound.Synthesizer.Plain.Control as Control +import qualified Test.Sound.Synthesizer.Plain.Filter as Filter +import qualified Test.Sound.Synthesizer.Plain.Interpolation as Interpolation +import qualified Test.Sound.Synthesizer.Plain.Oscillator as Oscillator +import qualified Test.Sound.Synthesizer.Plain.Wave as Wave +import qualified Test.Sound.Synthesizer.Basic.ToneModulation as ToneModulation +import qualified Test.Sound.Synthesizer.Plain.ToneModulation as ToneModulationL +import qualified Test.Sound.Synthesizer.Generic.ToneModulation as ToneModulationG + +import Data.Tuple.HT (mapFst, ) + + +prefix :: String -> [(String, IO ())] -> [(String, IO ())] +prefix msg = + map (mapFst (\str -> msg ++ "." ++ str)) + +main :: IO () +main = + mapM_ (\(msg,io) -> putStr (msg++": ") >> io) $ + concat $ + prefix "Plain.Analysis" Analysis.tests : + prefix "Plain.Control" Control.tests : + prefix "Plain.Filter" Filter.tests : + prefix "Plain.Interpolation" Interpolation.tests : + prefix "Plain.Oscillator" Oscillator.tests : + prefix "Plain.Wave" Wave.tests : + prefix "Basic.ToneModulation" ToneModulation.tests : + prefix "Plain.ToneModulation" ToneModulationL.tests : + prefix "Generic.ToneModulation" ToneModulationG.tests : + [] diff --git a/src/Test/Sound/Synthesizer/Basic/ToneModulation.hs b/src/Test/Sound/Synthesizer/Basic/ToneModulation.hs new file mode 100644 --- /dev/null +++ b/src/Test/Sound/Synthesizer/Basic/ToneModulation.hs @@ -0,0 +1,98 @@ +module Test.Sound.Synthesizer.Basic.ToneModulation where + +import qualified Synthesizer.Interpolation as Interpolation +import Synthesizer.Interpolation (margin, ) + +import qualified Synthesizer.Basic.Phase as Phase +import qualified Synthesizer.Basic.ToneModulation as ToneMod + +import qualified Test.Sound.Synthesizer.Plain.Interpolation as InterpolationTest + +import Test.QuickCheck (test, Property, (==>), Testable, ) +-- import Test.Utility + +import qualified Number.NonNegative as NonNeg +-- import qualified Number.NonNegativeChunky as Chunky + +-- import qualified Algebra.RealTranscendental as RealTrans +-- import qualified Algebra.Module as Module +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +-- import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + + +import NumericPrelude +import PreludeBase +import Prelude () + + +untangleShapePhase :: (Field.C a, Eq a) => + Int -> a -> (a, a) -> Property +untangleShapePhase periodInt period c = + period /= zero ==> + ToneMod.untangleShapePhase periodInt period c == + ToneMod.untangleShapePhaseAnalytic periodInt period c + +flattenShapePhase :: (RealField.C a) => + Int -> a -> (a, Phase.T a) -> Property +flattenShapePhase periodInt period c = + period /= zero ==> + ToneMod.flattenShapePhase periodInt period c == + ToneMod.flattenShapePhaseAnalytic periodInt period c + + +-- * auxiliary test functions + +{- +Although that looks like a too small value, it is actually right, +because numberLeap counts intervals of size periodInt, not single elements. +So numberLeap=2 like in linear interpolation means 2*periodInt. +-} +minLength :: + Interpolation.T a v -> + Interpolation.T a v -> + Int -> NonNeg.Int -> Int +minLength ipLeap ipStep = + minLengthMargin (margin ipLeap) (margin ipStep) + +minLengthMargin :: + Interpolation.Margin -> + Interpolation.Margin -> + Int -> NonNeg.Int -> Int +minLengthMargin marginLeap marginStep periodInt ext = + ToneMod.interpolationNumber + marginLeap marginStep periodInt + + NonNeg.toNumber ext + + + +shapeLimits :: + Interpolation.T a v -> + Interpolation.T a v -> + Int -> Int -> (Int, Int) +shapeLimits ipLeap ipStep periodInt len = + ToneMod.shapeLimits + (margin ipLeap) (margin ipStep) + periodInt len + + + +testRationalLineIp :: Testable test => + (InterpolationTest.LinePreserving Rational Rational -> test) -> IO () +testRationalLineIp f = test f + +testRationalIp :: Testable test => + (InterpolationTest.T Rational Rational -> test) -> IO () +testRationalIp f = test f + + +tests :: [(String, IO ())] +tests = + ("untangleShapePhase", + test (\periodInt period -> + untangleShapePhase periodInt (period :: Rational))) : + ("flattenShapePhase", + test (\periodInt period -> + flattenShapePhase periodInt (period :: Rational))) : + [] diff --git a/src/Test/Sound/Synthesizer/Generic/ToneModulation.hs b/src/Test/Sound/Synthesizer/Generic/ToneModulation.hs new file mode 100644 --- /dev/null +++ b/src/Test/Sound/Synthesizer/Generic/ToneModulation.hs @@ -0,0 +1,313 @@ +module Test.Sound.Synthesizer.Generic.ToneModulation (tests) where + +import Test.Sound.Synthesizer.Basic.ToneModulation ( + minLength, + minLengthMargin, +-- shapeLimits, +-- testRationalLineIp, + testRationalIp, + ) + +import Test.Sound.Synthesizer.Plain.ToneModulation ( + InfiniteList, + listFromInfinite, + ) + +import qualified Synthesizer.Causal.ToneModulation as ToneModC +import qualified Synthesizer.Generic.Wave as WaveG + +import qualified Synthesizer.Plain.Signal as Sig +import qualified Synthesizer.Plain.Oscillator as Osci +import qualified Synthesizer.Plain.Interpolation as Interpolation +import qualified Synthesizer.Plain.ToneModulation as ToneModL +import qualified Synthesizer.Plain.Wave as WaveL +import Synthesizer.Interpolation (marginNumber, ) + +import qualified Synthesizer.Causal.Oscillator as OsciC +import qualified Synthesizer.Causal.Process as Causal + +import qualified Synthesizer.State.Signal as SigS + +import qualified Synthesizer.Basic.Wave as Wave +import qualified Synthesizer.Basic.Phase as Phase + +import qualified Test.Sound.Synthesizer.Plain.Interpolation as InterpolationTest + +import Test.QuickCheck (test, Property, (==>), ) +import Test.Utility (ArbChar, ) +-- import Debug.Trace (trace, ) + +import qualified Number.NonNegative as NonNeg + +-- import qualified Algebra.RealTranscendental as RealTrans +-- import qualified Algebra.Module as Module +import qualified Algebra.RealField as RealField +-- import qualified Algebra.Field as Field +-- import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + + +import Data.List.HT (viewL, takeWhileJust, ) +import Data.Tuple.HT (mapSnd, ) +import qualified Data.List as List + + +import NumericPrelude +import PreludeBase +import Prelude () + + +limitMinRelativeValues :: + Int -> Int -> [NonNeg.Int] -> Bool +limitMinRelativeValues xMin x0 xsnn = + let xs = map NonNeg.toNumber xsnn + (y0,limiter) = ToneModC.limitMinRelativeValues xMin x0 + in (y0, Causal.applyGeneric limiter xs) == + ToneModL.limitMinRelativeValues xMin x0 xs + +integrateFractional :: (RealField.C t) => + NonNeg.T t -> t -> Phase.T t -> [NonNeg.T t] -> [t] -> Property +integrateFractional + periodNN shape0 phase shapesNN freqs = + let shapes = map NonNeg.toNumber shapesNN + period = NonNeg.toNumber periodNN + (c0, coordinator) = + ToneModC.integrateFractional + period (shape0, phase) + coords = + ToneModL.integrateFractional + period (shape0, shapes) (phase, freqs) + in period /= zero ==> + c0 : Causal.applyGeneric coordinator (zip shapes freqs) == + coords + +-- oscillatorCellSize :: (Show t, Show v, RealField.C t, Eq v) => +oscillatorCellSize :: (RealField.C t, Eq v) => + Interpolation.Margin -> + Interpolation.Margin -> + NonNeg.Int -> NonNeg.T t -> + NonNeg.Int -> InfiniteList v -> + t -> t -> [NonNeg.T t] -> [t] -> + Property +oscillatorCellSize + marginLeap marginStep periodIntNN periodNN ext + ixs shape0 phase shapesNN freqs = + let shapes = map NonNeg.toNumber shapesNN + period = NonNeg.toNumber periodNN + periodInt = NonNeg.toNumber periodIntNN + len = minLengthMargin marginLeap marginStep periodInt ext + tone = take len (listFromInfinite ixs) + resampledTone = + ToneModC.oscillatorCells + marginLeap marginStep periodInt period tone + (shape0, Phase.fromRepresentative phase) + `Causal.applyGeneric` + zip shapes freqs + in period /= zero && + marginNumber marginLeap > zero && + marginNumber marginStep > zero ==> + all + ((\cell -> + Sig.lengthAtLeast (marginNumber marginLeap) cell && + all (Sig.lengthAtLeast (marginNumber marginStep)) + (take (marginNumber marginLeap) cell)) + . SigS.toList . snd) + resampledTone + +oscillatorSuffixes :: (RealField.C t, Eq v) => + Interpolation.Margin -> + Interpolation.Margin -> + NonNeg.Int -> NonNeg.T t -> + NonNeg.Int -> InfiniteList v -> + t -> t -> [NonNeg.T t] -> [t] -> + Property +oscillatorSuffixes + marginLeap marginStep periodIntNN periodNN ext + ixs shape0 phase shapesNN freqs = + let shapes = map NonNeg.toNumber shapesNN + period = NonNeg.toNumber periodNN + periodInt = NonNeg.toNumber periodIntNN + len = minLengthMargin marginLeap marginStep periodInt ext + tone = take len (listFromInfinite ixs) + resampledToneA = + init $ + map (\(sp,cell) -> + (sp, takeWhileJust . map (fmap fst . viewL) $ cell)) $ + ToneModL.oscillatorSuffixes + marginLeap marginStep periodInt period tone + (shape0, shapes) (Phase.fromRepresentative phase, freqs) + resampledToneB = + ToneModC.oscillatorSuffixes + marginLeap marginStep periodInt period tone + (shape0, Phase.fromRepresentative phase) + `Causal.applyGeneric` + zip shapes freqs + in period /= zero && + periodInt /= zero && + marginNumber marginLeap > zero && + marginNumber marginStep > zero ==> + resampledToneA == resampledToneB + +oscillatorCells :: (RealField.C t, Eq v) => + Interpolation.Margin -> + Interpolation.Margin -> + NonNeg.Int -> NonNeg.T t -> + NonNeg.Int -> InfiniteList v -> + t -> t -> [NonNeg.T t] -> [t] -> + Property +oscillatorCells + marginLeap marginStep periodIntNN periodNN ext + ixs shape0 phase shapesNN freqs = + let shapes = map NonNeg.toNumber shapesNN + period = NonNeg.toNumber periodNN + periodInt = NonNeg.toNumber periodIntNN + len = minLengthMargin marginLeap marginStep periodInt ext + tone = take len (listFromInfinite ixs) + resampledToneA = + init $ map (mapSnd List.transpose) $ + ToneModL.oscillatorCells + marginLeap marginStep periodInt period tone + (shape0, shapes) (Phase.fromRepresentative phase, freqs) + resampledToneB = + map (mapSnd SigS.toList) $ + ToneModC.oscillatorCells + marginLeap marginStep periodInt period tone + (shape0, Phase.fromRepresentative phase) + `Causal.applyGeneric` + zip shapes freqs + in period /= zero && + periodInt /= zero && + marginNumber marginLeap > zero && + marginNumber marginStep > zero ==> + resampledToneA == resampledToneB +{- +Margin {marginNumber = 1, marginOffset = 2} +Margin {marginNumber = 5, marginOffset = 5} +3 % 4 +0 +('\DEL',['~','~','"']) +-2 % 5 +2 % 5 +[2 % 1,3 % 4] +[-5 % 2,-1 % 2] +-} + +{- | +'WaveL.sampledTone' and 'WaveG.sampledTone' +do not only differ in the signal types they process, +but also in the way they order the signal values. +The cells for 'WaveL.sampledTone' are transposed +with respect to 'WaveG.sampledTone'. +-} +sampledTone :: (RealField.C a, Eq v) => + InterpolationTest.T a v -> + InterpolationTest.T a v -> + NonNeg.T a -> NonNeg.Int -> InfiniteList v -> + a -> Phase.T a -> Property +sampledTone = + InterpolationTest.use2 $ \ ipLeap ipStep + periodNN ext ixs shape phase -> + let period = NonNeg.toNumber periodNN + periodInt = round period + len = minLength ipLeap ipStep periodInt ext + tone = take len (listFromInfinite ixs) + in period /= zero ==> + WaveG.sampledTone ipLeap ipStep period tone shape `Wave.apply` phase == + WaveL.sampledTone ipLeap ipStep period tone shape `Wave.apply` phase + + + +shapeFreqModFromSampledTone :: (RealField.C t, Eq v) => + InterpolationTest.T t v -> + InterpolationTest.T t v -> + NonNeg.T t -> + NonNeg.Int -> InfiniteList v -> + t -> Phase.T t -> [NonNeg.T t] -> [t] -> + Property +shapeFreqModFromSampledTone = + InterpolationTest.use2 $ \ ipLeap ipStep + periodNN ext ixs shape0 phase shapesNN freqs -> + let shapes = map NonNeg.toNumber shapesNN + period = NonNeg.toNumber periodNN + periodInt = round period + len = minLength ipLeap ipStep periodInt ext + tone = take len (listFromInfinite ixs) + resampledToneA = + init $ + Osci.shapeFreqModFromSampledTone ipLeap ipStep period tone + shape0 (Phase.toRepresentative phase) shapes freqs + resampledToneB = + OsciC.shapeFreqModFromSampledTone + ipLeap ipStep period tone shape0 phase + `Causal.applyGeneric` + zip shapes freqs + in period /= zero ==> + resampledToneA == resampledToneB + + +{- +We have a problem here with the phase distortion signal, +because frequency and shape modulation control signals +are delayed by one element with respect to the phase distortion. +How can we cope with different lengths of the control signals, +without padding the phase control with zeros? +This one did not work: + phaseDistorts = pd:pds + resampledToneA = + Osci.shapePhaseFreqModFromSampledTone ipLeap ipStep period tone + shape0 (Phase.toRepresentative phase) shapes (init phaseDistorts) freqs +-} +shapePhaseFreqModFromSampledTone :: (RealField.C t, Eq v) => + InterpolationTest.T t v -> + InterpolationTest.T t v -> + NonNeg.T t -> + NonNeg.Int -> InfiniteList v -> + t -> Phase.T t -> [NonNeg.T t] -> (t,[t]) -> [t] -> + Property +shapePhaseFreqModFromSampledTone = + InterpolationTest.use2 $ \ ipLeap ipStep + periodNN ext ixs shape0 phase shapesNN (pd,pds) freqs -> + let period = NonNeg.toNumber periodNN + periodInt = round period + len = minLength ipLeap ipStep periodInt ext + tone = take len (listFromInfinite ixs) + shapes = map NonNeg.toNumber shapesNN + phaseDistorts = pd:pds ++ repeat zero + resampledToneA = + init $ + Osci.shapePhaseFreqModFromSampledTone ipLeap ipStep period tone + shape0 (Phase.toRepresentative phase) shapes phaseDistorts freqs + resampledToneB = + OsciC.shapePhaseFreqModFromSampledTone + ipLeap ipStep period tone shape0 phase + `Causal.applyGeneric` + zip3 shapes phaseDistorts freqs + in period /= zero ==> + resampledToneA == resampledToneB + + + +tests :: [(String, IO ())] +tests = + ("limitMinRelativeValues", test limitMinRelativeValues) : + ("integrateFractional", + test (\period -> integrateFractional (period :: NonNeg.Rational))) : + ("oscillatorCellSize", + test (\ml ms periodInt period ext ixs -> + oscillatorCellSize ml ms periodInt (period :: NonNeg.Rational) + ext (ixs :: InfiniteList ArbChar))) : + ("oscillatorSuffixes", + test (\ml ms periodInt period ext ixs -> + oscillatorSuffixes ml ms periodInt (period :: NonNeg.Rational) + ext (ixs :: InfiniteList ArbChar))) : + ("oscillatorCells", + test (\ml ms periodInt period ext ixs -> + oscillatorCells ml ms periodInt (period :: NonNeg.Rational) + ext (ixs :: InfiniteList ArbChar))) : + ("sampledTone", + testRationalIp sampledTone) : + ("shapeFreqModFromSampledTone", + testRationalIp shapeFreqModFromSampledTone) : + ("shapePhaseFreqModFromSampledTone", + testRationalIp shapePhaseFreqModFromSampledTone) : + [] diff --git a/src/Test/Sound/Synthesizer/Plain/Analysis.hs b/src/Test/Sound/Synthesizer/Plain/Analysis.hs new file mode 100644 --- /dev/null +++ b/src/Test/Sound/Synthesizer/Plain/Analysis.hs @@ -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)) : + [] diff --git a/src/Test/Sound/Synthesizer/Plain/Control.hs b/src/Test/Sound/Synthesizer/Plain/Control.hs new file mode 100644 --- /dev/null +++ b/src/Test/Sound/Synthesizer/Plain/Control.hs @@ -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) : + [] diff --git a/src/Test/Sound/Synthesizer/Plain/Filter.hs b/src/Test/Sound/Synthesizer/Plain/Filter.hs new file mode 100644 --- /dev/null +++ b/src/Test/Sound/Synthesizer/Plain/Filter.hs @@ -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) : + [] diff --git a/src/Test/Sound/Synthesizer/Plain/Interpolation.hs b/src/Test/Sound/Synthesizer/Plain/Interpolation.hs new file mode 100644 --- /dev/null +++ b/src/Test/Sound/Synthesizer/Plain/Interpolation.hs @@ -0,0 +1,142 @@ +module Test.Sound.Synthesizer.Plain.Interpolation ( + T, ip, + LinePreserving, lpIp, + tests, + use, useLP, use2, + ) where + +import qualified Synthesizer.Plain.Interpolation as Interpolation +import qualified Synthesizer.Interpolation.Class as Interpol +import qualified Synthesizer.Interpolation.Custom as ExampleCustom +import qualified Synthesizer.Interpolation.Module as ExampleModule +import qualified Synthesizer.Interpolation as InterpolationCore + +import Test.QuickCheck (test, Arbitrary(..), elements, {- Property, (==>), -} Testable, ) +-- import Test.Utility + +import qualified Algebra.VectorSpace as VectorSpace +import qualified Algebra.Module as Module +-- import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +-- import qualified Algebra.Ring as Ring +-- import qualified Algebra.Additive as Additive + +import Control.Monad (liftM2, ) + +import Test.Utility (equalList, ) + + +import NumericPrelude +import PreludeBase +import Prelude () + + + +instance Arbitrary InterpolationCore.Margin where + arbitrary = + liftM2 InterpolationCore.Margin + (fmap abs arbitrary) + (fmap abs arbitrary) + coarbitrary = undefined + + +use :: + (Interpolation.T a v -> x) -> + (T a v -> x) +use f ipt = + f (ip ipt) + +useLP :: + (Interpolation.T a v -> x) -> + (LinePreserving a v -> x) +useLP f ipt = + f (lpIp ipt) + +use2 :: + (Interpolation.T a v -> + Interpolation.T a v -> x) -> + (T a v -> + T a v -> x) +use2 f = + use $ \ ipLeap -> + use $ \ ipStep -> + f ipLeap ipStep + + + +data T a v = Cons {name :: String, ip :: Interpolation.T a v} + +instance Show (T a v) where + show x = name x + +instance (Field.C a, Interpol.C a v) => Arbitrary (T a v) where + arbitrary = elements $ + Cons "constant" ExampleCustom.constant : + Cons "linear" ExampleCustom.linear : + Cons "cubic" ExampleCustom.cubic : + [] + coarbitrary = undefined + + + +data LinePreserving a v = + LPCons {lpName :: String, lpIp :: Interpolation.T a v} + +instance Show (LinePreserving a v) where + show x = lpName x + +instance (Field.C a, Interpol.C a v) => Arbitrary (LinePreserving a v) where + arbitrary = elements $ + LPCons "linear" ExampleCustom.linear : + LPCons "cubic" ExampleCustom.cubic : + [] + coarbitrary = undefined + + + +constant :: + (Interpol.C a v, Module.C a v, Eq v) => + a -> v -> [v] -> Bool +constant t x0 xs = + equalList $ map ($(x0:xs)) $ map ($t) $ + Interpolation.func ExampleCustom.constant : + Interpolation.func ExampleCustom.piecewiseConstant : + Interpolation.func ExampleModule.constant : + Interpolation.func ExampleModule.piecewiseConstant : + [] + +linear :: + (Interpol.C a v, Module.C a v, Eq v) => + a -> v -> v -> [v] -> Bool +linear t x0 x1 xs = + equalList $ map ($(x0:x1:xs)) $ map ($t) $ + Interpolation.func ExampleCustom.linear : + Interpolation.func ExampleCustom.piecewiseLinear : + Interpolation.func ExampleModule.linear : + Interpolation.func ExampleModule.piecewiseLinear : + [] + +cubic :: + (Interpol.C a v, VectorSpace.C a v, Eq v) => + a -> v -> v -> v -> v -> [v] -> Bool +cubic t x0 x1 x2 x3 xs = + equalList $ map ($(x0:x1:x2:x3:xs)) $ map ($t) $ + Interpolation.func ExampleCustom.cubic : + Interpolation.func ExampleCustom.piecewiseCubic : + Interpolation.func ExampleModule.cubic : + Interpolation.func ExampleModule.cubicAlt : + Interpolation.func ExampleModule.piecewiseCubic : + [] + + +testRational :: + (Testable t) => + (Rational -> Rational -> t) -> IO () +testRational = test + +tests :: [(String, IO ())] +tests = + ("constant", testRational constant) : + ("linear", testRational linear ) : + ("cubic", testRational cubic ) : + [] diff --git a/src/Test/Sound/Synthesizer/Plain/Oscillator.hs b/src/Test/Sound/Synthesizer/Plain/Oscillator.hs new file mode 100644 --- /dev/null +++ b/src/Test/Sound/Synthesizer/Plain/Oscillator.hs @@ -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) : + [] diff --git a/src/Test/Sound/Synthesizer/Plain/ToneModulation.hs b/src/Test/Sound/Synthesizer/Plain/ToneModulation.hs new file mode 100644 --- /dev/null +++ b/src/Test/Sound/Synthesizer/Plain/ToneModulation.hs @@ -0,0 +1,504 @@ +module Test.Sound.Synthesizer.Plain.ToneModulation (tests, + listFromInfinite, + InfiniteList, + ) where + +import Test.Sound.Synthesizer.Basic.ToneModulation ( + minLength, + minLengthMargin, + shapeLimits, + testRationalLineIp, + testRationalIp, + ) + +import qualified Synthesizer.Plain.Oscillator as Osci +import qualified Synthesizer.Plain.Interpolation as Interpolation +import qualified Synthesizer.Plain.ToneModulation as ToneModL +import qualified Synthesizer.Plain.Wave as WaveL +import Synthesizer.Interpolation (marginNumber, ) + +import qualified Synthesizer.Basic.Wave as Wave +import qualified Synthesizer.Basic.Phase as Phase + +import qualified Test.Sound.Synthesizer.Plain.Interpolation as InterpolationTest + +import Test.QuickCheck (test, Property, (==>), Arbitrary, arbitrary, coarbitrary, ) +import Test.Utility (ArbChar, ) + +import qualified Number.NonNegative as NonNeg +import qualified Number.NonNegativeChunky as Chunky + +import qualified Algebra.RealTranscendental as RealTrans +import qualified Algebra.Module as Module +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Control.Monad (liftM2, ) +import Data.List.HT (isAscending, ) +import Data.Ord.HT (limit, ) +import Data.Tuple.HT (mapPair, mapSnd, ) +import qualified Data.List as List + + +import NumericPrelude +import PreludeBase +import Prelude () + + +{- +Properties that do not hold: + commutativity of limitRelativeShapes and integrateFractional: + Does not hold because when you clip the integral skips at the end, + you would have to clear the fractional part, too. +-} + + + +data InfiniteList a = + InfiniteList a [a] + +listFromInfinite :: InfiniteList a -> [a] +listFromInfinite (InfiniteList x xs) = + cycle (x:xs) + +instance Functor InfiniteList where + fmap f (InfiniteList x xs) = + InfiniteList (f x) (map f xs) + +instance Arbitrary a => Arbitrary (InfiniteList a) where + arbitrary = liftM2 InfiniteList arbitrary arbitrary + coarbitrary = undefined + +instance Show a => Show (InfiniteList a) where + showsPrec p (InfiniteList x xs) = + showParen (p >= 10) $ + showString "cycle " . + showsPrec 11 (x:xs) + + + +absolutize :: (Additive.C a) => a -> [a] -> [a] +absolutize = scanl (+) + +limitMinRelativeValues :: + Int -> Int -> [NonNeg.Int] -> Bool +limitMinRelativeValues xMin x0 xsnn = + let xs = map NonNeg.toNumber xsnn + in map (max xMin) (absolutize x0 xs) == + uncurry absolutize (ToneModL.limitMinRelativeValues xMin x0 xs) + +limitMaxRelativeValues :: + Int -> Int -> [NonNeg.Int] -> Bool +limitMaxRelativeValues xMax x0 xsnn = + let xs = map NonNeg.toNumber xsnn + in map (min xMax) (absolutize x0 xs) == + uncurry absolutize (ToneModL.limitMaxRelativeValues xMax x0 xs) + +limitMaxRelativeValuesNonNeg :: + Int -> Int -> [NonNeg.Int] -> Bool +limitMaxRelativeValuesNonNeg xMax x0 xsnn = + let xs = map NonNeg.toNumber xsnn + in map (min xMax) (absolutize x0 xs) == + uncurry absolutize (ToneModL.limitMaxRelativeValuesNonNeg xMax x0 xs) + +-- chunky type is not necessary here but testing it a little is not wrong +limitMinRelativeValuesIdentity :: + Chunky.T NonNeg.Int -> [Chunky.T NonNeg.Int] -> Bool +limitMinRelativeValuesIdentity x0 xs = + (x0,xs) == ToneModL.limitMinRelativeValues 0 x0 xs + +limitMaxRelativeValuesIdentity :: + Chunky.T NonNeg.Int -> [Chunky.T NonNeg.Int] -> Bool +limitMaxRelativeValuesIdentity x0 xs = + let inf = 1 + inf + in (x0,xs) == ToneModL.limitMaxRelativeValues inf x0 xs + +limitMaxRelativeValuesNonNegIdentity :: + Chunky.T NonNeg.Int -> [Chunky.T NonNeg.Int] -> Bool +limitMaxRelativeValuesNonNegIdentity x0 xs = + let inf = 1 + inf + in (x0,xs) == ToneModL.limitMaxRelativeValuesNonNeg inf x0 xs + +limitMaxRelativeValuesInfinity :: + Chunky.T NonNeg.Int -> InfiniteList (Chunky.T NonNeg.Int) -> Bool +limitMaxRelativeValuesInfinity x0 ixs = + let inf = 1 + inf + ys = listFromInfinite ixs + (z0,zs) = ToneModL.limitMaxRelativeValues inf x0 ys + in (x0, take 100 ys) == (z0, take 100 zs) + +limitMaxRelativeValuesNonNegInfinity :: + Chunky.T NonNeg.Int -> InfiniteList (Chunky.T NonNeg.Int) -> Bool +limitMaxRelativeValuesNonNegInfinity x0 ixs = + let inf = 1 + inf + ys = listFromInfinite ixs + (z0,zs) = ToneModL.limitMaxRelativeValuesNonNeg inf x0 ys + in (x0, take 100 ys) == (z0, take 100 zs) + + +dropRem :: Eq a => NonNeg.Int -> [a] -> Bool +dropRem nn xs = + let n = NonNeg.toNumber nn + in map (flip ToneModL.dropRem xs) [0 .. n + length xs] == + map ((,) 0) (List.tails xs) ++ map (flip (,) []) [1..n] + + +sampledToneSine :: (RealTrans.C a, Module.C a a) => + NonNeg.T a -> NonNeg.Int -> a -> a -> a -> Bool +sampledToneSine periodNN ext phase0 shape phase = + let ipLeap = Interpolation.cubic + ipStep = Interpolation.cubic + ten = fromInteger 10 + period = ten + NonNeg.toNumber periodNN + periodInt = round period + len = minLength ipLeap ipStep periodInt ext + tone = take len (Osci.staticSine phase0 (recip period)) + in abs (WaveL.sampledTone ipLeap ipStep period tone shape `Wave.apply` (Phase.fromRepresentative phase) - + head (Osci.staticSine (phase0+phase) zero)) < ten ^- (-2) + + +sampledToneSineList :: (RealTrans.C a, Module.C a a) => + NonNeg.T a -> NonNeg.Int -> a -> a -> [a] -> [a] -> Bool +sampledToneSineList periodNN ext origPhase phase shapes freqs = + let ipLeap = Interpolation.cubic + ipStep = Interpolation.cubic + ten = fromInteger 10 + period = ten + NonNeg.toNumber periodNN + periodInt = round period + len = minLength ipLeap ipStep periodInt ext + tone = take len (Osci.staticSine origPhase (recip period)) + in all ((< ten ^- (-2)) . abs) $ + zipWith (-) + (Osci.shapeFreqMod (WaveL.sampledTone ipLeap ipStep period tone) + phase shapes freqs) + (Osci.freqModSine (origPhase+phase) freqs) + + +sampledToneLinear :: (RealField.C a, Module.C a v, Eq v) => + InterpolationTest.LinePreserving a v -> + InterpolationTest.LinePreserving a v -> + NonNeg.T a -> NonNeg.Int -> (v,v) -> a -> Phase.T a -> Property +sampledToneLinear = + InterpolationTest.useLP $ \ ipLeap -> + InterpolationTest.useLP $ \ ipStep -> + \ periodNN ext (i,d) shape phase -> + let period = NonNeg.toNumber periodNN + periodInt = round period + len = minLength ipLeap ipStep periodInt ext + ramp = take len (List.iterate (d+) i) + limits = + mapPair (fromIntegral, fromIntegral) $ + shapeLimits ipLeap ipStep periodInt len + in period /= zero ==> + -- should be (fraction phase), right? + WaveL.sampledTone ipLeap ipStep period ramp shape `Wave.apply` phase == + i + limit limits shape *> d +{- +let len=100; period=1/0.06::Double; ip = Interpolation.linear in GNUPlot.plotFuncs [] (GNUPlot.linearScale 1000 (0,fromIntegral len)) [\s -> WaveL.sampledTone ip ip period (take len $ iterate (1+) (0::Double)) s 0, limit (mapPair (fromIntegral, fromIntegral) $ shapeLimits ip ip (round period::Int) len)] +-} + +sampledToneStair :: (RealField.C a, Module.C a v, Eq v) => + InterpolationTest.LinePreserving a v -> + NonNeg.Int -> NonNeg.Int -> (v,v) -> a -> Property +sampledToneStair = + InterpolationTest.useLP $ \ ipLeap + periodIntNN ext (i,d) shape -> + let ipStep = Interpolation.constant + periodInt = NonNeg.toNumber periodIntNN + period = fromIntegral periodInt + len0 = minLength ipLeap ipStep periodInt ext + (rep,rm) = divMod (negate len0) periodInt + len = len0 + rm + stair = + concatMap (replicate periodInt) $ + take (negate rep) (List.iterate (period*>d+) i) + limits = + mapPair (fromIntegral, fromIntegral) $ + shapeLimits ipLeap ipStep periodInt len + in periodInt /= zero ==> + WaveL.sampledTone ipLeap ipStep period stair shape `Wave.apply` zero == + i + limit limits shape *> d +{- +let len=periodInt*rep; rep=10; periodInt = 14::Int; period=fromIntegral periodInt; ipl = Interpolation.linear; ipc = Interpolation.constant in GNUPlot.plotFuncs [] (GNUPlot.linearScale 1000 (-10,10+fromIntegral len)) [\s -> WaveL.sampledTone ipl ipc period (concatMap (replicate periodInt) $ take rep $ iterate (period+) (0::Double)) s 0, limit (mapPair (fromIntegral, fromIntegral) $ shapeLimits ipl ipc periodInt len)] +-} + +{- +sampledToneSaw :: (RealField.C a, Module.C a v, Eq v) => + InterpolationTest.LinePreserving a v -> + InterpolationTest.T a v -> + NonNeg.Int -> NonNeg.Int -> (v,v) -> a -> a -> Property +sampledToneSaw iptLeap iptStep periodIntNN ext (i,d) shape phase = + let ipLeap = InterpolationTest.lpIp iptLeap + ipStep = InterpolationTest.ip iptStep + periodInt = NonNeg.toNumber periodIntNN + period = fromIntegral periodInt + len0 = minLength ipLeap ipStep periodInt ext + rep = negate $ div (negate len0) periodInt + saw = + concat $ replicate rep $ + take periodInt $ List.iterate (d+) i + in periodInt /= zero ==> + WaveL.sampledTone ipLeap ipStep period saw shape phase == + i + fraction phase *> d +-} + +sampledToneStatic :: (RealField.C a, Eq v) => + InterpolationTest.T a v -> + InterpolationTest.T a v -> + NonNeg.Int -> (v,[v]) -> a -> a -> Property +sampledToneStatic = + InterpolationTest.use2 $ \ ipLeap ipStep + ext (x,xs) shape phase -> + let wave = x:xs + periodInt = length wave + period = fromIntegral periodInt + len = minLength ipLeap ipStep periodInt ext + rep = negate $ div (negate len) periodInt + tone = concat $ replicate rep wave + in period /= zero ==> + WaveL.sampledTone ipLeap ipStep period tone shape `Wave.apply` (Phase.fromRepresentative phase) == + Interpolation.cyclicPad Interpolation.single ipStep (phase*period) wave +{- +let wave = [1,-1,0.5,-0.5::Double]; period = fromIntegral (length wave) :: Double; ip = Interpolation.linear in GNUPlot.plotFuncs [] (GNUPlot.linearScale 1000 (-1,3)) [WaveL.sampledTone ip ip period (concat $ replicate 3 wave) 0.3, \phase -> Interpolation.cyclicPad Interpolation.single Interpolation.linear (phase*period) wave] +-} + + + +shapeFreqModFromSampledToneLimitIdentity :: (RealField.C t) => + Interpolation.Margin -> + Interpolation.Margin -> + NonNeg.Int -> InfiniteList y -> (t, InfiniteList (NonNeg.T t)) -> Bool +shapeFreqModFromSampledToneLimitIdentity + marginLeap marginStep periodIntNN ixs (shape0,shapesNN) = + let periodInt = NonNeg.toNumber periodIntNN + shapes = fmap NonNeg.toNumber shapesNN + a = snd + (ToneModL.limitRelativeShapes + marginLeap marginStep + periodInt (listFromInfinite ixs) + (shape0, listFromInfinite shapes)) !! 100 + in a == a + + +oscillatorCoords :: (RealField.C t) => + NonNeg.Int -> NonNeg.T t -> t -> Phase.T t -> [NonNeg.T t] -> [t] -> Property +oscillatorCoords + periodIntNN periodNN shape0 phase shapesNN freqs = + let shapes = map NonNeg.toNumber shapesNN + period = NonNeg.toNumber periodNN + periodInt = NonNeg.toNumber periodIntNN + periodRound = fromIntegral periodInt + coords = + ToneModL.oscillatorCoords + periodInt period + (shape0, shapes) (phase, freqs) + in period /= zero && periodInt /= zero ==> + all + (\(skip,(k,(qShape,qWave))) -> + skip >= zero && + isAscending [negate periodInt, k, zero] && + isAscending [zero, qShape, one] && + isAscending [zero, qWave, periodRound]) + (tail coords) + + +shapeFreqModFromSampledToneCoordsIdentity :: (RealField.C t) => + NonNeg.Int -> NonNeg.T t -> (t, [NonNeg.T t]) -> Property +shapeFreqModFromSampledToneCoordsIdentity + periodIntNN periodNN (shape0,shapesNN) = + let period = NonNeg.toNumber periodNN + periodInt = NonNeg.toNumber periodIntNN + shapes = map NonNeg.toNumber shapesNN + phase = Phase.fromRepresentative $ shape0 / period + freqs = map (/period) shapes + in period /= zero ==> + all + (isZero . fst . snd . snd) + (ToneModL.oscillatorCoords + periodInt period (shape0, shapes) (phase, freqs)) + + +shapeFreqModFromSampledTone :: (RealField.C t, Eq v) => + InterpolationTest.T t v -> + InterpolationTest.T t v -> + NonNeg.T t -> + NonNeg.Int -> InfiniteList v -> + t -> t -> [NonNeg.T t] -> [t] -> + Property +shapeFreqModFromSampledTone = + InterpolationTest.use2 $ \ ipLeap ipStep + periodNN ext ixs shape0 phase shapesNN freqs -> + let shapes = map NonNeg.toNumber shapesNN + period = NonNeg.toNumber periodNN + periodInt = round period + len = minLength ipLeap ipStep periodInt ext + tone = take len (listFromInfinite ixs) + resampledToneA = + Osci.shapeFreqModFromSampledTone ipLeap ipStep period tone + shape0 phase shapes freqs + resampledToneB = + Osci.shapeFreqMod + (WaveL.sampledTone ipLeap ipStep period tone) + phase (scanl (+) shape0 shapes) freqs + in period /= zero ==> + resampledToneA == resampledToneB +{- +let len=100; period=1/0.06::Double; ip = Interpolation.linear; tone = take len $ iterate (1+) (0::Double); shape0=0; shapes = replicate 100 1; in GNUPlot.plotLists [] [Osci.shapeFreqMod (WaveL.sampledTone ip ip period tone) 0 (scanl (+) shape0 shapes) (repeat 0), Osci.shapeFreqModFromSampledTone ip ip period tone shape0 0 shapes (repeat 0)] +*Test.Sound.Synthesizer.Plain.Oscillator> let len=100; period=1/0.06::Double; ip = Interpolation.linear; tone = take len $ iterate (1+) (0::Double); shape0=0; shapes = concat $ replicate 50 [1.5,0.5]; in GNUPlot.plotLists [] [Osci.shapeFreqMod (WaveL.sampledTone ip ip period tone) 0 (scanl (+) shape0 shapes) (repeat 0), Osci.shapeFreqModFromSampledTone ip ip period tone shape0 0 shapes (repeat 0)] +*Test.Sound.Synthesizer.Plain.Oscillator> let len=100; period=1/0.06::Rational; ipLeap = Interpolation.linear; ipStep = Interpolation.constant; tone = take len $ iterate (1+) (0::Rational); shape0=0; shapes = concat $ replicate 50 [1.5,0.5]; in GNUPlot.plotLists [] (map (map (\x -> fromRational' x :: Double)) [Osci.shapeFreqMod (WaveL.sampledTone ipLeap ipStep period tone) 0 (scanl (+) shape0 shapes) (repeat 0), Osci.shapeFreqModFromSampledTone ipLeap ipStep period tone shape0 0 shapes (repeat 0)]) +-} + + +shapePhaseFreqModFromSampledTone :: (RealField.C t, Eq v) => + InterpolationTest.T t v -> + InterpolationTest.T t v -> + NonNeg.T t -> + NonNeg.Int -> InfiniteList v -> + t -> t -> [NonNeg.T t] -> [t] -> [t] -> + Property +shapePhaseFreqModFromSampledTone = + InterpolationTest.use2 $ \ ipLeap ipStep + periodNN ext ixs shape0 phase shapesNN phaseDistorts freqs -> + let shapes = map NonNeg.toNumber shapesNN + period = NonNeg.toNumber periodNN + periodInt = round period + len = minLength ipLeap ipStep periodInt ext + tone = take len (listFromInfinite ixs) + resampledToneA = + Osci.shapePhaseFreqModFromSampledTone ipLeap ipStep period tone + shape0 phase shapes phaseDistorts freqs + resampledToneB = + Osci.shapeFreqMod + (uncurry $ + Wave.phaseOffset . + WaveL.sampledTone ipLeap ipStep period tone) + phase (zip (scanl (+) shape0 shapes) phaseDistorts) freqs + in period /= zero ==> + resampledToneA == resampledToneB + + +oscillatorCells :: (RealField.C t, Eq v) => + Interpolation.Margin -> + Interpolation.Margin -> + NonNeg.Int -> + NonNeg.T t -> + NonNeg.Int -> InfiniteList v -> + t -> t -> [NonNeg.T t] -> [t] -> + Property +oscillatorCells + marginLeap marginStep periodIntNN periodNN ext ixs shape0 phase shapesNN freqs = + let shapes = map NonNeg.toNumber shapesNN + period = NonNeg.toNumber periodNN + periodInt = NonNeg.toNumber periodIntNN + len = minLengthMargin marginLeap marginStep periodInt ext + tone = take len (listFromInfinite ixs) + crop = cropCell marginLeap marginStep + resampledToneA = + ToneModL.oscillatorCells + marginLeap marginStep periodInt period tone + (shape0, shapes) (Phase.fromRepresentative phase, freqs) + resampledToneB = + Osci.shapeFreqMod + (Wave.Cons . ToneModL.sampledToneCell + (ToneModL.makePrototype marginLeap marginStep + periodInt period tone)) + phase (scanl (+) shape0 shapes) freqs + in period /= zero && + periodInt /= zero && + marginNumber marginLeap > zero && + marginNumber marginStep > zero ==> + map crop resampledToneA == map crop resampledToneB + +cropCell :: + Interpolation.Margin -> + Interpolation.Margin -> + ((t,t), ToneModL.Cell v) -> ((t,t), ToneModL.Cell v) +cropCell ipLeap ipStep = + mapSnd + (take (marginNumber ipStep) . + map (take (marginNumber ipLeap))) + + +shapeFreqModFromSampledToneIdentity :: (RealField.C t, Eq v) => + InterpolationTest.T t v -> + InterpolationTest.T t v -> + NonNeg.T t -> + NonNeg.Int -> InfiniteList v -> + Property +shapeFreqModFromSampledToneIdentity = + InterpolationTest.use2 $ \ ipLeap ipStep + periodNN ext ixs -> + let period = NonNeg.toNumber periodNN + periodInt = round period + len = minLength ipLeap ipStep periodInt ext + tone = take len (listFromInfinite ixs) + shape0 = zero + shapes = repeat one + phase = zero + freqs = repeat (recip period) + (n0,n1) = + shapeLimits ipLeap ipStep periodInt len + + resampledTone = + Osci.shapeFreqModFromSampledTone ipLeap ipStep period tone + shape0 phase shapes freqs + in period /= zero ==> + and (drop n0 (take (succ n1) (zipWith (==) resampledTone tone))) + + +tests :: [(String, IO ())] +tests = + ("limitMinRelativeValues", test limitMinRelativeValues) : + ("limitMaxRelativeValues", test limitMaxRelativeValues) : + ("limitMaxRelativeValuesNonNeg", + test limitMaxRelativeValuesNonNeg) : + ("limitMinRelativeValuesIdentity", + test limitMinRelativeValuesIdentity) : + ("limitMaxRelativeValuesIdentity", + test limitMaxRelativeValuesIdentity) : + ("limitMaxRelativeValuesNonNegIdentity", + test limitMaxRelativeValuesNonNegIdentity) : + ("limitMaxRelativeValuesInfinity", + test limitMaxRelativeValuesInfinity) : + ("limitMaxRelativeValuesNonNegInfinity", + test limitMaxRelativeValuesNonNegInfinity) : + ("dropRem", test (dropRem :: NonNeg.Int -> [ArbChar] -> Bool)) : + ("sampledToneSine", + test (\period -> sampledToneSine (period :: NonNeg.Double))) : + ("sampledToneSineList", + test (\period -> sampledToneSineList (period :: NonNeg.Double))) : + ("sampledToneLinear", + testRationalLineIp sampledToneLinear) : + ("sampledToneStair", + testRationalLineIp sampledToneStair) : +{- + ("sampledToneSaw", + testRationalLineIp sampledToneSaw) : +-} + ("sampledToneStatic", + testRationalIp sampledToneStatic) : + ("shapeFreqModFromSampledToneLimitIdentity", + test (\ml ms p ixs (t,ts) -> + shapeFreqModFromSampledToneLimitIdentity ml ms p + (ixs::InfiniteList Rational) (t::Rational,ts))) : + ("oscillatorCoords", + test (\periodInt period -> + oscillatorCoords + periodInt (period :: NonNeg.Rational))) : + ("shapeFreqModFromSampledToneCoordsIdentity", + test (\periodInt period -> + shapeFreqModFromSampledToneCoordsIdentity + periodInt (period :: NonNeg.Rational))) : + ("shapeFreqModFromSampledTone", + testRationalIp shapeFreqModFromSampledTone) : + ("shapePhaseFreqModFromSampledTone", + testRationalIp shapePhaseFreqModFromSampledTone) : + ("oscillatorCells", + test (\ml ms periodInt period ext ixs -> + oscillatorCells ml ms periodInt (period :: NonNeg.Rational) + ext (ixs :: InfiniteList ArbChar))) : + ("shapeFreqModFromSampledToneIdentity", + testRationalIp shapeFreqModFromSampledToneIdentity) : + [] diff --git a/src/Test/Sound/Synthesizer/Plain/Wave.hs b/src/Test/Sound/Synthesizer/Plain/Wave.hs new file mode 100644 --- /dev/null +++ b/src/Test/Sound/Synthesizer/Plain/Wave.hs @@ -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) : + [] diff --git a/src/Test/Utility.hs b/src/Test/Utility.hs new file mode 100644 --- /dev/null +++ b/src/Test/Utility.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Test.Utility where + +import Test.QuickCheck (Arbitrary(..)) + +import qualified Algebra.Real as Real +import qualified Algebra.Ring as Ring + +import qualified Data.Char as Char + +import PreludeBase +import NumericPrelude + + +equalList :: Eq a => [a] -> Bool +equalList xs = + -- 'drop 1' instead of 'take' for suppression of error + and (zipWith (==) xs (drop 1 xs)) + + +approxEqual :: (Real.C a) => a -> a -> a -> Bool +approxEqual eps x y = + 2 * abs (x-y) <= eps * (abs x + abs y) + +approxEqualListRel :: (Real.C a) => a -> [a] -> Bool +approxEqualListRel eps xs = + let n = fromIntegral $ length xs + in approxEqualListAbs (eps * n * sum (map abs xs)) xs + +approxEqualListAbs :: (Real.C a) => a -> [a] -> Bool +approxEqualListAbs eps xs = + let n = fromIntegral $ length xs + s = sum xs + in sum (map (\x -> abs (n*x-s)) xs) <= eps + + +-- see event-list + +newtype ArbChar = ArbChar Char + deriving (Eq, Ord) + +instance Show ArbChar where + showsPrec n (ArbChar c) = showsPrec n c + +instance Arbitrary ArbChar where + arbitrary = fmap (ArbChar . Char.chr . (32+) . flip mod 96) arbitrary + coarbitrary = undefined diff --git a/synthesizer-core.cabal b/synthesizer-core.cabal new file mode 100644 --- /dev/null +++ b/synthesizer-core.cabal @@ -0,0 +1,295 @@ +Name: synthesizer-core +Version: 0.2 +License: GPL +License-File: LICENSE +Author: Henning Thielemann +Maintainer: Henning Thielemann +Homepage: http://www.haskell.org/haskellwiki/Synthesizer +Category: Sound +Synopsis: Audio signal processing coded in Haskell: Low level part +Description: + Low level audio signal processing + used by the other synthesizer packages. + The routines can be really fast + due to StorableVector, Stream-like list type and aggressive inlining. + For an interface to Haskore see . + For introductory examples see "Synthesizer.Plain.Tutorial" + and "Synthesizer.Generic.Tutorial". +-- the Overview module does not really fit into one of the part packages +-- For an overview of the organization of the package +-- and the discussion of various design issues see "Synthesizer.Overview". +Stability: Experimental +Tested-With: GHC==6.4.1, GHC==6.8.2 +Cabal-Version: >=1.6 +Build-Type: Simple + +Extra-Source-Files: + Makefile + src-3/Synthesizer/Causal/Process.hs + src-4/Synthesizer/Causal/Process.hs + src-4/Synthesizer/Inference/DesignStudy/Applicative.hs + src-4/Synthesizer/Inference/DesignStudy/Monad.hs + src-4/Synthesizer/Inference/DesignStudy/Arrow.hs + +Flag splitBase + description: Choose the new smaller, split-up base package. + +Flag category + description: Check whether Arrow class is split into Arrow and Category. + +Flag optimizeAdvanced + description: Enable advanced optimizations. They slow down compilation considerably. + default: True + +Flag buildProfilers + description: Build executables for investigating efficiency of code + default: False + +Flag buildTests + description: Build test suite + default: False + + +Source-Repository this + Tag: 0.2 + Type: darcs + Location: http://code.haskell.org/synthesizer/core/ + +Source-Repository head + Type: darcs + Location: http://code.haskell.org/synthesizer/core/ + +Library + Build-Depends: + transformers >=0.0.1 && <0.2, + event-list >=0.0.8 && <0.1, + non-negative >=0.0.5 && <0.1, + numeric-prelude >=0.1.1 && <0.2, + numeric-quest >= 0.1 && <0.2, + utility-ht >=0.0.5 && <0.1, + sox >=0.0 && <0.1, + filepath >=1.1 && <1.2, + bytestring >= 0.9 && <0.10, + binary >=0.1 && <1, + storablevector >=0.2.3 && <0.3, + storable-record >=0.0.1 && <0.1, + QuickCheck >=1 && <2 + + If flag(splitBase) + If flag(category) + Hs-Source-Dirs: src-4 + Build-Depends: base >= 4 && <5 + Else + Hs-Source-Dirs: src-3 + Build-Depends: base >= 3 && <4 + Build-Depends: + array >=0.1 && <0.3, + containers >=0.1 && <0.3, + random >=1.0 && <2.0, + process >=1.0 && <1.1 + Else + Hs-Source-Dirs: src-3 + Build-Depends: + base >= 1.0 && < 2, + special-functors >= 1.0 && <1.1 + + GHC-Options: -Wall + Hs-source-dirs: src + Exposed-modules: + Synthesizer.Storage + + Synthesizer.ApplicativeUtility + Synthesizer.Format + Synthesizer.RandomKnuth + Synthesizer.Piecewise + Synthesizer.Basic.Binary + Synthesizer.Basic.Distortion + Synthesizer.Basic.DistortionControlled + Synthesizer.Basic.Phase + Synthesizer.Basic.ToneModulation + Synthesizer.Basic.Wave + Synthesizer.Basic.WaveSmoothed + Synthesizer.Interpolation + Synthesizer.Interpolation.Class + Synthesizer.Interpolation.Module + Synthesizer.Interpolation.Custom + Synthesizer.Frame.Stereo + Synthesizer.Plain.Signal + Synthesizer.Plain.Analysis + Synthesizer.Plain.Cut + Synthesizer.Plain.Control + Synthesizer.Plain.Displacement + Synthesizer.Plain.Filter.NonRecursive + Synthesizer.Plain.Filter.Recursive + Synthesizer.Plain.Filter.Recursive.Allpass + Synthesizer.Plain.Filter.Recursive.AllpassPoly + Synthesizer.Plain.Filter.Recursive.Butterworth + Synthesizer.Plain.Filter.Recursive.Chebyshev + Synthesizer.Plain.Filter.Recursive.Comb + Synthesizer.Plain.Filter.Recursive.FirstOrder + Synthesizer.Plain.Filter.Recursive.FirstOrderComplex + Synthesizer.Plain.Filter.Recursive.Integration + Synthesizer.Plain.Filter.Recursive.Moog + Synthesizer.Plain.Filter.Recursive.MovingAverage + Synthesizer.Plain.Filter.Recursive.SecondOrder + Synthesizer.Plain.Filter.Recursive.SecondOrderCascade + Synthesizer.Plain.Filter.Recursive.Universal + Synthesizer.Plain.Filter.Recursive.Test + Synthesizer.Plain.Filter.Delay + Synthesizer.Plain.Filter.Delay.ST + Synthesizer.Plain.Filter.Delay.List + Synthesizer.Plain.Filter.Delay.Block + Synthesizer.Plain.Filter.LinearPredictive + Synthesizer.Plain.Interpolation + Synthesizer.Plain.LorenzAttractor + Synthesizer.Plain.Modifier + Synthesizer.Plain.Noise + Synthesizer.Plain.Oscillator + Synthesizer.Plain.ToneModulation + Synthesizer.Plain.Wave + Synthesizer.Plain.Miscellaneous + Synthesizer.Plain.Instrument + Synthesizer.Plain.Effect + Synthesizer.Plain.Effect.Fly + Synthesizer.Plain.Effect.Glass + Synthesizer.Plain.Builder + Synthesizer.Plain.IO + Synthesizer.Plain.File + Synthesizer.Plain.Play + Synthesizer.FusionList.Control + Synthesizer.FusionList.Filter.NonRecursive + Synthesizer.FusionList.Oscillator + Synthesizer.FusionList.Signal + Synthesizer.Storable.Cut + Synthesizer.Storable.Oscillator + Synthesizer.Storable.Signal + Synthesizer.State.Analysis + Synthesizer.State.Control + Synthesizer.State.Cut + Synthesizer.State.Displacement + Synthesizer.State.Filter.NonRecursive + Synthesizer.State.Filter.Delay + Synthesizer.State.Filter.Recursive.Comb + Synthesizer.State.Filter.Recursive.Integration + Synthesizer.State.Filter.Recursive.MovingAverage + Synthesizer.State.Interpolation + Synthesizer.State.Miscellaneous + Synthesizer.State.Noise + Synthesizer.State.NoiseCustom + Synthesizer.State.Oscillator + Synthesizer.State.Signal + Synthesizer.State.ToneModulation + Synthesizer.Causal.Process + Synthesizer.Causal.Displacement + Synthesizer.Causal.Interpolation + Synthesizer.Causal.Oscillator + Synthesizer.Causal.ToneModulation + Synthesizer.Generic.Analysis + Synthesizer.Generic.Cut + Synthesizer.Generic.Control + Synthesizer.Generic.Displacement + Synthesizer.Generic.Filter.NonRecursive + Synthesizer.Generic.Filter.Delay + Synthesizer.Generic.Filter.Recursive.Integration + Synthesizer.Generic.Filter.Recursive.MovingAverage + Synthesizer.Generic.Filter.Recursive.Comb + Synthesizer.Generic.Interpolation + Synthesizer.Generic.Noise + Synthesizer.Generic.Oscillator + Synthesizer.Generic.Signal + Synthesizer.Generic.Signal2 + Synthesizer.Generic.Wave + + -- that's only exposed for Haddock + Synthesizer.Plain.Tutorial + Synthesizer.Generic.Tutorial + + -- synthesizer.dimensional:Synthesizer.Dimensional.Causal.Filter import affineComb + Synthesizer.Utility + + Other-Modules: + Synthesizer.Filter.Basic + Synthesizer.Filter.Composition + Synthesizer.Filter.Example + Synthesizer.Filter.Fix + Synthesizer.Filter.Graph + Synthesizer.Filter.Graphic + Synthesizer.Filter.MonadFix + Synthesizer.Filter.OneWay + Synthesizer.Filter.TwoWay + + +Executable test + If !flag(buildTests) + Buildable: False + GHC-Options: -Wall + Hs-Source-Dirs: src + If flag(category) + Hs-Source-Dirs: src-4 + Else + Hs-Source-Dirs: src-3 + Other-Modules: + Test.Utility + Test.Sound.Synthesizer.Plain.Analysis + Test.Sound.Synthesizer.Plain.Control + Test.Sound.Synthesizer.Plain.Filter + Test.Sound.Synthesizer.Plain.Interpolation + Test.Sound.Synthesizer.Plain.Oscillator + Test.Sound.Synthesizer.Plain.ToneModulation + Test.Sound.Synthesizer.Plain.Wave + Test.Sound.Synthesizer.Basic.ToneModulation + Test.Sound.Synthesizer.Generic.ToneModulation + Main-Is: Test/Main.hs + +Executable fusiontest + If !flag(buildProfilers) + Buildable: False + GHC-Options: -Wall -fexcess-precision + If flag(optimizeAdvanced) + GHC-Options: -ddump-simpl-stats + Hs-Source-Dirs: speedtest, src + If flag(category) + Hs-Source-Dirs: src-4 + Else + Hs-Source-Dirs: src-3 + Main-Is: FusionTest.hs + +Executable speedtest + If !flag(buildProfilers) + Buildable: False + GHC-Options: -Wall -fexcess-precision + If flag(optimizeAdvanced) + GHC-Options: -optc-ffast-math -optc-O3 + -- -funfolding-use-threshold=20 -funfolding-creation-threshold=100 + -- -optc-march=pentium4 -optc-mfpmath=sse + Hs-Source-Dirs: speedtest, src + If flag(category) + Hs-Source-Dirs: src-4 + Else + Hs-Source-Dirs: src-3 + Main-Is: SpeedTest.hs + +Executable speedtest-exp + If !flag(buildProfilers) + Buildable: False + GHC-Options: -Wall -fexcess-precision + Hs-Source-Dirs: speedtest, src + If flag(category) + Hs-Source-Dirs: src-4 + Else + Hs-Source-Dirs: src-3 + Main-Is: SpeedTestExp.hs + If flag(splitBase) + Build-Depends: + old-time >= 1.0 && < 1.1, directory >= 1.0 && < 1.1 + +Executable speedtest-simple + If !flag(buildProfilers) + Buildable: False + GHC-Options: -Wall + Hs-Source-Dirs: speedtest, src + If flag(category) + Hs-Source-Dirs: src-4 + Else + Hs-Source-Dirs: src-3 + Main-Is: SpeedTestSimple.hs