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,124 @@ + +OBJECT_DIR := build/$(shell uname -s)-$(shell uname -m) +INTERFACE_DIR := build/Interface + + +SOURCE = $(patsubst %, src/%, $(TOPLEVEL)) \ + $(HASKORE_INTERFACE) $(MUSIC) \ + $(PLAIN) $(FILTER) $(DIMENSION) $(VOLUME) $(SRCONTEXT) $(PHYSICAL) \ + $(FUSION) $(STORABLE) \ + $(INFERENCE) $(SOX) + +TOPLEVEL = \ + BinarySample.hs +# DiscreteWavelet/Lifting DiscreteWavelet/Lattice \ +# Signal.hs ShiftedSignal.hs + +MUSIC = $(patsubst %, src/Music/%, \ + WinterAde.hs FilterSaw.hs FMBassLine.hs SwanLake.hs \ + ChildSong6ToSignal.hs Guitar.hs ) + +HASKORE_INTERFACE = \ + $(patsubst %, src/Haskore/Interface/Signal/%, \ + Note.hs InstrumentMap.hs Write.hs) + +SIGNAL = $(wildcard src/Sound/Signal/*.hs) src/Sound/Signal.hs + +PLAIN = $(wildcard src/Synthesizer/Plain/*.hs) \ + $(wildcard src/Synthesizer/Plain/Effect/*.hs) \ + $(wildcard src/Synthesizer/Plain/Filter/*.hs) \ + $(wildcard src/Synthesizer/Plain/Filter/Delay/*.hs) +FILTER = $(wildcard src/Filter/*.hs) +DIMENSION = $(wildcard src/Synthesizer/Dimension/*.hs) \ + $(wildcard src/Synthesizer/Dimension/Amplitude/*.hs) \ + $(wildcard src/Synthesizer/Dimension/Rate/*.hs) \ + $(wildcard src/Synthesizer/Dimension/RateAmplitude/*.hs) +VOLUME = $(wildcard src/Synthesizer/Amplitude/*.hs) +SRCONTEXT = $(wildcard src/Synthesizer/SampleRateContext/*.hs) +FUSION = $(wildcard src/Synthesizer/FusionList/*.hs) +STORABLE = $(wildcard src/Synthesizer/Storable/*.hs) +PHYSICAL = $(wildcard src/Synthesizer/Physical/*.hs) +INFERENCE = $(wildcard src/Synthesizer/Inference/Monad/*.hs) \ + $(wildcard src/Synthesizer/Inference/Monad/Signal/*.hs) \ + $(wildcard src/Synthesizer/Inference/Monad/SignalSeq/*.hs) \ + $(wildcard src/Synthesizer/Inference/Reader/*.hs) +SOX = src/Sox.hs $(wildcard src/Sox/*.hs) + + + +HTML = doc/html + +STDHADDOCK = base/base.haddock + +CUSTOMHADDOCK = numericprelude/docs/numericprelude.haddock haskore/docs/haskore.haddock + +HADDOCK_INCL = $(patsubst %, -i /usr/local/share/ghc-6.2/html/libraries/%, $(STDHADDOCK)) \ + $(patsubst %, -i $(HOME)/programming/haskell/%, $(CUSTOMHADDOCK)) + +# if the 6.4.1 files are used, many identifiers like ExitCode can not be found +# CUSTOMHADDOCK = numericprelude/docs/numericprelude.haddock haskore/docs/haskore.haddock +# HADDOCK_INCL = $(patsubst %, -i /usr/share/doc/ghc-6.4.1/libraries/%, $(STDHADDOCK)) \ +# $(patsubst %, -i $(HOME)/programming/haskell/%, $(CUSTOMHADDOCK)) + +HADDOCK_SOURCE = $(SOURCE) src/Synthesizer/Physical.hs src/Synthesizer/Inference/Monad.hs + + +#MODULES = Synthesizer Instruments SignalIO Signal Test Filter/Test + +MODULE_PATH = src # the other modules are now present by (Cabal) packages +# MODULE_PATH = src:..:../numericprelude/src:../linearalgebra:../math:../shell-haskell:../haskore/src:../haskore/src/GHC + + +HC = ghc # ghc-6.2.2 +HCINT = ghci # ghci-6.2.2 + +GHC_OPTIONS = -O -Wall -odir$(OBJECT_DIR) -hidir$(INTERFACE_DIR) -hide-package synthesizer + + +.PHONY: all doc build test clean perm + +all: build + +clean: + rm -r $(OBJECT_DIR) $(INTERFACE_DIR)/* + +doc: $(SOURCE) + haddock --html-help=devhelp -o $(HTML) -t Synthesizer -p doc/Prologue.txt -h --dump-interface=doc/synthesizer.haddock \ + $(HADDOCK_INCL) $(HADDOCK_SOURCE) + chmod -R o+rx $(HTML) + +publish-doc: doc + tar cz $(HTML) | ssh cvs.haskell.org tar xz --directory=/home/darcs/synthesizer + +build: + -mkdir $(OBJECT_DIR) + $(HC) --make $(GHC_OPTIONS) -i:$(MODULE_PATH) $(SOURCE) +# $(HC) --make -O -Wall $(patsubst %, %.hs, $(MODULES)) + +perm: + (cd /home/thielema; \ + chgrp -R perform projects/paper/haskellsignal programming/haskell/synthesizer; \ + chmod -R g+rw projects/paper/haskellsignal programming/haskell; \ + chmod g+x `find programming/haskell -type d`; \ + rm /tmp/curve.dat; ) + +test: + $(HC) $(GHC_OPTIONS) -i:$(MODULE_PATH) --make src/Test.hs + time $(HC) $(GHC_OPTIONS) -i:$(MODULE_PATH) -e main src/Test.hs +# time a.out + +main: + $(HC) $(GHC_OPTIONS) -i:$(MODULE_PATH) --make Main.hs + time a.out + +ghci: + $(HCINT) -Wall -odirdist/build -hidirdist/build -hide-package synthesizer -i:$(MODULE_PATH) + +ghci-custom: + $(HCINT) $(GHC_OPTIONS) -i:$(MODULE_PATH) + +%.o: %.hs + $(HC) -i:$(MODULE_PATH) -O --make $< + +%.o: %.c + gcc -c -o $@ $< 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/doc/Prologue.txt b/doc/Prologue.txt new file mode 100644 --- /dev/null +++ b/doc/Prologue.txt @@ -0,0 +1,272 @@ + +This is a collection of modules for synthesizing and processing audio signals. +It allows generation of effects, instruments and +even music using the Haskore package. +It can write raw audio data to files, +convert them to common audio formats or +play them using external commands from the Sox package. + +A signal is modeled by a list of values. +E.g. @[Double]@ represents a mono signal, +@[(Double, Double)]@ stores a stereo signal. +Since a list is lazy, it can be infinitely long, +and it also supports feedback. +(The drawback is, that its implementation is very slow. +I'm working on that issue.) +We are using the NumericPrelude type class hierarchy +which is cleaner than the one of Haskell 98 +and provides us with type classes for vector spaces. +This allows us to formulate many algorithms for mono, stereo and multi-channel signals at once. +The drawback is that the vector space type class has multiple type parameters. +This type extension is availabe in GHC and Hugs and maybe other compilers. +It may hurt you, because type inference fails sometimes, +resulting in strange type errors. +(To be precise: GHC suggests type constraints intended for fixing the problem, +but if you copy them to your program, they won't fix the problem, +because the constraint refers to local variables +that you have no access to at the signature. +In this case you have to use 'asTypeOf' or similar self-written helpers.) + +There must also be information about how fast sample values are emitted. +This is specified by the sample rate. +44100 Hz means that 44100 sample values are emitted per second. +This information must be stored along with the sample values. +This is where things become complicated. + +In the very basic modules in the "Synthesizer.Plain" directory, +there is no notion of sample rate. +You have to base all computations on the number of samples. +This is unintuitive and disallows easy adaption to different audio devices +(CD, DAT, ...). +But it is very simple and can be re-used in the higher level modules. + +Let's continue with the sample rate issue. +Sounds of different sources may differ in their sampling rate +(and also with respect to its amplitude and the unit of the values). +Sampled sounds have 44100 Hz on a compact disk, +48000 Hz or 32000 Hz on DAT recorders. +We want to respect different sampling rates and volumes, +we want to let signals in different formats coexist nicely, +and we want to let the user choose when to do which conversion +(called /resampling/) +in order to bring them together. + +In fact this view generalises the concept of note, control, and audio rates, +which is found in some software synthesizers, +like CSound and SuperCollider. +If signals of different rate are fed to a signal processor +in such a software synthesizer, +all signals are converted to the highest rate among the inputs. +Then the processor runs at this rate. +The conversion is usually done by \"constant\" interpolation, +in order to minimize recomputation of internal parameters. +However the handling of different signal rates must be built into every processor, +and may even reduce the computation speed. +Consider an exponential envelope which is computed at control rate +and an amplifier which applies this envelope to an audio signal. +The amplifier has to upsample the exponential envelope before applying it to the signal. +But the generation of the exponential is very simple, +one multiplication per sample, +and the amplifier is very simple, too, +again only one multiplication per sample. +So, is there a need for trouble of the resampling? +Does it really accelerates computation? +Many other envelope generators like straight lines, sines, oscillators, +are comparably simple. +However there are some processors like filters, +which need some recomputation when a control parameter changes. + +Our approach is this one: +We try to avoid resampling and compute all signals at the same rate, +if no speed loss must be expected. +If a speed loss is to be expected, +we can interpolate the internal parameters of the processor explicitly. +This way we can also specify an interpolation method. +Alternatively we can move the interpolation into the processor +but let the user specify an interpolation method. +(Currently it can be used only manually for the low-level routines in "Synthesizer.Plain" +and there is no support for that mechanism in the high level variants.) + +Additional to the treatment of sampling rates, +we also want to separate amplitude information from the signal. +The separated amplitude serves two purposes: + +(1) The amplitude can be equipped with a physical unit, + whereas this information is omitted for the samples. + Since I can hardly imagine that it is sensible to mix samples + with different physical units, + it would be only wasted time to always check + if all physical values of a sequence have the same unit. + +(2) The amplitude can be a floating point number, + but the samples can be fixed point numbers. + This is interesting for hardware digital signal processors + or other low-level applications. + With this method we can separate the overall dynamics from the samples. + + +Let's elaborate on the physical units now. +With them we can work with values from the real world immediately +and we have additional (dynamic) safety by unit checks. + +Of course I prefer static safety. +E.g. I want to avoid +to accidentally call a function with conflicting parameters. +However, I see no way for both applying the unit checks statically +and let the user enter physical quantities. +Phantom types or unit vectors stored in a type do not seem to help here. +We have two solutions: + +(1) Store units in a data structure and check them dynamically. + This is imported from NumericPreludes's "Number.Physical". + Units can be fetched from the user. + The API of signal processing functions is generic enough + to cover both values without units and values with units. + Debugging of unit errors is cumbersome. + +(2) Store physical dimensions in types + either using Buckwalter's dimensional package + or using NumericPreludes's "Number.DimensionTerm". + Here we use the latter one. + This is the most useful if user interaction is not needed. + If data is fetched from an audio file + the dimensions are statically fixed. + +There are still several alternatives +of how to handle the sample rates +(that can be equipped with physical dimensions). + +(1) Stick to simple lists as data and + pass additional information directly to the functions. + E.g. mixing several signals is easy + since only one sampleRate is given + which applies to all signals. + But it leads to the problem + that subsequent function calls must receive the same value. + This cannot be guaranteed and is thus a source of error. + E.g. the mistake + @play (44100*hertz) (osciSine (22050*hertz) (440*hertz))@ + can't be detected. + In this approach the signal data structure is very simple, + the values may be passed to multiple functions, + the combinations are simply done by function application, + a supervisor is not necessary, + consistency checks can hardly be performed. + This approach is certainly the most basic one, + on which others, more safer ones, can sit on top. + It is implemented in "Synthesizer.Plain" with numbers without units. + +(2) Equip signals with sample rate and amplitude. + Processors without input need the sample rate as explicit parameter. + If there is more than one signal as input, + then there must be additional checks. + The error in + @ + mix (osciSine (22050*hertz) (440*hertz)) + (osciSine (44100*hertz) (330*hertz)) + @ + can be detected at runtime. + However the sample rate has to be specified for both input signals, + although it is obvious, that both signals have to share the sample rate. + In this approach the data structure is more complex, + the values may be passed to multiple functions + but consistency checks can be performed + and a supervisor is still not necessary. + This strategy is implemented in the "Synthesizer.Physical" modules. + +(3) We still like to hide the sample rate where possible. + All processors should work as good as possible at each rate. + Here we provide the sample rate to each processor. + The result of a processor is not just a list of samples + but it is a function, which computes the list of samples + depending on the sample rate. + Sample rate is fixed not until it comes to the rendering of a sound, + e.g. for playing or writing of a file. + @play (44100*hertz) (osciSine (440*hertz))@ + Returning a function instead of computed data + has the disadvantage that multiply used data cannot be shared. + For these situations we need a @share@ function. + Combinator functions similar to @($)@ are used + to plug sample rate dependent output from one processor + into plain signal parameters. + With this approach, the type signature tells + which signals share the sample rate. + Infinitely many signals can be handled. + Types for time and volume can be chosen quite freely. + Supervision is not necessary. + This strategy is implemented in the "Synthesizer.Inference.Reader" modules, + where we hide the sample rate in a 'Control.Monad.Reader.Reader'. + There is also "Synthesizer.SampleRateContext" + which exposes the sample rate. + It is more convenient to implement and to call, + but I think it is more unsafe, + because you can mix sample rates from different sources accidentally. + The same is available for numbers with dimension terms in types. + See "Synthesizer.Dimensional". + /In most cases this will be the method of choice!/ + Maybe I'm going to wrap this in a Reader monad\/applicative functor. + It also requires that Haddock supports comments in parameters of type constructors. + +(4) I have tried more sophisticated approaches + in order to handle not only the sample rates but also the amplitudes. + However I feel that I wanted more than I actually needed. + I do no longer maintain these approaches but explain them for completeness. + The most convenient solution for handling sample rates and amplitudes + is certainly an inference system like Haskell's type system. + If some input and output signals of a processor + must have the same sampling rate, + then the concrete rate must only be known for one of these signals. + If no participating signal has a fixed rate, this is an error. + The dependencies of sampling rates become very large by this system. + The direction can be from inputs to outputs and vice versa, + not to mention loops. + This approach needs a lot of management, + e.g. a supervisor which runs the network, + but it is very convenient and safe. + However, sometimes you have to fiddle with monads. + Unfortunately it is restricted to finitely many monads + and the types for time and volume are restricted. + Thus this concept does not scale to physical units expressed in types. + This strategy is implemented in the modules under "Synthesizer.Inference.Monad". + +(5) We try to work-around the restrictions + using a function based approach. + Since the parameters are functions, + sharing cannot take place. + There is no way to spread sample rate from one consumer to another one. + E.g. If there is + @ + let y = f x; + z = g x + @ + and it is known that @f@ and @g@ maintain the sample rate, + and the sample rate of @z@ is known - how to infer the sample rate of @y@? + This approach was dropped quickly and + exists for historical reasons in "Synthesizer.Inference.Func". + +(6) There is a very cool approach, + which implements the equation solver of the monadic approach + by lazy evaluation and Peano numbers. + This poses no restriction on types + and works for infinitely many equations as well. + The drawbacks are difficult application + (you cannot simply apply a function to a signal, + but you must compose functions in a special way), + and slow solution of the equation system + (quadratic time although in principle + only run-time around linear time is necessary, + it's similar to topological sort). + However it's as slow as the explicit solver using monads in "Synthesizer.Inference.Monad". + This strategy is tested in the modules under "InferenceFix". + + +An interface to the music composition library Haskore +can be found in "Haskore.Interface.Signal.Write". +Example songs based on this interface +are stored in the directory "Music". + +The module "Presentation" in the @dafx@ package contains functions +for demonstrating synthesizer functions in GHCi +and "DAFx" contains some examples based on them. +Just hit @make dafx@ in a shell in order to compile the modules +and enter the interactive GHC with all modules loaded. diff --git a/speedtest/FusionTest.hs b/speedtest/FusionTest.hs new file mode 100644 --- /dev/null +++ b/speedtest/FusionTest.hs @@ -0,0 +1,821 @@ +{-# OPTIONS_GHC -O2 -fglasgow-exts #-} +module Main (main) where + +import qualified Synthesizer.Storable.Signal as SigSt +import qualified Synthesizer.Storable.Oscillator as OsciSt +import qualified Synthesizer.Storable.Cut as CutSt + +import qualified Synthesizer.State.Signal as SigS +import qualified Synthesizer.State.Oscillator as OsciS +import qualified Synthesizer.State.Control as CtrlS +import qualified Synthesizer.State.Filter.NonRecursive as FiltNRS +import qualified Synthesizer.State.Cut as CutS +import qualified Synthesizer.State.Control as CtrlS +import qualified Synthesizer.State.NoiseCustom as NoiseS +import qualified Synthesizer.State.Interpolation as InterpolationS + +import qualified Synthesizer.FusionList.Signal as SigFL +import qualified Synthesizer.FusionList.Oscillator as OsciFL +import qualified Synthesizer.FusionList.Control as CtrlFL +import qualified Synthesizer.FusionList.Filter.NonRecursive as FiltNRFL + +import qualified Synthesizer.Generic.Signal as SigG +import qualified Synthesizer.Generic.Filter.Delay as DelayG +import qualified Synthesizer.Generic.Interpolation as InterpolationG + +import qualified Synthesizer.Basic.Wave as Wave +import qualified Synthesizer.Basic.Phase as Phase +import qualified Synthesizer.Basic.DistortionControlled as Dist +import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilter +import qualified Synthesizer.Plain.Filter.Recursive as FiltR +import qualified Synthesizer.Plain.Control as Ctrl +import Synthesizer.Piecewise ((|#), (#|-), (-|#), (#|), ) + +import qualified Data.EventList.Relative.TimeBody as EventList + +import BinarySample (numToInt16Packed, doubleToInt16Packed) +import Data.Int (Int8, Int16) +import Foreign.Storable (Storable) +import qualified Sound.Signal as Signal +import qualified Data.List as List +import qualified Data.Char as Char + +import GHC.Float (double2Int, int2Double) +import NumericPrelude ((^?)) +import qualified NumericPrelude as NP + +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import System.Random (mkStdGen) +import qualified Synthesizer.RandomKnuth as Knuth + + +{- +If you increase the chunk size to 10000 the computation becomes slower. +Is this reproducable? +-} +defaultChunkSize :: SigSt.ChunkSize +defaultChunkSize = SigSt.chunkSize 1000 + + +{-# INLINE storableFromFusionList #-} +storableFromFusionList :: Storable a => SigFL.T a -> SigSt.T a +storableFromFusionList = + SigFL.toStorableSignal defaultChunkSize +-- SigSt.fromFusionList defaultChunkSize + +mapTest0 :: SigSt.T Char +mapTest0 = + SigSt.fromList defaultChunkSize + (List.map succ (List.replicate 200000 'a')) + +mapTest1 :: [Char] -> SigSt.T Char +mapTest1 = + SigSt.fromList defaultChunkSize . List.map Char.toUpper + +mapTest2 :: [Char] -> SigSt.T Char +mapTest2 xs = + SigSt.fromList defaultChunkSize (List.map Char.toUpper xs) + +mapTest3 :: SigSt.T Int8 +mapTest3 = + SigSt.fromList defaultChunkSize + (List.map succ (List.replicate 200000 1234)) + +mapTest4 :: SigSt.T Int8 +mapTest4 = + SigSt.fromList defaultChunkSize + (List.map pred (List.replicate 200000 1234)) + +mapTest5 :: SigSt.T Int8 +mapTest5 = + storableFromFusionList + (SigFL.map pred (SigFL.replicate 200000 1234)) + +{- inlining here even reduces the application of rules - Why? -} +{- INLINE mapTest6 -} +mapTest6 :: SigSt.T Int16 +mapTest6 = + storableFromFusionList $ SigFL.take 200000 $ + SigFL.map numToInt16Packed $ +-- SigFL.map (^2) $ + SigFL.repeat (3::Double) + + +{-# INLINE zeroPhase #-} +zeroPhase :: Phase.T Double +zeroPhase = NP.zero + +osciTest0 :: SigSt.T Int16 +osciTest0 = + storableFromFusionList $ + SigFL.take 200000 $ + -- numToInt16Packed is not only slow in execution but also blocks fusion - why? + SigFL.map numToInt16Packed $ + (OsciFL.staticSaw zeroPhase 0.01 :: SigFL.T Double) + +osciTest0a :: SigSt.T Int16 +osciTest0a = + storableFromFusionList $ + SigFL.take 200000 $ + SigFL.map doubleToInt16Packed $ + OsciFL.staticSaw zeroPhase 0.01 + +{- +{-# INLINE exponential2 #-} +exponential2 :: Trans.C a => + a {-^ half life -} + -> a {-^ initial value -} + -> SigFL.T a + {-^ exponential decay -} +exponential2 halfLife = + SigFL.iterate (((Ring.one Field./ (Ring.one Additive.+ Ring.one)) Trans.^? Field.recip halfLife) Ring.*) +-} + + +osciTest0b :: SigSt.T Int16 +osciTest0b = + storableFromFusionList $ + SigFL.take 200000 $ + SigFL.map doubleToInt16Packed $ + FiltNRFL.envelope + (CtrlFL.exponential2 50000 1) + (OsciFL.staticSaw zeroPhase 0.01) + +osciTest0ba :: SigSt.T Int16 +osciTest0ba = + storableFromFusionList $ + SigFL.take 200000 $ + SigFL.map doubleToInt16Packed $ + CtrlFL.exponential2 50000 1 + +osciTest0c :: SigSt.T Int16 +osciTest0c = + storableFromFusionList $ + SigFL.take 200000 $ + SigFL.map doubleToInt16Packed $ + FiltNRFL.envelope + (CtrlFL.exponential2 50000 0.5) + (OsciFL.shapeMod Wave.squareBalanced zeroPhase 0.01 $ + SigFL.map (0.5*) $ OsciFL.staticSine zeroPhase 0.00002) + +osciTest0d :: SigSt.T Int16 +osciTest0d = + storableFromFusionList $ + SigFL.take 200000 $ + SigFL.map doubleToInt16Packed $ + FiltNRFL.envelope +-- (exponential2 50000 0.5) + (CtrlFL.exponential2 50000 0.5) +-- (SigFL.iterate ((0.5 ^? recip 50000)*) 0.5) + (OsciFL.freqMod Wave.square zeroPhase + (SigFL.map (0.01+) $ SigFL.map (0.0001*) $ OsciFL.staticSine zeroPhase 0.0001)) + +osciTest0e :: SigSt.T Int16 +osciTest0e = + storableFromFusionList $ + SigFL.take 200000 $ + SigFL.map doubleToInt16Packed $ + FiltNRFL.envelope + (CtrlFL.exponential2 50000 0.5) + (OsciFL.shapeFreqMod Wave.squareBalanced zeroPhase + (SigFL.map (0.5*) $ OsciFL.staticSine zeroPhase 0.00002) + (SigFL.map (0.01+) $ SigFL.map (0.0001*) $ OsciFL.staticSine zeroPhase 0.0001)) + +osciTest0ea :: SigSt.T Int16 +osciTest0ea = + storableFromFusionList $ + SigFL.take 200000 $ + SigFL.map doubleToInt16Packed $ + (OsciFL.shapeFreqMod Wave.squareBalanced zeroPhase + (OsciFL.staticSine zeroPhase 0.00002) + (OsciFL.staticSine zeroPhase 0.0001)) + +osciTest0f :: SigSt.T Int16 +osciTest0f = + storableFromFusionList $ + SigFL.take 200000 $ + SigFL.map doubleToInt16Packed $ + FiltNRFL.envelope + (CtrlFL.exponential2 50000 1) +-- (SigFL.zipWith (\x y -> (x+y)/2) +-- (MiscFL.mix + (SigFL.mix + (OsciFL.static Wave.saw zeroPhase 0.01003) + (OsciFL.static Wave.saw zeroPhase 0.00997)) +-- staticSaw blocks fusion +-- (OsciFL.staticSaw zeroPhase 0.01003) +-- (OsciFL.staticSaw zeroPhase 0.00997)) + +osciTest0fa :: SigSt.T Int16 +osciTest0fa = + storableFromFusionList $ + SigFL.take 200000 $ + SigFL.map doubleToInt16Packed $ + FiltNRFL.envelope + (CtrlFL.exponential2 50000 1) + (SigFL.mix + (SigFL.mix + (OsciFL.staticSaw zeroPhase 0.01001) + (OsciFL.staticSaw zeroPhase 0.00998)) + (SigFL.mix + (OsciFL.staticSaw zeroPhase 0.01005) + (OsciFL.staticSaw zeroPhase 0.00996))) + +osciTest1 :: SigSt.T Double +osciTest1 = + storableFromFusionList $ + SigFL.take 200000 $ + (OsciFL.staticSaw zeroPhase 0.01 :: SigFL.T Double) + +osciTest2 :: SigSt.T Int16 +osciTest2 = + storableFromFusionList $ + SigFL.take 200000 $ + SigFL.iterate (200+) 0 + +osciTest3 :: SigSt.T Double +osciTest3 = + SigSt.take 200000 $ + SigSt.map (\x->x*x) $ + SigSt.iterate defaultChunkSize (200+) 0 + +osciTest4 :: SigSt.T Int16 +osciTest4 = + SigSt.take 200000 $ + SigSt.map numToInt16Packed $ -- this is now really fast thanks to specialisation + (SigSt.iterate defaultChunkSize (1+) 0 :: SigSt.T Double) + +osciTest5 :: SigSt.T Int16 +osciTest5 = + SigSt.take 200000 $ + SigSt.map doubleToInt16Packed $ + (SigSt.iterate defaultChunkSize (1+) 0 :: SigSt.T Double) + +osciTest6 :: SigSt.T Int16 +osciTest6 = + -- takeCrochet is slow if not fused away + SigSt.takeCrochet 200000 $ + SigSt.map doubleToInt16Packed $ + (SigSt.iterate defaultChunkSize (1+) 0 :: SigSt.T Double) + + +{- +waveSine :: Floating a => a -> a +waveSine x = sin (2*pi*x) +-} + +{- +waveSine :: Trans.C a => a -> a +waveSine x = Trans.sin (NP.fromInteger 2 NP.* Trans.pi NP.* x) + +incrFracDouble :: Double -> Double -> Double +incrFracDouble d x = NP.fraction (d + x) + +{-# ONLINE incrFrac #-} +incrFrac :: NP.RealFrac a => a -> a -> a +incrFrac d x = NP.fraction (d NP.+ x) + +fraction :: Double -> Double +fraction x = + let second :: (Int, a) -> a + second = snd + f = second (properFraction x) + in if f>=0 then f else f+1 +-} + +{- +fraction :: Double -> Double +fraction x = x - fromIntegral (floor x :: Int) +-} + +{- +fraction :: Double -> Double +fraction x = x - int2Double (double2Int x) + +incrFracDouble :: Double -> Double -> Double +incrFracDouble d x = fraction (d + x) +-} + +{- +incrFracDouble :: Double -> Double -> Double +incrFracDouble d x = d + x +-} + + +osciTest7 :: SigSt.T Int16 +osciTest7 = + SigSt.take 200000 $ + SigSt.map doubleToInt16Packed $ +-- SigSt.map (\x -> sin (2*pi*x)) $ + SigSt.map (Wave.apply Wave.sine) $ +-- SigSt.map (Wave.apply waveSine) $ +-- (SigSt.iterate defaultChunkSize (0.01 +) NP.zero :: SigSt.T (Phase.T Double)) + (SigSt.iterate defaultChunkSize (Phase.increment 0.01) NP.zero :: SigSt.T (Phase.T Double)) +-- (SigSt.iterate defaultChunkSize (incrFrac 0.01) NP.zero :: SigSt.T (Phase.T Double)) +-- (SigSt.iterate defaultChunkSize (incrFracDouble 0.01) NP.zero :: SigSt.T (Phase.T Double)) + +osciTest8 :: SigSt.T Int16 +osciTest8 = + SigSt.take 200000 $ + SigSt.map doubleToInt16Packed $ + (OsciSt.staticSaw defaultChunkSize zeroPhase 0.01 :: SigSt.T Double) + + +appendTest0 :: SigSt.T Int16 +appendTest0 = + storableFromFusionList $ + SigFL.map doubleToInt16Packed $ + let tone0 = SigFL.take 100000 $ OsciFL.static Wave.saw zeroPhase 0.010 + tone1 = SigFL.take 100000 $ OsciFL.static Wave.saw zeroPhase 0.015 + in SigFL.append tone0 tone1 + +appendTest1 :: SigSt.T Int16 +appendTest1 = + let tone0 = SigFL.take 100000 $ OsciFL.static Wave.saw zeroPhase 0.010 + tone1 = SigFL.take 100000 $ OsciFL.static Wave.saw zeroPhase 0.015 + in storableFromFusionList $ + SigFL.map doubleToInt16Packed $ + SigFL.append tone0 tone1 + +appendTest2 :: SigSt.T Int16 +appendTest2 = + SigSt.map doubleToInt16Packed $ + SigSt.appendFromFusionList defaultChunkSize + (SigFL.take 100000 $ OsciFL.static Wave.saw zeroPhase 0.010) + (SigFL.take 100000 $ OsciFL.static Wave.saw zeroPhase 0.015) + +appendTest3 :: SigSt.T Int16 +appendTest3 = + storableFromFusionList $ + SigFL.map doubleToInt16Packed $ + SigSt.appendFusionList defaultChunkSize + (SigFL.take 100001 $ OsciFL.static Wave.sine zeroPhase 0.010) + (SigFL.take 100000 $ OsciFL.static Wave.saw zeroPhase 0.015) + +mixTest0 :: SigSt.T Int16 +mixTest0 = + SigSt.map doubleToInt16Packed $ + SigSt.mixSize defaultChunkSize + (SigSt.replicate defaultChunkSize 100000 NP.zero) + (SigSt.replicate defaultChunkSize 100001 NP.one) + +mixTest3 :: SigSt.T Int16 +mixTest3 = + SigSt.map doubleToInt16Packed $ + SigSt.mixSize defaultChunkSize +-- (storableFromFusionList $ SigFL.take 100000 $ OsciFL.static Wave.sine zeroPhase 0.010) +-- (storableFromFusionList $ SigFL.take 100000 $ CtrlFL.exponential2 50000 1) + (storableFromFusionList $ SigFL.take 100001 $ OsciFL.static Wave.saw zeroPhase 0.015) + (SigSt.empty) + +mixTest4 :: SigSt.T Int16 +mixTest4 = + SigSt.map doubleToInt16Packed $ + SigSt.mixSize defaultChunkSize + (SigSt.take 100002 $ OsciSt.staticSine defaultChunkSize zeroPhase 0.020) $ + SigSt.mixSize defaultChunkSize + (SigSt.take 100001 $ OsciSt.staticSine defaultChunkSize zeroPhase 0.010) + (SigSt.take 100000 $ OsciSt.staticSaw defaultChunkSize zeroPhase 0.015) + + +mixTest5 :: SigSt.T Int16 +mixTest5 = + SigSt.map doubleToInt16Packed $ + SigSt.take 441000 $ +-- SigSt.append + SigSt.mix +-- SigSt.mixSize defaultChunkSize + (SigSt.iterate defaultChunkSize ((1-1e-6)*) 0.5) + (SigSt.iterate defaultChunkSize (1e-6 +) 0) + +mixTest6 :: SigSt.T Int16 +mixTest6 = + SigSt.map doubleToInt16Packed $ + SigSt.take 441000 $ +-- SigSt.append + SigSt.mix +-- SigSt.mixSize defaultChunkSize + (SigS.toStorableSignal defaultChunkSize $ SigS.iterate ((1-1e-6)*) 0.5) + (SigS.toStorableSignal defaultChunkSize $ SigS.iterate (1e-6 +) 0) + + +stateTest0 :: SigSt.T Int16 +stateTest0 = + SigS.toStorableSignal defaultChunkSize $ + SigS.map doubleToInt16Packed $ + SigS.take 441000 $ + SigS.zipWith (*) (SigS.iterate ((1-1e-4)*) 1) $ +-- SigS.map (\t -> if even (floor t :: Int) then 1 else -1) $ + SigS.map sin $ + SigS.iterate ((2*pi/100)+) (0::Double) + +stateTest1 :: SigSt.T Int16 +stateTest1 = + SigS.toStorableSignal defaultChunkSize $ + SigS.map doubleToInt16Packed $ + SigS.take 100000 $ + SigS.zipWith Dist.sine (SigS.iterate ((1-0.3e-4)*) 1) $ + SigS.map (Wave.apply Wave.sine) $ + SigS.iterate (Phase.increment 0.01) zeroPhase + +stateTest2 :: SigSt.T Int16 +stateTest2 = + SigS.toStorableSignal defaultChunkSize $ + SigS.map doubleToInt16Packed $ + SigS.take 100000 $ + SigS.map (Dist.logit 1) $ + SigS.map (Dist.sine 5) $ + SigS.zipWith (*) (SigS.iterate ((1-0.3e-4)*) 30) $ + SigS.map (Wave.apply Wave.sine) $ + SigS.iterate (Phase.increment 0.01) zeroPhase + +stateOsciTest0 :: SigSt.T Int16 +stateOsciTest0 = + SigS.toStorableSignal defaultChunkSize $ + SigS.take 200000 $ + SigS.map numToInt16Packed $ + (OsciS.static Wave.saw zeroPhase 0.01 :: SigS.T Double) + +stateOsciTest0a :: SigSt.T Int16 +stateOsciTest0a = + SigS.toStorableSignal defaultChunkSize $ + SigS.take 200000 $ + SigS.map doubleToInt16Packed $ + OsciS.static Wave.saw zeroPhase 0.01 + +stateOsciTest0fa :: SigSt.T Int16 +stateOsciTest0fa = + SigS.toStorableSignal defaultChunkSize $ + SigS.take 200000 $ + SigS.map doubleToInt16Packed $ +-- FiltNRS.envelope +-- (CtrlS.exponential2 50000 1) + SigS.map (0.5*) $ + (SigS.mix + (SigS.mix + (OsciS.static Wave.saw (Phase.fromRepresentative 0.1) 0.01001) + (OsciS.static Wave.saw (Phase.fromRepresentative 0.7) 0.00998)) + (SigS.mix + (OsciS.static Wave.saw (Phase.fromRepresentative 0.2) 0.01005) + (OsciS.static Wave.saw (Phase.fromRepresentative 0.4) 0.00996))) + +{-# INLINE chord #-} +chord :: SigS.T Double +chord = + let freq = 0.005 + {-# INLINE tone #-} + tone f = + SigS.mix + (SigS.mix + (OsciS.static Wave.saw zeroPhase (f*1.001)) + (OsciS.static Wave.saw zeroPhase (f*0.998))) + (SigS.mix + (OsciS.static Wave.saw zeroPhase (f*1.005)) + (OsciS.static Wave.saw zeroPhase (f*0.996))) + in tone (freq*1.00) `SigS.mix` + tone (freq*1.25) `SigS.mix` + tone (freq*1.50) + +stateOsciTestChord :: SigSt.T Int16 +stateOsciTestChord = + SigS.toStorableSignal defaultChunkSize $ + SigS.take 200000 $ + SigS.map doubleToInt16Packed $ + SigS.map (0.2*) $ + chord + +stateFilterTest :: SigSt.T Int16 +stateFilterTest = + SigS.toStorableSignal defaultChunkSize $ + SigS.take 200000 $ + SigS.map doubleToInt16Packed $ + SigS.map (0.05*) $ + SigS.map UniFilter.lowpass $ + SigS.modifyModulated + UniFilter.modifier + (SigS.map UniFilter.parameter $ + SigS.zipWith FiltR.Pole + (SigS.repeat (5::Double)) + (SigS.map (\f -> 0.02*3 ^? f) $ + OsciS.static Wave.fastSine2 (Phase.fromRepresentative 0.75) 0.000005)) $ + chord + +stateAppendTest0 :: SigSt.T Int16 +stateAppendTest0 = + SigS.toStorableSignal defaultChunkSize $ + SigS.map doubleToInt16Packed $ + let tone f = + SigS.take 50000 $ + SigS.map (Wave.apply Wave.saw) $ + SigS.iterate (Phase.increment f) zeroPhase + in tone 0.010 `SigS.append` + tone 0.015 `SigS.append` + tone 0.020 + +stateAppendTest1 :: SigSt.T Int16 +stateAppendTest1 = + SigS.toStorableSignal defaultChunkSize $ + SigS.map doubleToInt16Packed $ + let tone f = + SigS.take 50000 $ + SigS.map (Wave.apply Wave.saw) $ + SigS.iterate (Phase.increment f) zeroPhase + in tone 0.010 `SigS.appendStored` + tone 0.015 `SigS.appendStored` + tone 0.020 + +stateAppendTest2 :: SigSt.T Int16 +stateAppendTest2 = + SigSt.map doubleToInt16Packed $ + let tone f = + SigS.toStorableSignal defaultChunkSize $ + SigS.take 50000 $ + SigS.map (Wave.apply Wave.saw) $ + SigS.iterate (Phase.increment f) zeroPhase + in tone 0.010 `SigSt.append` + tone 0.015 `SigSt.append` + tone 0.020 + +stateConcatTest0 :: SigSt.T Int16 +stateConcatTest0 = + SigS.toStorableSignal defaultChunkSize $ + SigS.map doubleToInt16Packed $ + let tone f = + SigS.take 50000 $ + SigS.map (Wave.apply Wave.saw) $ + SigS.iterate (Phase.increment f) zeroPhase + in SigS.concat $ + tone 0.010 : + tone 0.015 : + tone 0.020 : + [] + +stateConcatTest1 :: SigSt.T Int16 +stateConcatTest1 = + SigS.toStorableSignal defaultChunkSize $ + SigS.map doubleToInt16Packed $ + let tone f = + SigS.take 50000 $ + SigS.map (Wave.apply Wave.saw) $ + SigS.iterate (Phase.increment f) zeroPhase + in SigS.concatStored $ + tone 0.010 : + tone 0.015 : + tone 0.020 : + [] + +{-# NOINLINE storablePercTone #-} +storablePercTone :: Double -> SigSt.T Double +storablePercTone f = + SigS.toStorableSignal defaultChunkSize $ + SigS.take 22000 $ + FiltNRS.envelope (CtrlS.exponential2 10000 1) $ +-- OsciS.static Wave.saw zero f + SigS.map (0.5*) $ + SigS.mix + (OsciS.static Wave.saw zeroPhase (f*0.999)) + (OsciS.static Wave.saw zeroPhase (f*1.001)) + +storableConcatTest :: SigSt.T Int16 +storableConcatTest = + SigSt.map doubleToInt16Packed $ + SigSt.concat $ + take 13 $ + map storablePercTone $ + iterate (* 2^?(1/12)) 0.005 + +storableArrangeTest :: SigSt.T Int16 +storableArrangeTest = + SigSt.map doubleToInt16Packed $ + SigSt.map (0.5*) $ + CutSt.arrange defaultChunkSize $ + foldr (EventList.cons 4000) (EventList.empty) $ +-- foldr (EventList.cons 4000) (EventList.pause 0) $ + take 25 $ + map storablePercTone $ + iterate (* 2^?(1/12)) 0.005 + +-- This is much faster than Arrange. +-- about 2 seconds +storableConcatInfTest :: SigSt.T Int16 +storableConcatInfTest = + SigSt.map doubleToInt16Packed $ + SigSt.map (0.5*) $ + SigSt.concat $ + take 110 $ + map storablePercTone $ + iterate (* 2^?(1/12)) 0.002 + +-- about 5-6 seconds +storableArrangeInfTest :: SigSt.T Int16 +storableArrangeInfTest = + SigSt.map doubleToInt16Packed $ + SigSt.map (0.5*) $ + SigSt.take 440000 $ + CutSt.arrange defaultChunkSize $ + foldr (EventList.cons 4000) (EventList.empty) $ + map storablePercTone $ + iterate (* 2^?(1/12)) 0.002 + + + +statePercTone :: Double -> SigS.T Double +statePercTone f = + SigS.take 22000 $ + FiltNRS.envelope (CtrlS.exponential2 10000 1) $ +-- OsciS.static Wave.saw zeroPhase f + SigS.map (0.5*) $ + SigS.mix + (OsciS.static Wave.saw zeroPhase (f*0.999)) + (OsciS.static Wave.saw zeroPhase (f*1.001)) + +stateArrangeInfTest :: SigSt.T Int16 +stateArrangeInfTest = + SigS.toStorableSignal defaultChunkSize $ + SigS.map doubleToInt16Packed $ + SigS.map (0.5*) $ + SigS.take 440000 $ + CutS.arrange $ + foldr (EventList.cons 4000) (EventList.empty) $ + map statePercTone $ + iterate (* 2^?(1/12)) 0.002 + + +{-# INLINE fastSine2 #-} +fastSine2 :: (Ord a, Ring.C a, Num a) => a -> a +fastSine2 x = + if 2*x<1 + then 1 - NP.sqr (4*x-1) + else NP.sqr (4*x-3) - 1 + +fastSineTest :: SigSt.T Int16 +fastSineTest = + SigS.toStorableSignal defaultChunkSize $ + SigS.map doubleToInt16Packed $ + SigS.take 440000 $ +-- OsciS.static Wave.sine zeroPhase $ +-- OsciS.static Wave.fastSine4 zeroPhase $ + OsciS.static Wave.fastSine2 zeroPhase $ +-- OsciS.static fastSine2 zeroPhase $ + 0.01 + + +{-# INLINE stateBubbles #-} +stateBubbles :: SigS.T Double +stateBubbles = + OsciS.freqMod Wave.sine zeroPhase $ + SigS.map (\p -> 0.01 * exp(-p)) $ + SigS.mix + (SigS.map (1.5*) $ OsciS.static Wave.saw zeroPhase 0.00001) + (SigS.map (0.5*) $ OsciS.static Wave.saw zeroPhase 0.0002) + +stateBubblesTest :: SigSt.T Int16 +stateBubblesTest = + SigS.toStorableSignal defaultChunkSize $ + SigS.map doubleToInt16Packed $ + SigS.take 440000 $ + stateBubbles + +storableCombTest :: SigSt.T Int16 +storableCombTest = + SigSt.map doubleToInt16Packed $ + SigSt.delayLoopOverlap 11000 (SigSt.map (0.5*)) $ + SigS.toStorableSignal defaultChunkSize $ +-- SigS.append (statePercTone 0.01) (SigS.replicate 40000 0) + SigS.take 440000 $ + SigS.map (0.5*) $ + stateBubbles + + +storableTakeTest :: SigSt.T Int16 +storableTakeTest = + SigSt.take 440000 $ + SigS.toStorableSignal defaultChunkSize $ + SigS.map doubleToInt16Packed $ + OsciS.static Wave.saw zeroPhase 0.01 + + +stateNoiseTest :: SigSt.T Int16 +stateNoiseTest = + SigS.toStorableSignal defaultChunkSize $ + SigS.take 440000 $ + SigS.map doubleToInt16Packed $ + SigS.map (0.3*) $ + SigS.map UniFilter.lowpass $ + SigS.modifyModulated + UniFilter.modifier + (SigS.map UniFilter.parameter $ + SigS.zipWith FiltR.Pole + (SigS.repeat (10::Double)) + (SigS.map (\f -> 0.02*3 ^? f) $ + OsciS.static Wave.sine (Phase.fromRepresentative 0.75) 0.000005)) $ +-- NoiseS.whiteGen (mkStdGen 1) + NoiseS.whiteGen (Knuth.cons 1) + + +stateADSRTest :: SigSt.T Int16 +stateADSRTest = + SigS.toStorableSignal defaultChunkSize $ + SigS.map doubleToInt16Packed $ + FiltNRS.envelope + (CtrlS.piecewise + (0 |# (5000, CtrlS.cubicPiece 0.001 0) #|- + 0.5 -|# (40000, CtrlS.stepPiece) #|- + 0.5 -|# (8000, CtrlS.exponentialPiece 0) #| + 0.01)) $ + OsciS.static Wave.saw zeroPhase 0.01 + + +phaserTest :: SigSt.T Int16 +phaserTest = + SigSt.take 440000 $ + SigSt.map doubleToInt16Packed $ + SigSt.map (0.5*) $ + (\noise -> + SigSt.mix + noise +-- (DelayG.modulated InterpolationG.linear (-500) + (DelayG.modulated (InterpolationS.toGeneric InterpolationS.linear) (-500) + (SigS.toStorableSignal defaultChunkSize + (SigS.map + (\x -> 100*(2+x) :: Double) + (OsciS.static Wave.sine zeroPhase 0.00001))) + noise)) $ + SigS.toStorableSignal defaultChunkSize $ +-- OsciS.static Wave.saw zeroPhase 0.01 + NoiseS.whiteGen (Knuth.cons 1) + + +phaserTest0 :: SigSt.T Int16 +phaserTest0 = + SigSt.take 440000 $ + SigSt.map doubleToInt16Packed $ + DelayG.modulated InterpolationG.constant (-500) + (SigSt.repeat defaultChunkSize (142::Double)) $ + SigSt.repeat defaultChunkSize (23::Double) + + +phaserTest1 :: SigSt.T Int16 +phaserTest1 = + SigSt.take 440000 $ + SigSt.map doubleToInt16Packed $ +-- SigG.mapTails (maybe 0 fst . SigSt.viewL . SigSt.drop 100) $ +{- + (\noise -> + SigSt.mix + (SigG.zipWithTails + (\n -> maybe 0 fst . SigSt.viewL . SigSt.drop (div n 50)) + (SigG.iterate succ 0) noise) + noise) $ +-} +{- + SigG.zipWithTails + (\n -> maybe 0 fst . SigSt.viewL . SigSt.drop (div n 50)) + (SigG.iterate succ 0) $ +-} + (\noise -> SigSt.mix noise noise) $ + SigS.toStorableSignal defaultChunkSize $ + NoiseS.whiteGen (Knuth.cons 1) + + + +main :: IO () +main = + do SigSt.writeFile "storable-fusion.sw" phaserTest + -- SigSt.writeFile "storable-fusion.sw" stateFilterTest + -- SigSt.writeFile "storable-fusion.sw" osciTest4 + -- SigSt.writeFile "storable-fusion.sw" mapTest5 + + +{- +show highlighted core output + +ghc-core -o dist/build/fusiontest/fusiontest -O -Wall -fexcess-precision -package synthesizer speedtest/FusionTest.hs + +use installed synthesizer package + +ghc -o dist/build/fusiontest/fusiontest -O -Wall -fexcess-precision -ddump-simpl-stats -package synthesizer speedtest/FusionTest.hs + +ghc -o dist/build/fusiontest/fusiontest -O -Wall -fexcess-precision -ddump-simpl-stats -ddump-simpl -package synthesizer speedtest/FusionTest.hs >dist/build/fusiontest/FusionTest.log + + +with make and no explicit package specification: + +ghc -Idist/build -o dist/build/fusiontest/fusiontest --make -Wall -O2 -fexcess-precision -ddump-simpl-stats -i -idist/build/autogen -isrc -odir dist/build/fusiontest/fusiontest-tmp -hidir dist/build/fusiontest/fusiontest-tmp src/FusionTest.hs + +with make and explicit package specification: + +ghc -Idist/build -o dist/build/fusiontest/fusiontest --make -Wall -O2 -fexcess-precision -hide-all-packages -i -idist/build/autogen -isrc -odir dist/build/fusiontest/fusiontest-tmp -hidir dist/build/fusiontest/fusiontest-tmp -package base-1.0 -package mtl-1.0 -package non-negative-0.0.2 -package numeric-prelude-0.0.3 -package event-list-0.0.7 -package Haskore-0.0.2 -package HTam-0.0 -package numeric-quest-0.1 -package bytestring-0.9.0.5 -package binary-0.4.1 -package storablevector-0.1 -package UniqueLogicNP-0.0 -package QuickCheck-1.0 src/FusionTest.hs + +without make and with detailed simplifier report: + +ghc -Idist/build -o dist/build/fusiontest/fusiontest -Wall -O2 -fexcess-precision -ddump-simpl-stats -ddump-simpl-iterations -ddump-asm -i -idist/build/autogen -isrc -idist/build/fusiontest/fusiontest-tmp -odir dist/build/fusiontest/fusiontest-tmp -hidir dist/build/fusiontest/fusiontest-tmp -package base-1.0 -package mtl-1.0 -package non-negative-0.0.2 -package numeric-prelude-0.0.3 -package event-list-0.0.7 -package Haskore-0.0.2 -package HTam-0.0 -package numeric-quest-0.1 -package bytestring-0.9.0.5 -package binary-0.4.1 -package storablevector-0.1 -package UniqueLogicNP-0.0 -package QuickCheck-1.0 dist/build/HSsynthesizer*.o src/FusionTest.hs + +ghc -Idist/build -o dist/build/fusiontest/fusiontest -Wall -O2 -fexcess-precision -ddump-simpl-stats -ddump-simpl-iterations -i -idist/build/autogen -isrc -idist/build/fusiontest/fusiontest-tmp -odir dist/build/fusiontest/fusiontest-tmp -hidir dist/build/fusiontest/fusiontest-tmp -package base-1.0 -package mtl-1.0 -package non-negative-0.0.2 -package numeric-prelude-0.0.3 -package event-list-0.0.7 -package Haskore-0.0.2 -package HTam-0.0 -package numeric-quest-0.1 -package bytestring-0.9.0.5 -package binary-0.4.1 -package storablevector-0.1 -package UniqueLogicNP-0.0 -package QuickCheck-1.0 dist/build/HSsynthesizer*.o src/FusionTest.hs >src/FusionTest.log + +ghc-6.8.2 -Idist/build -o dist/build/fusiontest/fusiontest -Wall -O2 -fexcess-precision -ddump-simpl-stats -ddump-simpl-iterations -i -idist/build/autogen -isrc -idist/build/fusiontest/fusiontest-tmp -odir dist/build/fusiontest/fusiontest-tmp -hidir dist/build/fusiontest/fusiontest-tmp -package base -package mtl -package non-negative -package numeric-prelude -package event-list -package Haskore -package HTam -package numeric-quest -package bytestring -package binary -package storablevector -package UniqueLogicNP -package QuickCheck dist/build/HSsynthesizer*.o src/FusionTest.hs >src/FusionTest.log +-} 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 NumericPrelude.Condition (toMaybe) +import NumericPrelude.List (sliceVert) + +import PreludeBase +import NumericPrelude + +import qualified Prelude as P98 + +{- + ghc -prof -auto-all -O -fvia-C SpeedTest.hs + a.out +RTS -p -RTS +-} + + +{-# SPECIALIZE osciModSaw :: Double -> [Double] -> [Double] #-} +{-# SPECIALIZE freqToPhase :: Double -> [Double] -> [Double] #-} +{-# SPECIALIZE exponential2 :: Double -> Double -> [Double] #-} +{-# SPECIALIZE clip :: Double -> Double -> Double -> Double #-} +{-# SPECIALIZE numToInt :: Double -> Int #-} +{-# SPECIALIZE numToInt16 :: Double -> Int16 #-} + +{- INLINE zeroSignal #-} +{- INLINE sawSignal #-} +{- INLINE zeroSignal16 #-} +{- INLINE sawSignal16 #-} + + +{- | +saw tooth oscillator with modulated frequency +-} +osciModSaw :: RealField.C a => a -> [a] -> [a] +osciModSaw phase freq = map (\x -> 2*x-1) (freqToPhase phase freq) + +{- | +Convert a list of phase steps into a list of momentum phases +phase is a number in the interval [0,1) +freq contains the phase steps +-} +freqToPhase :: RealField.C a => a -> [a] -> [a] +freqToPhase phase freq = + scanl (\curphase dif -> fraction (curphase+dif)) phase freq + +exponential2 :: Trans.C a => a -> a -> [a] +exponential2 halfLife y0 = + let k = 0.5**(1/halfLife) + in iterate (k*) y0 + + + +-- write the signal as binary file containing 16 bit words +writeSignalMono, writeSignalMonoS :: + FilePath -> [Int16] -> IO () +writeSignalMono fileName signal = + writeFile fileName (signalToBinaryMono signal) +writeSignalMonoS fileName signal = + writeFile fileName (signalToBinaryMonoS signal) + +signalToBinaryMono, signalToBinaryMonoS :: + [Int16] -> String +signalToBinaryMono = concatMap (int16ToChars . P98.fromIntegral) +signalToBinaryMonoS = foldr int16ToCharsS [] . map P98.fromIntegral + +writeSignalMonoInt :: + FilePath -> [Int] -> IO () +writeSignalMonoInt fileName signal = + writeFile fileName (signalToBinaryMonoInt signal) + +signalToBinaryMonoInt :: [Int] -> String +signalToBinaryMonoInt = concatMap int16ToChars + + +writeSignalMonoBStr :: FilePath -> [Int16] -> IO () +writeSignalMonoBStr fileName = + B.writeFile fileName . signalToBinaryMonoBStr + +signalToBinaryMonoBStr :: [Int16] -> B.ByteString +signalToBinaryMonoBStr = + B.pack . concatMap (int16ToBytes . P98.fromIntegral) + + +writeSignalMonoBinaryPut :: + FilePath -> [Int16] -> IO () +writeSignalMonoBinaryPut fileName = + B.writeFile fileName . signalToBinaryBinaryPut + +signalToBinaryBinaryPut :: [Int16] -> B.ByteString +signalToBinaryBinaryPut = + Bin.runPut . mapM_ (Bin.putWord16host . P98.fromIntegral) + + +writeSignalMonoBinaryIntPut :: + FilePath -> [Int] -> IO () +writeSignalMonoBinaryIntPut fileName = + B.writeFile fileName . signalToBinaryBinaryIntPut + +signalToBinaryBinaryIntPut :: [Int] -> B.ByteString +signalToBinaryBinaryIntPut = + Bin.runPut . mapM_ (Bin.putWord16host . P98.fromIntegral) + + + +-- from BinarySample +clip :: Ord a => a -> a -> a -> a +clip lower upper = max lower . min upper + +numToInt :: (RealField.C a) => a -> Int +numToInt x = round (32767 * clip (-1) 1 x) + +-- from BinarySample +-- return type could be Int16, but that is not well supported by NumericPrelude +numToInt16 :: (RealField.C a) => a -> Int16 +numToInt16 = P98.fromIntegral . numToInt + +roundDouble :: Double -> Int +roundDouble x = + double2Int (if x<0 then x-0.5 else x+0.5) + +doubleToInt :: Double -> Int +doubleToInt x = roundDouble (32767 * clip (-1) 1 x) + +doubleToInt16 :: Double -> Int16 +doubleToInt16 = P98.fromIntegral . doubleToInt + + + + +int16ToChars :: Int -> String +int16ToChars x = + let (hi,lo) = divMod x 256 + in [toEnum lo, toEnum (mod hi 256)] + +int16ToCharsS :: Int -> String -> String +int16ToCharsS x s = + let (hi,lo) = divMod x 256 + in toEnum lo : toEnum (mod hi 256) : s + +int16ToBytes :: Int -> [Word8] +int16ToBytes x = + let (hi,lo) = divMod x 256 +-- in [P98.fromIntegral lo, P98.fromIntegral (mod hi 256)] + in [P98.fromIntegral lo, P98.fromIntegral hi] + -- conversion to Word8 wraps silently to positive values + + +{- * machine oriented techniques -} + +writeSignalMonoPoke :: + FilePath -> [Int16] -> IO () +writeSignalMonoPoke fileName signal = + bracket (openBinaryFile fileName WriteMode) hClose $ + \h -> alloca $ + \p -> mapM_ (putInt h p) signal + +putInt :: Handle -> Ptr Int16 -> Int16 -> IO () +putInt h p n = + poke p n >> hPutBuf h p (sizeOf n) + + +maxBlockSize :: Int +maxBlockSize = 1000 + +int16size :: Int +int16size = sizeOf (undefined::Int16) + +writeSignalMonoBlock :: + FilePath -> [Int16] -> IO () +writeSignalMonoBlock fileName signal = + bracket (openBinaryFile fileName WriteMode) hClose $ + \h -> let blocks = sliceVert maxBlockSize signal + in allocaBytes (int16size * maxBlockSize) $ + \p -> mapM_ (putIntBlock h p) blocks + +putIntBlock :: Handle -> Ptr Int16 -> [Int16] -> IO () +putIntBlock h p xs = + do cnt <- foldM (\n x -> pokeElemOff p n x >> return (n+1)) 0 xs + hPutBuf h p (int16size * cnt) + +putIntBlockSlow :: Handle -> Ptr Int16 -> [Int16] -> IO () +putIntBlockSlow h p xs = + do zipWithM (pokeElemOff p) [0..] xs + hPutBuf h p (int16size * length xs) + + +chopLength :: Int {- ^ block size -} -> Int {- ^ length -} -> [Int] +chopLength blockSize = + unfoldr (\l -> let chunkSize = min blockSize l + in toMaybe (l>0) (chunkSize, l-chunkSize)) + +writeZeroBlocks :: + FilePath -> Int -> IO () +writeZeroBlocks fileName len = + bracket (openBinaryFile fileName WriteMode) hClose $ + \h -> allocaBytes (int16size * maxBlockSize) $ + \p -> + do mapM_ (\off -> pokeElemOff p off (P98.fromInteger 0 :: Int16)) + [0 .. maxBlockSize-1] + mapM_ (hPutBuf h p) + (map (int16size*) (chopLength maxBlockSize len)) + + +{- * driver -} + +measureTime :: String -> IO () -> IO () +measureTime name act = + do putStr (name++": ") + timeA <- getClockTime + act + timeB <- getClockTime + let td = diffClockTimes timeB timeA + print (fromIntegral (tdSec td) + + fromInteger (tdPicosec td) * 1e-12 :: Double) + +numSamples :: Int +numSamples = 200000 + +zeroSignal, sawSignal :: [Double] +zeroSignal = replicate numSamples 0 +sawSignal = take numSamples (osciModSaw 0 (exponential2 100000 0.1)) + +polysawSignal :: [Double] +polysawSignal = + take numSamples + (osciModSaw 0 (exponential2 100000 0.1) + + osciModSaw 0 (exponential2 100000 0.1001)) + +zeroSignal16, sawSignal16 :: [Int16] +zeroSignal16 = map numToInt16 zeroSignal +sawSignal16 = map numToInt16 sawSignal + +sawSignal16NonShared :: Double -> [Int16] +sawSignal16NonShared halfLife = + map numToInt16 + (take numSamples (osciModSaw 0 (exponential2 halfLife 0.1) :: [Double])) + +sawSignalIntNonShared :: Double -> [Int] +sawSignalIntNonShared halfLife = + map doubleToInt + (take numSamples (osciModSaw 0 (exponential2 halfLife 0.1) :: [Double])) + +zeroStream, zeroStreamPaired :: String +zeroStream = replicate (2*numSamples) '\000' +zeroStreamPaired = concat $ replicate numSamples "\001\000" + +sawStream :: String +sawStream = take (2*numSamples) (cycle ['\000'..'\177']) + +zeroByteString :: B.ByteString +zeroByteString = + B.replicate (P98.fromIntegral (2 * numSamples)) + (P98.fromIntegral (0::Int)) + +zeroByteStringPaired :: B.ByteString +zeroByteStringPaired = + B.concat $ replicate numSamples $ + B.pack [P98.fromIntegral (0::Int), P98.fromIntegral (1::Int)] + + +tests :: [(String, FilePath, FilePath -> IO ())] +tests = + ("zero bytestring", "zerobytestring.sw", flip B.writeFile zeroByteString) : + ("zero bytestring words", "zerobytestrnwd.sw", flip B.writeFile zeroByteStringPaired) : + ("zero blocks", "zerofastblocks.sw", flip writeZeroBlocks numSamples) : + ("zero bytes", "zerofast.sw", flip writeFile zeroStream) : + ("zero words", "zerowords.sw", flip writeFile zeroStreamPaired) : + ("saw bytes", "sawbytes.sw", flip writeFile sawStream) : + -- only the first test is reliable, because the subsequent test can access the already computed data + ("zero signal binary put", "zerowordbinary.sw", flip writeSignalMonoBinaryPut zeroSignal16) : + ("zero signal bytestring", "zerowordstring.sw", flip writeSignalMonoBStr zeroSignal16) : + ("zero signal block-wise", "zeroblock.sw", flip writeSignalMonoBlock zeroSignal16) : + ("zero signal poke", "zeropoke.sw", flip writeSignalMonoPoke zeroSignal16) : + ("zero signal foldr", "zerofoldr.sw", flip writeSignalMonoS zeroSignal16) : + ("zero signal", "zero.sw", flip writeSignalMono zeroSignal16) : + ("saw binary int lib", "sawbinaryint.sw", flip writeSignalMonoBinaryIntPut $ sawSignalIntNonShared 100004) : + ("saw int", "sawint.sw", flip writeSignalMonoInt $ sawSignalIntNonShared 100005) : + -- the same problem as with zeros + ("saw bytestring", "sawbytestring.sw", flip writeSignalMono sawSignal16) : + ("saw", "saw.sw", flip writeSignalMono sawSignal16) : + ("saw bytestring non-shd", "sawbytestrngns.sw", flip writeSignalMono $ sawSignal16NonShared 100001) : + ("saw non-shared", "sawns.sw", flip writeSignalMono $ sawSignal16NonShared 100002) : + ("saw binary lib", "sawbinary.sw", flip writeSignalMonoBinaryPut $ sawSignal16NonShared 100003) : + ("poly-saw binary lib", "polysawbinary.sw", flip writeSignalMonoBinaryPut $ map numToInt16 polysawSignal) : + [] + + +main :: IO () +main = + do mapM (\(label, fileName, action) -> + measureTime label (action fileName)) + tests + + when False $ + mapM_ (\(_,fileName,_) -> removeFile fileName) + tests 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/BinarySample.hs b/src/BinarySample.hs new file mode 100644 --- /dev/null +++ b/src/BinarySample.hs @@ -0,0 +1,210 @@ +{-# OPTIONS -fno-implicit-prelude #-} +module BinarySample + (C(..), + signalToBinary, signalToBinaryMono, signalToBinaryStereo, + writeInt16Stream, readInt16Stream, + writeLEInt16Stream, readLEInt16Stream, + int16ToNum, putInt16Stream, + numToInt16Packed, int16PackedToNum, + floatToInt16Packed, doubleToInt16Packed, + ) where + +import Foreign (Int16, Ptr, alloca, sizeOf, poke, peek) +import System.IO (openBinaryFile, IOMode(WriteMode,ReadMode), hClose, Handle, hPutBuf, hGetBuf) +import Control.Exception (bracket) +import Control.Monad (liftM) + +import qualified Algebra.Field as Field +import qualified Algebra.RealField as RealField +import qualified Algebra.Ring as Ring + +import Synthesizer.Utility (clip) + +import Data.Char(ord) + +import GHC.Float (float2Int, double2Int) + +import qualified Prelude as P98 + +import PreludeBase +import NumericPrelude + + + + +class C a where + toInt16 :: a -> [Int] + numChannels :: a -> Int + +instance C Float where +-- toInt16 = (:[]) . numToInt16 + toInt16 x = + [float2Int (if x<0 + then scale16 x - 0.5 + else scale16 x + 0.5)] + numChannels _ = 1 + +instance C Double where +-- toInt16 = (:[]) . numToInt16 + toInt16 x = + [double2Int (if x<0 + then scale16 x - 0.5 + else scale16 x + 0.5)] + numChannels _ = 1 + +instance (C a, C b) => C (a,b) where + toInt16 (x0,x1) = toInt16 x0 ++ toInt16 x1 + numChannels ~(x0,x1) = numChannels x0 + numChannels x1 + + + +{-# INLINE scale16 #-} +scale16 :: (Ring.C a, Ord a) => a -> a +scale16 x = 32767 * clip (-1) 1 x + +{-# INLINE numToInt16 #-} +numToInt16 :: (RealField.C a) => a -> Int +numToInt16 = round . scale16 + +{-# INLINE numToInt16Packed #-} +numToInt16Packed :: (RealField.C a) => a -> Int16 +numToInt16Packed = P98.fromIntegral . numToInt16 + +{-# INLINE floatToInt16Packed #-} +floatToInt16Packed :: Float -> Int16 +floatToInt16Packed = P98.fromIntegral . float2Int . scale16 + + +{- +{-# INLINE scale16Double #-} +scale16Double :: (Ring.C a, Ord a) => a -> a +scale16Double x = 32767 * clip (-1) 1 x +-} + +{-# INLINE doubleToInt16Packed #-} +doubleToInt16Packed :: Double -> Int16 +{- Why is scale16 not inlined here? See FusionTest.mixTest3 +doubleToInt16Packed = P98.fromIntegral . double2Int . scale16 +-} +-- doubleToInt16Packed = P98.fromIntegral . double2Int . scale16Double +-- doubleToInt16Packed x = P98.fromIntegral (double2Int (scale16 x)) +doubleToInt16Packed = P98.fromIntegral . double2Int . (32767*) . clip (-1) 1 + +{-# INLINE int16ToNum #-} +int16ToNum :: (Field.C a) => Int -> a +int16ToNum x = fromIntegral x / 32768 + +{-# INLINE int16PackedToNum #-} +int16PackedToNum :: (Field.C a) => Int16 -> a +int16PackedToNum = int16ToNum . P98.fromIntegral + +-- | little endian (Intel) +{-# INLINE int16ToLEChars #-} +int16ToLEChars :: Int -> [Char] +int16ToLEChars x = + let (hi,lo) = divMod x 256 + in [toEnum lo, toEnum (mod hi 256)] + +-- | little endian (Intel) +{-# INLINE leCharsToInt16 #-} +leCharsToInt16 :: Char -> Char -> Int +leCharsToInt16 hi lo = + let unsigned = ord lo + 256 * ord hi + in mod (unsigned + 32768) 65536 - 32768 + + +{-# INLINE signalToBinary #-} +signalToBinary :: (C v) => [v] -> [Int] +signalToBinary = concatMap toInt16 + +{-# INLINE signalToBinaryMono #-} +signalToBinaryMono :: (RealField.C a) => [a] -> [Int] +signalToBinaryMono = map numToInt16 + +{-# INLINE signalToBinaryStereo #-} +signalToBinaryStereo :: (RealField.C a) => [(a,a)] -> [Int] +signalToBinaryStereo = + concatMap (\(l,r) -> [numToInt16 l, numToInt16 r]) + + +{-# INLINE binaryToIntsMono16 #-} +binaryToIntsMono16 :: [Char] -> [Int] +binaryToIntsMono16 sig = + case sig of + (lo:hi:xs) -> + leCharsToInt16 hi lo : binaryToIntsMono16 xs + (_:[]) -> + error "binaryToIntsMono16: 16 bit sample files must have even length" + [] -> [] + + + +{- * I\/O -} + +{- | +Write a little endian 16 bit integer stream +via String data and 'writeFile'. +-} +writeLEInt16Stream :: FilePath -> [Int] -> IO () +writeLEInt16Stream fileName = + writeFile fileName . concatMap int16ToLEChars + +{- | +Uses endianess of the machine, like Sox does. +-} +writeInt16Stream :: FilePath -> [Int] -> IO () +writeInt16Stream fileName stream = + bracket (openBinaryFile fileName WriteMode) hClose + (flip putInt16Stream stream) + +putInt16Stream :: Handle -> [Int] -> IO () +putInt16Stream h stream = + alloca $ + \p -> mapM_ (putInt16 h p . P98.fromIntegral) stream + +putInt16 :: Handle -> Ptr Int16 -> Int16 -> IO () +putInt16 h p n = + poke p n >> hPutBuf h p (sizeOf n) + + +{- | +The end of the list is undefined, +if the file has odd length. +It would be better if it throws an exception. +-} +readLEInt16Stream :: FilePath -> IO [Int] +readLEInt16Stream fileName = + fmap binaryToIntsMono16 (readFile fileName) + +{- | +The end of the list is undefined, +if the file has odd length. +It would be better if it throws an exception. +-} +readInt16Stream :: FilePath -> IO [Int] +readInt16Stream fileName = + bracket (openBinaryFile fileName ReadMode) hClose + getInt16Stream + +{- | +In contrast to hGetContents this is strict! +-} +getInt16Stream :: Handle -> IO [Int] +getInt16Stream h = + alloca $ + \p -> fmap (map P98.fromIntegral) + (unfoldM (getInt16 h p)) + +-- candidate for Utility +unfoldM :: Monad m => m (Maybe a) -> m [a] +unfoldM act = + let listM = maybe (return []) (\x -> liftM (x:) listM) =<< act + in listM + +getInt16 :: Handle -> Ptr Int16 -> IO (Maybe Int16) +getInt16 h p = + do cnt <- hGetBuf h p (sizeOf (undefined::Int16)) + case cnt of + 0 -> return Nothing + 2 -> fmap Just (peek p) + _ -> return (error "getInt16: only one byte found") diff --git a/src/Filter/Basic.hs b/src/Filter/Basic.hs new file mode 100644 --- /dev/null +++ b/src/Filter/Basic.hs @@ -0,0 +1,57 @@ +{-# OPTIONS -fno-implicit-prelude -fglasgow-exts #-} +module Filter.Basic where + +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Module as Module +import qualified Algebra.RealField as RealField +import qualified Number.Complex as Complex + +import NumericPrelude +import PreludeBase + +{- todo: + - support of data before time 0 + - the problem is that all past data has to be kept, + the garbage collector can't flush it :-( + - this means we will also need functions for plain lists, + in this case we can't provide initial conditions to recursive filters + - the question of initial conditions is especially problematic + since for Graphs we have no explicit feed back + where initial conditions can be plugged in + - thus for two-way signal we must request the user + to insert initial conditions in every loop of a Graph + using the Past constructor + - all of the following filter primitives in static and modulated form: + - mask + - integer delay + - fractional delay + - shall the fractional delay constructor store the interpolation type? + (this discussion is similar to the one concerning + initial conditions for recursive filters) + - yes, because each delay may use a different interpolation type, + if no fractional delay is used, + no interpolation type needs to be specified + - no, because the interpolation is only of interest for filter + application not for the transfer function + - Is there a way to avoid the multi-parameter type class? + - Can we provide a class for lists (OneWay and TwoWay) + that help implementing filters and filter networks? + - The 'transferFunction' obviously does not depend on the signal list type. + - 'transferFunction' should not be restricted to complex numbers. + - For arguments of type 'Ratio (Polynomial Rational)' + you could compute the transfer function in terms of a rational function. +-} + +screw :: Trans.C a => a -> [Complex.T a] +screw w = iterate (Complex.cis w *) 1 + + +class Filter list filter | filter -> list where + {-| Apply a filter to a signal. -} + apply :: (RealField.C t, Trans.C t, + Module.C a v, Module.C a (list v)) => + filter t a v -> list v -> list v + {-| Compute the complex amplification factor + that is applied to the given frequency. -} + transferFunction :: (Trans.C t, Module.C a t) => + filter t a v -> t -> Complex.T t diff --git a/src/Filter/Composition.hs b/src/Filter/Composition.hs new file mode 100644 --- /dev/null +++ b/src/Filter/Composition.hs @@ -0,0 +1,146 @@ +{-# OPTIONS -fglasgow-exts -fno-implicit-prelude -fallow-undecidable-instances #-} +module Filter.Composition where + +import Filter.Basic (Filter,apply,transferFunction) + +import qualified Algebra.Module as Module +import qualified Algebra.Transcendental as Trans +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Additive as Additive +import qualified Number.Complex as Complex + +import Algebra.Additive ((+)) + +import PreludeBase +import NumericPrelude + +{- todo: + - functions that build a FilterComposition for specific filters + (1st order, universal, allpass, butterworth, chebyshev) + - functions that turn physical filter parameters into + internal ones + - How can these function be combined? + A function like + [ FilterComposition v [m] ] -> FilterComposition v [[m]] + is not satisfying, since the conversion function cannot rely + that the structure of all FilterComposition v [m] is equal. + If the list is empty the structure can't even be reconstructed. +-} + +{-| + This describes a generic filter with one input and one main output + that consists of non-recursive and recursive parts. + If you use Feedback, make sure that at least + one of the filters of a circle includes a delay, + otherwise the recursion will fail. + The main output is used to glue different parts together. + Additionally the functions 'apply' and 'transferFunction' + provide the signals at every node of the network. +-} +data T filter t a v = + Prim (filter t a v) + {-^ a filter primitve -} + | Serial [T filter t a v] + {-^ serial chain of filters -} + | Parallel [T filter t a v] + {-^ filters working parallel, there output is mixed together -} + | Feedback (T filter t a v) (T filter t a v) + {-^ filter the signal in the forward direction and + feed back the output signal filtered by the second filter -} + +{-| + This is the data structure is used for the results + of 'apply' and 'transferFunction'. + Each constructor corresponds to one of 'Filter.Composition.T'. + By choosing only some of the outputs + the lazy evaluation will content + with applying the necessary filter steps, only. +-} +data Sockets s = Sockets {output :: s, socket :: SocketSpec s} + +data SocketSpec s = + Output + | Multiplier [Sockets s] + | Adder [Sockets s] + | Loop (Sockets s) (Sockets s) + +instance (Filter list filter) => + Filter (list) (T filter) where +{- + apply :: (Module.C a v) => + FilterComposition a v -> TwoWayList v -> TwoWayList v +-} + apply f x = output (applyMulti f x) +{- + transferFunction :: (Trans.C b, Module.C a (Complex.T b)) => + T filter a v -> b -> (Complex.T b) +-} + transferFunction f w = output (transferFunctionMulti f w) + + +{-| Apply a filter network to a signal and keep the output of all nodes. + Generic function that is wrapped by 'apply'. -} +applyMulti :: (RealField.C t, Trans.C t, + Module.C a v, Module.C a (list v), Filter list filter) => + T filter t a v -> list v -> Sockets (list v) +applyMulti (Prim f) x = + Sockets (apply f x) Output +applyMulti (Serial fs) x = + let sq = scanl (\(Sockets y _) -> flip applyMulti y) (Sockets x Output) fs + in Sockets (output (last sq)) (Multiplier (tail sq)) +applyMulti (Parallel fs) x = + let socks = map (flip applyMulti x) fs + y = foldr (Additive.+) zero (map output socks) + in Sockets y (Adder socks) +{- the distinction between 'feed' and 'back' + can be dropped in a more general net structure -} +applyMulti (Feedback feed back) x = + let sockY@(Sockets y _) = applyMulti feed ((Additive.+) x z) + sockZ@(Sockets z _) = applyMulti back y + in Sockets y (Loop sockY sockZ) + + +transferFunctionMulti :: + (Trans.C t, Module.C a t, Filter list filter) => + T filter t a v -> t -> Sockets (Complex.T t) +transferFunctionMulti f w = tfAbsolutize 1 (tfRelative w f) + +{-| Compute the transitivity for each part of the filter network. + We must do this in such a relative manner to be able + to compute feedback. -} +tfRelative :: + (Trans.C t, Module.C a t, Filter list filter) => + t -> T filter t a v -> Sockets (Complex.T t) +tfRelative w (Prim f) = + Sockets (Filter.Basic.transferFunction f w) Output +tfRelative w (Serial fs) = + let sq = map (tfRelative w) fs + in Sockets (product (map output sq)) (Multiplier sq) +tfRelative w (Parallel fs) = + let sq = map (tfRelative w) fs + in Sockets (sum (map output sq)) (Adder sq) +tfRelative w (Feedback feed back) = + let sockY = tfRelative w feed + sockZ = tfRelative w back + q = output sockY / (1 - output sockZ) + in Sockets q (Loop sockY sockZ) + + +{-| Make the results from 'tfRelative' absolute. -} +tfAbsolutize :: (Field.C a) => a -> Sockets a -> Sockets a +tfAbsolutize x (Sockets y spec) = Sockets (x*y) + (case spec of + (Multiplier socks) -> + let sq = scanl (\(Sockets z _) -> tfAbsolutize z) + (Sockets x Output) socks + in Multiplier (tail sq) + (Adder socks) -> + let sq = map (tfAbsolutize x) socks + in Adder sq + (Loop feed back) -> + let sockY = tfAbsolutize (x / (1 - output back)) feed + sockZ = tfAbsolutize (output sockY) back + -- it should be x*y == output sockY + in Loop sockY sockZ + Output -> spec) diff --git a/src/Filter/Example.hs b/src/Filter/Example.hs new file mode 100644 --- /dev/null +++ b/src/Filter/Example.hs @@ -0,0 +1,241 @@ +{-# OPTIONS -fno-implicit-prelude #-} +module Filter.Example where + +import Filter.Basic +import qualified Filter.OneWay +import qualified Filter.TwoWay +import Filter.Composition +import qualified Filter.Graph +import qualified Synthesizer.Plain.Interpolation as Interpolation + +import qualified Synthesizer.Plain.Oscillator as Osci +import qualified Synthesizer.Basic.Wave as Wave +import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1 +import qualified Synthesizer.Plain.Filter.NonRecursive as FiltNR + +import qualified Algebra.Module as Module +import qualified Algebra.Transcendental as Trans +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Real as Real + +import Data.Maybe (fromMaybe) + +import PreludeBase +import NumericPrelude + + + +{-* Reconstruction of the sound of a plucked guitar string -} + +guitarInit :: Field.C a => [a] +guitarInit = map (/128) ( + 1 : 1 : 1 : 1 : 1 : 1 : 1 : 1 : + 1 : 2 : 2 : 2 : 2 : 2 : 2 : 2 : + 2 : 2 : 2 : 2 : 2 : 2 : 2 : 2 : + 2 : 2 : 2 : 3 : 3 : 3 : 3 : 3 : + 3 : 3 : 3 : 3 : 3 : 3 : 3 : 3 : + 3 : 3 : 3 : 4 : 4 : 4 : 4 : 4 : + 4 : 4 : 4 : 4 : 4 : 4 : 4 : 4 : + 5 : 5 : 5 : 5 : 5 : 5 : 5 : 5 : + 6 : 6 : 6 : 7 : 7 : 8 : 8 : 9 : + 10 : 11 : 12 : 13 : 14 : 15 : 15 : 16 : + 17 : 17 : 17 : 18 : 18 : 18 : 18 : 18 : + 18 : 18 : 18 : 17 : 17 : 16 : 16 : 15 : + 15 : 14 : 14 : 14 : 13 : 13 : 14 : 14 : + 15 : 16 : 17 : 18 : 19 : 20 : 22 : 23 : + 25 : 27 : 30 : 32 : 35 : 37 : 39 : 41 : + 43 : 45 : 47 : 48 : 49 : 49 : 48 : 46 : + 41 : 34 : 24 : 11 : -6 : -26 : -48 : -72 : + -96 : -114 : -128 : -128 : -128 : -128 : -128 : -128 : + -128 : -125 : -110 : -93 : -75 : -57 : -41 : -27 : + -17 : -10 : -6 : -4 : -2 : -2 : -2 : -2 : + -2 : -3 : -4 : -4 : -5 : -6 : -7 : -8 : + -9 : -10 : -11 : -12 : -12 : -12 : -13 : -13 : + -13 : -13 : -13 : -13 : -12 : -12 : -11 : -10 : + -9 : -9 : -8 : -8 : -7 : -6 : -6 : -5 : + -5 : -5 : -5 : -4 : -4 : -4 : -4 : -4 : + -4 : -4 : -4 : -4 : -4 : -5 : -7 : -8 : + -8 : -9 : -10 : -11 : -12 : -13 : -13 : -14 : + -14 : -14 : -13 : -10 : -7 : -2 : 5 : 15 : + 26 : 37 : 49 : 61 : 73 : 83 : 92 : 99 : + 105 : 109 : 111 : 112 : 110 : 105 : 99 : 90 : + 80 : 71 : 63 : 57 : 52 : 49 : 47 : 47 : + 48 : 49 : 51 : 51 : 52 : 52 : 50 : 48 : + 42 : 34 : 22 : 7 : -12 : -32 : -56 : -78 : + -96 : -114 : -127 : -128 : -128 : -128 : -128 : -128 : + -128 : -118 : -102 : -83 : -67 : -50 : -37 : -26 : + -17 : -12 : -8 : -5 : -3 : -3 : -2 : -2 : + -2 : -3 : -4 : -4 : -6 : -7 : -8 : -10 : + -11 : -12 : -12 : -13 : []) + +guitarCompShort, guitarCompLong :: + Field.C a => [a] -> Filter.Composition.T Filter.TwoWay.T Double a a +guitarCompShort past = Feedback (Prim (Filter.TwoWay.Past past)) (Parallel [ + Serial [Prim (Filter.TwoWay.Delay 1), + Prim (Filter.TwoWay.Mask [0.6519177892575342, 0.2331904728998289])], + Serial [Prim (Filter.TwoWay.Delay 126), + Prim (Filter.TwoWay.Mask [0.08253506238277844, + 0.2369601607320473, 0.18367848836060044, + -0.06422525077173147, -0.31836517142623727])]]) +guitarCompLong past = Feedback (Prim (Filter.TwoWay.Past past)) ( + Serial [Prim (Filter.TwoWay.Delay 122), + Prim (Filter.TwoWay.Mask [ + -0.23742303494466988, + 0.020278040917954415, + 0.12495333789385828, + 0.16125537461091102, + 0.1993410924766678, + 0.24673057006071691, + 0.25438881375430467, + 0.1424676847770117, + 0.03848071949084291, + -0.016618282409355676, + -0.04517323927531556, + -0.0061713683480988475, + 0.11137126130878339 + ])]) + +{-| Reconstruct the guitar sound from the sampled initial wave + and the analysed feedback factors. + This sounds pretty like the sampled sound. -} +guitarRaw :: (Field.C a, Module.C a a) => [a] +guitarRaw = + let gi = guitarInit -- assert monomorphism + y = Filter.TwoWay.future + (Filter.TwoWay.delay (length gi) + (apply (guitarCompLong (reverse gi)) + (Filter.TwoWay.Signal [] []))) + in y + +{-| Reconstruct the guitar sound from the sampled initial wave + but with simple smoothing on feedback. + This sounds more statically. -} +guitarRawSimple :: (Field.C a, Module.C a a) => [a] +guitarRawSimple = + let gi = guitarInit -- assert monomorphism + y = gi ++ drop (length gi) + (FiltNR.delay 128 (Filt1.lowpass + (repeat (Filt1.Parameter (0.4 `asTypeOf` head y))) y)) + in y + +{-| Reconstruct the guitar sound with the analysed feedback factors + but with an synthetic initial wave. + The sharpness of the initial wave can be controlled. + This is used to implement various velocities. -} +guitarRawVelo :: (Real.C a, Trans.C a, Module.C a a) => a -> [a] +guitarRawVelo velo = + let len = 128::Int + wave = + map (Wave.power01Normed velo) + (take len (iterate (+ 2 / fromIntegral len) (-1))) + y = Filter.TwoWay.future + (Filter.TwoWay.delay len + (apply (guitarCompLong wave) + (Filter.TwoWay.Signal [] []))) + in y + + +{-| Resample the reconstructed string sound + so that notes can be played. -} +guitar :: (RealField.C a, Module.C a a) => a -> [a] +guitar freq = + let srcFreq = 128 * freq + in Interpolation.multiRelativeZeroPadLinear 0 + (repeat (srcFreq `asTypeOf` freq)) guitarRawSimple + + + +{-* Tests for FilterGraphs -} + +type CompositionDouble = + Filter.Composition.T Filter.TwoWay.T Double Double Double + +{-| a simple lowpass used to create an exponential2 -} +--expo :: (RealField.C a, Module.C a a) => Filter.TwoWay.Signal a +expo :: Filter.TwoWay.Signal Double +expo = + let _flt1 = Feedback (Serial [Prim (Filter.OneWay.Delay ([0] `asTypeOf` past))]) + (Serial [Prim (Filter.OneWay.Mask + ([0.9] `asTypeOf` past))]) + _flt2 = (Prim (Filter.TwoWay.Mask ([0.5] `asTypeOf` past))) + :: CompositionDouble + flt3 = (Feedback (Serial []) + (Prim (Filter.TwoWay.Delay 1))) + :: CompositionDouble + Filter.TwoWay.Signal past future = apply flt3 (Filter.TwoWay.Signal [] [1]) + in Filter.TwoWay.Signal past (take 10 future) + +type GraphDouble f = Filter.Graph.T f Int Double Double Double + +simpleGraph :: Filter.TwoWay.Signal Double +simpleGraph = + let out = + Filter.Graph.apply + (Filter.Graph.fromList + [(0, []), + (1, [(0, Filter.TwoWay.Delay (-1))]), + (2, [(1, Filter.TwoWay.Mask [0.95])])] :: + GraphDouble Filter.TwoWay.T) + (Filter.Graph.signalFromList + [(0, Filter.TwoWay.Signal [] [1])]) + in fromMaybe (error "requested output of non-existing socket") + (Filter.Graph.lookupSignal out (2::Int)) + +expoGraphTwoWay :: [Double] +expoGraphTwoWay = + let out = + Filter.Graph.apply + (Filter.Graph.fromList + [(0, [(2, Filter.TwoWay.Past [1])]), + (1, [(0, Filter.TwoWay.Delay 1)]), + (2, [(1, Filter.TwoWay.Mask [0.95])])] :: + GraphDouble Filter.TwoWay.T) + (Filter.Graph.signalFromList + [(0, Filter.TwoWay.Signal [] [])]) + in Filter.TwoWay.take 20 $ Filter.TwoWay.delay 10 + (fromMaybe (error "requested output of non-existing socket") + (Filter.Graph.lookupSignal out (0::Int))) + + +expoGraph :: [Double] +expoGraph = + let out = + Filter.Graph.apply + (Filter.Graph.fromList + [(0, [(1, Filter.OneWay.Delay [0])]), + (1, [(0, Filter.OneWay.Mask [0.99])])] :: + GraphDouble Filter.OneWay.T) + (Filter.Graph.signalFromList + [(0, [1])]) + in fromMaybe (error "requested output of non-existing socket") + (Filter.Graph.lookupSignal out (0::Int)) + +{-| make recursive flanger with help of the two way interpolation -} +flangedSaw :: Double -> [Double] +flangedSaw sampleRate = + let {- The flanger's principal filter frequency will vary between + flangeFreq * 2**flangeRange and flangeFreq / 2**flangeRange -} + flangeFreq = 1000 + flangeRange = 2 + sawFreq = 440 + gain = 0.6 + vol = 0.5 + + {- 'control' contains the feedback times -} + control = map (\c -> sampleRate/flangeFreq * 2**(-flangeRange*c)) + (map sin (iterate (pi/(0.5*sampleRate)+) 0)) + sawPast = Osci.freqModSaw 0 (repeat (-sawFreq/sampleRate)) + sawFuture = Osci.freqModSaw 0 (repeat ( sawFreq/sampleRate)) + --lowNoise = amplify vol noise + flt = Feedback + (Prim (Filter.TwoWay.Mask [vol])) + (Serial [Prim (Filter.TwoWay.Mask [gain]), + Prim (Filter.TwoWay.Past []), + Prim (Filter.TwoWay.ModFracDelay + Interpolation.linear + (Filter.TwoWay.Signal [] control))]) + :: CompositionDouble + + in Filter.TwoWay.future + (apply flt (Filter.TwoWay.Signal sawPast sawFuture)) diff --git a/src/Filter/Fix.hs b/src/Filter/Fix.hs new file mode 100644 --- /dev/null +++ b/src/Filter/Fix.hs @@ -0,0 +1,38 @@ +module Filter.Fix where + +import qualified Filter.Graph as Graph + + +{-| +A 'Graph.T' with numbered nodes is not very comfortable. +Better provide a 'Control.Monad.Fix.fix'-like function +which allows to enter a graph this way: + +> fix $ \[v,w,y] -> +> [a·(u + d·w), +> b·(v + e·y), +> c· w] + +-} + +type T filter t a v = + [Channel filter t a v] -> [[(Channel filter t a v, filter t a v)]] + +type ChannelId = Int + +data Channel filter t a v = + Channel {channelId :: ChannelId, + channelInputs :: [(ChannelId, filter t a v)]} + + +fix :: T filter t a v -> [Channel filter t a v] +fix f = + let cs = zipWith (\n inputs -> + Channel n (map (\(c,filt) -> (channelId c, filt)) inputs)) + [0 ..] (f cs) + in cs + + +toGraph :: T filter t a v -> Graph.T filter Int t a v +toGraph = + Graph.fromList . map (\(Channel n inputs) -> (n, inputs)) . fix diff --git a/src/Filter/Graph.hs b/src/Filter/Graph.hs new file mode 100644 --- /dev/null +++ b/src/Filter/Graph.hs @@ -0,0 +1,178 @@ +{-# OPTIONS -fglasgow-exts -fallow-undecidable-instances -fno-implicit-prelude #-} +module Filter.Graph where + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + +import Filter.Basic(Filter,apply,transferFunction) +import qualified Data.Map as Map +import Data.Map(Map) +import MathObj.DiscreteMap() {- Module.C instances for Map -} + +import qualified Number.Complex as Complex +import qualified Algebra.RealField as RealField +import qualified Algebra.Additive as Additive +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Module as Module +import Algebra.Module((*>)) +import Orthogonals(Scalar,inverse,add_to_diagonal) + + +{-| +A filter network is a graph consisting +of nodes (input and output signals) +and edges (filter processes). +Output signals can be taken from every node, +inputs can be injected in some nodes +which means that the signal at this node is superposed with +the injected signal. +The same can be achieved by duplicating the network, +one duplicate per input, +and superposing the corresponding outputs. +It is also sensible to setup a graph without inputs, +e.g. a recursive filter with some initial conditions +that works independent from any input. + +In opposition to electric filter networks +digital filter networks must be directed. + +Test-case: leap-frog filters like + +> +-----------[d]-----------+ +> v | +>(u) -+-> [a] (v) -+-> [b] (w) -+-> [c] (y) -+-> +> ^ | +> +-----------[e]-----------+ + +@ +v = a·(u + d·w) +w = b·(v + e·y) +y = c· w +@ + +We model the general network by a list of nodes, +where each node is an adder that holds a list of its inputs. +Each input of a node is an output +of another node that has gone through a processor. +Additionally there may be one input from outside. +In principle a processor could be a simple filter network +as defined by the structure 'Filter'. + +The network is an applyable filter +whenever each circle contains a delay. +To compute the transfer function +we have to solve a system of linear equations +which we can construct quite straight forward +from the processors' input lists. + +The current design can be abstractly seen +as the system of linear equations: + + y = A*y + u + +where A is a matrix containing the edges hosting the filters, +y the vector of output signals, +u the vector of input signals. +In this formulation the number of inputs and outputs must match +but since you are free to ignore some of the inputs and outputs +you can use nodes for pure output, pure input or both of them. + +-} + +newtype T filter i t a v = + C (Map i + [(i, {- index of the processor whose output goes in here -} + filter t a v {- description of the filter -} + )]) + + +newtype Signal list i v = Signal (Map i (list v)) + + +fromList :: (Ord i) => [(i, [(i, filter t a v)])] -> T filter i t a v +fromList = C . Map.fromList + +toList :: T filter i t a v -> [(i, [(i, filter t a v)])] +toList (C fg) = Map.toList fg + +signalFromList :: (Ord i) => [(i, list v)] -> Signal list i v +signalFromList = Signal . Map.fromList + +signalToList :: Signal list i v -> [(i, list v)] +signalToList (Signal x) = Map.toList x + +lookupSignal :: (Ord i) => Signal list i v -> i -> Maybe (list v) +lookupSignal (Signal x) = flip Map.lookup x + + +{- + These instance may help to include FilterGraphs + in even bigger structures. +-} +instance (Ord i, Additive.C (list v), Eq (list v)) + => Additive.C (Signal list i v) where + zero = Signal Additive.zero + (+) (Signal x) (Signal y) = Signal ((Additive.+) x y) + (-) (Signal x) (Signal y) = Signal ((Additive.-) x y) + negate (Signal x) = Signal (Additive.negate x) + +instance (Ord i, Eq a, Additive.C a, Additive.C (list v), Eq (list v), + Module.C a v, Module.C a (list v)) + => Module.C a (Signal list i v) where + s *> (Signal x) = Signal (s *> x) + + +{- + It would be interesting to make FilterGraphs + an instance of Filter. + To achieve that we had to make GraphSignals an instance of Module.C + and the transferFunction would no longer return a factor + but a function that maps input amplitudes + of a given frequency to output amplitudes. + +instance (Ord i, Show i, Filter list filter) => + Filter (Signal list i) (T filter i) where +-} + +apply :: (Ord i, Show i, Additive.C t, Trans.C t, RealField.C t, + Module.C a v, Module.C a (list v), + Filter list filter) => + T filter i t a v -> Signal list i v -> Signal list i v +apply (C fg) (Signal inputs) = + let getInput i = Map.findWithDefault Additive.zero i inputs + getOutput i = Map.findWithDefault + (error ("Unknown processor: "++show i)) i outputs + output i edges = + foldl (Additive.+) (getInput i) (map (\(j,f) -> + Filter.Basic.apply f (getOutput j)) edges) + outputs = Map.mapWithKey output fg + in Signal outputs + +{-| Compute a matrix that tells how an input frequency + is mapped to the various output nodes. + + According to the formulation given above + we have to invert the matrix (I-A). + + Currently this is done by a QR decomposition for each frequency. + It would be probably faster if we decompose + the matrix containing polynomial elements. + Then the inverted matrix would consist of some + polynomial ratios which can be evaluated for each frequency. +-} +transferFunction :: + (Ord i, Show i, Trans.C t, + P.Fractional (Complex.T t), Scalar (Complex.T t), + Module.C a t, Filter list filter) => + T filter i t a v -> t -> [[Complex.T t]] +transferFunction (C fg) w = + let keys = Map.keys fg + elts = Map.elems fg + inputsToMap procs = + Map.mapWithKey (\_ f -> Filter.Basic.transferFunction f w) + (Map.fromList procs) + makeRow procs = + map (flip (Map.findWithDefault 0) (inputsToMap procs)) keys + matrix = map makeRow elts + in inverse (add_to_diagonal (-1) matrix) diff --git a/src/Filter/Graphic.hs b/src/Filter/Graphic.hs new file mode 100644 --- /dev/null +++ b/src/Filter/Graphic.hs @@ -0,0 +1,7 @@ +module Filter.Graphic where + +{-| + This module should be populated with functions + that create flowchart graphics from the filter networks + of the 'Composition' module. +-} diff --git a/src/Filter/MonadFix.hs b/src/Filter/MonadFix.hs new file mode 100644 --- /dev/null +++ b/src/Filter/MonadFix.hs @@ -0,0 +1,43 @@ +module Filter.MonadFix where + +import qualified Filter.Graph as Graph +import qualified Filter.Fix as FFix + +import Filter.Fix (Channel(Channel), ChannelId) + +import Control.Monad.State (StateT, evalStateT, get, modify, lift) +import Control.Monad.Writer (Writer, execWriter, tell) + + +{-| +If you find 'Filter.Fix.T' still inconvenient, +and if you don't care about portability, +you can also use the following monad with the @mdo@ notation. + +> mdo +> v <- a·(u + d·w) +> w <- b·(v + e·y) +> y <- c· w + +-} + + +type T filter t a v x = StateT ChannelId (Writer [Channel filter t a v]) x + +makeChannel :: + [(ChannelId, filter t a v)] -> + T filter t a v ChannelId +makeChannel inputs = + do n <- get + modify succ + lift $ tell [Channel n inputs] + return n + + +run :: T filter t a v x -> [Channel filter t a v] +run m = execWriter (evalStateT m 0) + + +toGraph :: T filter t a v x -> Graph.T filter Int t a v +toGraph = + Graph.fromList . map (\(Channel n inputs) -> (n, inputs)) . run diff --git a/src/Filter/OneWay.hs b/src/Filter/OneWay.hs new file mode 100644 --- /dev/null +++ b/src/Filter/OneWay.hs @@ -0,0 +1,74 @@ +{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-} +module Filter.OneWay where + +import Filter.Basic + +import qualified Synthesizer.Plain.Interpolation as Interpolation +import qualified Synthesizer.Plain.Filter.NonRecursive as FiltNR +import Number.Complex(cis) + +import qualified Algebra.Module as Module +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Algebra.Module(linearComb) +import Algebra.Additive(zero) + +import PreludeBase +import NumericPrelude + +type Signal = [] + +{-| shift signal in time -} +delay :: (Additive.C v) => + Int -> Signal v -> Signal v +delay = FiltNR.delayPad zero + +delayOnce :: (Additive.C v) => + Signal v -> Signal v +delayOnce = (zero:) + + +{-| Unmodulated non-recursive filter -} +nonRecursiveFilter :: Module.C a v => + [a] -> [v] -> [v] +nonRecursiveFilter = FiltNR.generic + +{-| Modulated non-recursive filter. -} +nonRecursiveFilterMod :: Module.C a v => + [[a]] -> [v] -> [v] +nonRecursiveFilterMod ms x = + zipWith linearComb ms (tail (scanl (flip (:)) [] x)) + + +{-| Description of a basic filter that can be used in larger networks. -} +data T t a v = + Mask [a] + {-^ A static filter described by its mask -} + | ModMask (Signal [a]) + {-^ A modulated filter described by a list of masks -} + | FracDelay (Interpolation.T t v) t + {-^ Delay the signal by a fractional amount of samples. + This is achieved by interpolation. -} + | ModFracDelay (Interpolation.T t v) (Signal t) + {-^ Delay with varying delay times. + The delay times sequence must monotonically decrease. + (This includes constant parts!) -} + | Delay [v] + {-^ Delay the signal by prepending another one -} + +instance Filter [] T where + + apply (Mask m) = nonRecursiveFilter m + apply (ModMask m) = nonRecursiveFilterMod m + apply (FracDelay ip t) = Interpolation.multiRelativeZeroPad zero + ip (-t) (repeat 1) + apply (ModFracDelay ip ts) = Interpolation.multiRelativeZeroPad zero + ip (- head ts) (repeat 1 - FiltNR.differentiate ts) + apply (Delay x) = (x++) + + transferFunction (Mask m) w = linearComb m (screw (negate w)) + transferFunction (FracDelay _ t) w = cis (negate w * t) + transferFunction (Delay x) w = cis (negate w * fromIntegral (length x)) + transferFunction _ _ = + error "transfer function can't be computed for modulated filters" diff --git a/src/Filter/TwoWay.hs b/src/Filter/TwoWay.hs new file mode 100644 --- /dev/null +++ b/src/Filter/TwoWay.hs @@ -0,0 +1,245 @@ +{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-} +module Filter.TwoWay where + +import Filter.Basic + +import Synthesizer.Plain.Interpolation (minLength,) +import qualified Synthesizer.Plain.Interpolation as Ip +import qualified Synthesizer.Plain.Interpolation as Interpolation + +import Algebra.Module(linearComb,(*>)) + +import qualified Algebra.Module as Module +import qualified Algebra.RealField as RealField +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Number.Complex(cis) +import Synthesizer.Utility(nest) +import qualified Data.List as List + +import PreludeBase hiding (take) +import NumericPrelude + + +{-| A TwoWay.Signal stores values of the past and the future -} +data Signal v = Signal {past, future :: [v]} + deriving (Show, Eq) + +{-| Take n values starting from time zero. + If you want clips from elsewhere, + call 'take' after 'delay'. -} +take :: Int -> Signal v -> [v] +take n (Signal _ x) = List.take n x + +zipSignalWith :: (a -> b -> c) -> Signal a -> Signal b -> Signal c +zipSignalWith f (Signal xPast xFuture) (Signal yPast yFuture) = + (Signal (zipWith f xPast yPast) (zipWith f xFuture yFuture)) + +{-| Take the value at time zero. -} +origin :: Ring.C a => Signal a -> a +origin (Signal _ (x:_)) = x +origin _ = 0 + +{-| A signal that consists entirely of ones -} +ones :: Ring.C a => Signal a +ones = Signal (repeat 1) (repeat 1) + +{-| shift signal in time, + keep all values but if required pad with zeros -} +delay :: (Additive.C v) => + Int -> Signal v -> Signal v +delay = delayGen delayOnce + +delayPad :: v -> Int -> Signal v -> Signal v +delayPad z = delayGen (delayPadOnce z) + +{-| shift signal in time, + zero values at either ends will be flushed -} +delayOpt :: (Eq v, Additive.C v) => + Int -> Signal v -> Signal v +delayOpt = delayGen delayOptOnce + + +{-| Delay by one sample. -} +delayOnce :: (Additive.C v) => + Signal v -> Signal v +--delayOnce (Signal [] []) = ([],[]) +delayOnce (Signal [] ys) = Signal [] (zero:ys) +delayOnce (Signal (x:xs) ys) = Signal xs (x:ys) + +delayPadOnce :: v -> Signal v -> Signal v +--delayPadOnce _ (Signal [] []) = ([],[]) +delayPadOnce z (Signal [] ys) = Signal [] (z:ys) +delayPadOnce _ (Signal (x:xs) ys) = Signal xs (x:ys) + +delayOptOnce :: (Eq v, Additive.C v) => + Signal v -> Signal v +--delayOptOnce (Signal [] []) = Signal [] [] +delayOptOnce (Signal [] ys) = Signal [] (zero:ys) +delayOptOnce (Signal (x:xs) []) = Signal xs (if x==zero then [] else x:[]) +delayOptOnce (Signal (x:xs) ys) = Signal xs (x:ys) + + +{-| General routine that supports delaying and prefetching + using a general one-sample delaying routine. -} +delayGen :: (Signal v -> Signal v) -> + Int -> Signal v -> Signal v +{- Using this optimization applications of recursive filters + with zero initial conditions represented by an empty list will fail. + This is because in this case the value of the first item of the future list + depends on the first item of the input future list, + whereas normally the first future value depends on no input future value, + at all. +delayGen _ _ (Signal [] []) = Signal [] [] + cf. the next example -} +delayGen delOnce t = + if t < 0 + then reverseTwoWay . nest (negate t) delOnce . reverseTwoWay + else nest t delOnce + +reverseTwoWay :: Signal v -> Signal v +reverseTwoWay (Signal x y) = Signal y x + + +instance (Additive.C v) => Additive.C (Signal v) where + zero = Signal zero zero + (+) (Signal y0 y1) (Signal x0 x1) = Signal (y0 + x0) (y1 + x1) + (-) (Signal y0 y1) (Signal x0 x1) = Signal (y0 - x0) (y1 - x1) + negate (Signal x0 x1) = Signal (negate x0) (negate x1) + +instance (Module.C a v) => Module.C a (Signal v) where + (*>) s (Signal x0 x1) = Signal (s *> x0) (s *> x1) + + + + +{-| for a Signal this means a reversion of the elements -} +flipPair :: (a,b) -> (b,a) +flipPair (x,y) = (y,x) + +{- This example simulates what happens if you call + apply (Feedback (Serial []) (Prim (Delay 1)) []) ([],[1]) + depending on the implementation of delayGen it may work or + loop infinitely when yFuture is computed. + It's even before the first element of yFuture is computed. + Note, that the equivalent + apply (Feedback (Serial []) (Prim (Delay 1)) [0]) ([],[1]) + works! (i.e. set yPast = [0] -} +testDelayGen :: Signal Double +testDelayGen = + let yPast = [] + x = Signal [] [1] + y = Signal yPast yFuture + Signal _ yFuture = delayOnce (x + y) + -- Signal _ yFuture = delayOptOnce (add x y) + -- Signal _ yFuture = delayGen delayOnce 1 (add x y) + in Signal yPast (List.take 10 yFuture) + + + +{-| Unmodulated non-recursive filter -} +nonRecursiveFilter :: Module.C a v => + [a] -> Signal v -> Signal v +nonRecursiveFilter m x = + linearComb m (iterate delayOnce x) + +{-| Modulated non-recursive filter. + The number of values before time 0 (past) or + the filter mask lengths must be at most finite. -} +nonRecursiveFilterMod :: Module.C a v => + Signal [a] -> Signal v -> Signal v +nonRecursiveFilterMod (Signal mpre msuf) x = + let (pre, suf) = unzip (map (\(Signal a b) -> (a,b)) (iterate delayOnce x)) + in Signal (zipWith linearComb mpre pre) (zipWith linearComb msuf suf) + + +{-| Interpolation allowing negative frequencies, + but requires storage of all past values. -} +interpolatePaddedZero :: (Ord a, RealField.C a) => + b -> Interpolation.T a b + -> a -> Signal a -> Signal b -> Signal b +interpolatePaddedZero z ip phase fs (Signal xPast xFuture) = + let (phInt, phFrac) = splitFraction phase + xPadded = Signal (xPast ++ repeat z) (xFuture ++ repeat z) + in interpolateCore ip phFrac fs + (delayPad z (Ip.offset ip - phInt) xPadded) + +interpolatePaddedCyclic :: (Ord a, RealField.C a) => + Interpolation.T a b + -> a -> Signal a -> Signal b -> Signal b +interpolatePaddedCyclic ip phase fs (Signal xPast xFuture) = + let (phInt, phFrac) = splitFraction phase + xCyclic = xFuture ++ reverse xPast + in interpolateCore ip phFrac fs + -- mod is for efficiency, only + (delayPad (error "interpolate: infinite signal needs no zero padding") + (mod (Ip.offset ip - phInt) (length xCyclic)) + (Signal (cycle (reverse xCyclic)) (cycle xCyclic))) + +-- note that the extrapolation may miss some of the first and some of the last points +interpolatePaddedExtrapolation :: (Ord a, RealField.C a) => + Interpolation.T a b + -> a -> Signal a -> Signal b -> Signal b +interpolatePaddedExtrapolation ip phase fs x = + interpolateCore ip (phase - fromIntegral (Ip.offset ip)) fs x + +interpolateCore :: (Ord a, Ring.C a) => + Interpolation.T a b -> a -> Signal a -> Signal b -> Signal b +interpolateCore ip phase (Signal freqPast freqFuture) x = + Signal (interpolateHalfWay ip (1-phase) freqPast + (delayPadOnce (error "interpolateCore: infinite signal needs no zero padding") + (reverseTwoWay x))) + (interpolateHalfWay ip phase freqFuture x) + +interpolateHalfWay :: (Ord a, Ring.C a) => + Interpolation.T a b -> a -> [a] -> Signal b -> [b] +interpolateHalfWay ip phase freqs (Signal xPast xFuture) = + if phase >= 1 && minLength (1+Ip.number ip) xFuture + then interpolateHalfWay ip (phase-1) freqs + (Signal (head xFuture : xPast) (tail xFuture)) + else if phase < 0 && minLength 1 xPast + then interpolateHalfWay ip (phase + 1) freqs + (Signal (tail xPast) (head xPast : xFuture)) + else Ip.func ip phase xFuture : + interpolateHalfWay ip (phase + head freqs) (tail freqs) + (Signal xPast xFuture) + + +{-| Description of a basic filter that can be used in larger networks. -} +data T t a v = + Mask [a] + {-^ A static filter described by its mask -} + | ModMask (Signal [a]) + {-^ A modulated filter described by a list of masks -} + | FracDelay (Interpolation.T t v) t + {-^ Delay the signal by a fractional amount of samples. + This is achieved by interpolation. -} + | ModFracDelay (Interpolation.T t v) (Signal t) + {-^ Delay with varying delay times. -} + | Delay Int + {-^ Delay the signal by given amount of samples. -} + | Past [v] + {-^ Replace the past by the given one. + This must be present in each recursive filter cycle + to let the magic work! -} + +instance Filter Signal T where + + apply (Mask m) = nonRecursiveFilter m + apply (ModMask m) = nonRecursiveFilterMod m + apply (FracDelay ip t) = interpolatePaddedZero zero + ip (-t) ones + apply (ModFracDelay ip ts) = interpolatePaddedZero zero + ip (- origin ts) (ts - delay (-1) ts + ones) + apply (Delay t) = delay t + apply (Past x) = Signal x . future + + {- This is in principle the same as for one way filters. + How can one merge them? -} + transferFunction (Mask m) w = linearComb m (screw (negate w)) + transferFunction (FracDelay _ t) w = cis (negate w * t) + transferFunction (Delay t) w = cis (negate w * fromIntegral t) + transferFunction (Past _) _ = 1 + transferFunction _ _ = + error "transfer function can't be computed for modulated filters" diff --git a/src/FourierSeries.hs b/src/FourierSeries.hs new file mode 100644 --- /dev/null +++ b/src/FourierSeries.hs @@ -0,0 +1,15 @@ +module FourierSeries where + +evalL :: Floating a => [(a,a)] -> a -> a +evalL [] _ = 0 +evalL ((c,_):cs) t = + c/2 + sum (zipWith (\(r,i) tk -> r * cos tk + i * sin tk) + cs (iterate (t+) t)) + +evalSineL, evalCosineL :: Floating a => [a] -> a -> a +evalSineL [] _ = 0 +evalSineL (_:cs) t = + sum (zipWith (*) cs (map sin (iterate (t+) t))) +evalCosineL [] _ = 0 +evalCosineL (c:cs) t = + c/2 + sum (zipWith (*) cs (map cos (iterate (t+) t))) diff --git a/src/OsciDiffEq.hs b/src/OsciDiffEq.hs new file mode 100644 --- /dev/null +++ b/src/OsciDiffEq.hs @@ -0,0 +1,75 @@ +module OsciDiffEq where + +{- +ghci -fglasgow-exts -fno-implicit-prelude ../numericprelude/MyPrelude.hs ../numericprelude/NumExtras.lhs ../numericprelude/VectorSpace.lhs ../numericprelude/PreludeBase.lhs ../numericprelude/NumericPrelude.lhs OsciDiffEq.hs + +import MyPrelude +but then (+) ends up in a loop Exception :-( +-} + +import Number.Complex((+:),phase) + +infixl 6 .+ +infixr 7 *> + +integrate :: Num a => a -> [a] -> [a] +integrate = scanl (+) + +(.+) :: Num a => [a] -> [a] -> [a] +(.+) = zipWith (+) + +(*>) :: Num a => a -> [a] -> [a] +(*>) v = map (v*) + +wave :: Num a => (a,a) -> (a,a) -> [a] +wave (k0,c0) (k1,c1) = + let y' = integrate c1 y'' + y = integrate c0 y' + y'' = map negate (k0 *> y .+ k1 *> y') + in y + +waveExample :: [Double] +waveExample = wave (0.07, 1) (0.08, 0) + + +waveSqr :: Num a => (a,a,a) -> (a,a) -> (a,a) -> [a] +waveSqr (a00,a01,a11) (k0,c0) (k1,c1) = + let mul = zipWith (*) + y' = integrate c1 y'' + y = integrate c0 y' + y'' = map negate (foldl1 (.+) + (zipWith (*>) [k0, k1, a00, a01, a11] + [y, y', mul y y, mul y y', mul y' y'])) + in y + +{- the square term destabilizes the solution -} +waveSqrExample :: [Double] +waveSqrExample = waveSqr (0.04,0,0) (0.07, 1) (0.08, 0) + + +waveSin :: Floating a => (a,a) -> (a,a) -> (a,a) -> [a] +waveSin (a0,a1) (k0,c0) (k1,c1) = + let y' = integrate c1 y'' + y = integrate c0 y' + y'' = map negate (foldl1 (.+) + (zipWith (*>) [k0, k1, a0, a1] + [y, y', map sin y, map sin y'])) + in y + +{- the square term destabilizes the solution -} +waveSinExample :: [Double] +waveSinExample = waveSin (0.1,0) (0.07, 10) (0.08, 0) + + +wavePhase :: RealFloat a => a -> (a,a) -> (a,a) -> [a] +wavePhase (a0) (k0,c0) (k1,c1) = + let y' = integrate c1 y'' + y = integrate c0 y' + y'' = map negate (foldl1 (.+) + (zipWith (*>) [k0, k1, a0] + [y, y', zipWith (\r i -> phase (r +: i)) y y'])) + in y + +{- the square term destabilizes the solution -} +wavePhaseExample :: [Double] +wavePhaseExample = wavePhase (0.005) (0.07, 1) (0.08, 0) diff --git a/src/Sound/Signal.hs b/src/Sound/Signal.hs new file mode 100644 --- /dev/null +++ b/src/Sound/Signal.hs @@ -0,0 +1,231 @@ +{-# OPTIONS_GHC -O -fglasgow-exts #-} +{- glasgow-exts are for the rules -} +module Sound.Signal where + +import Synthesizer.Utility (viewListL) +import NumericPrelude.Condition (toMaybe) +import Prelude hiding + ((++), iterate, foldl, map, repeat, replicate, + zipWith, zipWith3, take, takeWhile) + +{- +Signals can be lazy, but not necessarily element-wise lazy. +All values of signals must be defined. + +In future it may re-use functionality +from "Data.Foldable" and "Data.Traversable". + +Functions with accumulators always have a 'Maybe' result, +in order to be able to fuse them. +-} +class C s where + singleton :: a -> s a + unfoldR :: (acc -> Maybe (y, acc)) -> acc -> (acc, s y) + reduceL :: (x -> acc -> Maybe acc) -> acc -> s x -> acc + mapAccumL :: (x -> acc -> Maybe (y, acc)) -> acc -> s x -> (acc, s y) + (++) :: s a -> s a -> s a + zipWith :: (a -> b -> c) -> s a -> s b -> s c + + +{- +Typical examples for neither generate nor crochet: + data from disk + toList (this is a foldR) + reverse + drop + resample + Fourier transform + (++) (it could be fused, + but the fused variant needs checking a phase state each cycle + which is certainly less efficient than separate loops) +-} + +{- +Typical examples for zipWith: + mixer + controlled recursive filter +-} + +{- +Typical examples for foldL: + volume computation + DC offset + histogram +-} + + +{- +'generate' could be expressed as 'crochetL' on an empty signal (type @s ()@). +This would reduce the number of rules, +but at the end of optimization +there shouldn't be such 'crochetL's left that can represented as 'generate', +because 'generate' is more efficient. + +Typical examples for generate: + fromList + uncontrolled oscillator + constant curve + linear curve + exponential curve + noise generation +-} +generate :: C s => (acc -> Maybe (y, acc)) -> acc -> s y +generate f = snd . unfoldR f + +{-# INLINE fromList #-} +fromList :: C s => [y] -> s y +fromList = generate viewListL + + +{-# INLINE iterate #-} +iterate :: C s => (a -> a) -> a -> s a +iterate f = generate (\x -> Just (x, f x)) + +{-# INLINE repeat #-} +repeat :: C s => a -> s a +repeat = iterate id + +cycle :: C s => s a -> s a +cycle x = + let result = x ++ result + in result + + +{-# INLINE foldL' #-} +foldL' :: C s => (x -> acc -> acc) -> acc -> s x -> acc +foldL' f = reduceL (\x -> Just . f x) + +{-# INLINE lengthSlow #-} +{- | can be used to check against native length implementation -} +lengthSlow :: C s => s a -> Int +lengthSlow = foldL' (const succ) 0 + +recurse :: (acc -> Maybe acc) -> acc -> acc +recurse f = + let aux x = maybe x aux (f x) + in aux + +{- +Typical examples for crochetL: + controlled oscillator + enveloping + uncontrolled recursive filter + small delay + take +-} +crochetL :: C s => (x -> acc -> Maybe (y, acc)) -> acc -> s x -> s y +crochetL f a = snd . mapAccumL f a + +{-# INLINE scanL #-} +scanL :: C s => (x -> acc -> acc) -> acc -> s x -> s acc +scanL f start xs = + singleton start ++ + crochetL (\x acc -> let y = f x acc in Just (y, y)) start xs + +{-# INLINE map #-} +map :: C s => (a -> b) -> (s a -> s b) +map f = crochetL (\x _ -> Just (f x, ())) () + +unzip :: C s => s (a,b) -> (s a, s b) +unzip x = (map fst x, map snd x) + +{-# INLINE delay1 #-} +{- | +This is a fusion friendly implementation of delay. +However, in order to be a 'crochetL' +the output has the same length as the input, +that is, the last element is removed - at least for finite input. +-} +delay1 :: C s => a -> s a -> s a +delay1 = crochetL (flip (curry Just)) + +{-# INLINE take #-} +take :: C s => Int -> s a -> s a +take = crochetL (\x n -> toMaybe (n>0) (x, pred n)) + +{-# INLINE takeWhile #-} +takeWhile :: C s => (a -> Bool) -> s a -> s a +takeWhile p = crochetL (\x _ -> toMaybe (p x) (x, ())) () + +{-# INLINE replicate #-} +replicate :: C s => Int -> a -> s a +replicate n = take n . repeat + + +{-# INLINE zipWith3 #-} +zipWith3 :: C s => (a -> b -> c -> d) -> (s a -> s b -> s c -> s d) +zipWith3 f s0 s1 = + zipWith (uncurry f) (zipWith (,) s0 s1) + +{-# INLINE zipWith4 #-} +zipWith4 :: C s => (a -> b -> c -> d -> e) -> (s a -> s b -> s c -> s d -> s e) +zipWith4 f s0 s1 = + zipWith3 (uncurry f) (zipWith (,) s0 s1) + + +{- +The rules + "zipWith/*,generate" and + "zipWith/*,crochetL" +may generate infinite loops because GHC is free +to choose "zipWith/generate,*" or "zipWith/*,generate". +If it always chooses the latter one, it will loop forever. +-} + +{-# RULES + "crochetL/generate" forall f g a b. + crochetL g b (generate f a) = + generate (\(a0,b0) -> + do (y0,a1) <- f a0 + (z0,b1) <- g y0 b0 + return (z0, (a1,b1))) (a,b) ; + + "crochetL/crochetL" forall f g a b x. + crochetL g b (crochetL f a x) = + crochetL (\x0 (a0,b0) -> + do (y0,a1) <- f x0 a0 + (z0,b1) <- g y0 b0 + return (z0, (a1,b1))) (a,b) x ; + + + "zipWith/generate,*" forall f h a y. + zipWith h (generate f a) y = + crochetL (\y0 a0 -> + do (x0,a1) <- f a0 + return (h x0 y0, a1)) a y ; + + "zipWith/crochetL,*" forall f h a x y. + zipWith h (crochetL f a x) y = + crochetL (\(x0,y0) a0 -> + do (z0,a1) <- f x0 a0 + return (h z0 y0, a1)) + a (zipWith (,) x y) ; + + "zipWith/*,generate" forall f h a y. + zipWith h y (generate f a) = + zipWith (flip h) (generate f a) y ; + + "zipWith/*,crochetL" forall f h a x y. + zipWith h y (crochetL f a x) = + zipWith (flip h) (crochetL f a x) y ; + + "zipWith/double" forall (h :: a->a->b) (x :: s a). + zipWith h x x = map (\xi -> h xi xi) x ; + + + "reduceL/generate" forall f g a b. + reduceL g b (generate f a) = + snd + (recurse (\(a0,b0) -> + do (y,a1) <- f a0 + b1 <- g y b0 + return (a1, b1)) (a,b)) ; + + "reduceL/crochetL" forall f g a b x. + reduceL g b (crochetL f a x) = + snd + (reduceL (\x0 (a0,b0) -> + do (y,a1) <- f x0 a0 + b1 <- g y b0 + return (a1, b1)) (a,b) x) ; + #-} diff --git a/src/Sound/Signal/Block.hs b/src/Sound/Signal/Block.hs new file mode 100644 --- /dev/null +++ b/src/Sound/Signal/Block.hs @@ -0,0 +1,143 @@ +module Sound.Signal.Block where + +import Data.Array (Array, (!), listArray) + +import qualified Sound.Signal as Signal +import qualified Synthesizer.Plain.Signal as ListSignal + +import qualified Data.List as List + +import NumericPrelude.Condition (toMaybe) +import Prelude hiding ((++), iterate, foldl, zipWith, tail, head) + + +instance Signal.C T where + singleton = singleton + unfoldR = unfoldR defaultChunkSize + reduceL = reduceL + mapAccumL = mapAccumL defaultChunkSize + (++) = append + zipWith = zipWith defaultChunkSize + + +type ChunkSize = Int + +defaultChunkSize :: ChunkSize +defaultChunkSize = 256 + +newtype T a = Cons { + chunks :: [Chunk a] + } + deriving (Show) + +{- | +The array starts with index 0. +We always consider a subarray of 'body' +starting at 'offset' with size 'size'. +This way we safe copy operations +and we can efficiently 'drop', 'take' and 'append' chunk lists. +Unfortunately, 'Data.Array' does not provide subarrays with sharing. +Every chunk must have at least size 1. +-} +data Chunk a = Chunk { + offset :: Int, + size :: ChunkSize, + body :: Array Int a + } + deriving (Show) + + +singleton :: a -> T a +singleton x = Cons [Chunk 0 1 (listArray (0,0) [x])] + +isEmpty :: T a -> Bool +isEmpty (Cons x) = null x + +head :: T a -> a +head (Cons xt) = + case xt of + [] -> error "Signal.Block.head: empty list" + (Chunk start _ arr : _) -> arr ! start + +tail :: T a -> T a +tail (Cons xt) = + case xt of + [] -> error "Signal.Block.tail: empty list" + (Chunk start sz arr : xs) -> Cons + (if sz>1 + then Chunk (succ start) (pred sz) arr : xs + else xs) + +tails :: T a -> [T a] +tails = + List.unfoldr + (\x -> toMaybe (not (isEmpty x)) + (let tailX = tail x in (tailX,tailX))) + +toList :: T a -> [a] +toList = + List.concatMap + (\(Chunk start sz arr) -> + take sz (map (arr!) [start..])) . chunks + +toListAlt :: T a -> [a] +toListAlt = List.init . map head . tails + +fromList :: ChunkSize -> [a] -> T a +fromList chunkSize = + let recurse [] = [] + recurse xs = + let actSize = minLength chunkSize xs + in Chunk 0 actSize (listArray (0,actSize-1) xs) : + if actSize < chunkSize + then [] + else recurse (drop chunkSize xs) + in Cons . recurse + +{- +@minLength n x = min n (length x)@, +but 'minLength' is more lazy than 'length'. +-} +minLength :: Int -> [a] -> Int +minLength = + let recurse seenSoFar expected xt = + case xt of + [] -> seenSoFar + (_:xs) -> + if expected == 0 + then seenSoFar + else recurse (succ seenSoFar) (pred expected) xs + in recurse 0 + +{- +poor man's implementation via lists +I do not know which array function could be of help here. +-} +unfoldR :: ChunkSize -> (acc -> Maybe (y, acc)) -> acc -> (acc, T y) +unfoldR chunkSize f acc = + let (accEnd, xs) = ListSignal.unfoldR f acc + in (accEnd, fromList chunkSize xs) + +reduceL :: (a -> acc -> Maybe acc) -> acc -> T a -> acc +reduceL f start = + ListSignal.reduceL f start . toList +{- when running on array separately it would be complicated +to distinguish between termination because the signal is finished +and because the abort condition is fulfilled. -} +-- List.foldl' (\acc -> List.reduceL f acc . elems) start . toChunkList + + +mapAccumL :: ChunkSize -> + (x -> acc -> Maybe (y, acc)) -> acc -> T x -> (acc, T y) +mapAccumL chunkSize f accStart xs = + let (accEnd, ys) = ListSignal.mapAccumL f accStart (toList xs) + in (accEnd, fromList chunkSize ys) + + +append :: T a -> T a -> T a +append (Cons x) (Cons y) = Cons (x List.++ y) + +zipWith :: ChunkSize -> (a -> b -> c) -> (T a -> T b -> T c) +zipWith chunkSize f x y = + fromList chunkSize $ + List.zipWith f (toList x) (toList y) diff --git a/src/Sound/Signal/StrictBlock.hs b/src/Sound/Signal/StrictBlock.hs new file mode 100644 --- /dev/null +++ b/src/Sound/Signal/StrictBlock.hs @@ -0,0 +1,54 @@ +{-# OPTIONS -fglasgow-exts #-} +{- | +Needs generalized instances for IArray. +-} +module Sound.Signal.StrictBlock where + +import Data.Array.Unboxed (UArray) +import Data.Array.IArray (IArray, ixmap, bounds, elems, listArray) + +-- import qualified Sound.Signal as Signal + +import qualified Data.List as List + +import Prelude hiding ((++), iterate, foldl) + + +{- +instance Signal.C T where + singleton x = Cons 0 [x] +-- unfoldr f = List.unfoldr (Just . f) +-- foldl' = List.foldl' + (Cons k x) ++ y = Cons k (x List.++ toChunkList y) +-- mapAccumL = List.mapAccumL +-} + + +data T a = Cons { + offset :: Int, + chunks :: [UArray Int a] + } + +toChunkList :: (IArray UArray a) => T a -> [UArray Int a] +toChunkList (Cons k (x:xs)) = + ixmap (let (0,n) = bounds x in (0,n-k)) (k+) x + : xs +toChunkList (Cons 0 []) = [] +toChunkList _ = + error "Sound.Signal.Block: invalid empty structure" + +singleton :: (IArray UArray a) => a -> T a +singleton x = Cons 0 [listArray (0,0) [x]] + +-- unfoldr :: (a -> (b,a)) -> a -> T b +-- unfoldr f = List.unfoldr (Just . f) + +foldl' :: (IArray UArray a) => (acc -> a -> acc) -> acc -> T a -> acc +foldl' f start = + List.foldl' (\acc -> List.foldl' f acc . elems) start . toChunkList + +(++) :: (IArray UArray a) => T a -> T a -> T a +(Cons k x) ++ y = Cons k (x List.++ toChunkList y) + +-- mapAccumL :: (acc -> x -> (acc, y)) -> acc -> T x -> (acc, T y) +-- mapAccumL = List.mapAccumL diff --git a/src/Sox.hs b/src/Sox.hs new file mode 100644 --- /dev/null +++ b/src/Sox.hs @@ -0,0 +1,16 @@ +module Sox where + +import qualified Algebra.RealField as RealField + + +channelOption :: Int -> [String] +channelOption n = + ["-c", show n] +{- + if n == 1 + then [] + else ["-c", show n] +-} + +sampleRateOption :: (RealField.C a) => a -> [String] +sampleRateOption r = ["-r", show (RealField.round r :: Int)] diff --git a/src/Sox/File.hs b/src/Sox/File.hs new file mode 100644 --- /dev/null +++ b/src/Sox/File.hs @@ -0,0 +1,101 @@ +{-# OPTIONS -fno-implicit-prelude #-} +module Sox.File where + +import qualified BinarySample as BinSmp +import qualified Sox as Sox + +import System.Cmd(rawSystem) +import System.Exit(ExitCode) +import Data.List(isSuffixOf) + +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field + +import PreludeBase +import NumericPrelude + + +render :: (RealField.C a, BinSmp.C v) => + FilePath -> a -> (a -> [v]) -> IO ExitCode +render fileName sampleRate renderer = + write fileName sampleRate (renderer sampleRate) + +renderMono :: (RealField.C a) => + FilePath -> a -> (a -> [a]) -> IO ExitCode +renderMono fileName sampleRate renderer = + writeMono fileName sampleRate (renderer sampleRate) + +renderStereo :: (RealField.C a) => + FilePath -> a -> (a -> [(a,a)]) -> IO ExitCode +renderStereo fileName sampleRate renderer = + writeStereo fileName sampleRate (renderer sampleRate) + + +write :: (RealField.C a, BinSmp.C v) => + FilePath -> a -> [v] -> IO ExitCode +write fileName sampleRate signal = + writeSignalRaw fileName [] sampleRate + (BinSmp.numChannels (head signal)) + (BinSmp.signalToBinary signal) + +writeMono :: (RealField.C a) => + FilePath -> a -> [a] -> IO ExitCode +writeMono fileName sampleRate signal = + writeSignalRaw fileName [] + sampleRate 1 (BinSmp.signalToBinaryMono signal) + +writeStereo :: (RealField.C a) => + FilePath -> a -> [(a,a)] -> IO ExitCode +writeStereo fileName sampleRate signal = + writeSignalRaw fileName [] + sampleRate 2 (BinSmp.signalToBinaryStereo signal) + + +writeSignalRaw :: (RealField.C a) => + FilePath -> [String] -> a -> Int -> [Int] -> IO ExitCode +writeSignalRaw fileName soxOptions sampleRate numChannels stream = + let fileNameRaw = fileName ++ ".sw" + in do BinSmp.writeInt16Stream fileNameRaw stream + rawToAIFF fileName soxOptions sampleRate numChannels + encode fileName + +rawToAIFF :: (RealField.C a) => + FilePath -> [String] -> a -> Int -> IO ExitCode +rawToAIFF fileName soxOptions sampleRate numChannels = + let fileNameRaw = fileName ++ ".sw" + fileNameAIFF = fileName ++ ".aiff" + in rawSystem "sox" + (soxOptions ++ + Sox.sampleRateOption sampleRate ++ + Sox.channelOption numChannels ++ + [fileNameRaw, fileNameAIFF]) + +encode :: FilePath -> IO ExitCode +encode fileName = + let fileNameAIFF = fileName ++ ".aiff" + --fileNameOGG = fileName ++ ".ogg" + fileNameMP3 = fileName ++ ".mp3" + in do rawSystem "oggenc" ["--quality", "5", fileNameAIFF] + rawSystem "lame" ["-h", fileNameAIFF, fileNameMP3] + + +{- This implementation doesn't work properly. + It seems like readFile is run + after all system calls to Sox are performed. + Aren't the calls serialized? +readAIFFMono :: (RealField.C a, Floating a) => FilePath -> IO [a] +readAIFFMono file = + do putStrLn ("sox "++file++" /tmp/sample.sw") + system ("sox "++file++" /tmp/sample.sw") + str <- readFile "/tmp/sample.sw" + return (binaryToSignalMono str) +-} +readAIFFMono :: (Field.C a) => FilePath -> IO [a] +readAIFFMono file = + let stem = if isSuffixOf ".aiff" file + then take (length file - 5) file + else file + tmp = stem ++ ".sw" + in do --putStrLn ("sox "++file++" "++tmp) + rawSystem "sox" [file, tmp] + fmap (map BinSmp.int16ToNum) (BinSmp.readInt16Stream tmp) diff --git a/src/Sox/Play.hs b/src/Sox/Play.hs new file mode 100644 --- /dev/null +++ b/src/Sox/Play.hs @@ -0,0 +1,95 @@ +{-# OPTIONS -fno-implicit-prelude #-} +module Sox.Play where + +import qualified BinarySample as BinSmp +import qualified Sox as Sox + +import System.IO(IO) +import qualified System.IO as IO + +import qualified System.Process as Proc +import Control.Exception(bracket) + +{- +import qualified Shell +-} +import qualified System.Posix.Signals as Signals + +import qualified Algebra.RealField as RealField + +import PreludeBase +import NumericPrelude + + +autoR :: (RealField.C a, BinSmp.C v) => a -> (a -> [v]) -> IO () +autoR sampleRate renderer = + auto sampleRate (renderer sampleRate) + +monoR :: (RealField.C a) => a -> (a -> [a]) -> IO () +monoR sampleRate renderer = + mono sampleRate (renderer sampleRate) + +stereoR :: (RealField.C a) => a -> (a -> [(a,a)]) -> IO () +stereoR sampleRate renderer = + stereo sampleRate (renderer sampleRate) + + +auto :: (RealField.C a, BinSmp.C v) => a -> [v] -> IO () +auto sampleRate signal = + raw [] sampleRate (BinSmp.numChannels (head signal)) + (BinSmp.signalToBinary signal) + +mono :: (RealField.C a) => a -> [a] -> IO () +mono sampleRate signal = + raw [] sampleRate 1 (BinSmp.signalToBinaryMono signal) + +stereo :: (RealField.C a) => a -> [(a,a)] -> IO () +stereo sampleRate signal = + raw [] sampleRate 2 (BinSmp.signalToBinaryStereo signal) + +{- | +Disable sigPIPE. +This means that the whole program won't crash when the tool exits. +Unfortunately there doesn't seem to be another way of doing this. + +If we don't call this, GHCi quits, +when the playing command is aborted with CTRL-C. +-} +catchCtrlC :: IO Signals.Handler +catchCtrlC = + Signals.installHandler Signals.sigPIPE + Signals.Ignore Nothing + +{- +raw :: Show a => [String] -> a -> [Int] -> IO () +raw args sampleRate stream = + do catchCtrlC + (input,_,_) <- Shell.launch "play" + (["auto"] ++ Sox.sampleRateOption sampleRate ++ + ["-t","sw","-"] ++ args) + BinSmp.putInt16Stream input stream + IO.hClose input +-} + +{- | +This routine is probably portable +if there were not the CTRL-C problem. +-} +raw :: (RealField.C a) => [String] -> a -> Int -> [Int] -> IO () +raw args sampleRate numChannels stream = + bracket + (Proc.runInteractiveProcess "play" + (Sox.channelOption numChannels ++ + Sox.sampleRateOption sampleRate ++ + ["-t","sw","-"] ++ args) + Nothing Nothing) + (\(input,output,err,proc) -> do + mapM IO.hClose [input, output, err] + -- wait for end of replay + Proc.waitForProcess proc) + (\(input,_,_,_) -> + catchCtrlC >> + BinSmp.putInt16Stream input stream) + +example :: IO () +example = auto (11025::Double) (map sin [0::Double,0.1..]) diff --git a/src/StorableInstance.hs b/src/StorableInstance.hs new file mode 100644 --- /dev/null +++ b/src/StorableInstance.hs @@ -0,0 +1,78 @@ +{- +This should be in the standard library. +-} +module StorableInstance where + +import Foreign.Storable (Storable (..), ) +import Foreign.Ptr (castPtr, ) +import qualified Number.Complex as Complex +import qualified Number.Ratio as Ratio +import qualified Algebra.PrincipalIdealDomain as PID + + +roundUp :: Int -> Int -> Int +roundUp m x = x + mod (-x) m + +-- is handling of alignment correct? +instance (Storable a, Storable b) => Storable (a,b) where + sizeOf ~(a,b) = + roundUp (alignment b) (sizeOf a) + sizeOf b + alignment ~(a,b) = gcd (alignment a) (alignment b) +{- doesn't work - no monomorphism + peek ptr = + do a <- peekByteOff ptr 0 + let bu = undefined + b <- peekByteOff ptr (roundUp (alignment bu) (sizeOf a)) + return (a, asTypeOf b bu) +-} + peek ptr = + do a <- peekByteOff ptr 0 + let peekSecond :: Storable b => b -> IO b + peekSecond bu = + peekByteOff ptr (roundUp (alignment bu) (sizeOf a)) + b <- peekSecond undefined + return (a, b) + poke ptr (a,b) = + pokeByteOff ptr 0 a >> + pokeByteOff ptr (roundUp (alignment b) (sizeOf a)) b + + +instance (Storable a, Storable b, Storable c) => Storable (a,b,c) where + sizeOf = sizeOf . tripleToPair + alignment = alignment . tripleToPair + peek ptr = fmap (\ ~(~(a,b),c) -> (a,b,c)) (peek (castPtr ptr)) + poke ptr = poke (castPtr ptr) . tripleToPair + +tripleToPair :: (a,b,c) -> ((a,b),c) +tripleToPair ~(a,b,c) = ((a,b),c) + +instance (Storable a) => Storable (Complex.T a) where + sizeOf = sizeOf . complexToPair + alignment = alignment . complexToPair + peek ptr = fmap (uncurry (Complex.+:)) (peek (castPtr ptr)) + poke ptr = poke (castPtr ptr) . complexToPair + +complexToPair :: Complex.T a -> (a,a) +complexToPair a = (Complex.real a, Complex.imag a) + +instance (Storable a, PID.C a) => Storable (Ratio.T a) where + sizeOf = sizeOf . ratioToPair + alignment = alignment . ratioToPair + peek ptr = fmap (uncurry (Ratio.%)) (peek (castPtr ptr)) + poke ptr = poke (castPtr ptr) . ratioToPair + +ratioToPair :: Ratio.T a -> (a,a) +ratioToPair x = (Ratio.numerator x, Ratio.denominator x) + + +{- +{- Why is this allowed? -} +test :: Char +test = const 'a' undefined + +{- Why is type defaulting applied here? The type of 'c' should be fixed. -} +test1 :: (Integral a, RealField.C a) => a +test1 = + let c = undefined + in asTypeOf (round c) c +-} diff --git a/src/Synthesizer/Amplitude/Control.hs b/src/Synthesizer/Amplitude/Control.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Amplitude/Control.hs @@ -0,0 +1,88 @@ +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + + +Control curves which can be used +as envelopes, for controlling filter parameters and so on. +-} +module Synthesizer.Amplitude.Control + ({- * Primitives -} + constant, constantVector, + {- * Preparation -} + mapLinear, mapExponential, + ) where + +import qualified Synthesizer.Plain.Control as Ctrl + +import qualified Synthesizer.Amplitude.Signal as SigV +import Synthesizer.Amplitude.Signal (toAmplitudeScalar) + +import qualified Algebra.OccasionallyScalar as OccScalar +import qualified Algebra.Module as Module +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Field as Field +import qualified Algebra.Real as Real +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import NumericPrelude +import PreludeBase as P +import Prelude () + + +constant :: (Field.C y', Real.C y', OccScalar.C y y') => + y' {-^ value -} + -> SigV.T y y' y +constant y = + constantVector (abs y) (OccScalar.toScalar (signum y)) + +{- | +The amplitude must be positive! +This is not checked. +-} +constantVector :: -- (Field.C y', Real.C y', OccScalar.C y y') => + y' {-^ amplitude -} + -> yv {-^ value -} + -> SigV.T y y' yv +constantVector y yv = + SigV.Cons y (Ctrl.constant yv) + + +{- | +Map a control curve without amplitude unit +by a linear (affine) function with a unit. +-} +mapLinear :: (Ring.C y, Field.C y', Real.C y', OccScalar.C y y') => + y' {- ^ range: one is mapped to @center+range@ -} + -> y' {- ^ center: zero is mapped to @center@ -} + -> SigV.T y y' y + -> SigV.T y y' y +mapLinear range center (SigV.Cons amp ss) = + let absRange = abs range * amp + absCenter = abs center + rng = toAmplitudeScalar z absRange + cnt = toAmplitudeScalar z absCenter + z = SigV.Cons + (absRange + absCenter) + (map (\y -> cnt + rng*y) ss) + in z +-- SynI.mapScalar 1 (absRange + absCenter) (\y -> cnt + rng*y) x + +{- | +Map a control curve without amplitude unit +exponentially to one with a unit. +-} +mapExponential :: (Field.C y', Trans.C y, Module.C y y') => + y {- ^ range: one is mapped to @center*range@, must be positive -} + -> y' {- ^ center: zero is mapped to @center@ -} + -> SigV.T y y y + -> SigV.T y y' y +mapExponential range center (SigV.Cons amp ss) = + let b = range**amp + in SigV.Cons (b*>center) (map (\x -> b**(x-one)) ss) +-- SynI.mapScalar 1 center (range**) diff --git a/src/Synthesizer/Amplitude/Cut.hs b/src/Synthesizer/Amplitude/Cut.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Amplitude/Cut.hs @@ -0,0 +1,156 @@ +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes +-} +module Synthesizer.Amplitude.Cut ( + {- * dissection -} + unzip, + unzip3, + + {- * glueing -} + concat, concatVolume, + append, appendVolume, + zip, zipVolume, + zip3, zip3Volume, + ) where + +import qualified Synthesizer.Amplitude.Signal as SigV +import Synthesizer.Amplitude.Signal (toAmplitudeScalar) + +-- import qualified Algebra.NormedSpace.Maximum as NormedMax +import qualified Algebra.OccasionallyScalar as OccScalar +import qualified Algebra.Module as Module +import qualified Algebra.Field as Field +-- import qualified Algebra.Ring as Ring + +import qualified Data.List as List + +import PreludeBase (Ord, max, map) +-- import NumericPrelude +import Prelude () + + +{- * dissection -} + +unzip :: + SigV.T y y' (yv0, yv1) -> + (SigV.T y y' yv0, SigV.T y y' yv1) +unzip x = + let (ss0,ss1) = List.unzip (SigV.samples x) + in (SigV.replaceSamples ss0 x, SigV.replaceSamples ss1 x) + +unzip3 :: + SigV.T y y' (yv0, yv1, yv2) -> + (SigV.T y y' yv0, SigV.T y y' yv1, SigV.T y y' yv2) +unzip3 x = + let (ss0,ss1,ss2) = List.unzip3 (SigV.samples x) + in (SigV.replaceSamples ss0 x, SigV.replaceSamples ss1 x, SigV.replaceSamples ss2 x) + + + +{- * glueing -} + +{- | +Similar to @foldr1 append@ but more efficient and accurate, +because it reduces the number of amplifications. +Does not work for infinite lists, +because no maximum amplitude can be computed. +-} +concat :: + (Ord y', Field.C y', OccScalar.C y y', + Module.C y yv) => + [SigV.T y y' yv] -> SigV.T y y' yv +concat xs = + concatVolume (List.maximum (map SigV.amplitude xs)) xs + +{- | +Give the output volume explicitly. +Does also work for infinite lists. +-} +concatVolume :: + (Field.C y', OccScalar.C y y', + Module.C y yv) => + y' -> [SigV.T y y' yv] -> SigV.T y y' yv +concatVolume amp xs = + let smps = map (SigV.vectorSamples (toAmplitudeScalar z)) xs + z = SigV.Cons amp (List.concat smps) + in z + + +merge :: + (Ord y', Field.C y', OccScalar.C y y', + Module.C y yv0, Module.C y yv1) => + ([yv0] -> [yv1] -> [yv2]) -> + SigV.T y y' yv0 -> SigV.T y y' yv1 -> SigV.T y y' yv2 +merge f x0 x1 = + mergeVolume f (max (SigV.amplitude x0) (SigV.amplitude x1)) x0 x1 + +mergeVolume :: + (Field.C y', OccScalar.C y y', + Module.C y yv0, Module.C y yv1) => + ([yv0] -> [yv1] -> [yv2]) -> + y' -> + SigV.T y y' yv0 -> SigV.T y y' yv1 -> SigV.T y y' yv2 +mergeVolume f amp x y = + let sampX = SigV.vectorSamples (toAmplitudeScalar z) x + sampY = SigV.vectorSamples (toAmplitudeScalar z) y + z = SigV.Cons amp (f sampX sampY) + in z + + +append :: + (Ord y', Field.C y', OccScalar.C y y', + Module.C y yv) => + SigV.T y y' yv -> SigV.T y y' yv -> SigV.T y y' yv +append = merge (List.++) + +appendVolume :: + (Field.C y', OccScalar.C y y', + Module.C y yv) => + y' -> + SigV.T y y' yv -> SigV.T y y' yv -> SigV.T y y' yv +appendVolume = mergeVolume (List.++) + + +zip :: + (Ord y', Field.C y', OccScalar.C y y', + Module.C y yv0, Module.C y yv1) => + SigV.T y y' yv0 -> SigV.T y y' yv1 -> SigV.T y y' (yv0,yv1) +zip = merge List.zip + +zipVolume :: + (Field.C y', OccScalar.C y y', + Module.C y yv0, Module.C y yv1) => + y' -> + SigV.T y y' yv0 -> SigV.T y y' yv1 -> SigV.T y y' (yv0,yv1) +zipVolume = mergeVolume List.zip + + + +zip3 :: + (Ord y', Field.C y', OccScalar.C y y', + Module.C y yv0, Module.C y yv1, Module.C y yv2) => + SigV.T y y' yv0 -> SigV.T y y' yv1 -> SigV.T y y' yv2 -> + SigV.T y y' (yv0,yv1,yv2) +zip3 x0 x1 x2 = + zip3Volume + (SigV.amplitude x0 `max` SigV.amplitude x1 `max` SigV.amplitude x2) + x0 x1 x2 + +zip3Volume :: + (Field.C y', OccScalar.C y y', + Module.C y yv0, Module.C y yv1, Module.C y yv2) => + y' -> + SigV.T y y' yv0 -> SigV.T y y' yv1 -> SigV.T y y' yv2 -> + SigV.T y y' (yv0,yv1,yv2) +zip3Volume amp x0 x1 x2 = + let sampX0 = SigV.vectorSamples (toAmplitudeScalar z) x0 + sampX1 = SigV.vectorSamples (toAmplitudeScalar z) x1 + sampX2 = SigV.vectorSamples (toAmplitudeScalar z) x2 + z = SigV.Cons amp (List.zip3 sampX0 sampX1 sampX2) + in z + diff --git a/src/Synthesizer/Amplitude/Displacement.hs b/src/Synthesizer/Amplitude/Displacement.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Amplitude/Displacement.hs @@ -0,0 +1,88 @@ +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes +-} +module Synthesizer.Amplitude.Displacement ( + mix, mixVolume, + mixMulti, mixMultiVolume, + raise, + ) where + +import qualified Synthesizer.Amplitude.Signal as SigV + +import Synthesizer.Amplitude.Signal (toAmplitudeScalar) + +import qualified Synthesizer.Plain.Displacement as Synthesizer + +import qualified Algebra.OccasionallyScalar as OccScalar +import qualified Algebra.Module as Module +-- import qualified Algebra.Transcendental as Trans +import qualified Algebra.Field as Field +import qualified Algebra.Real as Real +-- import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Algebra.Module ((*>)) + +import PreludeBase +import NumericPrelude +import Prelude () + + +{- * Mixing -} + +{-| Mix two signals. + In opposition to 'zipWith' the result has the length of the longer signal. -} +mix :: + (Real.C y', Field.C y', Module.C y yv, OccScalar.C y y') => + SigV.T y y' yv + -> SigV.T y y' yv + -> SigV.T y y' yv +mix x y = + mixVolume (abs (SigV.amplitude x) + abs (SigV.amplitude y)) x y + +mixVolume :: + (Real.C y', Field.C y', Module.C y yv, OccScalar.C y y') => + y' + -> SigV.T y y' yv + -> SigV.T y y' yv + -> SigV.T y y' yv +mixVolume v x y = + let z = SigV.Cons v + (toAmplitudeScalar z (SigV.amplitude x) *> SigV.samples x + + toAmplitudeScalar z (SigV.amplitude y) *> SigV.samples y) + in z + +{-| Mix one or more signals. -} +mixMulti :: + (Real.C y', Field.C y', Module.C y yv, OccScalar.C y y') => + [SigV.T y y' yv] + -> SigV.T y y' yv +mixMulti x = + mixMultiVolume (sum (map (abs . SigV.amplitude) x)) x + +mixMultiVolume :: + (Real.C y', Field.C y', Module.C y yv, OccScalar.C y y') => + y' + -> [SigV.T y y' yv] + -> SigV.T y y' yv +mixMultiVolume v x = + let z = SigV.Cons v + (foldr (\y -> (toAmplitudeScalar z (SigV.amplitude y) *> + SigV.samples y +)) [] x) + in z + +{-| Add a number to all of the signal values. + This is useful for adjusting the center of a modulation. -} +raise :: (Field.C y', Module.C y yv, OccScalar.C y y') => + y' + -> yv + -> SigV.T y y' yv + -> SigV.T y y' yv +raise y' yv x = + SigV.Cons (SigV.amplitude x) + (Synthesizer.raise (toAmplitudeScalar x y' *> yv) (SigV.samples x)) diff --git a/src/Synthesizer/Amplitude/Filter.hs b/src/Synthesizer/Amplitude/Filter.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Amplitude/Filter.hs @@ -0,0 +1,58 @@ +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes +-} +module Synthesizer.Amplitude.Filter ( + {- * Non-recursive -} + + {- ** Amplification -} + amplify, + negate, + envelope, + +) where + + +import qualified Synthesizer.Amplitude.Signal as SigV + +import qualified Synthesizer.Plain.Filter.NonRecursive as FiltNR + +-- import qualified Algebra.OccasionallyScalar as OccScalar +-- import qualified Algebra.Transcendental as Trans +-- import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive +import qualified Algebra.Module as Module + +import NumericPrelude hiding (negate) +-- import PreludeBase as P +import Prelude () + + +{- | The amplification factor must be positive. -} +amplify :: (Ring.C y') => + y' + -> SigV.T y y' yv + -> SigV.T y y' yv +amplify volume x = + SigV.Cons (volume * SigV.amplitude x) (SigV.samples x) + +negate :: (Additive.C yv) => + SigV.T y y' yv + -> SigV.T y y' yv +negate x = + SigV.Cons (SigV.amplitude x) (Additive.negate (SigV.samples x)) + + +envelope :: (Module.C y0 yv, Ring.C y') => + SigV.T y y' y0 {- ^ the envelope -} + -> SigV.T y y' yv {- ^ the signal to be enveloped -} + -> SigV.T y y' yv +envelope y x = + SigV.Cons + (SigV.amplitude y * SigV.amplitude x) + (FiltNR.envelopeVector (SigV.samples y) (SigV.samples x)) diff --git a/src/Synthesizer/Amplitude/Signal.hs b/src/Synthesizer/Amplitude/Signal.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Amplitude/Signal.hs @@ -0,0 +1,61 @@ +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes (OccasionallyScalar) + +Signals equipped with a volume information that may carry a unit. +-} +module Synthesizer.Amplitude.Signal where + +import qualified Algebra.OccasionallyScalar as OccScalar +import qualified Algebra.Module as Module +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring + +import Algebra.OccasionallyScalar (toScalar) + +import NumericPrelude +import PreludeBase as P +import Prelude () + + +data T y y' yv = + Cons { + amplitude :: y' {-^ scaling of the values -} + , samples :: [yv] {-^ the sampled values -} + } + deriving (Eq, Show) + + +instance Functor (T y y') where + fmap f (Cons amp ss) = Cons amp (map f ss) + + +toAmplitudeScalar :: (Field.C y', OccScalar.C y y') => + T y y' yv -> y' -> y +toAmplitudeScalar sig y = + toScalar (y / amplitude sig) + + +scalarSamples :: (Ring.C y) => + (y' -> y) -> T y y' y -> [y] +scalarSamples toAmpScalar sig = + let y = toAmpScalar (amplitude sig) + in map (y*) (samples sig) + +vectorSamples :: (Module.C y yv) => + (y' -> y) -> T y y' yv -> [yv] +vectorSamples toAmpScalar sig = + let y = toAmpScalar (amplitude sig) + in y *> samples sig + + + +replaceAmplitude :: y1' -> T y y0' yv -> T y y1' yv +replaceAmplitude amp (Cons _ ss) = Cons amp ss + +replaceSamples :: [yv1] -> T y y' yv0 -> T y y' yv1 +replaceSamples ss (Cons amp _) = Cons amp ss 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,88 @@ +module Synthesizer.ApplicativeUtility where + +import Control.Applicative (Applicative, pure, (<*>), (<$>), liftA2, ) +import Data.Traversable (Traversable, sequenceA, ) + +import Control.Monad.Fix (fix, ) + + +liftA4 :: Applicative f => + (a -> b -> c -> d -> e) -> f a -> f b -> f c -> f d -> f e +liftA4 f a b c d = f <$> a <*> b <*> c <*> d + + +{- | +Create a loop (feedback) from one node to another one. +That is, compute the fix point of a process iteration. +-} +loop :: (Functor f) => + f (a -> a) {-^ process chain that shall be looped -} + -> f a +loop = fmap fix + + +infixl 0 $:, $::, $^, $# +infixr 9 .:, .^ + +{- | +This corresponds to 'Control.Applicative.<*>' +-} +($:) :: (Applicative f) => f (a -> b) -> f a -> f b +($:) = (<*>) + +{- | +Instead of @mixMulti $:: map f xs@ +the caller should write @mixMulti $: mapM f xs@ +in order to save the user from learning another infix operator. +-} +($::) :: (Applicative f, Traversable t) => + f (t a -> b) -> t (f a) -> f b +($::) f arg = f $: sequenceA arg +-- ($::) f arg sr = f sr (map ($sr) arg) + +(.:) :: (Applicative f) => f (b -> c) -> f (a -> b) -> f (a -> c) +(.:) = liftA2 (.) +-- (.:) f g sr x = f sr (g sr x) +-- (.:) f g sr x = ($:) f (flip g x) sr + +($^) :: (Functor f) => (a -> b) -> f a -> f b +($^) = fmap +-- ($^) = (.) +-- ($^) f x = pure f $: x + +(.^) :: (Functor f) => (b -> c) -> f (a -> b) -> f (a -> c) +(.^) f = fmap (f.) +-- (.^) f = (.:) (pure f) + +($#) :: (Applicative f) => f (a -> b) -> a -> f b +($#) f x = f $: pure x +-- ($#) = flip + + +{- | +Our signal processors have types like @f (a -> b -> c)@. +They could also have the type @a -> b -> f c@ +or @f a -> f b -> f c@. +We did not choose the last variant for reduction of redundancy in type signatures, +and we did not choose the second variant for easy composition of processors. +However the forms are freely convertible, +and if you prefer the last one because you do not want to sprinkle '($:)' in your code, +then you may want to convert the processors using the following functions, +that can be defined purely in the 'Control.Applicative.Applicative' class. +-} + +liftP :: (Applicative f) => + f (a -> b) -> f a -> f b +liftP = ($:) + +liftP2 :: (Applicative f) => + f (a -> b -> c) -> f a -> f b -> f c +liftP2 f a b = f $: a $: b + +liftP3 :: (Applicative f) => + f (a -> b -> c -> d) -> f a -> f b -> f c -> f d +liftP3 f a b c = f $: a $: b $: c + +liftP4 :: (Applicative f) => + f (a -> b -> c -> d -> e) -> f a -> f b -> f c -> f d -> f e +liftP4 f a b c d = f $: a $: b $: c $: d 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 @@ +{-# OPTIONS -fno-implicit-prelude #-} +module Synthesizer.Basic.Distortion ( + clip, logit, + zigZag, sine, + quantize, + ) where + +import qualified Algebra.Transcendental as Trans +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Real as Real +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import qualified Synthesizer.Utility as Util + +-- import qualified Prelude as P +-- import PreludeBase +import NumericPrelude + + +{- * Clipping -} + +{- | +limit, fuzz booster +-} +clip :: (Real.C a) => a -> a +clip = Util.clip (negate one) one + +{- | +logit, tanh +-} +logit :: (Trans.C a) => a -> a +logit = tanh + +{- +probit, error function +-} + + + +{- * Wrapping -} + +{- | +zig-zag +-} +zigZag :: (RealField.C a) => a -> a +zigZag x = + let (n,y) = splitFraction ((x+1)/2) + in if even (n::Int) + then 2*y - 1 + else 1 - 2*y + +{- | +sine +-} +sine :: (Trans.C a) => a -> a +sine = sin + + + + +{- * Quantization -} + +quantize :: (RealField.C a) => a -> a +quantize x = fromIntegral (round x :: Int) 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 @@ +{-# OPTIONS -fno-implicit-prelude #-} +module Synthesizer.Basic.DistortionControlled ( + clip, logit, + zigZag, sine, + quantize, + ) where + +import qualified Synthesizer.Basic.Distortion as Dist + +import qualified Algebra.Transcendental as Trans +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Real as Real +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import qualified Synthesizer.Utility as Util + +-- import qualified Prelude as P +-- import PreludeBase +import NumericPrelude + +{- * Clipping -} + +{- | +limit, fuzz booster +-} +clip :: (Real.C a) => a -> a -> a +clip c = Util.clip (negate c) c + +{- | +logit, tanh +-} +logit :: (Trans.C a) => a -> a -> a +logit k = rescale k Dist.logit + +{- +probit, error function +-} + + + +{- * Wrapping -} + +{- | +zig-zag +-} +zigZag :: (RealField.C a) => a -> a -> a +zigZag k = rescale k Dist.zigZag + +{- | +sine +-} +sine :: (Trans.C a) => a -> a -> a +sine k = rescale k Dist.sine + + + + +{- * Quantization -} + +quantize :: (RealField.C a) => a -> a -> a +quantize k = rescale k Dist.quantize + + + +{- Auxilary function -} + +rescale :: (Field.C a) => a -> (a -> a) -> a -> a +rescale k f x = k * f (x/k) + +{- +*Synthesizer.Basic.Distortion> GNUPlot.plotFuncs [] (GNUPlot.linearScale 1000 (-3,3::Double)) (map logit [0,0.1..1]) +-} 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,82 @@ +module Synthesizer.Basic.Phase + (T, + fromRepresentative, + toRepresentative, + increment, + multiply, + ) where + +import qualified Algebra.RealField as RealField +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import qualified Algebra.ToInteger as ToInteger + +import System.Random (Random(..)) +import Test.QuickCheck (Arbitrary(..), choose) + +import qualified Synthesizer.Generic.SampledValue as Sample +import Foreign.Storable (Storable(..), ) +import Foreign.Ptr (castPtr, ) + +import Synthesizer.Utility (mapFst) +import qualified NumericPrelude as NP + + +newtype T a = Cons {decons :: a} + + +instance Show a => Show (T a) where + showsPrec p x = + showParen (p >= 10) + (showString "Phase.fromRepresentative " . showsPrec 11 (toRepresentative x)) + +instance Storable a => Storable (T a) where + {-# INLINE sizeOf #-} + sizeOf = sizeOf . toRepresentative + {-# INLINE alignment #-} + alignment = alignment . toRepresentative + {-# INLINE peek #-} + peek ptr = fmap Cons $ peek (castPtr ptr) + {-# INLINE poke #-} + poke ptr = poke (castPtr ptr) . toRepresentative + +instance Sample.C a => Sample.C (T a) -- where + + +instance (Ring.C a, Random a) => Random (T a) where + randomR = error "Phase.randomR makes no sense" + random = mapFst Cons . randomR (NP.zero, NP.one) + +instance (Ring.C a, Random a) => Arbitrary (T a) where + arbitrary = fmap Cons $ choose (NP.zero, NP.one) + coarbitrary = error "Phase.coarbitrary not implemented" + + + +{-# INLINE fromRepresentative #-} +fromRepresentative :: RealField.C a => a -> T a +fromRepresentative = Cons . RealField.fraction + +{-# INLINE toRepresentative #-} +toRepresentative :: T a -> a +toRepresentative = decons + +{-# INLINE increment #-} +increment :: RealField.C a => a -> T a -> T a +increment d x = fromRepresentative (toRepresentative x Additive.+ d) + +{-# INLINE multiply #-} +multiply :: (RealField.C a, ToInteger.C b) => b -> T a -> T a +multiply n x = fromRepresentative (toRepresentative x Ring.* NP.fromIntegral n) + + +instance RealField.C a => Additive.C (T a) where + {-# INLINE zero #-} + {-# INLINE (+) #-} + {-# INLINE (-) #-} + {-# INLINE negate #-} + zero = Cons Additive.zero + x + y = fromRepresentative (toRepresentative x Additive.+ toRepresentative y) + x - y = fromRepresentative (toRepresentative x Additive.- toRepresentative y) + negate = fromRepresentative . Additive.negate . toRepresentative 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,825 @@ +{-# OPTIONS -O2 -fno-implicit-prelude -fglasgow-exts #-} +{- | +Copyright : (c) Henning Thielemann 2006 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +Basic waveforms + +If you want to use parametrized waves with two parameters +then zip your parameter signals and apply 'uncurry' to the wave function. +-} +module Synthesizer.Basic.Wave where + +import qualified Synthesizer.Plain.ToneModulation as ToneMod +import qualified Synthesizer.Plain.Interpolation as Interpolation +import Data.Array ((!), listArray) + +import qualified Synthesizer.Basic.Phase as Phase + +import qualified Algebra.RealTranscendental as RealTrans +import qualified Algebra.Transcendental as Trans +import qualified Algebra.RealField as RealField +import qualified Algebra.Algebraic as Algebraic +import qualified Algebra.Module as Module +import qualified Algebra.Field as Field +import qualified Algebra.Real as Real +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import qualified MathObj.Polynomial as Poly +import qualified Number.Complex as Complex + +import Synthesizer.Utility (swap) + +import NumericPrelude.Condition (select, ) +import NumericPrelude + +-- import qualified Prelude as P +import PreludeBase + + +{- * Definition and construction -} + +newtype T t y = Cons {decons :: Phase.T t -> y} + + +{-# INLINE fromFunction #-} +fromFunction :: (t -> y) -> (T t y) +fromFunction wave = Cons (wave . Phase.toRepresentative) + + +{- * Operations on waves -} + +{-# INLINE raise #-} +raise :: (Additive.C y) => y -> T t y -> T t y +raise y = distort (y+) + +{-# INLINE amplify #-} +amplify :: (Ring.C y) => y -> T t y -> T t y +amplify k = distort (k*) + +{-# INLINE distort #-} +distort :: (y -> z) -> T t y -> T t z +distort g (Cons f) = Cons (g . f) + +{-# INLINE apply #-} +apply :: T t y -> (Phase.T t -> y) +apply = decons + + + +instance Additive.C y => Additive.C (T t y) where + {-# INLINE zero #-} + {-# INLINE (+) #-} + {-# INLINE (-) #-} + {-# INLINE negate #-} + zero = Cons (const zero) + (+) (Cons f) (Cons g) = Cons (\t -> f t + g t) + (-) (Cons f) (Cons g) = Cons (\t -> f t - g t) + negate = distort negate + + +instance Module.C a y => Module.C a (T t y) where + {-# INLINE (*>) #-} + s *> w = distort (s*>) w + + +{- | +Turn an unparametrized waveform into a parametrized one, +where the parameter is a phase offset. +This way you express a phase modulated oscillator +using a shape modulated oscillator. +-} +{-# SPECULATE phaseOffset :: (T Double b) -> (Double -> T Double b) #-} +{-# INLINE phaseOffset #-} +phaseOffset :: (RealField.C a) => T a b -> (a -> T a b) +phaseOffset (Cons wave) offset = + Cons (wave . Phase.increment offset) + + + + +{- * Examples -} + +{- ** unparameterized -} + +{- | map a phase to value of a sine wave -} +{-# SPECULATE sine :: Double -> Double #-} +{-# INLINE sine #-} +sine :: Trans.C a => T a a +sine = fromFunction $ \x -> sin (2*pi*x) + +{-# INLINE cosine #-} +cosine :: Trans.C a => T a a +cosine = fromFunction $ \x -> cos (2*pi*x) + +{-# INLINE helix #-} +helix :: Trans.C a => T a (Complex.T a) +helix = fromFunction $ \x -> Complex.cis (2*pi*x) + +{- | +Approximation of sine by parabolas. +Surprisingly not really faster than 'sine'. +-} +{-# INLINE fastSine2 #-} +fastSine2 :: (Ord a, Ring.C a) => T a a +fastSine2 = fromFunction $ \x -> + if 2*x<1 + then 1 - sqr (4*x-1) + else sqr (4*x-3) - 1 + +{- | +Approximation of sine by fourth order polynomials. +-} +{-# INLINE fastSine4 #-} +fastSine4 :: (Ord a, Trans.C a) => T a a +fastSine4 = fromFunction $ \x -> + -- minimal least squares fit + let pi2 = pi*pi + pi3 = pi2*pi + c = 3*((10080/pi2 - 1050) / pi3 + 1) -- 0.2248391014 + {-# INLINE bow #-} + bow y = let y2 = y*y in 1-y2*(1+c*(1-y2)) + in if 2*x<1 + then bow (4*x-1) + else - bow (4*x-3) +{- +add a residue to fastSine2 and choose 'c' which minimizes the squared error + in if 2*x<1 + then let y = (4*x-1)^2 in 1-y-c*y*(1-y) + else let y = (4*x-3)^2 in y-1+c*y*(1-y) +-} + +{- +GNUPlot.plotFuncs [] (GNUPlot.linearScale 1000 (0,1::Double)) [sine, fastSine2, fastSine4] +-} + + +{- | saw tooth, +it's a ramp down in order to have a positive coefficient for the first partial sine +-} +{-# SPECULATE saw :: Double -> Double #-} +{-# INLINE saw #-} +saw :: Ring.C a => T a a +saw = fromFunction $ \x -> 1-2*x + +{- | +This wave has the same absolute Fourier coefficients as 'saw' +but the partial waves are shifted by 90 degree. +That is, it is the Hilbert transform of the saw wave. +The formula is derived from 'sawComplex'. +-} +{-# INLINE sawCos #-} +sawCos :: (Real.C a, Trans.C a) => T a a +sawCos = fromFunction $ \x -> log (2 * sin (pi*x)) * (-2/pi) + +{- | +@sawCos + i*saw@ + +This is an analytic function and thus it may be used for frequency shifting. + +The formula can be derived from the power series of the logarithm function. +-} +{-# INLINE sawComplex #-} +sawComplex :: + (Complex.Power a, RealTrans.C a) => + T a (Complex.T a) +sawComplex = fromFunction $ \x -> log (1 + Complex.cis (-pi*(1-2*x))) * (-2/pi) +{- +GNUPlot.plotFuncs [] (GNUPlot.linearScale 100 (0,1::Double)) [Complex.real . sawComplex, sawCos] + +GNUPlot.plotFuncs [] (GNUPlot.linearScale 100 (0,1::Double)) [sawCos, composedHarmonics (take 20 $ harmonic 0 0 : map (\n -> harmonic 0.25 ((2/pi) / fromInteger n)) [1..])] +-} + +{- +Matching implementation that do not match 'saw' exactly. + +sawCos :: (Real.C a, Trans.C a) => T a a +sawCos = fromFunction $ \x -> log (2 * abs (cos (pi*x))) + +sawComplex :: + (Complex.Power a, Trans.C a) => + T a (Complex.T a) +sawComplex = fromFunction $ \x -> log (1 + Complex.cis (2*pi*x)) +-} + + +{- | square -} +{-# SPECULATE square :: Double -> Double #-} +{-# INLINE square #-} +square :: (Ord a, Ring.C a) => T a a +square = fromFunction $ \x -> if 2*x<1 then 1 else -1 + +{- | +This wave has the same absolute Fourier coefficients as 'square' +but the partial waves are shifted by 90 degree. +That is, it is the Hilbert transform of the saw wave. +-} +{-# INLINE squareCos #-} +squareCos :: (RealField.C a, Trans.C a) => T a a +squareCos = fromFunction $ \x -> + log (abs (tan (pi*x))) * (-2/pi) + -- sawCos x - sawCos (fraction (0.5-x)) + +{- | +@squareCos + i*square@ + +This is an analytic function and thus it may be used for frequency shifting. + +The formula can be derived from the power series of the area tangens function. +-} +{-# INLINE squareComplex #-} +squareComplex :: + (Complex.Power a, RealTrans.C a) => + T a (Complex.T a) +squareComplex = fromFunction $ \x -> +{- these formulas are equivalent but wrong + + log (0 +: 2 * sine x) * (2/pi) + + log ((1 - Complex.cis (-2*pi*x)) * + (1 + Complex.cis ( 2*pi*x))) * (2/pi) + + sawComplex x + sawComplex (0.5-x) +-} + +{- +The Fourier series is equal to the power series of 'atanh'. +-} + atanh (Complex.cis (2*pi*x)) * (4/pi) +{- +GNUPlot.plotFuncs [] (GNUPlot.linearScale 100 (0,1::Double)) [squareCos, composedHarmonics (take 20 $ zipWith (\b n -> harmonic 0.25 (if b then (4/pi) / fromInteger n else 0)) (cycle [False,True]) [0..])] +-} + + +{- | triangle -} +{-# SPECULATE triangle :: Double -> Double #-} +{-# INLINE triangle #-} +triangle :: (Ord a, Ring.C a) => T a a +triangle = fromFunction $ \x -> + let x4 = 4*x + in select (2-x4) + [(x4<1, x4), + (x4>3, x4-4)] + +{- + +int(arctan(x)/x,x); + +- polylog(2, x*I)*1/2*I + polylog(2, x*(-I))*1/2*I + + +series(int(arctan(x)/x,x),x,10); + +x - 1/9*x^3 + 1/25*x^5 - 1/49*x^7 + 1/81*x^9 + O(x^11) + + + +int(arctan(I*x)/(I*x),x); +int(arctanh(x)/(x),x); + +1/2*polylog(2, x) - 1/2*polylog(2, -x) +int(1/x*arctanh(x), x) + +polylog(2,x) = dilog(1-x); -- dilog is implemented in GSL for complex arguments +polylog(2,x) = hypergeom([1,1,1],[2,2],x) * x; + + +series(int(arctan(I*x)/(I*x),x),x,10); + +x + 1/9*x^3 + 1/25*x^5 + 1/49*x^7 + 1/81*x^9 + O(x^11) +-} + +sample :: (RealField.C a) => + Interpolation.T a v -> [v] -> T a v +sample ip wave = + let len = length wave + arr = listArray (0, pred len) wave + in fromFunction $ \ phase -> + let (n,q) = splitFraction (phase * fromIntegral len) + xs = map (arr!) (map (flip mod len) + (enumFrom (n - Interpolation.offset ip))) +-- map (arr!) (enumFromTo (n - Interpolation.offset ip)) ++ cycle wave + in Interpolation.func ip q xs + + +{- ** discretely parameterized -} + +{- | +A truncated cosine. This has rich overtones. +-} +truncOddCosine :: Trans.C a => + Int -> T a a +truncOddCosine k = + let f = pi * fromIntegral (2*k+1) + in fromFunction $ \ x -> cos (f*x) + +{- | +For parameter zero this is 'saw'. +-} +truncOddTriangle :: (RealField.C a) => + Int -> T a a +truncOddTriangle k = + let s = fromIntegral (2*k+1) + in fromFunction $ \ x -> + let (n,frac) = splitFraction (s*x) + in if even (n::Int) + then 1-2*frac + else 2*frac-1 + + +{- ** continuously parameterized -} + +{- | +A truncated cosine plus a ramp that guarantees a bump of high 2 at the boundaries. + +It is @truncCosine (2 * fromIntegral n + 0.5) == truncOddCosine (2*n)@ +-} +truncCosine :: Trans.C a => + a -> T a a +truncCosine k = + let f = 2 * pi * k + s = 2 * (sin (f*0.5) - 1) + in fromFunction $ \ x0 -> + let x = x0-0.5 + in - sin (f*x) + s*x +{- +GNUPlot.plotFuncs [] (GNUPlot.linearScale 1000 (0,1::Double)) (map truncCosine [0.5,0.7..2.5]) +-} + +truncTriangle :: (RealField.C a) => + a -> T a a +truncTriangle k = + let tr x = + let (n,frac) = splitFraction (2*k*x+0.5) + in if even (n::Int) + then 1-2*frac + else 2*frac-1 + s = 2 * (1 + tr 0.5) + in fromFunction $ \ x0 -> + let x = x0-0.5 + in tr x - s*x +{- +GNUPlot.plotFuncs [] (GNUPlot.linearScale 1000 (0,1::Double)) (map truncTriangle [0,0.25..2.5]) +-} + + +{- | +Power function. +-} + + +{- | +Roughly the map @\x p -> x**p@ +but retains the sign of @x@ and +normalizes the mapping over @[-1,1]@ to L2 norm of 1. +-} +{-# INLINE powerNormed #-} +powerNormed :: (Real.C a, Trans.C a) => a -> T a a +powerNormed p = fromFunction $ \x -> power01Normed p (2*x-1) + +-- | auxiliary +{-# INLINE power01Normed #-} +power01Normed :: (Real.C a, Trans.C a) => a -> a -> a +power01Normed p x = (p+0.5) * powerSigned p x + +-- | auxiliary +{-# INLINE powerSigned #-} +powerSigned :: (Real.C a, Trans.C a) => a -> a -> a +powerSigned p x = signum x * abs x ** p + + +{- | +Tangens hyperbolicus allows interpolation +between some kind of saw tooth and square wave. +In principle it is not necessary +because you can distort a saw tooth oscillation by @map tanh@. +-} +logitSaw :: (Trans.C a) => a -> T a a +logitSaw c = distort tanh $ amplify c saw + + +{- | +Tangens hyperbolicus of a sine allows interpolation +between some kind of sine and square wave. +In principle it is not necessary +because you can distort a square oscillation by @map tanh@. +-} +logitSine :: (Trans.C a) => a -> T a a +logitSine c = distort tanh $ amplify c sine + + +{- | +Interpolation between 'sine' and 'square'. +-} +{-# INLINE sineSquare #-} +sineSquare :: (Real.C a, Trans.C a) => + a {- ^ 0 for 'sine', 1 for 'square' -} + -> T a a +sineSquare c = + distort (powerSigned (1-c)) sine + + + +{- | +Interpolation between 'fastSine2' and 'saw'. +We just shrink the parabola towards the borders +and insert a linear curve such that its slope matches the one of the parabola. +-} +{-# INLINE piecewiseParabolaSaw #-} +piecewiseParabolaSaw :: (Algebraic.C a, Ord a) => + a {- ^ 0 for 'fastSine2', 1 for 'saw' -} + -> T a a +piecewiseParabolaSaw c = + let xb = (1 - sqrt c) / 2 + y x = 1 - ((4*x - (1-c))/(1-c))^2 + in fromFunction $ \ x -> + select + ((2*x - 1)/(2*xb - 1) * y xb) + [(x < xb, y x), + (x > 1-xb, - y (1-x))] + +{- +equ0 c x = + let y = 1 - ((4*x - (3+c))/(1-c))^2 + secant = y/(x-1/2) + tangent = - 8 * (4*x - (3+c))/(1-c)^2 + in (tangent, secant) + +equ1 c x = + let secant = (1 - ((4*x - (3+c))/(1-c))^2)/(x-1/2) + tangent = - 8 * (4*x - (3+c))/(1-c)^2 + in (tangent, secant) + +equ2 c x = + (1, ((4*x - (3+c))/(1-c))^2 + - 8 * (x-1/2) * (4*x - (3+c))/(1-c)^2) + +equ3 c x = + ((1-c)^2, + (4*x - (3+c) - 4 * (2*x-1)) * (4*x - (3+c))) + +equ4 c x = + (4*x - (1-c)) * (4*x - (3+c)) + (1-c)^2 + +equ5 c x = + (4*x - 2) ^ 2 - (1+c)^2 + (1-c)^2 + +equ6 c x = + (4*x - 2) ^ 2 - 4*c +-} + + +{- | +Interpolation between 'sine' and 'saw'. +We just shrink the sine towards the borders +and insert a linear curve such that its slope matches the one of the sine. +-} +{-# INLINE piecewiseSineSaw #-} +piecewiseSineSaw :: (Trans.C a, Ord a) => + a {- ^ 0 for 'sine', 1 for 'saw' -} + -> T a a +piecewiseSineSaw c = + let {- This simple fix point iteration converges very slow for small 'c', + maybe we should use a Newton iteration. -} + iter z = iterate (\zi -> pi + atan (zi - pi / (1-c))) z !! 10 + xb = (1-c)/(2*pi) * iter 0 + -- iter (xInit * (2*pi) / (1-c)) + -- xb = (1 - sqrt c) / 2 + -- y x = sine (x/(1-c)) + y x = sin (2*pi*x/(1-c)) + in fromFunction $ \ x -> select + ((2*x - 1)/(2*xb - 1) * y xb) + [(x < xb, y x), + (x > 1-xb, - y (1-x))] + +{- +equ0 c x = + let secant = 2 * sin (2*pi*x/(1-c)) / (2*x - 1) + tangent = 2*pi/(1-c) * cos (2*pi*x/(1-c)) + in (tangent, secant) + +iter0 c x = + -- secant / tangent + -- (x - 1/2) = tan (2*pi*x/(1-c)) * (1-c) / (2*pi) + tan (2*pi*x/(1-c)) * (1-c) / (2*pi) + 1/2 + +iter1 c x = + (1-c)/(2*pi) * (pi + atan ((x - 1/2) * (2*pi) / (1-c))) + +iter2 c x = + let iter z = iterate (\zi -> pi + atan (zi - pi / (1-c))) z !! 10 + in (1-c)/(2*pi) * iter (x * (2*pi) / (1-c)) +-} + + +{- | +Interpolation between 'sine' and 'saw' +with smooth intermediate shapes but no perfect saw. +-} +{-# INLINE sineSawSmooth #-} +sineSawSmooth :: (Trans.C a) => + a {- ^ 0 for 'sine', 1 for 'saw' -} + -> T a a +sineSawSmooth c = + distort (\x -> sin (affineComb c (pi * x, asin x * 2))) saw + +{- | +Interpolation between 'sine' and 'saw' +with perfect saw, but sharp intermediate shapes. +-} +{-# INLINE sineSawSharp #-} +sineSawSharp :: (Trans.C a) => + a {- ^ 0 for 'sine', 1 for 'saw' -} + -> T a a +sineSawSharp c = + distort (\x -> sin (affineComb c (pi * x, asin x))) saw + + +affineComb :: Ring.C a => a -> (a,a) -> a +affineComb phase (x0,x1) = (1-phase)*x0 + phase*x1 + + +{- +{- | +Smooth saw generated by a quintic polynomial function. +Unfortunately if 'c' approaches the right border, +the function will overshoot the 'y' range (-1,1). +-} +quinticSaw :: Field.C a => + a {- ^ position of the right minimum -} + -> a + -> a +quinticSaw c x = + let (s,t) = ToneMod.solveSLE2 ((c^2-1, 3*c^2-1), (c^4-1, 5*c^4-1)) (-1/c,0) + r = - s - t + x2 = x^2 + in x * (r + x2 * (s + x2*t)) +{- + r*x + s* x^3 + t* x^5 + 0 = r + s + t + -1 = r*c + s* c^3 + t* c^5 + 0 = r + s*3*c^2 + t*5*c^4 + +-1/c = r + s* c^2 + t* c^4 + +-1/c = s*(c^2-1) + t*(c^4-1) + 0 = s*(3*c^2-1) + t*(5*c^4-1) +-} +-} + + +{- | +saw with space +-} +{-# SPECULATE sawPike :: Double -> Double -> Double #-} +{-# INLINE sawPike #-} +sawPike :: (Ord a, Field.C a) => + a {- ^ pike width ranging from 0 to 1, 1 yields 'saw' -} + -> T a a +sawPike r = fromFunction $ \x -> + if x 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 +-} +{-# SPECULATE trapezoidAsymmetric :: Double -> Double -> Double -> Double #-} +{-# INLINE trapezoidAsymmetric #-} +trapezoidAsymmetric :: (Real.C a, Field.C a) => + a {- ^ sum of the plateau widths ranging from 0 to 1: + 0 yields 'triangleAsymmetric', + 1 yields 'squareAsymmetric' -} + -> a {- ^ asymmetry of the plateau widths ranging from -1 to 1 -} + -> T a a +trapezoidAsymmetric w r = fromFunction $ \x -> + let c0 = 1+w*r + c1 = 1-w*r + in if 2*x < c0 + then min 1 ((c0 - abs (4*x-c0)) / (1-w)) + else max (-1) ((abs (4*(1-x)-c1) - c1) / (1-w)) +{- + let c = w*r+1 + in if 2*x < c + then min 1 ((1 - abs (4*x/c-1))*c/(1-w)) + else max (-1) ((abs (4*(1-x)/(2-c)-1) - 1)*(2-c)/(1-w)) +-} +{- + let c = (w*r+1)/2 + in if x < c + then min 1 ((1 - abs (2*x/c-1))*2*c/(1-w)) + else max (-1) ((abs (2*(1-x)/(1-c)-1) - 1)*2*(1-c)/(1-w)) +-} + +{- | +trapezoid with distinct high and low time +-} +{-# SPECULATE trapezoidBalanced :: Double -> Double -> Double -> Double #-} +{-# INLINE trapezoidBalanced #-} +trapezoidBalanced :: (Real.C a, Field.C a) => a -> a -> T a a +trapezoidBalanced w r = + raise (-w*r) $ trapezoidAsymmetric w r + + +{- | +We assume that a tone was generated by a shape modulated oscillator. +We try to reconstruct the wave function +(with parameters shape control and phase) +from a tone by interpolation. + +The unit for the shape control parameter is the sampling period. +That is the shape parameter is a time parameter +pointing to a momentary shape of the prototype signal. +Of course this momentary shape does not exist +and we can only guess it using interpolation. + +At the boundaries we repeat the outermost shapes +that can be reconstructed entirely from interpolated data +(that is, no extrapolation is needed). +This way we cannot reproduce the shape at the boundaries +because we have no data for cyclically extending it. +On the other hand this method guarantees a nice wave shape +with the required fractional period. + +It must be + @length tone >= + Interpolation.number ipStep + + Interpolation.number ipLeap * ceiling period@. +-} +sampledTone :: (RealField.C a) => + Interpolation.T a v -> + Interpolation.T a v -> + a -> [v] -> a -> T a v +sampledTone ipLeap ipStep period tone shape = Cons $ \phase -> + uncurry (ToneMod.interpolateCell ipLeap ipStep) $ + ToneMod.sampledToneCell + (ToneMod.makePrototype ipLeap ipStep period tone) + shape phase + +{- | +Interpolate first within waves and then across waves, +which is simpler but maybe less efficient. +-} +sampledToneAlt :: (RealField.C a) => + Interpolation.T a v -> + Interpolation.T a v -> + a -> [v] -> a -> T a v +sampledToneAlt ipLeap ipStep period tone shape = Cons $ \phase -> + uncurry (ToneMod.interpolateCell ipStep ipLeap . swap) $ + ToneMod.sampledToneAltCell + (ToneMod.makePrototype ipLeap ipStep period tone) + shape phase + +{- +*Synthesizer.Basic.Wave> +GNUPlot.plotFunc [] (GNUPlot.linearScale 1000 (0,12)) (\t -> sampledTone Interpolation.linear Interpolation.linear (6::Double) ([-5,-3,-1,1,3,5,-4,-4,-4,4,4,4]++replicate 20 0) t (t/6)) + +*Synthesizer.Plain.Oscillator> +let period = 6.3::Double in GNUPlot.plotFunc [] (GNUPlot.linearScale 1000 (-10,20)) (\t -> Wave.sampledTone Interpolation.linear Interpolation.cubic period (take 20 $ staticSine 0 (1/period)) t (t/period)) +-} + + +{- | +This is similar to Polar coordinates, +but the range of the phase is from @0@ to @1@, @0@ to @2*pi@. +-} +data Harmonic a = + Harmonic {harmonicPhase :: Phase.T a, harmonicAmplitude :: a} + +{-# INLINE harmonic #-} +harmonic :: Phase.T a -> a -> Harmonic a +harmonic = Harmonic + +{- | +Specify the wave by its harmonics. + +The function is implemented quite efficiently +by applying the Horner scheme to a polynomial with complex coefficients +(the harmonic parameters) +using a complex exponential as argument. +-} +{-# INLINE composedHarmonics #-} +composedHarmonics :: Trans.C a => [Harmonic a] -> T a a +composedHarmonics hs = + let p = Poly.fromCoeffs $ + map (\h -> Complex.fromPolar (harmonicAmplitude h) + (2*pi * Phase.toRepresentative (harmonicPhase h))) hs + in distort (Complex.imag . Poly.evaluate p) helix +{- +GNUPlot.plotFunc [] (GNUPlot.linearScale 1000 (0,1::Double)) (composedHarmonics [harmonic 0 0, harmonic 0 0, harmonic 0 0, harmonic 0.25 1]) +-} 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,193 @@ +{-# OPTIONS -O2 -fno-implicit-prelude -fglasgow-exts #-} +{- | +Copyright : (c) Henning Thielemann 2006 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +Waveforms which are smoothed according to the oscillator frequency +in order to suppress aliasing effects. +-} +module Synthesizer.Basic.WaveSmoothed ( + T, + fromFunction, + fromWave, + fromControlledWave, + + raise, + amplify, + distort, + apply, + + sine, + cosine, + saw, + square, + triangle, + + Wave.Harmonic, + Wave.harmonic, + composedHarmonics, + ) where + + +import qualified Synthesizer.Basic.Wave as Wave +import qualified Synthesizer.Basic.Phase as Phase + +-- import qualified Algebra.RealTranscendental as RealTrans +import qualified Algebra.Transcendental as Trans +-- import qualified Algebra.RealField as RealField +import qualified Algebra.Module as Module +import qualified Algebra.Field as Field +import qualified Algebra.Real as Real +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import qualified MathObj.Polynomial as Poly +import qualified Number.Complex as Complex + +import NumericPrelude + +-- import qualified Prelude as P +import PreludeBase + + +{- * Definition and construction -} + +newtype T t y = Cons {decons :: t -> Phase.T t -> y} + + +{-# INLINE fromFunction #-} +fromFunction :: (t -> t -> y) -> (T t y) +fromFunction wave = + Cons (\f p -> wave f (Phase.toRepresentative p)) + +{- | +Use this function for waves which are sufficiently smooth. +If the Nyquist frequency is exceeded the wave is simply replaced +by a constant zero wave. +-} +{-# INLINE fromWave #-} +fromWave :: + (Field.C t, Real.C t, Additive.C y) => + Wave.T t y -> (T t y) +fromWave wave = + fromControlledWaveAux (\f -> if abs f >= 1/2 then zero else wave) + +{-# INLINE fromControlledWave #-} +fromControlledWave :: + (Field.C t, Real.C t, Additive.C y) => + (t -> Wave.T t y) -> (T t y) +fromControlledWave wave = + fromControlledWaveAux (\f0 -> + let f = abs f0 + in if f >= 1/2 + then zero + else wave f) + +{-# INLINE fromControlledWaveAux #-} +fromControlledWaveAux :: (t -> Wave.T t y) -> (T t y) +fromControlledWaveAux wave = + Cons (\f p -> Wave.apply (wave f) p) + + +{- * Operations on waves -} + +{-# INLINE raise #-} +raise :: (Additive.C y) => y -> T t y -> T t y +raise y = distort (y+) + +{-# INLINE amplify #-} +amplify :: (Ring.C y) => y -> T t y -> T t y +amplify k = distort (k*) + +{-# INLINE distort #-} +distort :: (y -> z) -> T t y -> T t z +distort g (Cons w) = Cons (\f p -> g (w f p)) + +{-# INLINE apply #-} +apply :: T t y -> (t -> Phase.T t -> y) +apply = decons + + + +instance Additive.C y => Additive.C (T t y) where + {-# INLINE zero #-} + {-# INLINE (+) #-} + {-# INLINE (-) #-} + {-# INLINE negate #-} + zero = Cons (const zero) + (+) (Cons w) (Cons v) = Cons (\f p -> w f p + v f p) + (-) (Cons w) (Cons v) = Cons (\f p -> w f p - v f p) + negate = distort negate + + +instance Module.C a y => Module.C a (T t y) where + {-# INLINE (*>) #-} + s *> w = distort (s*>) w + + + + +{- * Examples -} + +{- ** unparameterized -} + +{- | map a phase to value of a sine wave -} +{-# INLINE sine #-} +sine :: (Trans.C a, Real.C a) => T a a +sine = fromWave Wave.sine + +{-# INLINE cosine #-} +cosine :: (Trans.C a, Real.C a) => T a a +cosine = fromWave Wave.cosine + + +{- | saw tooth, +it's a ramp down in order to have a positive coefficient for the first partial sine +-} +{-# INLINE saw #-} +saw :: (Real.C a, Field.C a) => T a a +saw = + fromControlledWave (\f -> Wave.triangleAsymmetric (2*f-1)) + + +{- | square -} +{-# INLINE square #-} +square :: (Real.C a, Field.C a) => T a a +square = + fromControlledWave (\f -> Wave.trapezoid (1-2*f)) + + +{- | triangle -} +{-# INLINE triangle #-} +triangle :: (Real.C a, Field.C a) => T a a +triangle = fromWave Wave.triangle + + + +{- | +Specify the wave by its harmonics. + +The function is implemented quite efficiently +by applying the Horner scheme to a polynomial with complex coefficients +(the harmonic parameters) +using a complex exponential as argument. +-} +{-# INLINE composedHarmonics #-} +composedHarmonics :: (Trans.C a, Real.C a) => [Wave.Harmonic a] -> T a a +composedHarmonics hs = + let c = map (\h -> Complex.fromPolar (Wave.harmonicAmplitude h) + (2*pi * Phase.toRepresentative (Wave.harmonicPhase h))) hs + -- @take (ceiling (1/(2*f)))@ would fail for small @f@ especially @f==zero@ + trunc f = + map snd . takeWhile ((<1/2) . fst) . zip (iterate (abs f +) zero) + in fromControlledWaveAux $ \f -> + Wave.distort + (Complex.imag . Poly.evaluate (Poly.fromCoeffs (trunc f c))) + Wave.helix +{- +GNUPlot.plotFunc [] (GNUPlot.linearScale 1000 (0,1::Double)) (composedHarmonics [harmonic 0 0, harmonic 0 0, harmonic 0 0, harmonic 0.25 1]) +-} 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 @@ +{-# OPTIONS -fno-implicit-prelude #-} +module Synthesizer.Causal.Displacement where + +import qualified Synthesizer.Causal.Process as Causal + +import qualified Algebra.Additive as Additive + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +{- * Mixing -} + +{-| +Mix two signals. +Unfortunately we have to use 'zipWith' semantic here, +that is the result is as long as the shorter of both inputs. +-} +{-# INLINE mix #-} +mix :: (Additive.C v) => Causal.T (v,v) v +mix = Causal.map (uncurry (+)) + + +{-| +Add a number to all of the signal values. +This is useful for adjusting the center of a modulation. +-} +{-# INLINE raise #-} +raise :: (Additive.C v) => v -> Causal.T v v +raise x = Causal.map (x+) + + +{- * Distortion -} +{-| +In "Synthesizer.Basic.Distortion" you find a collection +of appropriate distortion functions. +-} +{-# INLINE distort #-} +distort :: (c -> a -> a) -> Causal.T (c,a) a +distort f = Causal.map (uncurry f) 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,107 @@ +{-# OPTIONS -fno-implicit-prelude #-} +{- | +ToDo: +use AffineSpace instead of Module for the particular interpolation types, +since affine combinations assert reconstruction of constant functions. +They are more natural for interpolation of internal control parameters. +However, how can cubic interpolation expressed by affine combinations +without divisions? +-} +module Synthesizer.Causal.Interpolation ( + Interpolation.T, + Interpolation.toGeneric, + + relative, + relativeZeroPad, + relativeConstantPad, + relativeCyclicPad, + relativeExtrapolationPad, + relativeZeroPadConstant, + relativeZeroPadLinear, + relativeZeroPadCubic, + ) where + +import qualified Synthesizer.State.Interpolation as Interpolation + +import qualified Synthesizer.Causal.Process as Causal +import qualified Synthesizer.State.Signal as Sig + +import qualified Algebra.Module as Module +import qualified Algebra.RealField as RealField +import qualified Algebra.Additive as Additive + +import Algebra.Additive(zero) + + +import PreludeBase +import NumericPrelude + + +{-* Interpolation at multiple nodes with various padding methods -} + +{- | All values of frequency control must be non-negative. -} +{-# INLINE relative #-} +relative :: (RealField.C t) => + Interpolation.T t y -> t -> Sig.T y -> Causal.T t y +relative ip phase0 x0 = + Causal.crochetL + (\freq pos -> + let (phase,x) = Interpolation.skip ip pos + in Just (Interpolation.func ip phase x, (phase+freq,x))) + (phase0,x0) + + +{-# INLINE relativeZeroPad #-} +relativeZeroPad :: (RealField.C t) => + y -> Interpolation.T t y -> t -> Sig.T y -> Causal.T t y +relativeZeroPad z ip phase x = + Interpolation.zeroPad relative z ip phase x + +{-# INLINE relativeConstantPad #-} +relativeConstantPad :: (RealField.C t) => + Interpolation.T t y -> t -> Sig.T y -> Causal.T t y +relativeConstantPad ip phase x = + Interpolation.constantPad relative ip phase x + +{-# INLINE relativeCyclicPad #-} +relativeCyclicPad :: (RealField.C t) => + Interpolation.T t y -> t -> Sig.T y -> Causal.T t y +relativeCyclicPad ip phase x = + Interpolation.cyclicPad relative ip phase x + +{- | +The extrapolation may miss some of the first and some of the last points +-} +{-# INLINE relativeExtrapolationPad #-} +relativeExtrapolationPad :: (RealField.C t) => + Interpolation.T t y -> t -> Sig.T y -> Causal.T t y +relativeExtrapolationPad ip phase x = + Interpolation.extrapolationPad relative ip phase x +{- + This example shows pikes, although there shouldn't be any: + plotList (take 100 $ interpolate (Zero (0::Double)) ipCubic (-0.9::Double) (repeat 0.03) [1,0,1,0.8]) +-} + +{-* All-in-one interpolation functions -} + +{-# INLINE relativeZeroPadConstant #-} +relativeZeroPadConstant :: + (RealField.C t, Additive.C y) => + t -> Sig.T y -> Causal.T t y +relativeZeroPadConstant = + relativeZeroPad zero Interpolation.constant + +{-# INLINE relativeZeroPadLinear #-} +relativeZeroPadLinear :: + (RealField.C t, Module.C t y) => + t -> Sig.T y -> Causal.T t y +relativeZeroPadLinear = + relativeZeroPad zero Interpolation.linear + +{-# INLINE relativeZeroPadCubic #-} +relativeZeroPadCubic :: + (RealField.C t, Module.C t y) => + t -> Sig.T y -> Causal.T t y +relativeZeroPadCubic = + relativeZeroPad zero Interpolation.cubic + 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,173 @@ +{-# OPTIONS_GHC -O2 -fno-implicit-prelude #-} +{- | +Copyright : (c) Henning Thielemann 2006 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +Tone generators +-} +module Synthesizer.Causal.Oscillator where + +import qualified Synthesizer.Basic.WaveSmoothed as WaveSmooth +import qualified Synthesizer.Basic.Wave as Wave +import qualified Synthesizer.Basic.Phase as Phase + +import qualified Synthesizer.Causal.Process as Causal +import qualified Synthesizer.State.Signal as Sig + +import qualified Synthesizer.Causal.Interpolation as Interpolation + +{- +import qualified Algebra.RealTranscendental as RealTrans +import qualified Algebra.Field as Field +import qualified Algebra.Module as Module +import qualified Algebra.VectorSpace as VectorSpace + +import Algebra.Module((*>)) +-} +import qualified Algebra.Transcendental as Trans +import qualified Algebra.RealField as RealField +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Control.Arrow ((<<<), (&&&), second, returnA, ) + +import NumericPrelude + +import qualified Prelude as P +import PreludeBase + + + +{- * Oscillators with arbitrary but constant waveforms -} + +{-# INLINE freqToPhases #-} +freqToPhases :: RealField.C a => + Phase.T a -> a -> Sig.T (Phase.T a) +freqToPhases phase freq = + Sig.iterate (Phase.increment freq) phase + +{-# INLINE freqsToPhases #-} +{- | +Convert a list of phase steps into a list of momentum phases. +phase is a number in the interval [0,1). +freq contains the phase steps. +-} +freqsToPhases :: RealField.C a => + Phase.T a -> Causal.T a (Phase.T a) +freqsToPhases phase = + Causal.scanL (flip Phase.increment) phase + + +{- +{-# INLINE static #-} +{- | oscillator with constant frequency -} +static :: (RealField.C a) => + Wave.T a b -> (Phase.T a -> a -> Sig.T b) +static wave phase freq = + Sig.map (Wave.apply wave) (freqToPhases phase freq) +-} + + +{-# INLINE phaseMod #-} +{- | oscillator with modulated phase -} +phaseMod :: (RealField.C a) => + Wave.T a b -> a -> Causal.T a b +phaseMod wave = shapeMod (Wave.phaseOffset wave) zero + +{-# INLINE shapeMod #-} +{- | oscillator with modulated shape -} +shapeMod :: (RealField.C a) => + (c -> Wave.T a b) -> Phase.T a -> a -> Causal.T c b +shapeMod wave phase freq = + Causal.applySnd + (Causal.map (uncurry (Wave.apply . wave))) + (freqToPhases phase freq) + + +{-# INLINE freqMod #-} +{- | oscillator with modulated frequency -} +freqMod :: (RealField.C a) => + Wave.T a b -> Phase.T a -> Causal.T a b +freqMod wave phase = + Causal.map (Wave.apply wave) <<< freqsToPhases phase + +{-# INLINE freqModAntiAlias #-} +{- | oscillator with modulated frequency -} +freqModAntiAlias :: (RealField.C a) => + WaveSmooth.T a b -> Phase.T a -> Causal.T a b +freqModAntiAlias wave phase = + Causal.map (uncurry (WaveSmooth.apply wave)) <<< + returnA &&& freqsToPhases phase + +{-# INLINE phaseFreqMod #-} +{- | oscillator with both phase and frequency modulation -} +phaseFreqMod :: (RealField.C a) => + Wave.T a b -> Causal.T (a,a) b +phaseFreqMod wave = shapeFreqMod (Wave.phaseOffset wave) zero + +{-# INLINE shapeFreqMod #-} +{- | oscillator with both shape and frequency modulation -} +shapeFreqMod :: (RealField.C a) => + (c -> Wave.T a b) -> Phase.T a -> Causal.T (c,a) b +shapeFreqMod wave phase = + Causal.map (uncurry (Wave.apply . wave)) <<< + second (freqsToPhases phase) + + +{- +{- | oscillator with a sampled waveform with constant frequency + This essentially an interpolation with cyclic padding. -} +{-# INLINE staticSample #-} +staticSample :: RealField.C a => + Interpolation.T a b -> Sig.T b -> Phase.T a -> a -> Sig.T b +staticSample ip wave phase freq = + Causal.apply (freqModSample ip wave phase) (Sig.repeat freq) +-} + +{- | oscillator with a sampled waveform with modulated frequency + Should behave homogenously for different types of interpolation. -} +{-# INLINE freqModSample #-} +freqModSample :: RealField.C a => + Interpolation.T a b -> Sig.T b -> Phase.T a -> Causal.T a b +freqModSample ip wave phase = + let len = Sig.length wave + pr = Phase.toRepresentative $ Phase.multiply len phase + in Interpolation.relativeCyclicPad ip pr wave + <<< Causal.map (fromIntegral len *) + + + +{- * Oscillators with specific waveforms -} + +{- +{-# INLINE staticSine #-} +{- | sine oscillator with static frequency -} +staticSine :: (Trans.C a, RealField.C a) => Phase.T a -> a -> Sig.T a +staticSine = static Wave.sine +-} + +{-# INLINE freqModSine #-} +{- | sine oscillator with modulated frequency -} +freqModSine :: (Trans.C a, RealField.C a) => Phase.T a -> Causal.T a a +freqModSine = freqMod Wave.sine + +{-# INLINE phaseModSine #-} +{- | sine oscillator with modulated phase, useful for FM synthesis -} +phaseModSine :: (Trans.C a, RealField.C a) => a -> Causal.T a a +phaseModSine = phaseMod Wave.sine + +{- +{-# INLINE staticSaw #-} +{- | saw tooth oscillator with modulated frequency -} +staticSaw :: RealField.C a => Phase.T a -> a -> Sig.T a +staticSaw = static Wave.saw +-} + +{-# INLINE freqModSaw #-} +{- | saw tooth oscillator with modulated frequency -} +freqModSaw :: RealField.C a => Phase.T a -> Causal.T a a +freqModSaw = freqMod Wave.saw diff --git a/src/Synthesizer/Causal/Process.hs b/src/Synthesizer/Causal/Process.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Causal/Process.hs @@ -0,0 +1,214 @@ +{-# OPTIONS -fglasgow-exts #-} +{- | +Processes that use only the current and past data. +Essentially this is a data type for the 'Synthesizer.State.Signal.crochetL' function. +-} +module Synthesizer.Causal.Process ( + T, + fromStateMaybe, + fromState, + fromSimpleModifier, + + map, + first, + second, + compose, + split, + fanout, + loop, + +{- + We don't re-export these identifiers + because people could abuse them for other Arrows. + + (>>>), (***), (&&&), + (Arrow.^<<), (Arrow.^>>), (Arrow.<<^), (Arrow.>>^), +-} + + apply, + applyFst, + applySnd, + apply2, + feed, + + crochetL, + scanL, + zipWith, +) where + +import qualified Synthesizer.State.Signal as Sig + +import qualified Synthesizer.Plain.Modifier as Modifier + +-- import qualified Control.Arrow as Arrow + +import Control.Arrow + (Arrow(..), {- ArrowApply(..), -} ArrowLoop(..), + Kleisli(Kleisli), runKleisli, ) +import Control.Monad.State + (State(State), runState, + StateT(StateT), runStateT, liftM, ) + +import Synthesizer.Utility (mapSnd) +import Prelude hiding (map, zipWith, ) + + + +-- TODO: include ST monad for mutable arrays + +-- | Cf. StreamFusion 'Synthesizer.State.Signal.T' +data T a b = + forall s. -- Seq s => + Cons !(a -> StateT s Maybe b) -- compute next value + !s -- initial state + + + +{-# INLINE fromStateMaybe #-} +fromStateMaybe :: (a -> StateT s Maybe b) -> s -> T a b +fromStateMaybe = Cons + +{-# INLINE fromState #-} +fromState :: (a -> State s b) -> s -> T a b +fromState f s0 = + fromStateMaybe (\x -> StateT (Just . runState (f x))) s0 + +{-# INLINE fromSimpleModifier #-} +fromSimpleModifier :: + Modifier.Simple s ctrl a b -> T (ctrl,a) b +fromSimpleModifier (Modifier.Simple s f) = + fromState (uncurry f) s + + +{- +It's almost a Kleisli Arrow, +but the hidden type of the state disturbs. +-} +instance Arrow T where + {-# INLINE pure #-} + {-# INLINE (>>>) #-} + {-# INLINE first #-} + {-# INLINE second #-} + {-# INLINE (***) #-} + {-# INLINE (&&&) #-} + + pure = map + (>>>) = compose + first = liftKleisli first + second = liftKleisli second + (***) = split + (&&&) = fanout + + +{- +I think we cannot define an ArrowApply instance, +because we must extract the initial state somehow +from the inner (T a b) which is not possible. + +instance ArrowApply T where +-- app = Cons (runKleisli undefined) () + app = first (arr (flip Cons () . runKleisli)) >>> app +-} + + +instance ArrowLoop T where + {-# INLINE loop #-} + loop = liftKleisli loop + + +{-# INLINE extendStateFstT #-} +extendStateFstT :: Monad m => StateT s m a -> StateT (t,s) m a +extendStateFstT st = + StateT (\(t0,s0) -> liftM (mapSnd (\s1 -> (t0,s1))) (runStateT st s0)) + +{-# INLINE extendStateSndT #-} +extendStateSndT :: Monad m => StateT s m a -> StateT (s,t) m a +extendStateSndT st = + StateT (\(s0,t0) -> liftM (mapSnd (\s1 -> (s1,t0))) (runStateT st s0)) + + +{-# INLINE liftKleisli #-} +liftKleisli :: + (forall s. + Kleisli (StateT s Maybe) a0 a1 -> + Kleisli (StateT s Maybe) b0 b1) -> + T a0 a1 -> T b0 b1 +liftKleisli op (Cons f s) = + Cons (runKleisli $ op $ Kleisli f) s + +{-# INLINE liftKleisli2 #-} +liftKleisli2 :: + (forall s. + Kleisli (StateT s Maybe) a0 a1 -> + Kleisli (StateT s Maybe) b0 b1 -> + Kleisli (StateT s Maybe) c0 c1) -> + T a0 a1 -> T b0 b1 -> T c0 c1 +liftKleisli2 op (Cons f s) (Cons g t) = + Cons + (runKleisli + (Kleisli (extendStateSndT . f) `op` + Kleisli (extendStateFstT . g))) + (s,t) + + +{-# INLINE map #-} +map :: (a -> b) -> T a b +map f = fromState (return . f) () + +{-# INLINE compose #-} +compose :: T a b -> T b c -> T a c +compose = liftKleisli2 (>>>) + +{-# INLINE split #-} +split :: T a b -> T c d -> T (a,c) (b,d) +split = liftKleisli2 (***) + +{-# INLINE fanout #-} +fanout :: T a b -> T a c -> T a (b,c) +fanout = liftKleisli2 (&&&) + + +{-# INLINE apply #-} +apply :: T a b -> Sig.T a -> Sig.T b +apply (Cons f s) = + Sig.crochetL (runStateT . f) s + +{-# INLINE applyFst #-} +applyFst :: T (a,b) c -> Sig.T a -> T b c +applyFst (Cons f s) x = + Cons (\b -> + do a <- extendStateFstT $ StateT $ Sig.viewL + extendStateSndT (f (a,b))) + (s,x) + +{-# INLINE applySnd #-} +applySnd :: T (a,b) c -> Sig.T b -> T a c +applySnd (Cons f s) x = + Cons (\b -> + do a <- extendStateFstT $ StateT $ Sig.viewL + extendStateSndT (f (b,a))) + (s,x) + +{-# INLINE apply2 #-} +apply2 :: T (a,b) c -> Sig.T a -> Sig.T b -> Sig.T c +apply2 f x y = + apply (applyFst f x) y + + +{-# INLINE feed #-} +feed :: Sig.T a -> T () a +feed = fromStateMaybe (const (StateT Sig.viewL)) + + +{-# INLINE crochetL #-} +crochetL :: (x -> acc -> Maybe (y, acc)) -> acc -> T x y +crochetL f s = fromStateMaybe (StateT . f) s + +{-# INLINE scanL #-} +scanL :: (acc -> x -> acc) -> acc -> T x acc +scanL f start = + fromState (\x -> State $ \acc -> (acc, f acc x)) start + +{-# INLINE zipWith #-} +zipWith :: (a -> b -> c) -> Sig.T a -> T b c +zipWith f = applyFst (map (uncurry f)) diff --git a/src/Synthesizer/Dimensional/Abstraction/Flat.hs b/src/Synthesizer/Dimensional/Abstraction/Flat.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Dimensional/Abstraction/Flat.hs @@ -0,0 +1,65 @@ +{-# OPTIONS -fglasgow-exts #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +Class that allows unified handling of +@SigS.T@ and @Sig.D Dim.Scalar@ +which is often used for control curves. +-} +module Synthesizer.Dimensional.Abstraction.Flat where + +import qualified Synthesizer.Dimensional.RatePhantom as RP +import qualified Synthesizer.Dimensional.Straight.Signal as SigS +import qualified Synthesizer.Dimensional.Amplitude.Signal as SigA + +import qualified Synthesizer.State.Signal as Sig + +import qualified Number.DimensionTerm as DN +import qualified Algebra.DimensionTerm as Dim + +{- +import qualified Algebra.Module as Module +import qualified Algebra.Field as Field +-} +import qualified Algebra.Ring as Ring + +-- import Number.DimensionTerm ((&/&)) + + +-- import NumericPrelude +import PreludeBase +-- import Prelude () + + +toSamples :: C sig y => RP.T s sig y -> Sig.T y +toSamples = unwrappedToSamples . RP.toSignal + +class C sig y where + unwrappedToSamples :: sig y -> Sig.T y + +instance C Sig.T y where + unwrappedToSamples = id + +instance C sig y => C (SigS.T sig) y where + unwrappedToSamples = unwrappedToSamples . SigS.samples + + +{- +instance (Dim.IsScalar scalar, Module.C y yv) => C (SigA.T scalar y) yv where + toSamples = + SigA.vectorSamples (DN.toNumber . DN.rewriteDimension Dim.toScalar) +-} + +instance (C flat y, Dim.IsScalar scalar, Ring.C y) => + C (SigA.T scalar y flat) y where + unwrappedToSamples = + SigA.scalarSamples (DN.toNumber . DN.rewriteDimension Dim.toScalar) . + (\x -> + SigA.fromSamples + (SigA.privateAmplitude x) + (unwrappedToSamples (SigA.signal x))) diff --git a/src/Synthesizer/Dimensional/Abstraction/Homogeneous.hs b/src/Synthesizer/Dimensional/Abstraction/Homogeneous.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Dimensional/Abstraction/Homogeneous.hs @@ -0,0 +1,70 @@ +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +Class that allows unified handling of +@SigS.T@ and @Sig.D s u@ +whenever the applied function is homogeneous (with degree one), +that is scaling of the input must only result in scaling of the output. +Unfortunately, Haskell's type system cannot check this property, +so use this abstraction only for signal processes that are actually homogeneous. +-} +module Synthesizer.Dimensional.Abstraction.Homogeneous where + +import qualified Synthesizer.State.Signal as Sig +import qualified Synthesizer.Dimensional.RatePhantom as RP +import qualified Synthesizer.Dimensional.Straight.Signal as SigS +import qualified Synthesizer.Dimensional.Amplitude.Signal as SigA + +-- import qualified Number.DimensionTerm as DN +import qualified Algebra.DimensionTerm as Dim + +{- +import qualified Algebra.Module as Module +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +-} + +-- import Number.DimensionTerm ((&/&)) + + +-- import NumericPrelude +-- import PreludeBase +-- import Prelude () + +{-# INLINE processSamples #-} +processSamples :: C sig => + (Sig.T y0 -> Sig.T y1) -> RP.T s sig y0 -> RP.T s sig y1 +processSamples f = + RP.fromSignal . unwrappedProcessSamples f . RP.toSignal + + +{-# INLINE processSampleList #-} +processSampleList :: C sig => + ([y0] -> [y1]) -> + RP.T s sig y0 -> + RP.T s sig y1 +processSampleList f = + processSamples (Sig.fromList . f . Sig.toList) + + +class C sig where + unwrappedProcessSamples :: (Sig.T y0 -> Sig.T y1) -> sig y0 -> sig y1 + + +instance C Sig.T where + unwrappedProcessSamples f = f + +instance C sig => C (SigS.T sig) where +-- processSamples = SigS.processSamples + unwrappedProcessSamples f = + SigS.Cons . unwrappedProcessSamples f . SigS.samples + +instance (C sig, Dim.C u) => C (SigA.T u y sig) where + unwrappedProcessSamples f = + (\(SigA.Cons amp sig) -> + SigA.Cons amp (unwrappedProcessSamples f sig)) diff --git a/src/Synthesizer/Dimensional/Abstraction/RateIndependent.hs b/src/Synthesizer/Dimensional/Abstraction/RateIndependent.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Dimensional/Abstraction/RateIndependent.hs @@ -0,0 +1,38 @@ +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +Class that allows unified handling of @RP.T@ and @SigP.T@ +whenever the applied function does not depend on the sample rate. +Unfortunately, Haskell's type system cannot check this property, +so use this abstraction only for signal processes that are actually sample rate independent. +-} +module Synthesizer.Dimensional.Abstraction.RateIndependent where + +-- import qualified Synthesizer.Dimensional.RatePhantom as RP +-- import qualified Synthesizer.Dimensional.RateWrapper as SigP + +-- import qualified Number.DimensionTerm as DN +-- import qualified Algebra.DimensionTerm as Dim + +{- +import qualified Algebra.Module as Module +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +-} + +-- import Number.DimensionTerm ((&/&)) + + +-- import NumericPrelude +-- import PreludeBase +-- import Prelude () + + +class C w where + toSignal :: w sig y -> sig y + processSignal :: (sig0 y0 -> sig1 y1) -> w sig0 y0 -> w sig1 y1 diff --git a/src/Synthesizer/Dimensional/Amplitude/Analysis.hs b/src/Synthesizer/Dimensional/Amplitude/Analysis.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Dimensional/Amplitude/Analysis.hs @@ -0,0 +1,174 @@ +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes +-} +module Synthesizer.Dimensional.Amplitude.Analysis ( + volumeMaximum, + volumeEuclidean, + volumeSum, + volumeVectorMaximum, + volumeVectorEuclidean, + volumeVectorSum, + + directCurrentOffset, + rectify, + flipFlopHysteresis, + + compare, + lessOrEqual, + ) where + +import qualified Synthesizer.Dimensional.Abstraction.RateIndependent as Ind +import qualified Synthesizer.Dimensional.Abstraction.Homogeneous as Hom + +-- import qualified Synthesizer.Dimensional.RatePhantom as RP +import qualified Synthesizer.Dimensional.Straight.Signal as SigS + +import qualified Synthesizer.Dimensional.Amplitude.Signal as SigA +import qualified Synthesizer.Dimensional.Amplitude.Cut as CutD +-- import Synthesizer.Dimensional.Amplitude.Signal (toAmplitudeScalar) + +import qualified Synthesizer.State.Analysis as Ana +import qualified Synthesizer.State.Signal as Sig + +import qualified Number.DimensionTerm as DN +import qualified Algebra.DimensionTerm as Dim + +import Number.DimensionTerm ((*&)) + +import qualified Algebra.NormedSpace.Maximum as NormedMax +import qualified Algebra.NormedSpace.Euclidean as NormedEuc +import qualified Algebra.NormedSpace.Sum as NormedSum + +import qualified Algebra.Algebraic as Algebraic +import qualified Algebra.Module as Module +import qualified Algebra.Field as Field +import qualified Algebra.Real as Real +import qualified Algebra.Ring as Ring + + +-- import qualified Data.List as List +-- import NumericPrelude.List (zipWithMatch, ) + +import PreludeBase (Ord, Bool, (<=), ($), (.), uncurry, ) +-- import NumericPrelude +import qualified Prelude as P + + + +{- * Notions of volume -} + +{- | +Volume based on Manhattan norm. +-} +{-# INLINE volumeMaximum #-} +volumeMaximum :: (Ind.C w, Real.C y, Dim.C u) => + w (SigA.S u y) y -> DN.T u y +volumeMaximum = volumeAux Ana.volumeMaximum + +{- | +Volume based on Energy norm. +-} +{-# INLINE volumeEuclidean #-} +volumeEuclidean :: (Ind.C w, Algebraic.C y, Dim.C u) => + w (SigA.S u y) y -> DN.T u y +volumeEuclidean = volumeAux Ana.volumeEuclidean + +{- | +Volume based on Sum norm. +-} +{-# INLINE volumeSum #-} +volumeSum :: (Ind.C w, Field.C y, Real.C y, Dim.C u) => + w (SigA.S u y) y -> DN.T u y +volumeSum = volumeAux Ana.volumeSum + + + +{- | +Volume based on Manhattan norm. +-} +{-# INLINE volumeVectorMaximum #-} +volumeVectorMaximum :: (Ind.C w, NormedMax.C y yv, Ord y, Dim.C u) => + w (SigA.S u y) yv -> DN.T u y +volumeVectorMaximum = volumeAux Ana.volumeVectorMaximum + +{- | +Volume based on Energy norm. +-} +{-# INLINE volumeVectorEuclidean #-} +volumeVectorEuclidean :: (Ind.C w, NormedEuc.C y yv, Algebraic.C y, Dim.C u) => + w (SigA.S u y) yv -> DN.T u y +volumeVectorEuclidean = volumeAux Ana.volumeVectorEuclidean + +{- | +Volume based on Sum norm. +-} +{-# INLINE volumeVectorSum #-} +volumeVectorSum :: (Ind.C w, NormedSum.C y yv, Field.C y, Dim.C u) => + w (SigA.S u y) yv -> DN.T u y +volumeVectorSum = volumeAux Ana.volumeVectorSum + + +{-# INLINE volumeAux #-} +volumeAux :: (Ind.C w, Ring.C y, Dim.C u) => + (Sig.T yv -> y) -> w (SigA.S u y) yv -> DN.T u y +volumeAux vol x = + vol (SigA.samples x) *& SigA.amplitude x + + +{- * Miscellaneous -} + +{- | +Requires finite length. +This is identical to the arithmetic mean. +-} +{-# INLINE directCurrentOffset #-} +directCurrentOffset :: (Ind.C w, Field.C y, Dim.C u) => + w (SigA.S u y) y -> DN.T u y +directCurrentOffset = + volumeAux Ana.directCurrentOffset + +{-# INLINE rectify #-} +rectify :: (Ind.C w, Hom.C sig, Real.C y) => + w sig y -> w sig y +rectify = Ind.processSignal (Hom.unwrappedProcessSamples Ana.rectify) + + +{- | +Detect thresholds with a hysteresis. +-} +{-# INLINE flipFlopHysteresis #-} +flipFlopHysteresis :: (Ind.C w, Ord y, Field.C y, Dim.C u) => + (DN.T u y, DN.T u y) -> Bool -> + w (SigA.S u y) y -> w (SigS.T Sig.T) Bool +-- SigA.R s u y y -> SigS.Binary s +flipFlopHysteresis (lower,upper) start x = + let l = SigA.toAmplitudeScalar x lower + h = SigA.toAmplitudeScalar x upper + in Ind.processSignal + (SigS.Cons . + Ana.flipFlopHysteresis (l,h) start . + SigA.privateSamples) x + + +{- * comparison -} + +{-# INLINE compare #-} +compare :: + (Ord y, Field.C y, Dim.C u, + Module.C y yv, Ord yv) => + SigA.R s u y yv -> SigA.R s u y yv -> SigS.R s P.Ordering +compare x y = + SigS.fromSamples $ Sig.map (uncurry P.compare) $ SigA.samples $ CutD.zip x y + +{-# INLINE lessOrEqual #-} +lessOrEqual :: + (Ord y, Field.C y, Dim.C u, + Module.C y yv, Ord yv) => + SigA.R s u y yv -> SigA.R s u y yv -> SigS.Binary s +lessOrEqual x y = + P.fmap (<= P.EQ) $ compare x y diff --git a/src/Synthesizer/Dimensional/Amplitude/Control.hs b/src/Synthesizer/Dimensional/Amplitude/Control.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Dimensional/Amplitude/Control.hs @@ -0,0 +1,132 @@ +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + + +Control curves which can be used +as envelopes, for controlling filter parameters and so on. +-} +module Synthesizer.Dimensional.Amplitude.Control + ({- * Primitives -} + constant, constantVector, + {- * Preparation -} + mapLinear, mapLinearDimension, + mapExponential, + ) where + +import qualified Synthesizer.Dimensional.Abstraction.RateIndependent as Ind +import qualified Synthesizer.Dimensional.Abstraction.Flat as Flat + +-- import qualified Synthesizer.Dimensional.RatePhantom as RP +import qualified Synthesizer.Dimensional.Straight.Signal as SigS +import qualified Synthesizer.Dimensional.Amplitude.Signal as SigA +import Synthesizer.Dimensional.Amplitude.Signal (toAmplitudeScalar) + +import qualified Synthesizer.State.Control as Ctrl +import qualified Synthesizer.State.Signal as Sig + +import qualified Number.DimensionTerm as DN +import qualified Algebra.DimensionTerm as Dim + +import Number.DimensionTerm ((&*&)) + +-- import qualified Algebra.Module as Module +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Field as Field +import qualified Algebra.Real as Real +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import NumericPrelude +import PreludeBase as P +import Prelude () + + +{-# INLINE constant #-} +constant :: (Real.C y, Dim.C u) => + DN.T u y {-^ value -} + -> SigA.R s u y y +constant = + uncurry constantVector . + DN.absSignum + +{- | +The amplitude must be positive! +This is not checked. +-} +{-# INLINE constantVector #-} +constantVector :: -- (Field.C y', Real.C y', OccScalar.C y y') => + DN.T u y {-^ amplitude -} + -> yv {-^ value -} + -> SigA.R s u y yv +constantVector y yv = + SigA.fromSamples y (Ctrl.constant yv) + + + +{- +This signature is too general. +It will cause strange type errors +if u is Scalar and further process want to use the Flat instance. +The Flat instance cannot be found, if q cannot be determined. + +mapLinear :: (Ind.C w, Flat.C flat y, Ring.C y, Dim.C u) => + y -> + DN.T u q -> + w flat y -> + w (SigA.S u q) y +-} + +{-# INLINE mapLinear #-} +mapLinear :: (Ind.C w, Flat.C flat y, Ring.C y, Dim.C u) => + y -> + DN.T u y -> + w flat y -> + w (SigA.S u y) y +mapLinear depth center = + Ind.processSignal + (SigA.Cons center . SigS.Cons . + Sig.map (\x -> one+x*depth) . + Flat.unwrappedToSamples) + +{-# INLINE mapExponential #-} +mapExponential :: (Ind.C w, Flat.C flat y, Trans.C y, Dim.C u) => + y -> + DN.T u q -> + w flat y -> + w (SigA.S u q) y +mapExponential depth center = + Ind.processSignal + (SigA.Cons center . SigS.Cons . + Sig.map (depth**) . + Flat.unwrappedToSamples) + + +-- combination of 'raise' and 'amplify' *** +{- | +Map a control curve without amplitude unit +by a linear (affine) function with a unit. +-} +{-# INLINE mapLinearDimension #-} +mapLinearDimension :: + (Ind.C w, Field.C y, Real.C y, Dim.C u, Dim.C v) => + DN.T v y {- ^ range: one is mapped to @center + range * ampX@ -} + -> DN.T (Dim.Mul v u) y {- ^ center: zero is mapped to @center@ -} + -> w (SigA.S u y) y + -> w (SigA.S (Dim.Mul v u) y) y +mapLinearDimension range center x = + let absRange = DN.abs range &*& SigA.amplitude x + absCenter = DN.abs center + rng = toAmplitudeScalar z absRange + cnt = toAmplitudeScalar z absCenter + z = + Ind.processSignal + (SigA.Cons (absRange + absCenter) . SigS.Cons . + Sig.map (\y -> cnt + rng*y) . + SigA.privateSamples) x + in z +-- SynI.mapScalar 1 (absRange + absCenter) (\y -> cnt + rng*y) x diff --git a/src/Synthesizer/Dimensional/Amplitude/Cut.hs b/src/Synthesizer/Dimensional/Amplitude/Cut.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Dimensional/Amplitude/Cut.hs @@ -0,0 +1,222 @@ +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes +-} +module Synthesizer.Dimensional.Amplitude.Cut ( + {- * dissection -} + unzip, + unzip3, + leftFromStereo, rightFromStereo, + + {- * glueing -} + concat, concatVolume, + append, appendVolume, + zip, zipVolume, + zip3, zip3Volume, + mergeStereo, mergeStereoVolume, + selectBool, + ) where + +import qualified Synthesizer.Dimensional.Straight.Signal as SigS +import qualified Synthesizer.Dimensional.Amplitude.Signal as SigA +import Synthesizer.Dimensional.Amplitude.Signal (toAmplitudeScalar) + +import qualified Synthesizer.State.Signal as Sig + +import qualified Synthesizer.Frame.Stereo as Stereo + +import qualified Number.DimensionTerm as DN +import qualified Algebra.DimensionTerm as Dim + +-- import Number.DimensionTerm ((&*&)) + +-- import qualified Algebra.NormedSpace.Maximum as NormedMax +import qualified Algebra.Module as Module +import qualified Algebra.Field as Field +-- import qualified Algebra.Ring as Ring + +import qualified Data.List as List +-- import NumericPrelude.List (zipWithMatch, ) + +import PreludeBase (Ord, max, ) +-- import NumericPrelude +import Prelude () + + +{- * dissection -} + +{-# INLINE unzip #-} +unzip :: (Dim.C u) => + SigA.R s u y (yv0, yv1) -> + (SigA.R s u y yv0, SigA.R s u y yv1) +unzip x = + let (ss0,ss1) = Sig.unzip (SigA.samples x) + in (SigA.replaceSamples ss0 x, SigA.replaceSamples ss1 x) + +{-# INLINE unzip3 #-} +unzip3 :: (Dim.C u) => + SigA.R s u y (yv0, yv1, yv2) -> + (SigA.R s u y yv0, SigA.R s u y yv1, SigA.R s u y yv2) +unzip3 x = + let (ss0,ss1,ss2) = Sig.unzip3 (SigA.samples x) + in (SigA.replaceSamples ss0 x, SigA.replaceSamples ss1 x, SigA.replaceSamples ss2 x) + + +{-# INLINE leftFromStereo #-} +leftFromStereo :: (Dim.C u) => + SigA.R s u y (Stereo.T yv) -> SigA.R s u y yv +leftFromStereo = SigA.processSamples (Sig.map Stereo.left) + +{-# INLINE rightFromStereo #-} +rightFromStereo :: (Dim.C u) => + SigA.R s u y (Stereo.T yv) -> SigA.R s u y yv +rightFromStereo = SigA.processSamples (Sig.map Stereo.right) + + + +{- * glueing -} + +{- | +Similar to @foldr1 append@ but more efficient and accurate, +because it reduces the number of amplifications. +Does not work for infinite lists, +because no maximum amplitude can be computed. +-} +{-# INLINE concat #-} +concat :: + (Ord y, Field.C y, Dim.C u, + Module.C y yv) => + [SigA.R s u y yv] -> SigA.R s u y yv +concat xs = + concatVolume (List.maximum (List.map SigA.amplitude xs)) xs + +{- | +Give the output volume explicitly. +Does also work for infinite lists. +-} +{-# INLINE concatVolume #-} +concatVolume :: + (Field.C y, Dim.C u, + Module.C y yv) => + DN.T u y -> [SigA.R s u y yv] -> SigA.R s u y yv +concatVolume amp xs = + let smps = List.map (SigA.vectorSamples (toAmplitudeScalar z)) xs + z = SigA.fromSamples amp (Sig.concat smps) + in z + + +{-# INLINE merge #-} +merge :: + (Ord y, Field.C y, Dim.C u, + Module.C y yv0, Module.C y yv1) => + (Sig.T yv0 -> Sig.T yv1 -> Sig.T yv2) -> + SigA.R s u y yv0 -> SigA.R s u y yv1 -> SigA.R s u y yv2 +merge f x0 x1 = + mergeVolume f (max (SigA.amplitude x0) (SigA.amplitude x1)) x0 x1 + +{-# INLINE mergeVolume #-} +mergeVolume :: + (Field.C y, Dim.C u, + Module.C y yv0, Module.C y yv1) => + (Sig.T yv0 -> Sig.T yv1 -> Sig.T yv2) -> + DN.T u y -> + SigA.R s u y yv0 -> SigA.R s u y yv1 -> SigA.R s u y yv2 +mergeVolume f amp x y = + let sampX = SigA.vectorSamples (toAmplitudeScalar z) x + sampY = SigA.vectorSamples (toAmplitudeScalar z) y + z = SigA.fromSamples amp (f sampX sampY) + in z + + +{-# INLINE append #-} +append :: + (Ord y, Field.C y, Dim.C u, + Module.C y yv) => + SigA.R s u y yv -> SigA.R s u y yv -> SigA.R s u y yv +append = merge Sig.append + +{-# INLINE appendVolume #-} +appendVolume :: + (Field.C y, Dim.C u, + Module.C y yv) => + DN.T u y -> + SigA.R s u y yv -> SigA.R s u y yv -> SigA.R s u y yv +appendVolume = mergeVolume Sig.append + + +{-# INLINE zip #-} +zip :: + (Ord y, Field.C y, Dim.C u, + Module.C y yv0, Module.C y yv1) => + SigA.R s u y yv0 -> SigA.R s u y yv1 -> SigA.R s u y (yv0,yv1) +zip = merge Sig.zip + +{-# INLINE zipVolume #-} +zipVolume :: + (Field.C y, Dim.C u, + Module.C y yv0, Module.C y yv1) => + DN.T u y -> + SigA.R s u y yv0 -> SigA.R s u y yv1 -> SigA.R s u y (yv0,yv1) +zipVolume = mergeVolume Sig.zip + + + +{-# INLINE mergeStereo #-} +mergeStereo :: + (Ord y, Field.C y, Dim.C u, + Module.C y yv) => + SigA.R s u y yv -> SigA.R s u y yv -> SigA.R s u y (Stereo.T yv) +mergeStereo = merge (Sig.zipWith Stereo.cons) + +{-# INLINE mergeStereoVolume #-} +mergeStereoVolume :: + (Field.C y, Dim.C u, + Module.C y yv) => + DN.T u y -> + SigA.R s u y yv -> SigA.R s u y yv -> SigA.R s u y (Stereo.T yv) +mergeStereoVolume = mergeVolume (Sig.zipWith Stereo.cons) + + + +{-# INLINE zip3 #-} +zip3 :: + (Ord y, Field.C y, Dim.C u, + Module.C y yv0, Module.C y yv1, Module.C y yv2) => + SigA.R s u y yv0 -> SigA.R s u y yv1 -> SigA.R s u y yv2 -> + SigA.R s u y (yv0,yv1,yv2) +zip3 x0 x1 x2 = + zip3Volume + (SigA.amplitude x0 `max` SigA.amplitude x1 `max` SigA.amplitude x2) + x0 x1 x2 + +{-# INLINE zip3Volume #-} +zip3Volume :: + (Field.C y, Dim.C u, + Module.C y yv0, Module.C y yv1, Module.C y yv2) => + DN.T u y -> + SigA.R s u y yv0 -> SigA.R s u y yv1 -> SigA.R s u y yv2 -> + SigA.R s u y (yv0,yv1,yv2) +zip3Volume amp x0 x1 x2 = + let sampX0 = SigA.vectorSamples (toAmplitudeScalar z) x0 + sampX1 = SigA.vectorSamples (toAmplitudeScalar z) x1 + sampX2 = SigA.vectorSamples (toAmplitudeScalar z) x2 + z = SigA.fromSamples amp (Sig.zip3 sampX0 sampX1 sampX2) + in z + + +{-# INLINE selectBool #-} +selectBool :: + (Ord y, Field.C y, Dim.C u, + Module.C y yv) => + SigA.R s u y yv {- ^ False -} -> + SigA.R s u y yv {- ^ True -} -> + SigS.Binary s -> + SigA.R s u y yv +selectBool xf xt cs = + SigA.processSamples + (Sig.zipWith (\c (xfi,xti) -> if c then xti else xfi) (SigS.toSamples cs)) + (zip xf xt) diff --git a/src/Synthesizer/Dimensional/Amplitude/Displacement.hs b/src/Synthesizer/Dimensional/Amplitude/Displacement.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Dimensional/Amplitude/Displacement.hs @@ -0,0 +1,110 @@ +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes +-} +module Synthesizer.Dimensional.Amplitude.Displacement ( + mix, mixVolume, + mixMulti, mixMultiVolume, + raise, distort, + ) where + +import qualified Synthesizer.Dimensional.Abstraction.RateIndependent as Ind + +import qualified Synthesizer.Dimensional.Amplitude.Signal as SigA +import Synthesizer.Dimensional.Amplitude.Signal (toAmplitudeScalar) + +import qualified Number.DimensionTerm as DN +import qualified Algebra.DimensionTerm as Dim + +-- import Number.DimensionTerm ((&*&)) + +import qualified Synthesizer.State.Displacement as Disp +import qualified Synthesizer.State.Signal as Sig + +import qualified Algebra.Module as Module +import qualified Algebra.Field as Field +import qualified Algebra.Real as Real +-- import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Algebra.Module ((*>)) + +import PreludeBase +import NumericPrelude +import Prelude () + + +{- * Mixing -} + +{-| Mix two signals. + In opposition to 'zipWith' the result has the length of the longer signal. -} +{-# INLINE mix #-} +mix :: + (Real.C y, Field.C y, Module.C y yv, Dim.C u) => + SigA.R s u y yv + -> SigA.R s u y yv + -> SigA.R s u y yv +mix x y = + mixVolume (DN.abs (SigA.amplitude x) + DN.abs (SigA.amplitude y)) x y + +{-# INLINE mixVolume #-} +mixVolume :: + (Real.C y, Field.C y, Module.C y yv, Dim.C u) => + DN.T u y + -> SigA.R s u y yv + -> SigA.R s u y yv + -> SigA.R s u y yv +mixVolume v x y = + let z = SigA.fromSamples v + (toAmplitudeScalar z (SigA.amplitude x) *> SigA.samples x + + toAmplitudeScalar z (SigA.amplitude y) *> SigA.samples y) + in z + +{-| Mix one or more signals. -} +{-# INLINE mixMulti #-} +mixMulti :: + (Real.C y, Field.C y, Module.C y yv, Dim.C u) => + [SigA.R s u y yv] + -> SigA.R s u y yv +mixMulti x = + mixMultiVolume (sum (map (DN.abs . SigA.amplitude) x)) x + +{-# INLINE mixMultiVolume #-} +mixMultiVolume :: + (Real.C y, Field.C y, Module.C y yv, Dim.C u) => + DN.T u y + -> [SigA.R s u y yv] + -> SigA.R s u y yv +mixMultiVolume v x = + let z = SigA.fromSamples v + (foldr (\y -> (toAmplitudeScalar z (SigA.amplitude y) *> + SigA.samples y +)) Sig.empty x) + in z + +{-| Add a number to all of the signal values. + This is useful for adjusting the center of a modulation. -} +{-# INLINE raise #-} +raise :: (Ind.C w, Field.C y, Module.C y yv, Dim.C u) => + DN.T u y + -> yv + -> w (SigA.S u y) yv + -> w (SigA.S u y) yv +raise y' yv x = + SigA.processSamples + (Disp.raise (toAmplitudeScalar x y' *> yv)) x + +{-# INLINE distort #-} +distort :: (Field.C y, Module.C y yv, Dim.C u) => + (yv -> yv) + -> SigA.R s u y y + -> SigA.R s u y yv + -> SigA.R s u y yv +distort f cs xs = + SigA.processSamples + (Sig.zipWith + (\c y -> c *> f (recip c *> y)) + (SigA.scalarSamples (toAmplitudeScalar xs) cs)) xs diff --git a/src/Synthesizer/Dimensional/Amplitude/Filter.hs b/src/Synthesizer/Dimensional/Amplitude/Filter.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Dimensional/Amplitude/Filter.hs @@ -0,0 +1,102 @@ +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes +-} +module Synthesizer.Dimensional.Amplitude.Filter ( + {- * Non-recursive -} + + {- ** Amplification -} + amplify, + amplifyDimension, + negate, + envelope, + envelopeVector, + envelopeVectorDimension, + ) where + + +import qualified Synthesizer.Dimensional.Abstraction.RateIndependent as Ind +import qualified Synthesizer.Dimensional.Abstraction.Homogeneous as Hom +import qualified Synthesizer.Dimensional.Abstraction.Flat as Flat + +import qualified Synthesizer.Dimensional.RatePhantom as RP + +-- import qualified Synthesizer.Dimensional.Straight.Signal as SigS +import qualified Synthesizer.Dimensional.Amplitude.Signal as SigA +-- import Synthesizer.Dimensional.Amplitude.Signal (toAmplitudeScalar) + +import qualified Number.DimensionTerm as DN +import qualified Algebra.DimensionTerm as Dim + +import Number.DimensionTerm ((&*&)) + +-- import qualified Synthesizer.State.Signal as Sig +import qualified Synthesizer.State.Filter.NonRecursive as FiltNR + +-- import qualified Algebra.Transcendental as Trans +-- import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive +import qualified Algebra.Module as Module + +-- import NumericPrelude hiding (negate) +-- import PreludeBase as P +import Prelude (($)) + + +{- | The amplification factor must be positive. -} +{-# INLINE amplify #-} +amplify :: (Ind.C w, Ring.C y, Dim.C u) => + y + -> w (SigA.S u y) yv + -> w (SigA.S u y) yv +amplify volume x = + SigA.replaceAmplitude (DN.scale volume $ SigA.amplitude x) x + +{-# INLINE amplifyDimension #-} +amplifyDimension :: (Ind.C w, Ring.C y, Dim.C u, Dim.C v) => + DN.T v y + -> w (SigA.S u y) yv + -> w (SigA.S (Dim.Mul v u) y) yv +amplifyDimension volume x = + SigA.replaceAmplitude (volume &*& SigA.amplitude x) x + +-- FIXME: move to Dimensional.Straight +{-# INLINE negate #-} +negate :: (Ind.C w, Hom.C sig, Additive.C yv) => + w sig yv + -> w sig yv +negate = + Ind.processSignal (Hom.unwrappedProcessSamples Additive.negate) + +-- FIXME: move to Dimensional.Straight +{-# INLINE envelope #-} +envelope :: (Hom.C sig, Flat.C flat y0, Ring.C y0) => + RP.T s flat y0 {- ^ the envelope -} + -> RP.T s sig y0 {- ^ the signal to be enveloped -} + -> RP.T s sig y0 +envelope y = + Hom.processSamples (FiltNR.envelope (Flat.toSamples y)) + +-- FIXME: move to Dimensional.Straight +{-# INLINE envelopeVector #-} +envelopeVector :: (Hom.C sig, Flat.C flat y0, Module.C y0 yv) => + RP.T s flat y0 {- ^ the envelope -} + -> RP.T s sig yv {- ^ the signal to be enveloped -} + -> RP.T s sig yv +envelopeVector y = + Hom.processSamples (FiltNR.envelopeVector (Flat.toSamples y)) + +{-# INLINE envelopeVectorDimension #-} +envelopeVectorDimension :: (Module.C y0 yv, Ring.C y, Dim.C u, Dim.C v) => + SigA.R s v y y0 {- ^ the envelope -} + -> SigA.R s u y yv {- ^ the signal to be enveloped -} + -> SigA.R s (Dim.Mul v u) y yv +envelopeVectorDimension y x = + SigA.fromSamples + (SigA.amplitude y &*& SigA.amplitude x) + (FiltNR.envelopeVector (SigA.samples y) (SigA.samples x)) diff --git a/src/Synthesizer/Dimensional/Amplitude/Signal.hs b/src/Synthesizer/Dimensional/Amplitude/Signal.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Dimensional/Amplitude/Signal.hs @@ -0,0 +1,219 @@ +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +Signals equipped with a volume information that may carry a unit. +Is the approach with separated volume information still appropriate? +Actually it simplifies reusing code from "Synthesizer.State.Signal" +because we do not have to replace @(*)@ by @(&*&)@. +-} +module Synthesizer.Dimensional.Amplitude.Signal where + +import qualified Synthesizer.Format as Format +import qualified Synthesizer.Dimensional.Abstraction.RateIndependent as Ind + +import qualified Synthesizer.Dimensional.RatePhantom as RP +import qualified Synthesizer.Dimensional.Straight.Signal as SigS + +import qualified Synthesizer.State.Filter.NonRecursive as Filt +import qualified Synthesizer.State.Signal as Sig + +import qualified Synthesizer.Generic.Filter.NonRecursive as FiltG +import qualified Synthesizer.Generic.Signal as SigG +import qualified Synthesizer.Generic.SampledValue as Sample + +import qualified Number.DimensionTerm as DN +import qualified Algebra.DimensionTerm as Dim + +import qualified Algebra.Module as Module +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring + +-- import Number.DimensionTerm ((&/&)) + + +import NumericPrelude +import PreludeBase as P +import Prelude () + + +data T v y sig yv = + Cons { + privateAmplitude :: DN.T v y {-^ scaling of the values -} + , signal :: sig yv {-^ the embedded signal -} + } +-- deriving (Eq, Show) + +instance (Dim.C v, Show y, Format.C sig) => Format.C (T v y sig) where + format p (Cons amp sig) = + showParen (p >= 10) + (showString "amplitudeSignal " . showsPrec 11 amp . + showString " " . Format.format 11 sig) + +instance (Dim.C v, Show y, Show yv, Format.C sig) => Show (T v y sig yv) where + showsPrec = Format.format + +type R s v y yv = RP.T s (S v y) yv +type S v y = T v y (SigS.T Sig.T) -- kind * -> * + +{- +We removed that instance because 'fmap' is too dangerous for application code. +You may write functions that depend on the particular amplitude scaling. + +instance Dim.C v => Functor (T v y s) where + fmap f (Cons amp ss) = Cons amp (map f ss) +-} + +{-# INLINE amplitude #-} +amplitude :: (Ind.C w, Dim.C v) => + w (T v y sig) yv -> DN.T v y +amplitude = privateAmplitude . Ind.toSignal + +{-# INLINE samples #-} +samples :: (Ind.C w, Dim.C v) => + w (T v y (SigS.T sig)) yv -> sig yv +samples = privateSamples . Ind.toSignal + +{-# INLINE privateSamples #-} +privateSamples :: (Dim.C v) => + T v y (SigS.T sig) yv -> sig yv +privateSamples = SigS.samples . signal + +{-# INLINE phantomSignal #-} +phantomSignal :: + RP.T s (T v y sig) yv -> RP.T s sig yv +phantomSignal = + RP.fromSignal . signal . RP.toSignal + + +{-# INLINE toAmplitudeScalar #-} +toAmplitudeScalar :: (Ind.C w, Field.C y, Dim.C v) => + w (T v y sig) yv -> DN.T v y -> y +toAmplitudeScalar sig y = + DN.divToScalar y (amplitude sig) + +{-# INLINE scalarSamples #-} +scalarSamples :: (Ind.C w, Ring.C y, Dim.C v) => + (DN.T v y -> y) -> w (S v y) y -> Sig.T y +scalarSamples toAmpScalar = + scalarSamplesPrivate toAmpScalar . Ind.toSignal + +{-# INLINE scalarSamplesGeneric #-} +scalarSamplesGeneric :: + (Ind.C w, Ring.C y, Dim.C v, Sample.C y, SigG.C sig) => + (DN.T v y -> y) -> w (T v y (SigS.T sig)) y -> sig y +scalarSamplesGeneric toAmpScalar = + scalarSamplesPrivateGeneric toAmpScalar . Ind.toSignal + +{-# INLINE vectorSamples #-} +vectorSamples :: (Ind.C w, Module.C y yv, Dim.C v) => + (DN.T v y -> y) -> w (S v y) yv -> Sig.T yv +vectorSamples toAmpScalar = + vectorSamplesPrivate toAmpScalar . Ind.toSignal + + +{-# INLINE rewriteDimension #-} +rewriteDimension :: (Dim.C v0, Dim.C v1) => + (v0 -> v1) -> T v0 y sig yv -> T v1 y sig yv +rewriteDimension f (Cons amp ss) = + Cons (DN.rewriteDimension f amp) ss + + +{-# INLINE fromSignal #-} +fromSignal :: DN.T v y -> SigS.R s yv -> R s v y yv +fromSignal amp = RP.fromSignal . Cons amp . RP.toSignal + + +{-# INLINE toScalarSignal #-} +toScalarSignal :: (Ind.C w, Field.C y, Dim.C v) => + DN.T v y -> w (S v y) y -> w (SigS.T Sig.T) y +toScalarSignal amp = + Ind.processSignal + (SigS.Cons . scalarSamplesPrivate (flip DN.divToScalar amp)) + +{-# INLINE toVectorSignal #-} +toVectorSignal :: (Ind.C w, Field.C y, Module.C y yv, Dim.C v) => + DN.T v y -> w (S v y) yv -> w (SigS.T Sig.T) yv +toVectorSignal amp = + Ind.processSignal + (SigS.Cons . vectorSamplesPrivate (flip DN.divToScalar amp)) + + +{-# INLINE scalarSamplesPrivate #-} +scalarSamplesPrivate :: (Ring.C y, Dim.C v) => + (DN.T v y -> y) -> S v y y -> Sig.T y +scalarSamplesPrivate toAmpScalar sig = + let y = toAmpScalar (privateAmplitude sig) + in Filt.amplify y (privateSamples sig) + +{-# INLINE scalarSamplesPrivateGeneric #-} +scalarSamplesPrivateGeneric :: + (Ring.C y, Dim.C v, Sample.C y, SigG.C sig) => + (DN.T v y -> y) -> T v y (SigS.T sig) y -> sig y +scalarSamplesPrivateGeneric toAmpScalar sig = + let y = toAmpScalar (privateAmplitude sig) + in FiltG.amplify y (privateSamples sig) + +{-# INLINE vectorSamplesPrivate #-} +vectorSamplesPrivate :: (Module.C y yv, Dim.C v) => + (DN.T v y -> y) -> S v y yv -> Sig.T yv +vectorSamplesPrivate toAmpScalar sig = + let y = toAmpScalar (privateAmplitude sig) + in y *> privateSamples sig + + +{-# INLINE fromSamples #-} +fromSamples :: DN.T v y -> Sig.T yv -> R s v y yv +fromSamples amp = fromSignal amp . SigS.fromSamples + +{-# INLINE fromScalarSamples #-} +fromScalarSamples :: DN.T v y -> Sig.T y -> R s v y y +fromScalarSamples = fromSamples + +{-# INLINE fromVectorSamples #-} +fromVectorSamples :: DN.T v y -> Sig.T yv -> R s v y yv +fromVectorSamples = fromSamples + +{-# INLINE replaceAmplitude #-} +replaceAmplitude :: (Ind.C w, Dim.C v0, Dim.C v1) => + DN.T v1 y -> w (T v0 y sig) yv -> w (T v1 y sig) yv +replaceAmplitude amp = Ind.processSignal (replaceAmplitudePrivate amp) + +{-# INLINE replaceSamples #-} +replaceSamples :: (Ind.C w, Dim.C v) => + sig1 yv1 -> w (T v y sig0) yv0 -> w (T v y (SigS.T sig1)) yv1 +replaceSamples ss = Ind.processSignal (replaceSamplesPrivate ss) + +{-# INLINE replaceAmplitudePrivate #-} +replaceAmplitudePrivate :: (Dim.C v0, Dim.C v1) => + DN.T v1 y -> T v0 y sig yv -> T v1 y sig yv +replaceAmplitudePrivate amp = Cons amp . signal + +{-# INLINE replaceSamplesPrivate #-} +replaceSamplesPrivate :: (Dim.C v) => + sig1 yv1 -> T v y sig0 yv0 -> T v y (SigS.T sig1) yv1 +replaceSamplesPrivate ss x = Cons (privateAmplitude x) (SigS.Cons ss) + + +{-# INLINE processSamples #-} +processSamples :: (Ind.C w, Dim.C v) => + (sig0 yv0 -> sig1 yv1) -> + w (T v y (SigS.T sig0)) yv0 -> w (T v y (SigS.T sig1)) yv1 +processSamples f = + Ind.processSignal (processSamplesPrivate f) + +{-# INLINE processSamplesPrivate #-} +processSamplesPrivate :: (Dim.C v) => + (sig0 yv0 -> sig1 yv1) -> + T v y (SigS.T sig0) yv0 -> T v y (SigS.T sig1) yv1 +processSamplesPrivate f (Cons amp sig) = + Cons amp (SigS.processSamplesPrivate f sig) + + +{-# INLINE asTypeOfAmplitude #-} +asTypeOfAmplitude :: y -> w (T v y sig) yv -> y +asTypeOfAmplitude = const diff --git a/src/Synthesizer/Dimensional/Causal/Process.hs b/src/Synthesizer/Dimensional/Causal/Process.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Dimensional/Causal/Process.hs @@ -0,0 +1,176 @@ +module Synthesizer.Dimensional.Causal.Process where + +import qualified Synthesizer.Causal.Process as Causal + +import qualified Synthesizer.Dimensional.Amplitude.Signal as SigA + +import qualified Algebra.Module as Module +import qualified Algebra.Field as Field +import Algebra.Module ((*>)) + +import qualified Number.DimensionTerm as DN +import qualified Algebra.DimensionTerm as Dim + +import qualified Control.Arrow as Arrow + +import Prelude hiding (map, ) + + +{- +TODO: +This differs from Rate.Process and Amplitude.Signal in the following way: +Here we expect, that @amp@ are types that contain physical units, +whereas Rate.Process.T has separate type variables for unit and values. +Thus Rate.Process.T is limited to DimensionalTerm numbers. +We need the additional flexibility here +because @amp@ can also be a pair of amplitudes +or a more complicated ensemble of amplitudes. +-} +newtype T amp0 amp1 yv0 yv1 = + Cons (amp0 -> (amp1, Causal.T yv0 yv1)) + + +{-# INLINE apply #-} +apply :: (Dim.C v0) => + T (DN.T v0 y0) (DN.T v1 y1) yv0 yv1 -> + SigA.R s v0 y0 yv0 -> SigA.R s v1 y1 yv1 +apply (Cons f) x = + let (yAmp, causal) = f (SigA.amplitude x) + in SigA.fromSamples yAmp (Causal.apply causal (SigA.samples x)) + + +{-# INLINE applyFst #-} +applyFst :: (Dim.C v0) => + T (DN.T v0 y0, restAmp) (DN.T v1 y1) (yv0, restSamp) yv1 -> + SigA.R s v0 y0 yv0 -> + T restAmp (DN.T v1 y1) restSamp yv1 +applyFst (Cons f) x = + Cons $ \yAmp -> + let (zAmp, causal) = f (SigA.amplitude x, yAmp) + in (zAmp, Causal.applyFst causal (SigA.samples x)) + +{-# INLINE map #-} +map :: + (amp0 -> amp1) -> + (yv0 -> yv1) -> + T amp0 amp1 yv0 yv1 +map f g = + Cons $ \ xAmp -> (f xAmp, Causal.map g) + + +infixr 3 *** +infixr 3 &&& +infixr 1 >>>, ^>>, >>^ +infixr 1 <<<, ^<<, <<^ + + +{-# INLINE compose #-} +{-# INLINE (>>>) #-} +compose, (>>>) :: + T amp0 amp1 yv0 yv1 -> + T amp1 amp2 yv1 yv2 -> + T amp0 amp2 yv0 yv2 +compose (Cons f) (Cons g) = + Cons $ \ xAmp -> + let (yAmp, causalXY) = f xAmp + (zAmp, causalYZ) = g yAmp + in (zAmp, Causal.compose causalXY causalYZ) + +(>>>) = compose + +{-# INLINE (<<<) #-} +(<<<) :: + T amp1 amp2 yv1 yv2 -> + T amp0 amp1 yv0 yv1 -> + T amp0 amp2 yv0 yv2 +(<<<) = flip (>>>) + + +{-# INLINE first #-} +first :: + T amp0 amp1 yv0 yv1 -> + T (amp0, amp) (amp1, amp) (yv0, yv) (yv1, yv) +first (Cons f) = + Cons $ \ (xAmp, amp) -> + let (yAmp, causal) = f xAmp + in ((yAmp, amp), Causal.first causal) + +{-# INLINE second #-} +second :: + T amp0 amp1 yv0 yv1 -> + T (amp, amp0) (amp, amp1) (yv, yv0) (yv, yv1) +second (Cons f) = + Cons $ \ (amp, xAmp) -> + let (yAmp, causal) = f xAmp + in ((amp, yAmp), Causal.second causal) + +{-# INLINE split #-} +{-# INLINE (***) #-} +split, (***) :: + T amp0 amp1 yv0 yv1 -> + T amp2 amp3 yv2 yv3 -> + T (amp0, amp2) (amp1, amp3) (yv0, yv2) (yv1, yv3) +split f g = + compose (first f) (second g) + +(***) = split + +{-# INLINE fanout #-} +{-# INLINE (&&&) #-} +fanout, (&&&) :: + T amp amp0 yv yv0 -> + T amp amp1 yv yv1 -> + T amp (amp0, amp1) yv (yv0, yv1) +fanout f g = + compose (map (\amp -> (amp,amp)) (\y -> (y,y))) (split f g) + +(&&&) = fanout + + +{-# INLINE (^>>) #-} +-- | Precomposition with a pure function. +(^>>) :: + (amp0 -> amp1, yv0 -> yv1) -> + T amp1 amp2 yv1 yv2 -> + T amp0 amp2 yv0 yv2 +f ^>> a = uncurry map f >>> a + +{-# INLINE (>>^) #-} +-- | Postcomposition with a pure function. +(>>^) :: + T amp0 amp1 yv0 yv1 -> + (amp1 -> amp2, yv1 -> yv2) -> + T amp0 amp2 yv0 yv2 +a >>^ f = a >>> uncurry map f + +{-# INLINE (<<^) #-} +-- | Precomposition with a pure function (right-to-left variant). +(<<^) :: + T amp1 amp2 yv1 yv2 -> + (amp0 -> amp1, yv0 -> yv1) -> + T amp0 amp2 yv0 yv2 +a <<^ f = a <<< uncurry map f + +{-# INLINE (^<<) #-} +-- | Postcomposition with a pure function (right-to-left variant). +(^<<) :: + (amp1 -> amp2, yv1 -> yv2) -> + T amp0 amp1 yv0 yv1 -> + T amp0 amp2 yv0 yv2 +f ^<< a = uncurry map f <<< a + + + +{-# INLINE loop #-} +-- loop :: a (b, d) (c, d) -> a b c +loop :: + (Field.C y, Module.C y yv, Dim.C v) => + DN.T v y -> + T (restAmp0, DN.T v y) (restAmp1, DN.T v y) (restSamp0, yv) (restSamp1, yv) -> + T restAmp0 restAmp1 restSamp0 restSamp1 +loop ampIn (Cons f) = + Cons $ \restAmp0 -> + let ((restAmp1, ampOut), causal) = f (restAmp0, ampIn) + in (restAmp1, + Causal.loop (causal Arrow.>>^ + Arrow.second (DN.divToScalar ampOut ampIn *>))) diff --git a/src/Synthesizer/Dimensional/ControlledProcess.hs b/src/Synthesizer/Dimensional/ControlledProcess.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Dimensional/ControlledProcess.hs @@ -0,0 +1,154 @@ +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes (OccasionallyScalar) + and local universal quantification + + +Basic definitions for signal processors +which are controlled by another signal. +If a control curve is expensive to compute, +or, what happens more frequently, +the conversion from natural control parameters +to internal control parameters is expensive, +then it can be more efficient to compute the control curve at a lower rate +and interpolate the internal control parameters of a particular process. +CSound and SuperCollider have a sample rate +that is common to all control curves +and they use constant interpolation exclusively. +-} +module Synthesizer.Dimensional.ControlledProcess where + +import qualified Synthesizer.Dimensional.Process as Proc +import qualified Synthesizer.Dimensional.Rate as Rate +import qualified Synthesizer.Dimensional.RatePhantom as RP +import qualified Synthesizer.Dimensional.RateWrapper as SigP +-- import qualified Synthesizer.Dimensional.Straight.Signal as SigS +-- import qualified Synthesizer.Dimensional.Amplitude.Signal as SigA +import qualified Synthesizer.Causal.Process as Causal +import qualified Synthesizer.Causal.Interpolation as Interpolation +import qualified Synthesizer.State.Signal as Sig +import qualified Number.DimensionTerm as DN +import qualified Algebra.DimensionTerm as Dim + +-- import Synthesizer.Dimensional.Process (($:), ($#), ) +-- import Synthesizer.Dimensional.RateAmplitude.Signal (($-)) + +-- import Number.DimensionTerm ((*&), ) -- ((&*&), (&/&)) + +import qualified Algebra.RealField as RealField +-- import qualified Algebra.Field as Field +-- import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +{- +import Control.Monad (liftM2, ) +import qualified Control.Applicative as App +import Control.Applicative (Applicative) +-} + +import NumericPrelude +{- +import PreludeBase as P +-} + + +{- | +@ec@ is the type for the curve of external control parameters, +@ic@ for internal control parameters. +-} +newtype T s u t ec ic a = Cons { + process :: Proc.T s u t (ec -> Sig.T ic, Sig.T ic -> a) + } + + +{-# INLINE runSynchronous #-} +runSynchronous :: + T s u t ec ic a -> + Proc.T s u t (ec -> a) +runSynchronous cp = + do (convert, func) <- process cp + return (func . convert) + +{-# INLINE runSynchronous1 #-} +runSynchronous1 :: + T s u t (RP.T s sig0 ec0) ic a -> + Proc.T s u t (RP.T s sig0 ec0 -> a) +runSynchronous1 = runSynchronous + +{-# INLINE runSynchronous2 #-} +runSynchronous2 :: + T s u t (RP.T s sig0 ec0, RP.T s sig1 ec1) ic a -> + Proc.T s u t (RP.T s sig0 ec0 -> RP.T s sig1 ec1 -> a) +runSynchronous2 = fmap curry . runSynchronous + +{-# INLINE runSynchronous3 #-} +runSynchronous3 :: + T s u t (RP.T s sig0 ec0, RP.T s sig1 ec1, RP.T s sig2 ec2) ic a -> + Proc.T s u t (RP.T s sig0 ec0 -> RP.T s sig1 ec1 -> RP.T s sig2 ec2 -> a) +runSynchronous3 = + fmap (\f x y z -> f (x,y,z)) . runSynchronous + + + +{-# INLINE runAsynchronous #-} +runAsynchronous :: + (Dim.C u, Additive.C ic, RealField.C t) => + Interpolation.T t ic -> + T s u t ec ic a -> + Rate.T r u t -> + ec -> + Proc.T s u t a +runAsynchronous ip cp srcRate sig = + do (convert, func) <- process cp + k <- fmap + (DN.divToScalar (Rate.toDimensionNumber srcRate)) + Proc.getSampleRate + return + (func (Causal.apply + (Interpolation.relativeConstantPad ip zero (convert sig)) + (Sig.repeat k))) + +{-# INLINE runAsynchronous1 #-} +runAsynchronous1 :: + (Dim.C u, Additive.C ic, RealField.C t) => + Interpolation.T t ic -> + T s u t (RP.T r sig0 ec0) ic a -> + SigP.T u t sig0 ec0 -> + Proc.T s u t a +runAsynchronous1 ip cp x = + uncurry (runAsynchronous ip cp) (SigP.toSignal x) + +{-# INLINE runAsynchronous2 #-} +runAsynchronous2 :: + (Dim.C u, Additive.C ic, RealField.C t) => + Interpolation.T t ic -> + T s u t (RP.T r sig0 ec0, RP.T r sig1 ec1) ic a -> + SigP.T u t sig0 ec0 -> + SigP.T u t sig1 ec1 -> + Proc.T s u t a +runAsynchronous2 ip cp x y = + let (srcRateX,sigX) = SigP.toSignal x + (srcRateY,sigY) = SigP.toSignal y + srcRate = Rate.common "ControlledProcess.runAsynchronous2" srcRateX srcRateY + in runAsynchronous ip cp srcRate (sigX,sigY) + +{-# INLINE runAsynchronous3 #-} +runAsynchronous3 :: + (Dim.C u, Additive.C ic, RealField.C t) => + Interpolation.T t ic -> + T s u t (RP.T r sig0 ec0, RP.T r sig1 ec1, RP.T r sig2 ec2) ic a -> + SigP.T u t sig0 ec0 -> + SigP.T u t sig1 ec1 -> + SigP.T u t sig2 ec2 -> + Proc.T s u t a +runAsynchronous3 ip cp x y z = + let (srcRateX,sigX) = SigP.toSignal x + (srcRateY,sigY) = SigP.toSignal y + (srcRateZ,sigZ) = SigP.toSignal z + common = Rate.common "ControlledProcess.runAsynchronous3" + srcRate = srcRateX `common` srcRateY `common` srcRateZ + in runAsynchronous ip cp srcRate (sigX,sigY,sigZ) diff --git a/src/Synthesizer/Dimensional/Cyclic/Signal.hs b/src/Synthesizer/Dimensional/Cyclic/Signal.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Dimensional/Cyclic/Signal.hs @@ -0,0 +1,95 @@ +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +Signals equipped with a phantom type parameter that reflects the sample rate. +-} +module Synthesizer.Dimensional.Cyclic.Signal where + +import qualified Synthesizer.Format as Format +import qualified Synthesizer.Dimensional.RatePhantom as RP + +import qualified Synthesizer.Dimensional.Straight.Signal as SigS +import qualified Synthesizer.State.Signal as Sig + +-- import qualified Number.DimensionTerm as DN +-- import qualified Algebra.DimensionTerm as Dim + +{- +import qualified Algebra.Module as Module +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +-} +import qualified Algebra.Additive as Additive + +-- import Number.DimensionTerm ((&/&)) + + +import NumericPrelude +import PreludeBase +import Prelude () + + +newtype T seq yv = + Cons { + samples :: seq yv {-^ the sampled values -} + } +-- deriving (Eq, Show) + +instance Functor seq => Functor (T seq) where + fmap f = Cons . fmap f . samples + +instance Format.C seq => Format.C (T seq) where + format p = Format.format p . samples + +instance (Format.C seq, Show y) => Show (T seq y) where + showsPrec = Format.format + + +type R s yv = RP.T s (T Sig.T) yv + + +{- +replaceSamples :: Sig.T yv1 -> R s yv0 -> R s yv1 +replaceSamples ss _ = fromSamples ss + + +processSamples :: + (Sig.T yv0 -> Sig.T yv1) -> R s yv0 -> R s yv1 +processSamples f x = + replaceSamples (f $ samples $ RP.toSignal x) x +-} + + +{-# INLINE fromPeriod #-} +fromPeriod :: Sig.T yv -> R s yv +fromPeriod = RP.fromSignal . Cons + +{-# INLINE fromPeriodList #-} +fromPeriodList :: [yv] -> R s yv +fromPeriodList = fromPeriod . Sig.fromList + +{-# INLINE toPeriod #-} +toPeriod :: R s yv -> Sig.T yv +toPeriod = samples . RP.toSignal + + +{- | +Periodization of a straight signal. +-} +{-# INLINE fromSignal #-} +fromSignal :: Additive.C yv => Int -> SigS.R s yv -> R s yv +fromSignal n = + fromPeriod . sum . Sig.sliceVert n . SigS.toSamples + +{- | +Convert a cyclic signal to a straight signal containing a loop. +-} +{-# INLINE toSignal #-} +toSignal :: Additive.C yv => R s yv -> SigS.R s yv +toSignal = + SigS.fromSamples . Sig.cycle . toPeriod diff --git a/src/Synthesizer/Dimensional/Process.hs b/src/Synthesizer/Dimensional/Process.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Dimensional/Process.hs @@ -0,0 +1,162 @@ +{-# OPTIONS -fglasgow-exts #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + and local universal quantification + + +Light-weight sample parameter inference which will fit most needs. +We only do \"poor man's inference\", only for sample rates. +The sample rate will be provided as an argument of a special type 'T'. +This argument will almost never be passed explicitly +but should be handled by operators analogous to '($)' and '(.)'. + +In contrast to the run-time inference approach, +we have the static guarantee that the sample rate is fixed +before passing a signal to the outside world. +However we still need to make it safe that signals +that are rendered for one sample rate +are not processed with another sample rate. +-} +module Synthesizer.Dimensional.Process ( + T(..), + run, {-share,-} withParam, getSampleRate, + toTimeScalar, toFrequencyScalar, + toTimeDimension, toFrequencyDimension, + loop, pure, + ($:), ($::), ($^), ($#), + (.:), (.^), + liftP, liftP2, liftP3, liftP4, + ) where + +import qualified Synthesizer.Dimensional.Rate as Rate +import qualified Number.DimensionTerm as DN +import qualified Algebra.DimensionTerm as Dim + +import Number.DimensionTerm ((*&), ) -- ((&*&), (&/&)) + +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring + +import Control.Monad.Fix (MonadFix(mfix), ) +-- import Control.Monad.Reader () +import Synthesizer.ApplicativeUtility +import qualified Control.Applicative as App +import Control.Applicative (Applicative) + + +{- +import NumericPrelude +import PreludeBase as P +-} + + +{- | +This wraps a function which computes a sample rate dependent result. +Sample rate tells how many values per unit are stored +for representation of a signal. + +The process is labeled with a type variable @s@ which is part the signals. +This way we can ensure that signals are only used +with the sample rate they are created for. +-} +newtype T s u t a = Cons {process :: Rate.T s u t -> a} + +instance Functor (T s u t) where + fmap f (Cons g) = Cons (f . g) + +instance Applicative (T s u t) where + pure = pure + (<*>) = apply + +instance Monad (T s u t) where + return = pure + (>>=) = bind + +instance MonadFix (T s u t) where + mfix = loop . withParam + + +{-# INLINE pure #-} +pure :: a -> T s u t a +pure = Cons . const + +{-# INLINE apply #-} +apply :: T s u t (a -> b) -> T s u t a -> T s u t b +apply (Cons f) arg = Cons $ \sr -> f sr (process arg sr) + + +{- | +Get results from the Process monad. +You can obtain only signals (or other values) +that do not implicitly depend on the sample rate, +that is value without the @s@ type parameter. +-} +{-# INLINE run #-} +run :: (Dim.C u) => DN.T (Dim.Recip u) t -> (forall s. T s u t a) -> a +run sampleRate f = process f (Rate.fromDimensionNumber sampleRate) + +{- +{- | +You can write +@x >>= (\x0 -> Cut.zip $# x0 $# x0)@ +or +@share x (\x0 -> Cut.zip $: x0 $: x0)@. +'share' allows for more consistent usage of @($:)@. +-} +share :: T s u t a -> (T s u t a -> T s u t b) -> T s u t b +share x y = y . return =<< x +-} + +{-# INLINE bind #-} +bind :: T s u t a -> (a -> T s u t b) -> T s u t b +bind (Cons f) mg = + Cons $ \ sr -> process (mg (f sr)) sr + +-- same as Inference.Reader.Process.injectParam +{-# INLINE withParam #-} +withParam :: (a -> T s u t b) -> T s u t (a -> b) +withParam f = Cons (\sr a -> process (f a) sr) + + +{-# INLINE getSampleRate #-} +getSampleRate :: Dim.C u => T s u t (DN.T (Dim.Recip u) t) +getSampleRate = Cons Rate.toDimensionNumber + + +{-# INLINE toTimeScalar #-} +toTimeScalar {- , (~*&) -} :: (Ring.C t, Dim.C u) => + DN.T u t -> T s u t t +toTimeScalar time = + fmap (DN.mulToScalar time) getSampleRate + +{-# INLINE toFrequencyScalar #-} +toFrequencyScalar {- , (~/&) -} :: (Field.C t, Dim.C u) => + DN.T (Dim.Recip u) t -> T s u t t +toFrequencyScalar freq = + fmap (DN.divToScalar freq) getSampleRate + + +{-# INLINE toTimeDimension #-} +toTimeDimension :: (Field.C t, Dim.C u) => + t -> T s u t (DN.T u t) +toTimeDimension t = + fmap (\sampleRate -> t *& DN.unrecip sampleRate) getSampleRate + +{-# INLINE toFrequencyDimension #-} +toFrequencyDimension :: (Ring.C t, Dim.C u) => + t -> T s u t (DN.T (Dim.Recip u) t) +toFrequencyDimension f = + fmap (\sampleRate -> f *& sampleRate) getSampleRate + + +{- +infixl 7 ~*&, ~/& + +(~*&) = toTimeScalar +(~/&) = toFrequencyScalar +-} diff --git a/src/Synthesizer/Dimensional/Rate.hs b/src/Synthesizer/Dimensional/Rate.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Dimensional/Rate.hs @@ -0,0 +1,71 @@ +{- | + +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + + + +Light-weight sample parameter inference which will fit most needs. +We only do \"poor man's inference\", only for sample rates. +The sample rate will be provided as an argument of a special type 'T'. +This argument will almost never be passed explicitly +but should be handled by operators analogous to '($)' and '(.)'. + +In contrast to the run-time inference approach, +we have the static guarantee that the sample rate is fixed +before passing a signal to the outside world. +However we still need to make it safe that signals +that are rendered for one sample rate +are not processed with another sample rate. +We should wrap @T s u t -> a@ in a @Reader@ monad, but that's not all. +We must investigate a little more here. +Maybe we need another type parameter for the sample rate and the signals +in order to show that they belong together, +like it is done in the ST monad. +-} +module Synthesizer.Dimensional.Rate where + +import qualified Number.DimensionTerm as DN +import qualified Algebra.DimensionTerm as Dim + +import qualified Synthesizer.Utility as Util + +{- +import NumericPrelude +import PreludeBase as P +-} + + +{- | +This wraps a function which computes a sample rate dependent result. +Sample rate tells how many values per unit are stored +for representation of a signal. +-} +newtype T s u t = Cons {decons :: DN.T (Dim.Recip u) t} + deriving (Eq, Ord, Show) + + +{-# INLINE fromNumber #-} +fromNumber :: Dim.C u => Dim.Recip u -> t -> T s u t +fromNumber u = Cons . DN.fromNumberWithDimension u + +{-# INLINE toNumber #-} +toNumber :: Dim.C u => Dim.Recip u -> T s u t -> t +toNumber u = DN.toNumberWithDimension u . decons + +{-# INLINE fromDimensionNumber #-} +fromDimensionNumber :: Dim.C u => DN.T (Dim.Recip u) t -> T s u t +fromDimensionNumber = Cons + +{-# INLINE toDimensionNumber #-} +toDimensionNumber :: Dim.C u => T s u t -> DN.T (Dim.Recip u) t +toDimensionNumber = decons + +{-# INLINE common #-} +common :: Eq t => String -> T s u t -> T s u t -> T s u t +common funcName = + Util.common ("Sample rates differ in " ++ funcName) diff --git a/src/Synthesizer/Dimensional/Rate/Analysis.hs b/src/Synthesizer/Dimensional/Rate/Analysis.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Dimensional/Rate/Analysis.hs @@ -0,0 +1,79 @@ +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes +-} +module Synthesizer.Dimensional.Rate.Analysis ( + centroid, + length, + + centroidProc, + lengthProc, + ) where + +import qualified Synthesizer.Dimensional.Straight.Signal as SigS +import qualified Synthesizer.Dimensional.RateWrapper as SigP + +import qualified Synthesizer.State.Analysis as Ana +import qualified Synthesizer.State.Signal as Sig + +import qualified Synthesizer.Dimensional.Process as Proc + +import qualified Number.DimensionTerm as DN +import qualified Algebra.DimensionTerm as Dim + +import Number.DimensionTerm ((*&)) + +import qualified Algebra.Field as Field +-- import qualified Algebra.Real as Real +-- import qualified Algebra.Ring as Ring + + +import PreludeBase ((.), ($), ) +import NumericPrelude +import Prelude () + + + +{-# INLINE centroid #-} +centroid :: (Field.C q, Dim.C u) => + SigP.T u q (SigS.T Sig.T) q -> DN.T u q +centroid = makePhysicalLength Ana.centroid + +{-# INLINE length #-} +length :: (Field.C t, Dim.C u) => + SigP.T u t (SigS.T Sig.T) yv -> DN.T u t +length = makePhysicalLength (fromIntegral . Sig.length) + +{-# INLINE makePhysicalLength #-} +makePhysicalLength :: (Field.C t, Dim.C u) => + (Sig.T y -> t) -> + SigP.T u t (SigS.T Sig.T) y -> DN.T u t +makePhysicalLength f x = + f (SigS.samples (SigP.signal x)) *& DN.unrecip (SigP.sampleRate x) + + +{-# DEPRECATED #-} +{-# INLINE centroidProc #-} +centroidProc :: (Field.C y, Dim.C u) => + Proc.T s u y (SigS.R s y -> DN.T u y) +centroidProc = makePhysicalLengthProc Ana.centroid + +{-# DEPRECATED #-} +{-# INLINE lengthProc #-} +lengthProc :: (Field.C y, Dim.C u) => + Proc.T s u y (SigS.R s y -> DN.T u y) +lengthProc = makePhysicalLengthProc (fromIntegral . Sig.length) + +{-# INLINE makePhysicalLengthProc #-} +makePhysicalLengthProc :: (Field.C t, Dim.C u) => + (Sig.T y -> t) -> + Proc.T s u t ( + SigS.R s y -> + DN.T u t) +makePhysicalLengthProc f = + Proc.withParam $ + Proc.toTimeDimension . f . SigS.toSamples diff --git a/src/Synthesizer/Dimensional/Rate/Control.hs b/src/Synthesizer/Dimensional/Rate/Control.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Dimensional/Rate/Control.hs @@ -0,0 +1,83 @@ +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + + +Control curves which can be used +as envelopes, for controlling filter parameters and so on. +-} +module Synthesizer.Dimensional.Rate.Control + ({- * Primitives -} + constant, linear, exponential, exponential2, ) + where + +import qualified Synthesizer.Dimensional.Straight.Signal as SigS + +import qualified Synthesizer.State.Control as Ctrl +-- import qualified Synthesizer.State.Signal as Sig + +import qualified Synthesizer.Dimensional.Process as Proc + +-- import Synthesizer.Dimensional.Process (($#), ) + +import qualified Number.DimensionTerm as DN +import qualified Algebra.DimensionTerm as Dim + +-- import Number.DimensionTerm ((&*&)) + +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Field as Field +-- import qualified Algebra.Real as Real +import qualified Algebra.Ring as Ring +-- import qualified Algebra.Additive as Additive + +import NumericPrelude +import PreludeBase +import Prelude () + + +{-# INLINE constant #-} +constant :: (Ring.C y, Dim.C u) => + Proc.T s u t (SigS.R s y) +constant = Proc.pure $ SigS.fromSamples $ Ctrl.constant one + +{- | +Caution: This control curve can contain samples +with an absolute value greater than 1. +The linear curve starts with zero. +-} +{-# INLINE linear #-} +linear :: + (Field.C q, Dim.C u) => + DN.T u q {-^ distance until curve reaches one -} + -> Proc.T s u q (SigS.R s q) +linear dist = + fmap + (SigS.fromSamples . Ctrl.linearMultiscaleNeutral . recip) + (Proc.toTimeScalar dist) + +{-# INLINE exponential #-} +exponential :: (Trans.C q, Dim.C u) => + DN.T u q {-^ time where the function reaches 1\/e of the initial value -} + -> Proc.T s u q (SigS.R s q) +exponential time = + fmap + (SigS.fromSamples . Ctrl.exponentialMultiscaleNeutral) + (Proc.toTimeScalar time) + +{- + take 1000 $ show (run (fixSampleRate 100 (exponential 0.1 1)) :: SigDouble) +-} + +{-# INLINE exponential2 #-} +exponential2 :: (Trans.C q, Dim.C u) => + DN.T u q {-^ half life, time where the function reaches 1\/2 of the initial value -} + -> Proc.T s u q (SigS.R s q) +exponential2 time = + fmap + (SigS.fromSamples . Ctrl.exponential2MultiscaleNeutral) + (Proc.toTimeScalar time) diff --git a/src/Synthesizer/Dimensional/Rate/Cut.hs b/src/Synthesizer/Dimensional/Rate/Cut.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Dimensional/Rate/Cut.hs @@ -0,0 +1,55 @@ +{-# OPTIONS -fno-implicit-prelude #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes +-} +module Synthesizer.Dimensional.Rate.Cut ( + take, drop, + ) where + +import qualified Synthesizer.Dimensional.Abstraction.Homogeneous as Hom + +import qualified Synthesizer.Dimensional.RatePhantom as RP + +import qualified Synthesizer.Dimensional.Process as Proc +-- import qualified Synthesizer.Dimensional.Rate as Rate + +-- import Synthesizer.Dimensional.Process ((.:), (.^), ) + +import qualified Synthesizer.Dimensional.RateAmplitude.Signal as SigA +import qualified Synthesizer.State.Signal as Sig + +import Synthesizer.Dimensional.RateAmplitude.Signal + (toTimeScalar, ) + +import qualified Number.DimensionTerm as DN +import qualified Algebra.DimensionTerm as Dim + +-- import qualified Number.NonNegative as NonNeg + +import qualified Algebra.RealField as RealField +-- import qualified Algebra.Field as Field + + +import NumericPrelude hiding (negate) +-- import PreludeBase as P +import Prelude hiding (take, drop, ) + + +{-# INLINE take #-} +take :: (Hom.C sig, RealField.C t, Dim.C u) => + DN.T u t -> Proc.T s u t (RP.T s sig y -> RP.T s sig y) +take t' = + do t <- toTimeScalar t' + return $ Hom.processSamples (Sig.take (RealField.round t)) + +{-# INLINE drop #-} +drop :: (Hom.C sig, RealField.C t, Dim.C u) => + DN.T u t -> Proc.T s u t (RP.T s sig y -> RP.T s sig y) +drop t' = + do t <- toTimeScalar t' + return $ Hom.processSamples (Sig.drop (RealField.round t)) diff --git a/src/Synthesizer/Dimensional/Rate/Filter.hs b/src/Synthesizer/Dimensional/Rate/Filter.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Dimensional/Rate/Filter.hs @@ -0,0 +1,579 @@ +{-# OPTIONS -fno-implicit-prelude #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes +-} +module Synthesizer.Dimensional.Rate.Filter ( + {- * Non-recursive -} + + {- ** Amplification -} + negate, + envelope, + envelopeVector, + convolveVector, + + {- ** Smooth -} + mean, + meanStatic, + + {- ** Delay -} + delay, + phaseModulation, + phaser, + phaserStereo, + frequencyModulation, + frequencyModulationDecoupled, + + + {- * Recursive -} + + {- ** Without resonance -} + firstOrderLowpass, + firstOrderHighpass, + butterworthLowpass, + butterworthHighpass, + chebyshevALowpass, + chebyshevAHighpass, + chebyshevBLowpass, + chebyshevBHighpass, + {- ** With resonance -} + universal, + highpassFromUniversal, + bandpassFromUniversal, + lowpassFromUniversal, + moogLowpass, + + {- ** Allpass -} + allpassCascade, + + {- ** Reverb -} + comb, + + {- * Helper functions -} + interpolateMultiRelativeZeroPad, +) where + +-- import qualified Synthesizer.Dimensional.Abstraction.Linear as Lin +import qualified Synthesizer.Dimensional.Abstraction.Homogeneous as Hom +-- import qualified Synthesizer.Dimensional.Abstraction.RateIndependent as Ind +import qualified Synthesizer.Dimensional.Abstraction.Flat as Flat + +import qualified Synthesizer.Dimensional.RatePhantom as RP + +import qualified Synthesizer.Dimensional.Amplitude.Filter as FiltV +import qualified Synthesizer.Dimensional.Process as Proc +-- import qualified Synthesizer.Dimensional.Rate as Rate + +-- import Synthesizer.Dimensional.Process ((.:), (.^), ) + +import qualified Synthesizer.Dimensional.Straight.Signal as SigS +import qualified Synthesizer.Dimensional.RateAmplitude.Signal as SigA +import qualified Synthesizer.Dimensional.RateWrapper as SigP +import qualified Synthesizer.State.Signal as Sig +import Synthesizer.Plain.Signal (Modifier) + +import Synthesizer.Dimensional.RateAmplitude.Signal + (toTimeScalar, toFrequencyScalar, ) + +import qualified Synthesizer.Causal.Process as Causal +import qualified Synthesizer.Causal.Interpolation as Interpolation +import qualified Synthesizer.State.Displacement as Disp +import qualified Synthesizer.State.Filter.Delay as Delay +import qualified Synthesizer.State.Filter.Recursive.MovingAverage as MA +import qualified Synthesizer.State.Filter.NonRecursive as FiltNR + +import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1 +import qualified Synthesizer.Plain.Filter.Recursive.Allpass as Allpass +import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilter +import qualified Synthesizer.Plain.Filter.Recursive.Moog as Moog +import qualified Synthesizer.Plain.Filter.Recursive.Butterworth as Butter +import qualified Synthesizer.Plain.Filter.Recursive.Chebyshev as Cheby +import qualified Synthesizer.Plain.Filter.Recursive as FiltR + +import qualified Synthesizer.Storable.Signal as SigSt +import qualified Synthesizer.Storable.Filter.Recursive.Comb as Comb + +-- import qualified Synthesizer.Generic.Interpolation as InterpolationG +import qualified Synthesizer.Generic.Filter.Recursive.MovingAverage as MAG +import qualified Synthesizer.Generic.Filter.NonRecursive as FiltG +import qualified Synthesizer.Generic.Filter.Delay as DelayG +import qualified Synthesizer.Generic.Signal as SigG +import qualified Synthesizer.Generic.SampledValue as Sample + +import qualified Synthesizer.Frame.Stereo as Stereo + +import qualified Number.DimensionTerm as DN +import qualified Algebra.DimensionTerm as Dim + +import qualified Number.NonNegative as NonNeg + +import qualified Algebra.Transcendental as Trans +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +-- import qualified Algebra.Real as Real +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive +import qualified Algebra.VectorSpace as VectorSpace +import qualified Algebra.Module as Module + +-- import Synthesizer.Utility(clip) + +-- import qualified Data.List as List + +-- import Control.Monad(liftM2) + +import NumericPrelude hiding (negate) +import PreludeBase as P +import Prelude () + + +{-# INLINE negate #-} +negate :: (Hom.C sig, Additive.C yv, Dim.C u) => + Proc.T s u t ( + RP.T s sig yv + -> RP.T s sig yv) +negate = Proc.pure FiltV.negate + + +{-# INLINE envelope #-} +envelope :: (Hom.C sig, Flat.C flat y0, Ring.C y0, Dim.C u) => + Proc.T s u t ( + RP.T s flat y0 {- v the envelope -} + -> RP.T s sig y0 {- v the signal to be enveloped -} + -> RP.T s sig y0) +envelope = Proc.pure FiltV.envelope + +{-# INLINE envelopeVector #-} +envelopeVector :: + (Hom.C sig, Flat.C flat y0, Module.C y0 yv, Dim.C u) => + Proc.T s u t ( + RP.T s flat y0 {- v the envelope -} + -> RP.T s sig yv {- v the signal to be enveloped -} + -> RP.T s sig yv) +envelopeVector = Proc.pure FiltV.envelopeVector + +{-# INLINE convolveVector #-} +convolveVector :: + (Hom.C sig, Module.C q yv, Field.C q, Dim.C u, Sample.C q) => + Proc.T s u q ( + SigA.R s (Dim.Recip u) q q + {- v the filter window -} + -> RP.T s sig yv {- v the signal to be enveloped -} + -> RP.T s sig yv) +convolveVector = + do toFreq <- Proc.withParam toFrequencyScalar + return $ \ window -> + Hom.processSamples + (FiltNR.generic (SigA.scalarSamples toFreq window)) + + +{- | needs a better handling of boundaries, yet -} +{-# INLINE meanStatic #-} +meanStatic :: (Hom.C sig, Additive.C yv, RealField.C q, + Module.C q yv, Dim.C u) => + DN.T (Dim.Recip u) q {- ^ cut-off freqeuncy -} + -> Proc.T s u q ( + RP.T s sig yv + -> RP.T s sig yv) +meanStatic freq = + do f <- toFrequencyScalar freq + return $ + let tInt = round ((recip f - 1)/2) + width = tInt*2+1 + in Hom.processSamples + ((asTypeOf (recip (fromIntegral width)) f *> ) . + Delay.staticNeg tInt . + MA.sumsStaticInt width) + +{- | needs a better handling of boundaries, yet -} +{-# INLINE mean #-} +mean :: (Hom.C sig, Additive.C yv, RealField.C q, + Module.C q yv, Dim.C u, Sample.C q, Sample.C yv) => + DN.T (Dim.Recip u) q {- ^ minimum cut-off freqeuncy -} + -> Proc.T s u q ( + SigA.R s (Dim.Recip u) q q + {- v cut-off freqeuncies -} + -> RP.T s sig yv + -> RP.T s sig yv) +mean minFreq = + do mf <- toFrequencyScalar minFreq + frequencyControl $ \ freqs -> + let tMax = ceiling (recip (2*mf)) + err = error "Filter.mean: frequencies must be positive" + widths = Sig.map (\f -> if f>0 then recip (2*f) else err) freqs + in Hom.processSamples + (fromStorable . +-- MAG.sumsStaticInt tMax . + MAG.modulatedFrac tMax (toStorable widths) . + toStorable) + +{-# INLINE delay #-} +delay :: (Hom.C sig, Additive.C yv, RealField.C t, Dim.C u) => + DN.T u t + -> Proc.T s u t ( + RP.T s sig yv + -> RP.T s sig yv) +delay time = + do t <- toTimeScalar time + return $ Hom.processSamples (Delay.static (round t)) + + +{-# INLINE toStorable #-} +toStorable :: (Sample.C a) => Sig.T a -> SigSt.T a +toStorable = Sig.toStorableSignal SigSt.defaultChunkSize + +{-# INLINE fromStorable #-} +fromStorable :: (Sample.C a) => SigSt.T a -> Sig.T a +fromStorable = Sig.fromStorableSignal + +{-# INLINE phaseModulation #-} +phaseModulation :: + (Hom.C sig, Additive.C yv, RealField.C q, Dim.C u, + Sample.C q, Sample.C yv) => + Interpolation.T q yv + -> DN.T u q + {- ^ minimal deviation from current time, usually negative -} + -> DN.T u q + {- ^ maximal deviation, it must be @minDev <= maxDev@ + and the modulation must always be + in the range [minDev,maxDev]. -} + -> Proc.T s u q ( + SigA.R s u q q + {- v deviation control, + positive numbers meanStatic prefetch, + negative numbers meanStatic delay -} + -> RP.T s sig yv + -> RP.T s sig yv) +phaseModulation ip minDev maxDev = + fmap + (\f devs -> + Hom.processSamples + (Sig.fromStorableSignal . + f (SigA.processSamples toStorable devs) . + toStorable)) + (phaseModulationGeneric ip minDev maxDev) + +{-# INLINE phaseModulationGeneric #-} +phaseModulationGeneric :: + (Additive.C yv, RealField.C q, Dim.C u, + Sample.C q, Sample.C yv, SigG.C sig) => + Interpolation.T q yv + -> DN.T u q + {- ^ minimal deviation from current time, usually negative -} + -> DN.T u q + {- ^ maximal deviation, it must be @minDev <= maxDev@ + and the modulation must always be + in the range [minDev,maxDev]. -} + -> Proc.T s u q ( + RP.T s (SigA.T u q (SigS.T sig)) q + {- v deviation control, + positive numbers meanStatic prefetch, + negative numbers meanStatic delay -} + -> sig yv + -> sig yv) +phaseModulationGeneric ip minDev _maxDev = + fmap + (\toTime devs -> + let t0 = toTime minDev + tInt0 = floor t0 + in DelayG.modulated (Interpolation.toGeneric ip) tInt0 + (SigG.map (max t0) (SigA.scalarSamplesGeneric toTime devs))) + (Proc.withParam toTimeScalar) + + +{- +FIXME: move to Dimensional.Straight +-} +{-# INLINE frequencyModulation #-} +frequencyModulation :: + (Hom.C sig, Flat.C flat q, Additive.C yv, RealField.C q, Dim.C u) => + Interpolation.T q yv + -> Proc.T s u q ( + RP.T s flat q {- v frequency factors -} + -> RP.T s sig yv + -> RP.T s sig yv) +frequencyModulation ip = + Proc.pure $ + \ factors -> + Hom.processSamples + (interpolateMultiRelativeZeroPad ip (Flat.toSamples factors)) + +{- | +Frequency modulation where the input signal can have a sample rate +different from the output. +(The sample rate values can differ, the unit must be the same. +We could lift that restriction, +but then the unit handling becomes more complicated, +and I didn't have a use for it so far.) + +The function can be used for resampling. +-} +{-# INLINE frequencyModulationDecoupled #-} +frequencyModulationDecoupled :: + (Additive.C yv, RealField.C q, Dim.C u) => + Interpolation.T q yv + -> Proc.T s u q ( + SigS.R s q {- v frequency factors -} + -> SigP.T u q (SigS.T Sig.T) yv + -> SigS.R s yv) +frequencyModulationDecoupled ip = + fmap + (\toFreq factors y -> + flip SigS.processSamples (RP.fromSignal (SigP.signal y)) $ + (interpolateMultiRelativeZeroPad ip + (SigA.scalarSamples toFreq + (SigA.fromSignal (SigP.sampleRate y) factors)))) + (Proc.withParam Proc.toFrequencyScalar) + + + +{-# INLINE interpolateMultiRelativeZeroPad #-} +interpolateMultiRelativeZeroPad :: + (RealField.C q, Additive.C yv) => + Interpolation.T q yv + -> Sig.T q + -> Sig.T yv + -> Sig.T yv +interpolateMultiRelativeZeroPad ip k x = + Causal.apply (Interpolation.relativeZeroPad zero ip zero x) k + +{- | symmetric phaser -} +{-# INLINE phaser #-} +phaser :: + (Hom.C sig, Additive.C yv, RealField.C q, + Module.C q yv, Dim.C u, + Sample.C q, Sample.C yv) => + Interpolation.T q yv + -> DN.T u q {- ^ maxDev, must be positive -} + -> Proc.T s u q ( + SigA.R s u q q + {- v delay control -} + -> RP.T s sig yv + -> RP.T s sig yv) +phaser ip maxDev = + fmap + (\p devs -> + Hom.processSamples + (FiltNR.amplifyVector (SigA.asTypeOfAmplitude 0.5 devs) . + uncurry Disp.mix . p devs)) + (phaserCore ip maxDev) + +{-# INLINE phaserStereo #-} +phaserStereo :: + (Hom.C sig, Additive.C yv, RealField.C q, + Module.C q yv, Dim.C u, + Sample.C q, Sample.C yv) => + Interpolation.T q yv + -> DN.T u q {- ^ maxDev, must be positive -} + -> Proc.T s u q ( + SigA.R s u q q + {- v delay control -} + -> RP.T s sig yv + -> RP.T s sig (Stereo.T yv)) +phaserStereo ip maxDev = + fmap + (\p devs -> + Hom.processSamples (uncurry (Sig.zipWith Stereo.cons) . p devs)) + (phaserCore ip maxDev) + +{-# INLINE phaserCore #-} +phaserCore :: + (Additive.C yv, RealField.C q, + Module.C q yv, Dim.C u, + Sample.C q, Sample.C yv) => + Interpolation.T q yv + -> DN.T u q {- ^ maxDev, must be positive -} + -> Proc.T s u q ( + SigA.R s u q q + {- v delay control -} + -> Sig.T yv + -> (Sig.T yv, Sig.T yv)) +phaserCore ip maxDev = + do let minDev = Additive.negate maxDev + pm <- phaseModulationGeneric ip minDev maxDev + return $ \ devs x -> + let devsPos = SigA.processSamples toStorable devs + devsNeg = SigA.processSamples FiltG.negate devsPos + xst = toStorable x + in (fromStorable (pm devsPos xst), + fromStorable (pm devsNeg xst)) + + +{-# INLINE firstOrderLowpass #-} +{-# INLINE firstOrderHighpass #-} +firstOrderLowpass, firstOrderHighpass :: + (Hom.C sig, Trans.C q, Module.C q yv, Dim.C u) => + Proc.T s u q ( + SigA.R s (Dim.Recip u) q q + {- v Control signal for the cut-off frequency. -} + -> RP.T s sig yv + {- v Input signal -} + -> RP.T s sig yv) +firstOrderLowpass = firstOrderGen Filt1.lowpassModifier +firstOrderHighpass = firstOrderGen Filt1.highpassModifier + +{-# INLINE firstOrderGen #-} +firstOrderGen :: + (Hom.C sig, Trans.C q, Module.C q yv, Dim.C u) => + (Modifier yv (Filt1.Parameter q) yv yv) + -> Proc.T s u q ( + SigA.R s (Dim.Recip u) q q + -> RP.T s sig yv + -> RP.T s sig yv) +firstOrderGen modif = + frequencyControl $ \ freqs -> + modifyModulated Filt1.parameter modif freqs + + +{-# INLINE butterworthLowpass #-} +{-# INLINE butterworthHighpass #-} +{-# INLINE chebyshevALowpass #-} +{-# INLINE chebyshevAHighpass #-} +{-# INLINE chebyshevBLowpass #-} +{-# INLINE chebyshevBHighpass #-} + +butterworthLowpass, butterworthHighpass, + chebyshevALowpass, chebyshevAHighpass, + chebyshevBLowpass, chebyshevBHighpass :: + (Hom.C sig, Trans.C q, VectorSpace.C q yv, Dim.C u) => + NonNeg.Int {- ^ Order of the filter, must be even, + the higher the order, the sharper is the separation of frequencies. -} + -> q {- ^ The attenuation at the cut-off frequency. + Should be between 0 and 1. -} + -> Proc.T s u q ( + SigA.R s (Dim.Recip u) q q + {- v Control signal for the cut-off frequency. -} + -> RP.T s sig yv {- v Input signal -} + -> RP.T s sig yv) + +butterworthLowpass = higherOrderNoResoGen Butter.lowpass +butterworthHighpass = higherOrderNoResoGen Butter.highpass +chebyshevALowpass = higherOrderNoResoGen Cheby.lowpassA +chebyshevAHighpass = higherOrderNoResoGen Cheby.highpassA +chebyshevBLowpass = higherOrderNoResoGen Cheby.lowpassB +chebyshevBHighpass = higherOrderNoResoGen Cheby.highpassB + + +{-# INLINE higherOrderNoResoGen #-} +higherOrderNoResoGen :: + (Hom.C sig, Field.C q, Dim.C u) => + (Int -> q -> [q] -> [yv] -> [yv]) + -> NonNeg.Int + -> q + -> Proc.T s u q ( + SigA.R s (Dim.Recip u) q q + -> RP.T s sig yv + -> RP.T s sig yv) +higherOrderNoResoGen filt order ratio = + frequencyControl $ \ freqs -> + Hom.processSampleList (filt (NonNeg.toNumber order) ratio (Sig.toList freqs)) + + + +highpassFromUniversal, bandpassFromUniversal, lowpassFromUniversal :: + (Hom.C sig, Dim.C u) => + Proc.T s u q ( + RP.T s sig (UniFilter.Result yv) + -> RP.T s sig yv) +highpassFromUniversal = return (Hom.processSamples (Sig.map UniFilter.highpass)) +bandpassFromUniversal = return (Hom.processSamples (Sig.map UniFilter.bandpass)) +lowpassFromUniversal = return (Hom.processSamples (Sig.map UniFilter.lowpass)) + + +{-# INLINE universal #-} +universal :: + (Hom.C sig, Flat.C flat q, Trans.C q, Module.C q yv, Dim.C u) => + Proc.T s u q ( + RP.T s flat q + {- v signal for resonance, + i.e. factor of amplification at the resonance frequency + relatively to the transition band. -} + -> SigA.R s (Dim.Recip u) q q + {- v signal for cut off and band center frequency -} + -> RP.T s sig yv + {- v input signal -} + -> RP.T s sig (UniFilter.Result yv)) + {- ^ highpass, bandpass, lowpass filter -} +universal = + fmap flip $ frequencyControl $ \ freqs reso -> + let resos = Flat.toSamples reso + in modifyModulated + UniFilter.parameter + UniFilter.modifier + (Sig.zipWith FiltR.Pole resos freqs) + +{-# INLINE moogLowpass #-} +moogLowpass :: (Hom.C sig, Flat.C flat q, Trans.C q, Module.C q yv, Dim.C u) => + NonNeg.Int + -> Proc.T s u q ( + RP.T s flat q + {- v signal for resonance, + i.e. factor of amplification at the resonance frequency + relatively to the transition band. -} + -> SigA.R s (Dim.Recip u) q q + {- v signal for cut off frequency -} + -> RP.T s sig yv + -> RP.T s sig yv) +moogLowpass order = + fmap flip $ frequencyControl $ \ freqs reso -> + let resos = Flat.toSamples reso + orderInt = NonNeg.toNumber order + in modifyModulated + (Moog.parameter orderInt) + (Moog.lowpassModifier orderInt) + (Sig.zipWith FiltR.Pole resos freqs) + + +{-# INLINE allpassCascade #-} +allpassCascade :: (Hom.C sig, Trans.C q, Module.C q yv, Dim.C u) => + NonNeg.Int {- ^ order, number of filters in the cascade -} + -> q {- ^ the phase shift to be achieved for the given frequency -} + -> Proc.T s u q ( + SigA.R s (Dim.Recip u) q q {- v lowest comb frequency -} + -> RP.T s sig yv + -> RP.T s sig yv) +allpassCascade order phase = + frequencyControl $ \ freqs -> + let orderInt = NonNeg.toNumber order + in modifyModulated + (Allpass.parameter orderInt phase) + (Allpass.cascadeModifier orderInt) + freqs + + +{- | Infinitely many equi-delayed exponentially decaying echos. -} +{-# INLINE comb #-} +comb :: (Hom.C sig, RealField.C t, Module.C y yv, Dim.C u, Sample.C yv) => + DN.T u t -> y -> Proc.T s u t (RP.T s sig yv -> RP.T s sig yv) +comb time gain = + do t <- toTimeScalar time + return $ Hom.processSamples + (fromStorable . Comb.run (round t) gain . toStorable) + + +-- * auxiliary functions + +{-# INLINE frequencyControl #-} +frequencyControl :: (Dim.C u, Field.C y) => + (Sig.T y -> t) + -> Proc.T s u y ( + SigA.R s (Dim.Recip u) y y + -> t) +frequencyControl f = + do toFreq <- Proc.withParam toFrequencyScalar + return $ \ freq -> f (SigA.scalarSamples toFreq freq) + + +{-# INLINE modifyModulated #-} +modifyModulated :: Hom.C sig => + (param -> ctrl) -> + Modifier state ctrl y0 y1 -> + Sig.T param -> + RP.T s sig y0 -> + RP.T s sig y1 +modifyModulated makeParam modif params = + Hom.processSamples (Sig.modifyModulated modif (Sig.map makeParam params)) diff --git a/src/Synthesizer/Dimensional/Rate/Oscillator.hs b/src/Synthesizer/Dimensional/Rate/Oscillator.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Dimensional/Rate/Oscillator.hs @@ -0,0 +1,218 @@ +{-# OPTIONS -fno-implicit-prelude #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +-} +module Synthesizer.Dimensional.Rate.Oscillator ( + {- * Oscillators with constant waveforms -} + static, + staticAntiAlias, + freqMod, + freqModAntiAlias, + phaseMod, + phaseFreqMod, + shapeMod, + shapeFreqMod, + staticSample, + freqModSample, +) where + +import qualified Synthesizer.Dimensional.Abstraction.Flat as Flat + +import qualified Synthesizer.Dimensional.RatePhantom as RP + +import qualified Synthesizer.State.Oscillator as Osci +import qualified Synthesizer.State.Signal as Sig + +import qualified Synthesizer.Basic.WaveSmoothed as WaveSmooth +import qualified Synthesizer.Basic.Wave as Wave +import qualified Synthesizer.Basic.Phase as Phase + +import qualified Synthesizer.Dimensional.Straight.Signal as SigS +import qualified Synthesizer.Dimensional.Cyclic.Signal as SigC + +import qualified Synthesizer.Dimensional.Amplitude.Signal as SigA +import qualified Synthesizer.Dimensional.Process as Proc +import Synthesizer.Dimensional.Process (toFrequencyScalar, ) + +import qualified Synthesizer.State.Interpolation as Interpolation + +import qualified Number.DimensionTerm as DN +import qualified Algebra.DimensionTerm as Dim +-- import Number.DimensionTerm ((&*&)) + +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field + +-- import NumericPrelude +import PreludeBase as P + + +{- * Oscillators with constant waveforms -} + +{- | oscillator with a functional waveform with constant frequency -} +{-# INLINE static #-} +static :: (RealField.C t, Dim.C u) => + Wave.T t y {- ^ waveform -} + -> Phase.T t {- ^ start phase from the range [0,1] -} + -> DN.T (Dim.Recip u) t + {- ^ frequency -} + -> Proc.T s u t (SigS.R s y) +static wave phase = + staticAux (SigS.fromSamples . Osci.static wave phase) + +{- | oscillator with a functional waveform with constant frequency -} +{-# INLINE staticAntiAlias #-} +staticAntiAlias :: (RealField.C t, Dim.C u) => + WaveSmooth.T t y + {- ^ waveform -} + -> Phase.T t {- ^ start phase from the range [0,1] -} + -> DN.T (Dim.Recip u) t + {- ^ frequency -} + -> Proc.T s u t (SigS.R s y) +staticAntiAlias wave phase = + staticAux (SigS.fromSamples . Osci.staticAntiAlias wave phase) + +{- | oscillator with a functional waveform with modulated frequency -} +{-# INLINE freqMod #-} +freqMod :: (RealField.C t, Dim.C u) => + Wave.T t y {- ^ waveform -} + -> Phase.T t {- ^ start phase from the range [0,1] -} + -> Proc.T s u t ( + SigA.R s (Dim.Recip u) t t + {- v frequency control -} + -> SigS.R s y) +freqMod wave phase = + freqModAux (SigS.fromSamples . Osci.freqMod wave phase) + +{- | oscillator with a functional waveform with modulated frequency -} +{-# INLINE freqModAntiAlias #-} +freqModAntiAlias :: (RealField.C t, Dim.C u) => + WaveSmooth.T t y + {- ^ waveform -} + -> Phase.T t {- ^ start phase from the range [0,1] -} + -> Proc.T s u t ( + SigA.R s (Dim.Recip u) t t + {- v frequency control -} + -> SigS.R s y) +freqModAntiAlias wave phase = + freqModAux (SigS.fromSamples . Osci.freqModAntiAlias wave phase) + +{- | oscillator with modulated phase -} +{-# INLINE phaseMod #-} +phaseMod :: (Flat.C flat t, RealField.C t, Dim.C u) => + Wave.T t y {- ^ waveform -} + -> DN.T (Dim.Recip u) t + {- ^ frequency -} + -> Proc.T s u t ( + RP.T s flat t + {- v phase modulation, phases must have no unit and + are from range [0,1] -} + -> SigS.R s y) +phaseMod wave = + staticAux (\freq -> SigS.fromSamples . Osci.phaseMod wave freq . Flat.toSamples) + +{- | oscillator with modulated shape -} +{-# INLINE shapeMod #-} +shapeMod :: (Flat.C flat c, RealField.C t, Dim.C u) => + (c -> Wave.T t y) + {- ^ waveform -} + -> Phase.T t {- ^ phase -} + -> DN.T (Dim.Recip u) t + {- ^ frequency -} + -> Proc.T s u t ( + RP.T s flat c {- v shape control -} + -> SigS.R s y) +shapeMod wave phase = + staticAux (\freq -> SigS.fromSamples . Osci.shapeMod wave phase freq . Flat.toSamples) + + +{- | oscillator with a functional waveform with modulated phase and frequency -} +{-# INLINE phaseFreqMod #-} +phaseFreqMod :: (Flat.C flat t, RealField.C t, Dim.C u) => + Wave.T t y {- ^ waveform -} + -> Proc.T s u t ( + RP.T s flat t + {- v phase control -} + -> SigA.R s (Dim.Recip u) t t + {- v frequency control -} + -> SigS.R s y) +phaseFreqMod wave = + fmap flip $ + freqModAux + (\ freqs phases -> + SigS.fromSamples $ Osci.phaseFreqMod wave (Flat.toSamples phases) freqs) + +{- | oscillator with both shape and frequency modulation -} +{-# INLINE shapeFreqMod #-} +shapeFreqMod :: (Flat.C flat c, RealField.C t, Dim.C u) => + (c -> Wave.T t y) + {- ^ waveform -} + -> Phase.T t {- ^ phase -} + -> Proc.T s u t ( + RP.T s flat c + {- v shape control -} + -> SigA.R s (Dim.Recip u) t t + {- v frequency control -} + -> SigS.R s y) +shapeFreqMod wave phase = + fmap flip $ + freqModAux + (\ freqs parameters -> + SigS.fromSamples $ Osci.shapeFreqMod wave phase (Flat.toSamples parameters) freqs) + + +{- | +oscillator with a sampled waveform with constant frequency +This is essentially an interpolation with cyclic padding. +-} +{-# INLINE staticSample #-} +staticSample :: (RealField.C t, Dim.C u) => + Interpolation.T t y + -> SigC.R r y {- ^ waveform -} + -> Phase.T t {- ^ start phase from the range [0,1] -} + -> DN.T (Dim.Recip u) t + {- ^ frequency -} + -> Proc.T s u t (SigS.R s y) +staticSample ip wave phase = + staticAux (SigS.fromSamples . Osci.staticSample ip (SigC.toPeriod wave) phase) + +{- | +oscillator with a sampled waveform with modulated frequency +Should behave homogenously for different types of interpolation. +-} +{-# INLINE freqModSample #-} +freqModSample :: (RealField.C t, Dim.C u) => + Interpolation.T t y + -> SigC.R r y {- ^ waveform -} + -> Phase.T t {- ^ start phase from the range [0,1] -} + -> Proc.T s u t ( + SigA.R s (Dim.Recip u) t t + {- v frequency control -} + -> SigS.R s y) +freqModSample ip wave phase = + freqModAux (SigS.fromSamples . Osci.freqModSample ip (SigC.toPeriod wave) phase) + + +{-# INLINE freqModAux #-} +freqModAux :: (Field.C t, Dim.C u) => + (Sig.T t -> c) + -> Proc.T s u t ( + SigA.R s (Dim.Recip u) t t + -> c) +freqModAux f = + do toFreq <- Proc.withParam toFrequencyScalar + return $ f . SigA.scalarSamples toFreq + +{-# INLINE staticAux #-} +staticAux :: (Dim.C u, Field.C t) => + (t -> c) + -> DN.T (Dim.Recip u) t + -> Proc.T s u t c +staticAux f freq = + fmap f (toFrequencyScalar freq) diff --git a/src/Synthesizer/Dimensional/RateAmplitude/Analysis.hs b/src/Synthesizer/Dimensional/RateAmplitude/Analysis.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Dimensional/RateAmplitude/Analysis.hs @@ -0,0 +1,359 @@ +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes +-} +module Synthesizer.Dimensional.RateAmplitude.Analysis ( + centroid, + length, + + normMaximum, normVectorMaximum, + normEuclideanSqr, normVectorEuclideanSqr, + normSum, normVectorSum, + + normMaximumProc, normVectorMaximumProc, + normEuclideanSqrProc, normVectorEuclideanSqrProc, + normSumProc, normVectorSumProc, + + histogram, + zeros, + + toFrequencySpectrum, fromFrequencySpectrum, + ) where + +import qualified Synthesizer.State.Analysis as Ana +import qualified Synthesizer.State.Signal as Sig + +-- import qualified Synthesizer.Dimensional.Rate as Rate +import qualified Synthesizer.Dimensional.Process as Proc +import qualified Synthesizer.Dimensional.Amplitude.Analysis as AnaA +import qualified Synthesizer.Dimensional.Amplitude.Signal as SigA +import qualified Synthesizer.Dimensional.RateAmplitude.Signal as SigRA +import qualified Synthesizer.Dimensional.Straight.Signal as SigS +import qualified Synthesizer.Dimensional.Cyclic.Signal as SigC +import qualified Synthesizer.Dimensional.RateWrapper as SigP + +import Synthesizer.Dimensional.RateAmplitude.Signal (DimensionGradient) + +import qualified Number.DimensionTerm as DN +import qualified Algebra.DimensionTerm as Dim + +import Number.DimensionTerm ((&*&), (*&), ) + +import qualified Number.Complex as Complex + +import qualified Algebra.NormedSpace.Maximum as NormedMax +import qualified Algebra.NormedSpace.Euclidean as NormedEuc +import qualified Algebra.NormedSpace.Sum as NormedSum + +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Algebraic as Algebraic +import qualified Algebra.Field as Field +import qualified Algebra.RealField as RealField +import qualified Algebra.Ring as Ring +import qualified Algebra.Real as Real + + +-- import qualified Data.List as List +-- import NumericPrelude.List (takeMatch) + +import PreludeBase (Ord, ($), (.), return, fmap, id, ) +import NumericPrelude ((+), negate, (/), sqr, abs, fromIntegral, pi, ) +import Prelude (Int, ) + + +{- * Positions -} + +{-# INLINE centroid #-} +centroid :: (Field.C q, Dim.C u, Dim.C v) => + SigP.T u q (SigA.S v y) q -> DN.T u q +centroid = makePhysicalLength Ana.centroid + +{-# INLINE length #-} +length :: (Field.C t, Dim.C u, Dim.C v) => + SigP.T u t (SigA.S v y) yv -> DN.T u t +length = makePhysicalLength (fromIntegral . Sig.length) + +{-# INLINE makePhysicalLength #-} +makePhysicalLength :: (Field.C t, Dim.C u, Dim.C v) => + (Sig.T yv -> t) -> + SigP.T u t (SigA.S v y) yv -> DN.T u t +makePhysicalLength f x = + f (SigA.samples x) *& DN.unrecip (SigP.sampleRate x) + +{-# INLINE period #-} +period :: (Field.C t, Dim.C u, Dim.C v) => + SigP.T u t (SigA.T v y (SigC.T Sig.T)) yv -> DN.T u t +period = makePhysicalPeriod (fromIntegral . Sig.length) + +{-# INLINE makePhysicalPeriod #-} +makePhysicalPeriod :: (Field.C t, Dim.C u, Dim.C v) => + (Sig.T yv -> t) -> + SigP.T u t (SigA.T v y (SigC.T Sig.T)) yv -> DN.T u t +makePhysicalPeriod f x = + f (SigC.samples (SigA.signal (SigP.signal x))) + *& DN.unrecip (SigP.sampleRate x) + + +{- * Norms -} + +{- | +Manhattan norm. +-} +{-# INLINE normMaximum #-} +normMaximum :: (Real.C y, Dim.C u, Dim.C v) => + SigP.T u t (SigA.S v y) y -> DN.T v y +normMaximum = + AnaA.volumeMaximum + +{- | +Square of energy norm. + +Could also be called @variance@. +-} +{-# INLINE normEuclideanSqr #-} +normEuclideanSqr :: (Algebraic.C q, Dim.C u, Dim.C v) => + SigP.T u q (SigA.S v q) q -> + DN.T (Dim.Mul u (Dim.Sqr v)) q +normEuclideanSqr = + normAux DN.sqr (Sig.sum . Sig.map sqr) + +{- | +Sum norm. +-} +{-# INLINE normSum #-} +normSum :: (Field.C q, Real.C q, Dim.C u, Dim.C v) => + SigP.T u q (SigA.S v q) q -> + DN.T (Dim.Mul u v) q +normSum = + normAux id (Sig.sum . Sig.map abs) + + + +{- | +Manhattan norm. +-} +{-# INLINE normVectorMaximum #-} +normVectorMaximum :: + (NormedMax.C q yv, Ord q, Dim.C u, Dim.C v) => + SigP.T u q (SigA.S v q) yv -> + DN.T v q +normVectorMaximum = + AnaA.volumeVectorMaximum -- NormedMax.norm + +{- | +Energy norm. +-} +{-# INLINE normVectorEuclideanSqr #-} +normVectorEuclideanSqr :: + (NormedEuc.C q yv, Algebraic.C q, Dim.C u, Dim.C v) => + SigP.T u q (SigA.S v q) yv -> + DN.T (Dim.Mul u (Dim.Sqr v)) q +normVectorEuclideanSqr = + normAux DN.sqr (Sig.sum . Sig.map NormedEuc.normSqr) + +{- | +Sum norm. +-} +{-# INLINE normVectorSum #-} +normVectorSum :: + (NormedSum.C q yv, Field.C q, Dim.C u, Dim.C v) => + SigP.T u q (SigA.S v q) yv -> + DN.T (Dim.Mul u v) q +normVectorSum = + normAux id (Sig.sum . Sig.map NormedSum.norm) + + +{-# INLINE normAux #-} +normAux :: (Dim.C v0, Dim.C v1, Dim.C u, Field.C t) => + (DN.T v0 y -> DN.T v1 t) -> + (Sig.T yv -> t) -> + SigP.T u t (SigA.T v0 y (SigS.T Sig.T)) yv -> + DN.T (Dim.Mul u v1) t +normAux amp norm x = + norm (SigA.samples x) + *& DN.unrecip (SigP.sampleRate x) + &*& amp (SigA.amplitude x) + + + + +{-# DEPRECATED #-} +{- | +Manhattan norm. +-} +{-# INLINE normMaximumProc #-} +normMaximumProc :: (Real.C y, Dim.C u, Dim.C v) => + Proc.T s u y (SigA.R s v y y -> DN.T v y) +normMaximumProc = + Proc.pure AnaA.volumeMaximum + +{-# DEPRECATED #-} +{- | +Square of energy norm. + +Could also be called @variance@. +-} +{-# INLINE normEuclideanSqrProc #-} +normEuclideanSqrProc :: (Algebraic.C q, Dim.C u, Dim.C v) => + Proc.T s u q ( + SigA.R s v q q -> + DN.T (Dim.Mul u (Dim.Sqr v)) q) +normEuclideanSqrProc = + normAuxProc DN.sqr (Sig.sum . Sig.map sqr) + +{-# DEPRECATED #-} +{- | +Sum norm. +-} +{-# INLINE normSumProc #-} +normSumProc :: (Field.C q, Real.C q, Dim.C u, Dim.C v) => + Proc.T s u q ( + SigA.R s v q q -> + DN.T (Dim.Mul u v) q) +normSumProc = + normAuxProc id (Sig.sum . Sig.map abs) + + + +{-# DEPRECATED #-} +{- | +Manhattan norm. +-} +{-# INLINE normVectorMaximumProc #-} +normVectorMaximumProc :: + (NormedMax.C y yv, Ord y, Dim.C u, Dim.C v) => + Proc.T s u y ( + SigA.R s v y yv -> + DN.T v y) +normVectorMaximumProc = + Proc.pure AnaA.volumeVectorMaximum -- NormedMax.norm + +{-# DEPRECATED #-} +{- | +Energy norm. +-} +{-# INLINE normVectorEuclideanSqrProc #-} +normVectorEuclideanSqrProc :: + (NormedEuc.C y yv, Algebraic.C y, Dim.C u, Dim.C v) => + Proc.T s u y ( + SigA.R s v y yv -> + DN.T (Dim.Mul u (Dim.Sqr v)) y) +normVectorEuclideanSqrProc = + normAuxProc DN.sqr (Sig.sum . Sig.map NormedEuc.normSqr) + +{-# DEPRECATED #-} +{- | +Sum norm. +-} +{-# INLINE normVectorSumProc #-} +normVectorSumProc :: + (NormedSum.C y yv, Field.C y, Dim.C u, Dim.C v) => + Proc.T s u y ( + SigA.R s v y yv -> + DN.T (Dim.Mul u v) y) +normVectorSumProc = + normAuxProc id (Sig.sum . Sig.map NormedSum.norm) + + +{-# INLINE normAuxProc #-} +normAuxProc :: (Dim.C v0, Dim.C v1, Dim.C u, Field.C t) => + (DN.T v0 y -> DN.T v1 t) -> + (Sig.T yv -> t) -> + Proc.T s u t ( + SigA.R s v0 y yv -> + DN.T (Dim.Mul u v1) t) +normAuxProc amp norm = + Proc.withParam $ \ x -> + fmap + (&*& amp (SigA.amplitude x)) + (Proc.toTimeDimension (norm (SigA.samples x))) + + + + + +{- * Miscellaneous -} + +{-# INLINE histogram #-} +histogram :: (RealField.C q, Dim.C u, Dim.C v) => + SigP.T u q (SigA.S v q) q -> + Proc.T s v q (Int, SigA.R s (DimensionGradient v u) q q) +histogram xs = + do rateY <- Proc.getSampleRate + toTime <- Proc.withParam Proc.toTimeScalar + return $ + let (offset, hist) = + Ana.histogramLinearIntMap + (SigA.scalarSamples toTime xs) + in (offset, + SigA.fromSamples + (rateY &*& DN.unrecip (SigP.sampleRate xs)) + hist) + +{- | +Detects zeros (sign changes) in a signal. +This can be used as a simple measure of the portion +of high frequencies or noise in the signal. +The result has a frequency as amplitude. +If you smooth it, you will get a curve that represents a frequency progress. +It ca be used as voiced\/unvoiced detector in a vocoder. + +The result will be one value shorter than the input. +-} +{-# INLINE zeros #-} +zeros :: (Ord q, Ring.C q, Dim.C u, Dim.C v) => + Proc.T s u q (SigA.R s v q q -> SigA.R s (Dim.Recip u) q q) +zeros = + do fp <- SigRA.fromPeaks + return (fp . SigRA.Peaks . Ana.zeros . SigA.samples) + + + +{- | +Fourier analysis +-} +{-# INLINE toFrequencySpectrum #-} +toFrequencySpectrum :: (Trans.C q, Dim.C u, Dim.C v) => + SigP.T u q (SigA.T v q (SigC.T Sig.T)) (Complex.T q) -> + SigP.T (Dim.Recip u) q (SigA.T (Dim.Mul u v) q (SigC.T Sig.T)) (Complex.T q) +toFrequencySpectrum x = + let len = DN.rewriteDimension Dim.doubleRecip (period x) + amp = SigA.amplitude x + ss = SigC.samples (SigA.signal (SigP.signal x)) + n = Sig.length ss + z = Complex.cis (negate (pi+pi) / fromIntegral n) + newAmp = DN.unrecip (SigP.sampleRate x) &*& amp + in SigP.Cons len + (SigA.Cons newAmp + (SigC.Cons (Sig.take n (Ana.chirpTransform z ss)))) +{- +toFrequencySpectrum $ SigP.Cons (DN.frequency (4::Prelude.Double)) (SigA.Cons (DN.voltage (1::Prelude.Double)) (SigC.Cons [1, 0 Number.Complex.+: (1::Prelude.Double), -1, 0 Number.Complex.+: (-1)])) +toFrequencySpectrum $ SigP.Cons (DN.frequency (4::Prelude.Double)) (SigA.Cons (DN.voltage (1::Prelude.Double)) (SigC.Cons [0 Number.Complex.+: (1::Prelude.Double), -1, 0 Number.Complex.+: (-1), 1])) +toFrequencySpectrum $ SigP.Cons (DN.frequency (4::Prelude.Double)) (SigA.Cons (DN.voltage (1::Prelude.Double)) (SigC.Cons [1, -1,1, (-1) Number.Complex.+: (0::Prelude.Double)])) +-} + + +{- | +Fourier synthesis +-} +{-# INLINE fromFrequencySpectrum #-} +fromFrequencySpectrum :: (Trans.C q, Dim.C u, Dim.C v) => + SigP.T (Dim.Recip u) q (SigA.T (Dim.Mul u v) q (SigC.T Sig.T)) (Complex.T q) -> + SigP.T u q (SigA.T v q (SigC.T Sig.T)) (Complex.T q) +fromFrequencySpectrum x = + let len = period x + amp = SigA.amplitude x + ss = SigC.samples (SigA.signal (SigP.signal x)) + n = Sig.length ss + z = Complex.cis ((pi+pi) / fromIntegral n) + newAmp = + DN.rewriteDimension + (Dim.identityLeft . Dim.applyLeftMul Dim.cancelLeft . Dim.associateLeft) + (DN.unrecip (SigP.sampleRate x) &*& amp) + in SigP.Cons len + (SigA.Cons newAmp + (SigC.Cons (Sig.take n (Ana.chirpTransform z ss)))) diff --git a/src/Synthesizer/Dimensional/RateAmplitude/Control.hs b/src/Synthesizer/Dimensional/RateAmplitude/Control.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Dimensional/RateAmplitude/Control.hs @@ -0,0 +1,332 @@ +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + + +Control curves which can be used +as envelopes, for controlling filter parameters and so on. +-} +module Synthesizer.Dimensional.RateAmplitude.Control + ({- * Primitives -} + constant, constantVector, + linear, line, + exponential, exponential2, exponentialFromTo, + cubicHermite, + {- * Piecewise -} + stepPiece, linearPiece, exponentialPiece, cosinePiece, cubicPiece, + piecewise, piecewiseVolume, Piece, Piecewise, + (-|#), ( #|-), (=|#), ( #|=), (|#), ( #|), -- spaces before # for Haddock + {- * Preparation -} + mapLinearDimension, mapExponentialDimension, ) + where + +import qualified Synthesizer.Dimensional.Amplitude.Control as CtrlA +import qualified Synthesizer.State.Control as Ctrl +import qualified Synthesizer.Dimensional.Straight.Signal as SigS + +import qualified Synthesizer.Piecewise as Piecewise +import Synthesizer.Piecewise ((-|#), ( #|-), (=|#), ( #|=), (|#), ( #|), ) + +import qualified Synthesizer.Dimensional.RateAmplitude.Signal as SigA +import qualified Synthesizer.Dimensional.Process as Proc +-- import Synthesizer.Dimensional.Process (($:), ($#), ) +import Synthesizer.Dimensional.RateAmplitude.Signal + (toTimeScalar, toAmplitudeScalar, toGradientScalar, DimensionGradient) + +import qualified Synthesizer.State.Signal as Sig + +import qualified Number.DimensionTerm as DN +import qualified Algebra.DimensionTerm as Dim + +-- import Number.DimensionTerm ((&*&)) + +-- import qualified Algebra.Module as Module +import qualified Algebra.Transcendental as Trans +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Real as Real +-- import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +-- import Control.Monad.Fix (mfix, ) +import Control.Monad (liftM3, ) + +import NumericPrelude +import PreludeBase +import Prelude () + + + +{-# INLINE constant #-} +constant :: (Real.C y, Dim.C u, Dim.C v) => + DN.T v y {-^ value -} + -> Proc.T s u t (SigA.R s v y y) +constant y = Proc.pure $ CtrlA.constant y + +{- | +The amplitude must be positive! +This is not checked. +-} +{-# INLINE constantVector #-} +constantVector :: -- (Field.C y', Real.C y', Dim.C v) => + DN.T v y {-^ amplitude -} + -> yv {-^ value -} + -> Proc.T s u t (SigA.R s v y yv) +constantVector y yv = Proc.pure $ CtrlA.constantVector y yv + +{- Using the 'Ctrl.linear' instead of 'Ctrl.linearStable' + the type class constraints would be weaker. +linear :: (Additive.C y, Field.C y', Real.C y', Dim.C v) => +-} + +{- | +Caution: This control curve can contain samples +with an absolute value greater than 1. + +Linear curves starting with zero are impossible. +Maybe you prefer using 'line'. +-} +{-# INLINE linear #-} +linear :: + (Field.C q, Real.C q, Dim.C u, Dim.C v) => + DN.T (DimensionGradient u v) q + {-^ slope of the curve -} + -> DN.T v q {-^ initial value -} + -> Proc.T s u q (SigA.R s v q q) +linear slope y0 = + let (amp,sgn) = DN.absSignum y0 + in do steep <- toGradientScalar amp slope + return (SigA.fromSamples amp (Ctrl.linearMultiscale steep sgn)) + +{- | +Generates a finite ramp. +-} +{-# INLINE line #-} +line :: + (RealField.C q, Dim.C u, Dim.C v) => + DN.T u q {-^ duration of the ramp -} + -> (DN.T v q, DN.T v q) + {-^ initial and final value -} + -> Proc.T s u q (SigA.R s v q q) +line dur' (y0',y1') = + (toTimeScalar dur') >>= \dur -> return $ + let amp = max (DN.abs y0') (DN.abs y1') + y0 = toAmplitudeScalar z y0' + y1 = toAmplitudeScalar z y1' + z = SigA.fromSamples amp + (Sig.take (floor dur) + (Ctrl.linearMultiscale ((y1-y0)/dur) y0)) + in z + +{-# INLINE exponential #-} +exponential :: (Trans.C q, Real.C q, Dim.C u, Dim.C v) => + DN.T u q {-^ time where the function reaches 1\/e of the initial value -} + -> DN.T v q {-^ initial value -} + -> Proc.T s u q (SigA.R s v q q) +exponential time y0 = + (toTimeScalar time) >>= \t -> return $ + let (amp,sgn) = DN.absSignum y0 + in SigA.fromSamples amp (Ctrl.exponentialMultiscale t sgn) + +{- + take 1000 $ show (run (fixSampleRate 100 (exponential 0.1 1)) :: SigDouble) +-} + +{-# INLINE exponential2 #-} +exponential2 :: (Trans.C q, Real.C q, Dim.C u, Dim.C v) => + DN.T u q {-^ half life, time where the function reaches 1\/2 of the initial value -} + -> DN.T v q {-^ initial value -} + -> Proc.T s u q (SigA.R s v q q) +exponential2 time y0 = + (toTimeScalar time) >>= \t -> return $ + let (amp,sgn) = DN.absSignum y0 + in SigA.fromSamples amp (Ctrl.exponential2Multiscale t sgn) + +{- | +Generate an exponential curve through two nodes. +-} +{-# INLINE exponentialFromTo #-} +exponentialFromTo :: + (Trans.C q, RealField.C q, Dim.C u, Dim.C v) => + DN.T u q {-^ duration of the ramp -} + -> (DN.T v q, DN.T v q) + {-^ initial and final value -} + -> Proc.T s u q (SigA.R s v q q) +exponentialFromTo dur' (y0',y1') = + (toTimeScalar dur') >>= \dur -> return $ + let amp = max (DN.abs y0') (DN.abs y1') + y0 = toAmplitudeScalar z y0' + y1 = toAmplitudeScalar z y1' + z = SigA.fromSamples amp + (Sig.take (floor dur) + (Ctrl.exponentialFromTo dur y0 y1)) + in z + + + +{-# INLINE cubicHermite #-} +cubicHermite :: + (Field.C q, Real.C q, Dim.C u, Dim.C v) => + (DN.T u q, (DN.T v q, DN.T (DimensionGradient u v) q)) + -> (DN.T u q, (DN.T v q, DN.T (DimensionGradient u v) q)) + -> Proc.T s u q (SigA.R s v q q) +cubicHermite (t0', (y0',dy0')) (t1', (y1',dy1')) = + let amp = max (DN.abs y0') (DN.abs y1') + in do t0 <- toTimeScalar t0' + t1 <- toTimeScalar t1' + dy0 <- toGradientScalar amp dy0' + dy1 <- toGradientScalar amp dy1' + return $ + let y0 = toAmplitudeScalar z y0' + y1 = toAmplitudeScalar z y1' + z = SigA.fromSamples amp (Ctrl.cubicHermite (t0, (y0,dy0)) (t1, (y1,dy1))) + in z + + + + +-- * piecewise curves + +type Piece s u v q = + Piecewise.Piece + (DN.T u q) (DN.T v q) + (DN.T v q -> q -> Proc.T s u q (SigS.R s q)) + +type Piecewise s u v q = + Piecewise.T + (DN.T u q) (DN.T v q) + (DN.T v q -> q -> Proc.T s u q (SigS.R s q)) + + +{- | +Since this function looks for the maximum node value, +and since the signal parameter inference phase must be completed before signal processing, +infinite descriptions cannot be used here. +-} +{-# INLINE piecewise #-} +piecewise :: (Trans.C q, RealField.C q, Dim.C u, Dim.C v) => + Piecewise s u v q + -> Proc.T s u q (SigA.R s v q q) +piecewise cs = + let amplitude = maximum + (map (\c -> max (DN.abs (Piecewise.pieceY0 c)) + (DN.abs (Piecewise.pieceY1 c))) cs) + in piecewiseVolume cs amplitude + + +{-# INLINE piecewiseVolume #-} +piecewiseVolume :: + (Trans.C q, RealField.C q, Dim.C u, Dim.C v) => + Piecewise s u v q + -> DN.T v q + -> Proc.T s u q (SigA.R s v q q) +piecewiseVolume cs amplitude = + -- it would be nice if we could re-use Ctrl.piecewise + do ts0 <- mapM (toTimeScalar . Piecewise.pieceDur) cs + fmap (SigA.fromSamples amplitude . Sig.concat) $ + sequence $ zipWith + (\(n,t) (Piecewise.PieceData c yi0 yi1 d) -> + fmap (Sig.take n . SigS.toSamples) $ + Piecewise.computePiece c yi0 yi1 d amplitude t) + (Ctrl.splitDurations ts0) + cs + + +{-# INLINE makePiece #-} +makePiece :: (Field.C q, Dim.C u, Dim.C v) => + Ctrl.Piece q -> Piece s u v q +makePiece piece = + Piecewise.pieceFromFunction $ \ y0 y1 d amplitude t0 -> + flip fmap (toTimeScalar d) (\d' -> + let za = SigA.fromSignal amplitude z + z = SigS.fromSamples $ + Piecewise.computePiece piece + (toAmplitudeScalar za y0) + (toAmplitudeScalar za y1) + d' t0 + in z) + +{-# INLINE stepPiece #-} +stepPiece :: (Field.C q, Dim.C u, Dim.C v) => Piece s u v q +stepPiece = + makePiece Ctrl.stepPiece + +{-# INLINE linearPiece #-} +linearPiece :: (Field.C q, Dim.C u, Dim.C v) => Piece s u v q +linearPiece = + makePiece Ctrl.linearPiece + +{-# INLINE exponentialPiece #-} +exponentialPiece :: (Trans.C q, Dim.C u, Dim.C v) => + DN.T v q -> Piece s u v q +exponentialPiece saturation = + Piecewise.pieceFromFunction $ \ y0 y1 d amplitude t0 -> + flip fmap (toTimeScalar d) (\d' -> + let za = SigA.fromSignal amplitude z + z = SigS.fromSamples $ + Piecewise.computePiece + (Ctrl.exponentialPiece (toAmplitudeScalar za saturation)) + (toAmplitudeScalar za y0) + (toAmplitudeScalar za y1) + d' t0 + in z) + +{-# INLINE cosinePiece #-} +cosinePiece :: (Trans.C q, Dim.C u, Dim.C v) => Piece s u v q +cosinePiece = + makePiece Ctrl.cosinePiece + +{-# INLINE cubicPiece #-} +cubicPiece :: (Field.C q, Dim.C u, Dim.C v) => + DN.T (DimensionGradient u v) q -> + DN.T (DimensionGradient u v) q -> + Piece s u v q +cubicPiece yd0 yd1 = + Piecewise.pieceFromFunction $ \ y0 y1 d amplitude t0 -> + liftM3 (\d' yd0' yd1' -> + let za = SigA.fromSignal amplitude z + z = SigS.fromSamples $ + Piecewise.computePiece + (Ctrl.cubicPiece yd0' yd1') + (toAmplitudeScalar za y0) + (toAmplitudeScalar za y1) + d' t0 + in z) + (toTimeScalar d) + (toGradientScalar amplitude yd0) + (toGradientScalar amplitude yd1) + + +-- * convert values to different graduations + +{- | +Map a control curve without amplitude unit +by a linear (affine) function with a unit. +-} +{-# INLINE mapLinearDimension #-} +mapLinearDimension :: (Field.C y, Real.C y, Dim.C u, Dim.C v) => + DN.T v y {- ^ range: one is mapped to @center + range * ampX@ -} + -> DN.T (Dim.Mul v u) y {- ^ center: zero is mapped to @center@ -} + -> Proc.T s u t ( + SigA.R s u y y + -> SigA.R s (Dim.Mul v u) y y) +mapLinearDimension range center = + Proc.pure $ CtrlA.mapLinearDimension range center + +{- | +Map a control curve without amplitude unit +exponentially to one with a unit. +-} +{-# INLINE mapExponentialDimension #-} +mapExponentialDimension :: (Trans.C y, Dim.C u) => + y {- ^ range: one is mapped to @center*range@, must be positive -} + -> DN.T u y {- ^ center: zero is mapped to @center@ -} + -> Proc.T s u t ( + SigA.R s Dim.Scalar y y + -> SigA.R s u y y) +mapExponentialDimension range center = + Proc.pure $ CtrlA.mapExponential range center diff --git a/src/Synthesizer/Dimensional/RateAmplitude/Cut.hs b/src/Synthesizer/Dimensional/RateAmplitude/Cut.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Dimensional/RateAmplitude/Cut.hs @@ -0,0 +1,289 @@ +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes +-} +module Synthesizer.Dimensional.RateAmplitude.Cut ( + {- * dissection -} + splitAt, + take, + drop, + takeUntilPause, + unzip, + unzip3, + leftFromStereo, rightFromStereo, + + {- * glueing -} + concat, concatVolume, + append, appendVolume, + zip, zipVolume, + zip3, zip3Volume, + mergeStereo, mergeStereoVolume, + arrange, arrangeVolume, + ) where + +import qualified Synthesizer.Dimensional.Amplitude.Cut as CutV +import qualified Synthesizer.Dimensional.Rate.Cut as CutR +import qualified Synthesizer.State.Cut as CutS +import qualified Synthesizer.State.Signal as Sig + +import qualified Synthesizer.Frame.Stereo as Stereo +import qualified Synthesizer.Generic.SampledValue as Sample + +import qualified Synthesizer.Dimensional.RateAmplitude.Signal as SigA +import qualified Synthesizer.Dimensional.Process as Proc +import Synthesizer.Dimensional.Process (($#)) +import Synthesizer.Dimensional.RateAmplitude.Signal + (toTimeScalar, toAmplitudeScalar) + +import qualified Number.DimensionTerm as DN +import qualified Algebra.DimensionTerm as Dim + +-- import Number.DimensionTerm ((&*&)) + +import qualified Data.EventList.Relative.TimeBody as EventList +import qualified Numeric.NonNegative.Class as NonNeg + +import qualified Algebra.NormedSpace.Maximum as NormedMax +import qualified Algebra.Module as Module +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring + +import qualified Data.List as List + +import PreludeBase ((.), ($), Ord, (<=), map, return, ) +-- import NumericPrelude +import Prelude (RealFrac) + + +{- * dissection -} + +{-# INLINE splitAt #-} +splitAt :: (RealField.C t, Dim.C u, Dim.C v, Sample.C yv) => + DN.T u t -> Proc.T s u t (SigA.R s v y yv -> (SigA.R s v y yv, SigA.R s v y yv)) +splitAt t' = + do t <- toTimeScalar t' + return $ \x -> + let (ss0,ss1) = Sig.splitAt (RealField.round t) (SigA.samples x) + in (SigA.replaceSamples ss0 x, + SigA.replaceSamples ss1 x) + +{-# INLINE take #-} +take :: (RealField.C t, Dim.C u, Dim.C v) => + DN.T u t -> Proc.T s u t (SigA.R s v y yv -> SigA.R s v y yv) +take t' = + CutR.take t' + -- fmap (fst.) $ splitAt t + {- + do t <- toTimeScalar t' + return $ SigA.processSamples (Sig.take (RealField.round t)) + -} + +{-# INLINE drop #-} +drop :: (RealField.C t, Dim.C u, Dim.C v) => + DN.T u t -> Proc.T s u t (SigA.R s v y yv -> SigA.R s v y yv) +drop t' = + CutR.drop t' + -- fmap (snd.) $ splitAt t + {- + do t <- toTimeScalar t' + return $ SigA.processSamples (Sig.drop (RealField.round t)) + -} + +{-# INLINE takeUntilPause #-} +takeUntilPause :: + (RealField.C t, Dim.C u, + Field.C y, NormedMax.C y yv, Dim.C v) => + DN.T v y -> DN.T u t -> Proc.T s u t (SigA.R s v y yv -> SigA.R s v y yv) +takeUntilPause y' t' = + do t <- toTimeScalar t' + return $ \x -> + let y = toAmplitudeScalar x y' + in SigA.processSamples + (CutS.takeUntilInterval ((<=y) . NormedMax.norm) + (RealField.ceiling t)) x + + +{-# INLINE unzip #-} +unzip :: (Dim.C u, Dim.C v) => + Proc.T s u t + (SigA.R s v y (yv0, yv1) -> + (SigA.R s v y yv0, SigA.R s v y yv1)) +unzip = Proc.pure CutV.unzip + +{-# INLINE unzip3 #-} +unzip3 :: (Dim.C u, Dim.C v) => + Proc.T s u t + (SigA.R s v y (yv0, yv1, yv2) -> + (SigA.R s v y yv0, SigA.R s v y yv1, SigA.R s v y yv2)) +unzip3 = Proc.pure CutV.unzip3 + + +{-# INLINE leftFromStereo #-} +leftFromStereo :: (Dim.C u) => + Proc.T s u t + (SigA.R s u y (Stereo.T yv) -> SigA.R s u y yv) +leftFromStereo = Proc.pure CutV.leftFromStereo + +{-# INLINE rightFromStereo #-} +rightFromStereo :: (Dim.C u) => + Proc.T s u t + (SigA.R s u y (Stereo.T yv) -> SigA.R s u y yv) +rightFromStereo = Proc.pure CutV.rightFromStereo + + + +{- * glueing -} + +{- | +Similar to @foldr1 append@ but more efficient and accurate, +because it reduces the number of amplifications. +Does not work for infinite lists, +because no maximum amplitude can be computed. +-} +{-# INLINE concat #-} +concat :: + (Ord y, Field.C y, Dim.C v, + Module.C y yv) => + Proc.T s u t ([SigA.R s v y yv] -> SigA.R s v y yv) +concat = Proc.pure $ CutV.concat + +{- | +Give the output volume explicitly. +Does also work for infinite lists. +-} +{-# INLINE concatVolume #-} +concatVolume :: + (Field.C y, Dim.C v, + Module.C y yv) => + DN.T v y -> Proc.T s u t ([SigA.R s v y yv] -> SigA.R s v y yv) +concatVolume amp = Proc.pure $ CutV.concatVolume amp + + +{-# INLINE append #-} +append :: + (Ord y, Field.C y, Dim.C v, + Module.C y yv) => + Proc.T s u t (SigA.R s v y yv -> SigA.R s v y yv -> SigA.R s v y yv) +append = Proc.pure $ CutV.append + +{-# INLINE appendVolume #-} +appendVolume :: + (Field.C y, Dim.C v, + Module.C y yv) => + DN.T v y -> + Proc.T s u t (SigA.R s v y yv -> SigA.R s v y yv -> SigA.R s v y yv) +appendVolume amp = Proc.pure $ CutV.appendVolume amp + + +{-# INLINE zip #-} +zip :: + (Ord y, Field.C y, Dim.C v, + Module.C y yv0, Module.C y yv1) => + Proc.T s u t (SigA.R s v y yv0 -> SigA.R s v y yv1 -> SigA.R s v y (yv0,yv1)) +zip = Proc.pure $ CutV.zip + +{-# INLINE zipVolume #-} +zipVolume :: + (Field.C y, Dim.C v, + Module.C y yv0, Module.C y yv1) => + DN.T v y -> + Proc.T s u t (SigA.R s v y yv0 -> SigA.R s v y yv1 -> SigA.R s v y (yv0,yv1)) +zipVolume amp = Proc.pure $ CutV.zipVolume amp + + +{-# INLINE mergeStereo #-} +mergeStereo :: + (Ord y, Field.C y, Dim.C v, + Module.C y yv) => + Proc.T s u t (SigA.R s v y yv -> SigA.R s v y yv -> SigA.R s v y (Stereo.T yv)) +mergeStereo = Proc.pure $ CutV.mergeStereo + +{-# INLINE mergeStereoVolume #-} +mergeStereoVolume :: + (Field.C y, Dim.C v, + Module.C y yv) => + DN.T v y -> + Proc.T s u t (SigA.R s v y yv -> SigA.R s v y yv -> SigA.R s v y (Stereo.T yv)) +mergeStereoVolume amp = Proc.pure $ CutV.mergeStereoVolume amp + + + +{-# INLINE zip3 #-} +zip3 :: + (Ord y, Field.C y, Dim.C v, + Module.C y yv0, Module.C y yv1, Module.C y yv2) => + Proc.T s u t ( + SigA.R s v y yv0 -> SigA.R s v y yv1 -> SigA.R s v y yv2 -> + SigA.R s v y (yv0,yv1,yv2)) +zip3 = Proc.pure $ CutV.zip3 + +{-# INLINE zip3Volume #-} +zip3Volume :: + (Field.C y, Dim.C v, + Module.C y yv0, Module.C y yv1, Module.C y yv2) => + DN.T v y -> + Proc.T s u t ( + SigA.R s v y yv0 -> SigA.R s v y yv1 -> SigA.R s v y yv2 -> + SigA.R s v y (yv0,yv1,yv2)) +zip3Volume amp = Proc.pure $ CutV.zip3Volume amp + + +{- | +Uses maximum input volume as output volume. +-} +{-# INLINE arrange #-} +arrange :: + (Ring.C t, Dim.C u, + RealFrac t, NonNeg.C t, + Ord y, Field.C y, Dim.C v, + Module.C y yv) => + DN.T u t {-^ Dim of the time values in the time ordered list. -} + -> Proc.T s u t ( + EventList.T t (SigA.R s v y yv) + {- v A list of pairs: (relative start time, signal part), + The start time is relative + to the start time of the previous event. -} + -> SigA.R s v y yv) + {- ^ The mixed signal. -} +arrange unit' = + Proc.withParam $ \sched -> + let amp = List.maximum (map SigA.amplitude (EventList.getBodies sched)) + in arrangeVolume amp unit' $# sched + + +{- | +Given a list of signals with time stamps, +mix them into one signal as they occur in time. +Ideally for composing music. +Infinite schedules are not supported. +Does not work for infinite lists, +because no maximum amplitude can be computed. +-} +{-# INLINE arrangeVolume #-} +arrangeVolume :: + (Ring.C t, Dim.C u, + RealFrac t, NonNeg.C t, + Field.C y, Dim.C v, + Module.C y yv) => + DN.T v y {- ^ Output volume. -} + -> DN.T u t {- ^ Dim of the time values in the time ordered list. -} + -> Proc.T s u t ( + EventList.T t (SigA.R s v y yv) + {- v A list of pairs: (relative start time, signal part), + The start time is relative + to the start time of the previous event. -} + -> SigA.R s v y yv) + {- ^ The mixed signal. -} +arrangeVolume amp unit' = + do unit <- toTimeScalar unit' + return $ \sched' -> + let sched = + EventList.mapBody (SigA.vectorSamples (toAmplitudeScalar z)) sched' + z = SigA.fromSamples amp + (CutS.arrange (EventList.resample unit sched)) + in z diff --git a/src/Synthesizer/Dimensional/RateAmplitude/Demonstration.hs b/src/Synthesizer/Dimensional/RateAmplitude/Demonstration.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Dimensional/RateAmplitude/Demonstration.hs @@ -0,0 +1,554 @@ +{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-} +module Main (main) where +-- module Synthesizer.Dimensional.RateAmplitude.Demonstration where + +import qualified Synthesizer.Dimensional.Rate.Oscillator as Osci +import qualified Synthesizer.Dimensional.Rate.Filter as Filt +import qualified Synthesizer.Dimensional.RateAmplitude.Displacement as Disp +import qualified Synthesizer.Dimensional.RateAmplitude.Noise as Noise +-- import qualified Synthesizer.SampleRateDimension.Filter.Recursive as FiltR +-- import qualified Synthesizer.SampleRateDimension.Filter.NonRecursive as FiltNR +import qualified Synthesizer.Dimensional.RateAmplitude.Filter as FiltA +import qualified Synthesizer.Dimensional.RateAmplitude.Cut as Cut +import qualified Synthesizer.Dimensional.Amplitude.Cut as CutA +import qualified Synthesizer.Dimensional.Rate.Cut as CutR + +import qualified Synthesizer.Dimensional.RateAmplitude.Control as Ctrl +import qualified Synthesizer.Dimensional.Rate.Control as CtrlR + +import qualified Synthesizer.Dimensional.Straight.Displacement as DispS + +import qualified Synthesizer.Dimensional.Amplitude.Analysis as Ana + +import qualified Synthesizer.Dimensional.Process as Proc +import qualified Synthesizer.Dimensional.Cyclic.Signal as SigC +import qualified Synthesizer.Dimensional.Straight.Signal as SigS +import qualified Synthesizer.Dimensional.RateAmplitude.Signal as SigA + +import qualified Synthesizer.Dimensional.RateAmplitude.File as File +import qualified Synthesizer.Dimensional.RateAmplitude.Play as Play +import qualified Synthesizer.Dimensional.RateWrapper as SigP + +import Synthesizer.Dimensional.RateAmplitude.Signal (($-), ($&), (&*^), (&*>^), ) +import Synthesizer.Dimensional.Process (($:), ($::), (.:), ($^), (.^), ($#)) +import Synthesizer.Dimensional.Amplitude.Control (mapLinear, mapExponential, ) +import Synthesizer.Dimensional.RateAmplitude.Instrument (wasp, ) + +import qualified Synthesizer.Frame.Stereo as Stereo +import qualified Synthesizer.Generic.SampledValue as Sample + +import qualified Synthesizer.State.Interpolation as Interpolation +import Synthesizer.Plain.Instrument (choirWave) +import qualified Synthesizer.Basic.WaveSmoothed as WaveSmooth +import qualified Synthesizer.Basic.Wave as Wave +import qualified Synthesizer.Basic.Phase as Phase + +import qualified Algebra.DimensionTerm as Dim +import qualified Number.DimensionTerm as DN + +import Number.DimensionTerm ((*&)) + +import qualified Number.NonNegative as NonNeg + +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Module as Module +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring + +import System.Random (Random, randomRs, mkStdGen) + +import Synthesizer.Utility (snd3, thd3, ) +import Data.List(zip4) + +import PreludeBase +import NumericPrelude + + + + +{-# INLINE sineLow #-} +sineLow :: + (RealField.C q, Trans.C q, Module.C q q, Sample.C q) => + Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q) +sineLow = + DN.voltage 1 &*^ + Osci.static Wave.sine zero (DN.frequency 440) + +{-# INLINE sineHigh #-} +sineHigh :: + (RealField.C q, Trans.C q, Module.C q q, Sample.C q) => + Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q) +sineHigh = + DN.voltage 1 &*^ + Osci.static Wave.sine zero (DN.frequency 660) + +{-# INLINE sineMix #-} +sineMix :: + (RealField.C q, Trans.C q, Module.C q q, Sample.C q) => + Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q) +sineMix = + FiltA.amplify 0.5 $: (Disp.mix $: sineLow $: sineHigh) + + +{-# INLINE exponential #-} +exponential :: + (RealField.C q, Trans.C q, Module.C q q, Random q, Sample.C q) => + Proc.T s Dim.Time q (SigS.R s q) +exponential = + CtrlR.exponential (DN.time 0.3) + + +{-# INLINE ping #-} +ping :: + (RealField.C q, Trans.C q, Module.C q q, Random q, Sample.C q) => + Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q) +ping = + Filt.envelope + $: exponential + $: sineLow + + + +{-# INLINE sawWave #-} +sawWave :: (RealField.C a) => Wave.T a a +sawWave = Wave.triangleAsymmetric (-0.9) + +{- +{-# INLINE saw #-} +saw :: + (RealField.C q, Trans.C q, Module.C q q, Random q, Sample.C q) => + Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q) +saw = + DN.voltage 1 &*^ Osci.static sawWave zero (DN.frequency 440) +-} + +{-# INLINE sawVibrato #-} +sawVibrato :: + (RealField.C q, Trans.C q, Module.C q q, Random q, Sample.C q) => + Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q) +sawVibrato = + DN.voltage 1 &*^ + (Osci.freqMod sawWave zero + $: (mapLinear 0.01 (DN.frequency 440) $^ Osci.static Wave.sine zero (DN.frequency 5))) + +{-# INLINE sawChorus #-} +sawChorus :: + (RealField.C q, Trans.C q, Module.C q q, Random q, Sample.C q) => + Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q) +sawChorus = + let v = DN.voltage (1/4) + in Disp.mixMulti + $:: (v &*^ Osci.static sawWave (Phase.fromRepresentative 0.00) (DN.frequency 442.0) : + v &*^ Osci.static sawWave (Phase.fromRepresentative 0.25) (DN.frequency 441.2) : + v &*^ Osci.static sawWave (Phase.fromRepresentative 0.50) (DN.frequency 438.7) : + v &*^ Osci.static sawWave (Phase.fromRepresentative 0.75) (DN.frequency 438.1) : + []) + + + + +{-# INLINE amplitudeModulationChirp #-} +amplitudeModulationChirp :: + (RealField.C q, Trans.C q) => + Proc.T s Dim.Time q (SigS.R s q) +amplitudeModulationChirp = + Filt.envelope + $: (Osci.static Wave.sine zero (DN.frequency 440)) + $: (Osci.freqMod Wave.sine zero + $: (Ctrl.exponentialFromTo + (DN.time 10) + (DN.frequency 1, DN.frequency 1000))) + + +{-# INLINE airplane #-} +airplane :: + (RealField.C q, Trans.C q, Module.C q q, Random q, Sample.C q) => + Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q) +airplane = + SigA.share + (Noise.white (DN.frequency 20000) (DN.voltage 0.2)) + (\noise -> + Cut.take (DN.time 5) $: (Disp.mix + $: noise + $: (Filt.frequencyModulation Interpolation.linear + $- DN.scalar 1.001 + $: noise))) + +{-# INLINE airplaneFade #-} +airplaneFade :: + Proc.T s Dim.Time Double (SigA.R s Dim.Voltage Double Double) +airplaneFade = + Filt.envelope + $: (DispS.map (\t -> recip (1 + 30*(t-1)^2)) $^ CtrlR.linear (DN.time 5)) +-- $: Osci.static Wave.sine zero (DN.recip (DN.time 20)) + $: (Filt.phaser Interpolation.linear (DN.time 0.01) + $: Ctrl.exponentialFromTo + (DN.time 10) + (DN.unrecip (DN.frequency 5000), DN.unrecip (DN.frequency 100)) + $: Noise.white (DN.frequency 20000) (DN.voltage 0.5)) + + +{-# INLINE wind #-} +wind :: + (RealField.C q, Trans.C q, Module.C q q, Random q, Sample.C q) => + Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q) +wind = + Filt.lowpassFromUniversal $: + (Filt.universal + $- DN.scalar 20 + $: (mapExponential 2 (DN.frequency 1000) $^ + (Disp.mix + $: DN.scalar 0.5 &*^ Osci.static Wave.sine zero (DN.frequency 0.2) + $: DN.scalar 1.0 &*^ Osci.static Wave.sine zero (DN.frequency (sqrt 0.2)))) + $: Noise.white (DN.frequency 20000) (DN.voltage 0.2)) + +{-# INLINE windStereo #-} +windStereo :: + (RealField.C q, Trans.C q, Module.C q q, Random q, Sample.C q) => + Proc.T s Dim.Time q (SigA.R s Dim.Voltage q (Stereo.T q)) +windStereo = + SigA.share + wind + (\w -> Cut.mergeStereo $: w $: (Cut.drop (DN.time 0.5) $: w)) + + +{-# INLINE glissandoControl #-} +glissandoControl :: + (RealField.C q, Trans.C q, Module.C q q, Random q) => + Proc.T s Dim.Time q (SigA.R s Dim.Scalar q q) +glissandoControl = + Filt.firstOrderLowpass + $- DN.frequency 4 + $: (Cut.concatVolume (DN.scalar 1) $: + mapM (\p -> + Cut.take (DN.time (1/6)) + $: Ctrl.constant (DN.scalar (fromInteger p / 12))) + (randomRs (0,24) (mkStdGen 3141))) + + +{-# INLINE bassFilter #-} +bassFilter :: + (RealField.C q, Trans.C q, Module.C q q, Random q) => + Proc.T s Dim.Time q (SigA.R s Dim.Voltage q (Stereo.T q)) +bassFilter = + Filt.lowpassFromUniversal $: + (Filt.universal + $- DN.scalar 5 +{- + $- DN.frequency 440 +-} + $: (mapExponential 2 (DN.frequency 440) $^ + glissandoControl) +{- + $: (mapExponential 10 (DN.frequency 440) $^ + Osci.static Wave.sine zero (DN.frequency 0.2)) +-} + $: (Cut.mergeStereo + $: DN.voltage 1 &*^ Osci.static Wave.saw zero (DN.frequency 55.0) + $: DN.voltage 1 &*^ Osci.static Wave.saw zero (DN.frequency 55.1))) + + + +{-# INLINE noiseLowpass #-} +noiseLowpass :: + (RealField.C q, Trans.C q, Module.C q q, Random q) => + Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q) +noiseLowpass = + let noise = Noise.white (DN.frequency 20000) (DN.voltage 0.1) + control = + Ctrl.exponentialFromTo + (DN.time 5) + (DN.frequency 10000, DN.frequency 10) + in Filt.firstOrderLowpass + $: control + $: noise + + +{-# INLINE noiseHighpass #-} +noiseHighpass :: + (RealField.C q, Trans.C q, Module.C q q, Random q) => + Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q) +noiseHighpass = + let noise = Noise.white (DN.frequency 20000) (DN.voltage 0.1) + control = + Ctrl.exponentialFromTo + (DN.time 5) + (DN.frequency 10000, DN.frequency 10) + in Filt.firstOrderHighpass + $: control + $: noise + + +{-# INLINE bubbles #-} +bubbles :: + (RealField.C q, Trans.C q, Module.C q q, Random q, Sample.C q) => + Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q) +bubbles = + let delay = 0.24 + in Filt.comb (DN.time delay) (0.5 `asTypeOf` delay) $: + (DN.voltage 0.5 &*^ + (Osci.freqMod Wave.sine zero $: + (mapExponential 0.5 (DN.frequency 440) $^ + (Disp.mix + $: DN.scalar 1.5 &*^ Osci.static Wave.saw zero (DN.frequency 0.5) + $: DN.scalar 0.5 &*^ Osci.static Wave.saw zero (DN.frequency 10))))) + + +{-# INLINE bubblesStereo #-} +bubblesStereo :: + (RealField.C q, Trans.C q, Module.C q q, Random q, Sample.C q) => + Proc.T s Dim.Time q (SigA.R s Dim.Voltage q (Stereo.T q)) +bubblesStereo = + let delay = 0.24 + {-# INLINE channel #-} + channel f = + DN.voltage 0.5 &*^ + (Osci.freqMod Wave.sine zero $: + (mapExponential 0.5 (DN.frequency 440) $^ + (Disp.mix + $: DN.scalar 1.5 &*^ Osci.static Wave.saw zero (DN.frequency 0.5) + $: DN.scalar 0.5 &*^ Osci.static Wave.saw zero f))) + in Filt.comb (DN.time delay) (0.5 `asTypeOf` delay) $: + (Cut.mergeStereo + $: channel (DN.frequency 10) + $: channel (DN.frequency 9.23)) + + +{-# INLINE dampedEcho #-} +dampedEcho :: + (RealField.C q, Trans.C q, Module.C q q, Random q, Sample.C q) => + Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q) +dampedEcho = + FiltA.combProc (DN.time 0.2) + (Filt.firstOrderLowpass $- DN.frequency 1000) + $: (Filt.envelope + $: CtrlR.exponential2 (DN.time 0.1) + $: DN.voltage 1 &*^ Osci.static Wave.saw zero (DN.frequency 440)) + + +{-# INLINE trapezoid #-} +trapezoid :: + (RealField.C q, Trans.C q, Module.C q q, Random q, Sample.C q) => + Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q) +trapezoid = + Filt.mean (DN.frequency 500) + $: (mapExponential 4 (DN.frequency 2000) $^ Osci.static Wave.sine zero (DN.frequency 1)) + $: DN.voltage 0.7 &*^ Osci.static (Wave.trapezoid 0.9) zero (DN.frequency 440) +{- + Filt.meanStatic (DN.frequency 440) + $: DN.voltage 1 &*^ Osci.static Wave.square zero (DN.frequency 440) +-} + + + +{-# INLINE staticSine #-} +staticSine :: + (RealField.C q, Trans.C q) => + Proc.T s Dim.Time q (SigS.R s q) +staticSine = + CutR.take (DN.time 10) + $: (Osci.static Wave.sine zero (DN.frequency 440)) + + +{-# INLINE harmonicTone #-} +harmonicTone :: + (RealField.C q, Trans.C q, Module.C q q) => + [(DN.Frequency q, q, Phase.T q)] -> + Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q) +harmonicTone hs = + let k = recip (sum (map (abs . snd3) hs)) + in Disp.mixMulti $:: + map (\(f, amp, phase) -> + DN.voltage (amp*k) &*^ + Osci.static Wave.sine phase f) hs + +newtype Sound q v = + Sound {fromSound :: forall s. Proc.T s Dim.Time q (SigA.R s Dim.Voltage q v)} + +{-# INLINE harmonicExamples #-} +harmonicExamples :: + (RealField.C q, Trans.C q, Module.C q q) => + [(FilePath, Sound q q)] +harmonicExamples = + do expo <- [0,1,2] + (harmName,harm::[Int]) + <- [("all", take 10 [1 ..]), ("odd", take 10 [1,3 ..])] + (phaseName,phase) + <- [("sin", Phase.fromRepresentative 0), + ("cos", Phase.fromRepresentative (1/4))] + return + ("power" ++ show expo ++ harmName ++ "-" ++ phaseName, + Sound + (harmonicTone + (map ((\n -> (n *& DN.frequency 440, + recip (n ^ expo), + phase)) + . fromIntegral) + harm))) + +{- | +Morphing shapes with constant sound. +By shifting the frequency of all harmonics up by an constant amount, +the periods of the harmonic do no longer match +and recombine only afte a period that depends on the frequency shift. +At the beginning we have the waveform of mixed sines, +after a quarter period of the shift frequency we have mixed cosines and so on. +-} +{-# INLINE harmonicMorph #-} +harmonicMorph :: + (RealField.C q, Trans.C q, Module.C q q) => + [(FilePath, Sound q q)] +harmonicMorph = + do expo <- [0,1,2] + (harmName,harm::[Int]) + <- [("all", take 10 [1 ..]), ("odd", take 10 [1,3 ..])] + return + ("power" ++ show expo ++ harmName ++ "-shift", + Sound + (harmonicTone + (map ((\n -> (n *& DN.frequency 440 + DN.frequency 1, + recip (n ^ expo), + zero)) + . fromIntegral) + harm))) + + +{-# INLINE waveforms #-} +waveforms :: + (RealField.C q, Trans.C q, Module.C q q) => + [(FilePath, Sound q q)] +waveforms = + do (name,wave) + <- ("square", Wave.trapezoid 0.9) : + ("triangle", Wave.triangle) : + ("saw", sawWave) : + [] + return + (name, + Sound + (DN.voltage 1 &*^ Osci.static wave zero (DN.frequency 440))) + + +{-# INLINE waveformsBandlimited #-} +waveformsBandlimited :: + (RealField.C q, Trans.C q, Module.C q q) => + [(FilePath, Sound q q)] +waveformsBandlimited = + do (name,wave) + <- ("square", WaveSmooth.square) : + ("triangle", WaveSmooth.triangle) : + ("saw", WaveSmooth.saw) : + ("sine", WaveSmooth.sine) : + ("harmonic", WaveSmooth.composedHarmonics $ + let k = 0.5 + in [WaveSmooth.harmonic zero 0, + WaveSmooth.harmonic zero k, + WaveSmooth.harmonic zero (k/2), + WaveSmooth.harmonic zero (k/3), + WaveSmooth.harmonic zero (k/4)]) : + [] + return + (name++"-antialias-chirp", + Sound + (DN.voltage 1 &*^ (Osci.freqModAntiAlias wave zero $: + Ctrl.line (DN.time 10) (DN.frequency (-30000), DN.frequency 30000)))) + + +main :: IO () +main = + do +{- + Play.timeVoltageMonoDoubleR (DN.frequency 44100) bubbles +-} +{- + File.writeTimeVoltage "chirp" + (SigP.runProcess + (DN.frequency (44100::Double)) + (DN.voltage 1 &*^ amplitudeModulationChirp)) +-} + mapM_ + (\(name, sound) -> + putStrLn name >> + File.renderTimeVoltageStereoDouble + (DN.frequency 44100) name (fromSound sound)) $ + + ("bass-filter", Sound (Cut.take (DN.time 15) $: bassFilter)) : + ("wind", Sound (Cut.take (DN.time 10) $: windStereo)) : + ("bubbles", Sound (Cut.take (DN.time 10) $: bubblesStereo)) : + [] + + mapM_ + (\(name, sound) -> + putStrLn name >> + File.renderTimeVoltageMonoDouble + (DN.frequency 44100) name (fromSound sound)) $ + + ("sine-low", Sound (Cut.take (DN.time 1) $: sineLow)) : + ("sine-high", Sound (Cut.take (DN.time 1) $: sineHigh)) : + ("sine-mix", Sound (Cut.take (DN.time 1) $: sineMix)) : + ("exponential", Sound (Cut.take (DN.time 1) $: DN.voltage 1 &*^ exponential)) : + ("ping", Sound (Cut.take (DN.time 1) $: ping)) : + +-- ("saw", Sound (Cut.take (DN.time 2) $: saw)) : + ("saw-vibrato", Sound (Cut.take (DN.time 2) $: sawVibrato)) : + ("saw-chorus", Sound (Cut.take (DN.time 2) $: sawChorus)) : + + ("wasp", Sound (Cut.take (DN.time 5) $: wasp (DN.frequency 110))) : + ("trapezoid", Sound (Cut.take (DN.time 5) $: trapezoid)) : + ("damped-echo", Sound (Cut.take (DN.time 4) $: dampedEcho)) : + ("chirp", Sound (DN.voltage 1 &*^ amplitudeModulationChirp)) : + ("airplane", Sound airplane) : + {- This becomes considerably faster, if other effects are not rendered. + This is obviously an optimizer bug. -} + ("airplane-fade", Sound airplaneFade) : + + ("noise-lowpass1", Sound noiseLowpass) : + ("noise-highpass1", Sound noiseHighpass) : + [] + + flip mapM_ waveformsBandlimited $ + \(fileName, tone) -> + putStrLn fileName >> + File.renderTimeVoltageMonoDouble + (DN.frequency 44100) fileName + (fromSound tone) + + flip mapM_ (harmonicExamples ++ harmonicMorph ++ waveforms) $ + \(fileName, tone) -> + putStrLn fileName >> + File.renderTimeVoltageMonoDouble + (DN.frequency 44100) fileName + (Cut.take (DN.time 1) $: fromSound tone) + + +{- +import installed synthesizer package + +ghc-core -f html -- -o dist/build/demonstration/demonstration -Wall -O2 -fexcess-precision -fvia-C -optc-O2 -package synthesizer src/Synthesizer/Dimensional/RateAmplitude/Demonstration.hs >dist/build/demonstration/demonstration.html + +ghc -o dist/build/demonstration/demonstration -Wall -O2 -fexcess-precision -fvia-C -optc-O2 -ddump-simpl-stats -package synthesizer src/Synthesizer/Dimensional/RateAmplitude/Demonstration.hs + +ghc -o dist/build/demonstration/demonstration -O -Wall -fexcess-precision -ddump-simpl-stats -package synthesizer src/Synthesizer/Dimensional/RateAmplitude/Demonstration.hs + +ghc -o dist/build/demonstration/demonstration -O -Wall -fexcess-precision -ddump-simpl -package synthesizer src/Synthesizer/Dimensional/RateAmplitude/Demonstration.hs >dist/build/Demonstration.log + + +with assembly output + +ghc -o dist/build/fusiontest/fusiontest -O -Wall -fexcess-precision -ddump-simpl-stats -ddump-asm -package synthesizer speedtest/DemonstrationInlineMono.hs >dist/build/Demonstration.asm + + +with make and no explicit package specification: + +ghc -Idist/build -o dist/build/demonstration/demonstration --make -Wall -O -fexcess-precision -ddump-simpl-stats -i -idist/build/autogen -isrc -odir dist/build/demonstration/demonstration-tmp -hidir dist/build/demonstration/demonstration-tmp src/Synthesizer/Dimensional/RateAmplitude/Demonstration.hs + + +with make and explicit package specification: + +ghc --make -Idist/build -o dist/build/demonstration/demonstration -Wall -O -fexcess-precision -ddump-simpl-stats -ddump-simpl-iterations -i -idist/build/autogen -isrc -idist/build/demonstration/demonstration-tmp -odir dist/build/demonstration/demonstration-tmp -hidir dist/build/demonstration/demonstration-tmp -package base-1.0 -package mtl-1.0 -package non-negative-0.0.2 -package numeric-prelude-0.0.3 -package event-list-0.0.7 -package bytestring-0.9.0.5 -package binary-0.4.1 -package storablevector-0.1 src/Synthesizer/Dimensional/RateAmplitude/Demonstration.hs >src/Synthesizer/Dimensional/RateAmplitude/Demonstration.log + +without make and with detailed simplifier report: + +ghc -Idist/build -o dist/build/demonstration/demonstration -Wall -O -fexcess-precision -ddump-simpl-stats -ddump-simpl-iterations -i -idist/build/autogen -isrc -idist/build/demonstration/demonstration-tmp -odir dist/build/demonstration/demonstration-tmp -hidir dist/build/demonstration/demonstration-tmp -package base-1.0 -package mtl-1.0 -package non-negative-0.0.2 -package numeric-prelude-0.0.3 -package event-list-0.0.7 -package HTam-0.0 -package numeric-quest-0.1 -package bytestring-0.9.0.5 -package binary-0.4.1 -package storablevector-0.1 dist/build/HSsynthesizer*.o src/Synthesizer/Dimensional/RateAmplitude/Demonstration.hs >src/Synthesizer/Dimensional/RateAmplitude/Demonstration.log +-} diff --git a/src/Synthesizer/Dimensional/RateAmplitude/Displacement.hs b/src/Synthesizer/Dimensional/RateAmplitude/Displacement.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Dimensional/RateAmplitude/Displacement.hs @@ -0,0 +1,96 @@ +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes +-} +module Synthesizer.Dimensional.RateAmplitude.Displacement ( + mix, mixVolume, + mixMulti, mixMultiVolume, + raise, distort, + ) where + +import qualified Synthesizer.Dimensional.Amplitude.Displacement as DispV + +import qualified Synthesizer.Dimensional.RateAmplitude.Signal as SigA +import qualified Synthesizer.Dimensional.Process as Proc + +import qualified Number.DimensionTerm as DN +import qualified Algebra.DimensionTerm as Dim + +import qualified Algebra.Module as Module +import qualified Algebra.Field as Field +import qualified Algebra.Real as Real +-- import qualified Algebra.Ring as Ring +-- import qualified Algebra.Additive as Additive + +-- import Algebra.Module ((*>)) + +import PreludeBase +-- import NumericPrelude +import Prelude () + + +{- * Mixing -} + +{-| Mix two signals. + In opposition to 'zipWith' the result has the length of the longer signal. -} +{-# INLINE mix #-} +mix :: (Real.C y, Field.C y, Module.C y yv, Dim.C v) => + Proc.T s u t ( + SigA.R s v y yv + -> SigA.R s v y yv + -> SigA.R s v y yv) +mix = Proc.pure DispV.mix + +{-# INLINE mixVolume #-} +mixVolume :: + (Real.C y, Field.C y, Module.C y yv, Dim.C v) => + DN.T v y + -> Proc.T s u t ( + SigA.R s v y yv + -> SigA.R s v y yv + -> SigA.R s v y yv) +mixVolume v = Proc.pure $ DispV.mixVolume v + +{-| Mix one or more signals. -} +{-# INLINE mixMulti #-} +mixMulti :: + (Real.C y, Field.C y, Module.C y yv, Dim.C v) => + Proc.T s u t ( + [SigA.R s v y yv] + -> SigA.R s v y yv) +mixMulti = Proc.pure DispV.mixMulti + +{-# INLINE mixMultiVolume #-} +mixMultiVolume :: + (Real.C y, Field.C y, Module.C y yv, Dim.C v) => + DN.T v y + -> Proc.T s u t ( + [SigA.R s v y yv] + -> SigA.R s v y yv) +mixMultiVolume v = Proc.pure $ DispV.mixMultiVolume v + +{-| Add a number to all of the signal values. + This is useful for adjusting the center of a modulation. -} +{-# INLINE raise #-} +raise :: (Field.C y, Module.C y yv, Dim.C v) => + DN.T v y + -> yv + -> Proc.T s u t ( + SigA.R s v y yv + -> SigA.R s v y yv) +raise y' yv = Proc.pure $ DispV.raise y' yv + +{-| Add a number to all of the signal values. + This is useful for adjusting the center of a modulation. -} +{-# INLINE distort #-} +distort :: (Field.C y, Module.C y yv, Dim.C v) => + (yv -> yv) + -> Proc.T s u t ( + SigA.R s v y y + -> SigA.R s v y yv + -> SigA.R s v y yv) +distort f = Proc.pure $ DispV.distort f diff --git a/src/Synthesizer/Dimensional/RateAmplitude/File.hs b/src/Synthesizer/Dimensional/RateAmplitude/File.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Dimensional/RateAmplitude/File.hs @@ -0,0 +1,119 @@ +{-# OPTIONS -fno-implicit-prelude -fglasgow-exts #-} +-- glasgow-exts for all quantifier +module Synthesizer.Dimensional.RateAmplitude.File ( + write, + writeTimeVoltage, + writeTimeVoltageMonoDouble, + writeTimeVoltageStereoDouble, + renderTimeVoltageMonoDouble, + renderTimeVoltageStereoDouble, + ) where + +import qualified Sox.File +import qualified BinarySample as BinSmp + +import qualified Synthesizer.Dimensional.Process as Proc + +import qualified Synthesizer.Dimensional.Amplitude.Signal as SigA +import qualified Synthesizer.Dimensional.RateAmplitude.Signal as SigRA +import qualified Synthesizer.Dimensional.RateWrapper as SigP + +import qualified Synthesizer.Frame.Stereo as Stereo + +import qualified Synthesizer.Storable.Signal as SigSt + +-- import qualified Synthesizer.Dimensional.Straight.Signal as SigS +import qualified Synthesizer.State.Signal as Sig + +-- import qualified Algebra.Transcendental as Trans +import qualified Algebra.Module as Module +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +-- import qualified Algebra.Ring as Ring + +import qualified Algebra.DimensionTerm as Dim +import qualified Number.DimensionTerm as DN + + +import System.Exit(ExitCode) + +import NumericPrelude +import PreludeBase + + + +{-# INLINE write #-} +write :: + (RealField.C t, BinSmp.C yv, + Dim.C u, Field.C t, + Dim.C v, Module.C y yv, Field.C y) => + DN.T (Dim.Recip u) t -> + DN.T v y -> + FilePath -> + SigP.T u t (SigA.S v y) yv -> +-- SigP.T u t (SigA.T v y (SigS.T Sig.T)) yv -> + IO ExitCode +write freqUnit amp name sig = + Sox.File.write name + (DN.divToScalar (SigP.sampleRate sig) freqUnit) + (Sig.toList (SigA.vectorSamples (flip DN.divToScalar amp) sig)) + + +{-# INLINE writeTimeVoltage #-} +writeTimeVoltage :: + (RealField.C t, BinSmp.C yv, + Field.C t, + Module.C y yv, Field.C y) => + FilePath -> + SigP.T Dim.Time t (SigA.S Dim.Voltage y) yv -> +-- SigP.T Dim.Time t (SigA.T Dim.Voltage y (SigS.T Sig.T)) yv -> + IO ExitCode +writeTimeVoltage = + write (DN.frequency one) (DN.voltage one) + + + +{-# INLINE writeTimeVoltageMonoDouble #-} +writeTimeVoltageMonoDouble :: + FilePath -> + SigP.T Dim.Time Double (SigA.S Dim.Voltage Double) Double -> +-- SigP.T Dim.Time t (SigA.T Dim.Voltage y (SigS.T Sig.T)) yv -> + IO () +writeTimeVoltageMonoDouble name sig = + let rate = DN.toNumberWithDimension Dim.frequency (SigP.sampleRate sig) + in do SigSt.writeFile (name ++ ".sw") + (SigP.signal (SigRA.toStorableInt16Mono sig)) + Sox.File.rawToAIFF name [] rate 1 + return () + + +{-# INLINE writeTimeVoltageStereoDouble #-} +writeTimeVoltageStereoDouble :: + FilePath -> + SigP.T Dim.Time Double (SigA.S Dim.Voltage Double) (Stereo.T Double) -> +-- SigP.T Dim.Time t (SigA.T Dim.Voltage y (SigS.T Sig.T)) yv -> + IO () +writeTimeVoltageStereoDouble name sig = + let rate = DN.toNumberWithDimension Dim.frequency (SigP.sampleRate sig) + in do SigSt.writeFile (name ++ ".sw") + (SigP.signal (SigRA.toStorableInt16Stereo sig)) + Sox.File.rawToAIFF name [] rate 2 + return () + +{-# INLINE renderTimeVoltageMonoDouble #-} +renderTimeVoltageMonoDouble :: + DN.T Dim.Frequency Double -> + FilePath -> + (forall s. Proc.T s Dim.Time Double (SigA.R s Dim.Voltage Double Double)) -> + IO () +renderTimeVoltageMonoDouble rate name sig = + writeTimeVoltageMonoDouble name (SigP.runProcess rate sig) + +{-# INLINE renderTimeVoltageStereoDouble #-} +renderTimeVoltageStereoDouble :: + DN.T Dim.Frequency Double -> + FilePath -> + (forall s. Proc.T s Dim.Time Double (SigA.R s Dim.Voltage Double (Stereo.T Double))) -> + IO () +renderTimeVoltageStereoDouble rate name sig = + writeTimeVoltageStereoDouble name (SigP.runProcess rate sig) diff --git a/src/Synthesizer/Dimensional/RateAmplitude/Filter.hs b/src/Synthesizer/Dimensional/RateAmplitude/Filter.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Dimensional/RateAmplitude/Filter.hs @@ -0,0 +1,599 @@ +{-# OPTIONS -fno-implicit-prelude #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes +-} +module Synthesizer.Dimensional.RateAmplitude.Filter ( + {- * Non-recursive -} + + {- ** Amplification -} + amplify, + amplifyDimension, + negate, + envelope, + envelopeVector, + envelopeVectorDimension, + {- ** Filter operators from calculus -} + differentiate, + + {- ** Smooth -} + meanStatic, + mean, + + {- ** Delay -} + delay, + phaseModulation, + frequencyModulation, + frequencyModulationDecoupled, + phaser, + phaserStereo, + + + {- * Recursive -} + + {- ** Without resonance -} + firstOrderLowpass, + firstOrderHighpass, + butterworthLowpass, + butterworthHighpass, + chebyshevALowpass, + chebyshevAHighpass, + chebyshevBLowpass, + chebyshevBHighpass, + {- ** With resonance -} + universal, + FiltR.highpassFromUniversal, + FiltR.bandpassFromUniversal, + FiltR.lowpassFromUniversal, + moogLowpass, + + {- ** Allpass -} + allpassCascade, + + {- ** Reverb -} + comb, + combProc, + + {- ** Filter operators from calculus -} + integrate, +) where + +import qualified Synthesizer.Dimensional.Rate.Filter as FiltR +import qualified Synthesizer.Dimensional.Amplitude.Filter as FiltV +-- import qualified Synthesizer.Dimensional.Amplitude.Displacement as MiscV +-- import qualified Synthesizer.Dimensional.Amplitude.Cut as CutV +import qualified Synthesizer.Dimensional.ControlledProcess as CProc +import qualified Synthesizer.Dimensional.Process as Proc +-- import qualified Synthesizer.Dimensional.Rate as Rate + +-- import Synthesizer.Dimensional.Process ((.:), (.^), ) + +import qualified Synthesizer.Dimensional.Abstraction.Flat as Flat +import qualified Synthesizer.Dimensional.Abstraction.Homogeneous as Hom + +import qualified Synthesizer.Dimensional.RatePhantom as RP + +import qualified Synthesizer.Dimensional.Straight.Signal as SigS +import qualified Synthesizer.Dimensional.RateAmplitude.Signal as SigA +import qualified Synthesizer.Dimensional.RateWrapper as SigP +-- import qualified Synthesizer.Dimensional.Amplitude.Signal as SigPA +import qualified Synthesizer.State.Signal as Sig +import Synthesizer.Plain.Signal (Modifier) + +import Synthesizer.Dimensional.RateAmplitude.Signal + (toTimeScalar, toFrequencyScalar, DimensionGradient, ) + +import qualified Synthesizer.Generic.SampledValue as Sample + +import qualified Synthesizer.Frame.Stereo as Stereo + +-- import qualified Synthesizer.State.Displacement as Disp +import qualified Synthesizer.State.Interpolation as Interpolation +import qualified Synthesizer.State.Filter.Delay as Delay +import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1 +import qualified Synthesizer.Plain.Filter.Recursive.Allpass as Allpass +import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilter +import qualified Synthesizer.Plain.Filter.Recursive.Moog as Moog +import qualified Synthesizer.Plain.Filter.Recursive.Butterworth as Butter +import qualified Synthesizer.Plain.Filter.Recursive.Chebyshev as Cheby +import qualified Synthesizer.Plain.Filter.Recursive as FiltR +import qualified Synthesizer.State.Filter.Recursive.Integration as Integrate +import qualified Synthesizer.State.Filter.Recursive.MovingAverage as MA +import qualified Synthesizer.State.Filter.NonRecursive as FiltNR + +import qualified Synthesizer.Storable.Signal as SigSt +import qualified Synthesizer.Storable.Filter.Recursive.Comb as Comb + +import qualified Number.DimensionTerm as DN +import qualified Algebra.DimensionTerm as Dim + +import Number.DimensionTerm ((&*&), (&/&)) + +import qualified Number.NonNegative as NonNeg + +import qualified Algebra.Transcendental as Trans +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Real as Real +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive +import qualified Algebra.VectorSpace as VectorSpace +import qualified Algebra.Module as Module + +-- import Control.Monad(liftM2) + +import NumericPrelude hiding (negate) +import PreludeBase as P +import Prelude () + + +{- | The amplification factor must be positive. -} +{-# INLINE amplify #-} +amplify :: (Ring.C y, Dim.C u, Dim.C v) => + y + -> Proc.T s u t ( + SigA.R s v y yv + -> SigA.R s v y yv) +amplify volume = Proc.pure $ FiltV.amplify volume + +{-# INLINE amplifyDimension #-} +amplifyDimension :: (Ring.C y, Dim.C u, Dim.C v0, Dim.C v1) => + DN.T v0 y + -> Proc.T s u t ( + SigA.R s v1 y yv + -> SigA.R s (Dim.Mul v0 v1) y yv) +amplifyDimension volume = Proc.pure $ FiltV.amplifyDimension volume + + +{-# INLINE negate #-} +negate :: (Additive.C yv, Dim.C u, Dim.C v) => + Proc.T s u t ( + SigA.R s v y yv + -> SigA.R s v y yv) +negate = Proc.pure FiltV.negate + + +{-# INLINE envelope #-} +envelope :: (Flat.C flat y0, Ring.C y0, Dim.C u, Dim.C v) => + Proc.T s u t ( + RP.T s flat y0 {- v the envelope -} + -> SigA.R s v y y0 {- v the signal to be enveloped -} + -> SigA.R s v y y0) +envelope = Proc.pure FiltV.envelope + +{-# INLINE envelopeVector #-} +envelopeVector :: (Flat.C flat y0, Module.C y0 yv, Ring.C y, Dim.C u, Dim.C v) => + Proc.T s u t ( + RP.T s flat y0 {- v the envelope -} + -> SigA.R s v y yv {- v the signal to be enveloped -} + -> SigA.R s v y yv) +envelopeVector = Proc.pure FiltV.envelopeVector + +{-# INLINE envelopeVectorDimension #-} +envelopeVectorDimension :: + (Module.C y0 yv, Ring.C y, Dim.C u, Dim.C v0, Dim.C v1) => + Proc.T s u t ( + SigA.R s v0 y y0 {- the envelope -} + -> SigA.R s v1 y yv {- the signal to be enveloped -} + -> SigA.R s (Dim.Mul v0 v1) y yv) +envelopeVectorDimension = Proc.pure FiltV.envelopeVectorDimension + + +{-# INLINE differentiate #-} +differentiate :: (Additive.C yv, Ring.C q, Dim.C u, Dim.C v) => + Proc.T s u q ( + SigA.R s v q yv + -> SigA.R s (DimensionGradient u v) q yv) +differentiate = + do rate <- Proc.getSampleRate + return $ \ x -> + SigA.fromSamples + (rate &*& SigA.amplitude x) + (FiltNR.differentiate (SigA.samples x)) + + +{- | needs a good handling of boundaries, yet -} +{-# INLINE meanStatic #-} +meanStatic :: + (RealField.C q, Module.C q yv, Dim.C u, Dim.C v) => + DN.T (Dim.Recip u) q {- ^ cut-off freqeuncy -} + -> Proc.T s u q ( + SigA.R s v q yv + -> SigA.R s v q yv) +meanStatic time = + FiltR.meanStatic time + +meanStaticSeparateTY :: (Additive.C yv, Field.C y, RealField.C t, + Module.C y yv, Dim.C u, Dim.C v) => + DN.T (Dim.Recip u) t {- ^ cut-off freqeuncy -} + -> Proc.T s u t ( + SigA.R s v y yv + -> SigA.R s v y yv) +meanStaticSeparateTY time = + -- FiltR.meanStatic time, means that 't' = 'y' + do f <- toFrequencyScalar time + return $ \ x -> + let tInt = round ((recip f - 1)/2) + width = tInt*2+1 + in SigA.processSamples + ((SigA.asTypeOfAmplitude (recip (fromIntegral width)) x *> ) . + Delay.staticNeg tInt . + MA.sumsStaticInt width) x + + +{- | needs a better handling of boundaries, yet -} +{-# INLINE mean #-} +mean :: (Additive.C yv, RealField.C q, + Module.C q yv, Dim.C u, Dim.C v, Sample.C q, Sample.C yv) => + DN.T (Dim.Recip u) q {- ^ minimum cut-off freqeuncy -} + -> Proc.T s u q ( + SigA.R s (Dim.Recip u) q q + {- v cut-off freqeuncies -} + -> SigA.R s v q yv + -> SigA.R s v q yv) +mean minFreq = + FiltR.mean minFreq + + +{-# INLINE delay #-} +delay :: (Additive.C yv, Field.C y, RealField.C t, Dim.C u, Dim.C v) => + DN.T u t + -> Proc.T s u t ( + SigA.R s v y yv + -> SigA.R s v y yv) +delay time = + do t <- toTimeScalar time + return $ SigA.processSamples (Delay.static (round t)) + + +{-# INLINE phaseModulation #-} +phaseModulation :: + (Additive.C yv, RealField.C q, Dim.C u, Dim.C v, + Sample.C q, Sample.C yv) => + Interpolation.T q yv + -> DN.T u q + {- ^ minDelay, minimal delay, may be negative -} + -> DN.T u q + {- ^ maxDelay, maximal delay, it must be @minDelay <= maxDelay@ + and the modulation must always be + in the range [minDelay,maxDelay]. -} + -> Proc.T s u q ( + SigA.R s u q q + {- v delay control, positive numbers meanStatic delay, + negative numbers meanStatic prefetch -} + -> SigA.R s v q yv + -> SigA.R s v q yv) +phaseModulation ip minDelay maxDelay = + FiltR.phaseModulation ip minDelay maxDelay + +{-# INLINE frequencyModulation #-} +frequencyModulation :: + (Flat.C flat q, Additive.C yv, RealField.C q, Dim.C u, Dim.C v) => + Interpolation.T q yv + -> Proc.T s u q ( + RP.T s flat q {- v frequency factors -} + -> SigA.R s v q yv + -> SigA.R s v q yv) +frequencyModulation ip = + Proc.pure $ + \ factors -> + SigA.processSamples + (FiltR.interpolateMultiRelativeZeroPad ip (Flat.toSamples factors)) + +{- | +Frequency modulation where the input signal can have a sample rate +different from the output. +(The sample rate values can differ, the unit must be the same. +We could lift that restriction, +but then the unit handling becomes more complicated, +and I didn't have a use for it so far.) + +The function can be used for resampling. +-} +{-# INLINE frequencyModulationDecoupled #-} +frequencyModulationDecoupled :: + (Flat.C flat q, Additive.C yv, RealField.C q, Dim.C u, Dim.C v) => + Interpolation.T q yv + -> Proc.T s u q ( + RP.T s flat q {- v frequency factors -} + -> SigP.T u q (SigA.T v q (SigS.T Sig.T)) yv + -> SigA.R s v q yv) +frequencyModulationDecoupled ip = + fmap + (\toFreq factors y -> + flip SigA.processSamples (RP.fromSignal (SigP.signal y)) $ + FiltR.interpolateMultiRelativeZeroPad ip + (SigA.scalarSamples toFreq + (SigA.fromSamples (SigP.sampleRate y) (Flat.toSamples factors)))) + (Proc.withParam Proc.toFrequencyScalar) + + +{- | symmetric phaser -} +{-# INLINE phaser #-} +phaser :: + (Additive.C yv, RealField.C q, + Module.C q yv, Dim.C u, Dim.C v, + Sample.C q, Sample.C yv) => + Interpolation.T q yv + -> DN.T u q {- ^ maxDelay, must be positive -} + -> Proc.T s u q ( + SigA.R s u q q + {- v delay control -} + -> SigA.R s v q yv + -> SigA.R s v q yv) +phaser = FiltR.phaser +{- +phaser ip maxDelay = + do p <- phaserCore ip maxDelay + return $ \ delays x -> + FiltV.amplify 0.5 . + uncurry MiscV.mix . p delays $ x +-} + +{-# INLINE phaserStereo #-} +phaserStereo :: + (Additive.C yv, RealField.C q, + Module.C q yv, Dim.C u, Dim.C v, + Sample.C q, Sample.C yv) => + Interpolation.T q yv + -> DN.T u q {- ^ maxDelay, must be positive -} + -> Proc.T s u q ( + SigA.R s u q q + {- v delay control -} + -> SigA.R s v q yv + -> SigA.R s v q (Stereo.T yv)) +phaserStereo = FiltR.phaserStereo +{- +phaserStereo ip maxDelay = + do p <- phaserCore ip maxDelay + return $ \ delays -> uncurry CutV.zip . p delays +-} + +{- +{-# INLINE phaserCore #-} +phaserCore :: + (Additive.C yv, RealField.C q, + Module.C q yv, Dim.C u, Dim.C v, + Sample.C q, Sample.C yv) => + Interpolation.T q yv + -> DN.T u q {- ^ maxDelay, must be positive -} + -> Proc.T s u q ( + SigA.R s u q q + {- v delay control -} + -> SigA.R s v q yv + -> (SigA.R s v q yv, SigA.R s v q yv)) +phaserCore ip maxDelay = + do let minDelay = Additive.negate maxDelay + pm <- phaseModulation ip minDelay maxDelay + return $ \ delays x -> + let negDelays = FiltV.negate delays + in (pm delays x, + pm negDelays x) +-} + + + +{-# INLINE firstOrderLowpass #-} +{-# INLINE firstOrderHighpass #-} +firstOrderLowpass, firstOrderHighpass :: + (Trans.C q, Module.C q yv, Dim.C u, Dim.C v) => + CProc.T s u q + (SigA.R s (Dim.Recip u) q q + {- v Control signal for the cut-off frequency. -} ) + (Filt1.Parameter q) ( + SigA.R s v q yv + {- v Input signal -} + -> SigA.R s v q yv) +firstOrderLowpass = firstOrderGen Filt1.lowpassModifier +firstOrderHighpass = firstOrderGen Filt1.highpassModifier + +{-# INLINE firstOrderGen #-} +firstOrderGen :: + (Trans.C q, Module.C q yv, Dim.C u, Dim.C v) => + (Modifier yv (Filt1.Parameter q) yv yv) +-- (Sig.T (Filt1.Parameter q) -> Sig.T yv -> Sig.T yv) + -> CProc.T s u q (SigA.R s (Dim.Recip u) q q) (Filt1.Parameter q) ( + SigA.R s v q yv + -> SigA.R s v q yv) +firstOrderGen modif = + frequencyControl Filt1.parameter + (Sig.modifyModulated modif) + + + +{-# INLINE butterworthLowpass #-} +{-# INLINE butterworthHighpass #-} +{-# INLINE chebyshevALowpass #-} +{-# INLINE chebyshevAHighpass #-} +{-# INLINE chebyshevBLowpass #-} +{-# INLINE chebyshevBHighpass #-} + +butterworthLowpass, butterworthHighpass, + chebyshevALowpass, chebyshevAHighpass, + chebyshevBLowpass, chebyshevBHighpass :: + (Trans.C q, VectorSpace.C q yv, Dim.C u, Dim.C v) => + NonNeg.Int {- ^ Order of the filter, must be even, + the higher the order, the sharper is the separation of frequencies. -} + -> q {- ^ The attenuation at the cut-off frequency. + Should be between 0 and 1. -} + -> CProc.T s u q + (SigA.R s (Dim.Recip u) q q + {- v Control signal for the cut-off frequency. -} ) + q ( + SigA.R s v q yv {- v Input signal -} + -> SigA.R s v q yv) + +butterworthLowpass = higherOrderNoResoGen Butter.lowpass +butterworthHighpass = higherOrderNoResoGen Butter.highpass +chebyshevALowpass = higherOrderNoResoGen Cheby.lowpassA +chebyshevAHighpass = higherOrderNoResoGen Cheby.highpassA +chebyshevBLowpass = higherOrderNoResoGen Cheby.lowpassB +chebyshevBHighpass = higherOrderNoResoGen Cheby.highpassB + +{- FIXME: +currently only frequencies can be interpolated not the filter parameters, +this is not very efficient +-} +{- TODO: +initial value +-} +{-# INLINE higherOrderNoResoGen #-} +higherOrderNoResoGen :: + (Field.C q, Dim.C u, Dim.C v) => + (Int -> q -> [q] -> [yv] -> [yv]) + -> NonNeg.Int + -> q + -> CProc.T s u q (SigA.R s (Dim.Recip u) q q) q ( + SigA.R s v q yv + -> SigA.R s v q yv) +higherOrderNoResoGen filt order ratio = + frequencyControl id + (\ cs xs -> + Sig.fromList (filt (NonNeg.toNumber order) ratio + (Sig.toList cs) (Sig.toList xs))) + + + +{-# INLINE universal #-} +universal :: + (Flat.C flat q, Trans.C q, Module.C q yv, Dim.C u, Dim.C v) => + CProc.T s u q + (RP.T s flat q + {- v signal for resonance, + i.e. factor of amplification at the resonance frequency + relatively to the transition band. -}, + SigA.R s (Dim.Recip u) q q + {- v signal for cut off and band center frequency -} ) + (UniFilter.Parameter q) ( + SigA.R s v q yv + {- v input signal -} + -> SigA.R s v q (UniFilter.Result yv)) + {- ^ highpass, bandpass, lowpass filter -} +universal = + frequencyResonanceControl + UniFilter.parameter + (Sig.modifyModulated UniFilter.modifier) + +{-# INLINE moogLowpass #-} +moogLowpass :: (Flat.C flat q, Trans.C q, Module.C q yv, Dim.C u, Dim.C v) => + NonNeg.Int + -> CProc.T s u q + (RP.T s flat q + {- v signal for resonance, + i.e. factor of amplification at the resonance frequency + relatively to the transition band. -}, + SigA.R s (Dim.Recip u) q q + {- v signal for cut off frequency -} ) + (Moog.Parameter q) ( + SigA.R s v q yv + -> SigA.R s v q yv) +moogLowpass order = + let orderInt = NonNeg.toNumber order + in frequencyResonanceControl + (Moog.parameter orderInt) + (Sig.modifyModulated (Moog.lowpassModifier orderInt)) + +{-# INLINE allpassCascade #-} +allpassCascade :: (Trans.C q, Module.C q yv, Dim.C u, Dim.C v) => + NonNeg.Int {- ^ order, number of filters in the cascade -} + -> q {- ^ the phase shift to be achieved for the given frequency -} + -> CProc.T s u q + (SigA.R s (Dim.Recip u) q q {- v lowest comb frequency -}) + (Allpass.Parameter q) ( + SigA.R s v q yv + -> SigA.R s v q yv) +allpassCascade order phase = + let orderInt = NonNeg.toNumber order + in frequencyControl + (Allpass.parameter orderInt phase) + (Sig.modifyModulated (Allpass.cascadeModifier orderInt)) + + +{-# INLINE frequencyControl #-} +frequencyControl :: + (Field.C y, Dim.C u, Dim.C v) => + (y -> ic) -> + (Sig.T ic -> Sig.T yv0 -> Sig.T yv1) -> + CProc.T s u y + (SigA.R s (Dim.Recip u) y y) ic + (SigA.R s v y1 yv0 -> SigA.R s v y1 yv1) + +frequencyControl mkParam filt = CProc.Cons $ + do toFreq <- Proc.withParam toFrequencyScalar + return + (\ freqs -> Sig.map mkParam (SigA.scalarSamples toFreq freqs), + \ params -> SigA.processSamples (filt params)) + + +{-# INLINE frequencyResonanceControl #-} +frequencyResonanceControl :: + (Flat.C flat y, Field.C y, Dim.C u, Dim.C v) => + (FiltR.Pole y -> ic) -> + (Sig.T ic -> Sig.T yv0 -> Sig.T yv1) -> + CProc.T s u y + (RP.T s flat y, SigA.R s (Dim.Recip u) y y) ic + (SigA.R s v y1 yv0 -> SigA.R s v y1 yv1) + +frequencyResonanceControl mkParam filt = CProc.Cons $ + do toFreq <- Proc.withParam toFrequencyScalar + return + (\ (resos, freqs) -> + Sig.map mkParam $ + Sig.zipWith FiltR.Pole + (Flat.toSamples resos) + (SigA.scalarSamples toFreq freqs), + \ params -> SigA.processSamples (filt params)) + + +{- | Infinitely many equi-delayed exponentially decaying echos. -} +{-# INLINE comb #-} +comb :: (RealField.C t, Module.C y yv, Dim.C u, Dim.C v, Sample.C yv) => + DN.T u t -> y -> Proc.T s u t (SigA.R s v y yv -> SigA.R s v y yv) +comb = FiltR.comb + + +{- | Infinitely many equi-delayed echos processed by an arbitrary time-preserving signal processor. -} +{-# INLINE combProc #-} +combProc :: + (RealField.C t, Real.C y, Field.C y, Module.C y yv, Sample.C yv, + Dim.C u, Dim.C v) => + DN.T u t -> + Proc.T s u t (SigA.R s v y yv -> SigA.R s v y yv) -> + Proc.T s u t (SigA.R s v y yv -> SigA.R s v y yv) +combProc time proc = + do f <- proc + t <- fmap round $ toTimeScalar time + let chunkSize = SigSt.chunkSize t + return $ \x -> + SigA.processSamples + (Sig.fromStorableSignal . + Comb.runProc t + (Sig.toStorableSignal chunkSize . + SigA.vectorSamples (SigA.toAmplitudeScalar x) . + f . + SigA.fromSamples (SigA.amplitude x) . + Sig.fromStorableSignal) . + Sig.toStorableSignal chunkSize) x + +{- +combProc time proc sr x = + Rate.loop (\sr' y -> MiscV.mixVolume (SigA.amplitude x) x (delay time sr' (proc sr' y))) sr +-} + + +{-# INLINE integrate #-} +integrate :: (Additive.C yv, Field.C q, Dim.C u, Dim.C v) => + Proc.T s u q ( + SigA.R s v q yv + -> SigA.R s (Dim.Mul u v) q yv) +integrate = + do rate <- Proc.getSampleRate + return $ \ x -> + SigA.replaceAmplitude + (DN.rewriteDimension (Dim.commute . Dim.applyRightMul Dim.invertRecip) $ + SigA.amplitude x &/& rate) + (Hom.processSamples Integrate.run x) diff --git a/src/Synthesizer/Dimensional/RateAmplitude/Instrument.hs b/src/Synthesizer/Dimensional/RateAmplitude/Instrument.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Dimensional/RateAmplitude/Instrument.hs @@ -0,0 +1,540 @@ +{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-} +module Synthesizer.Dimensional.RateAmplitude.Instrument where + +import qualified Synthesizer.Dimensional.Rate.Oscillator as Osci +import qualified Synthesizer.Dimensional.Rate.Filter as Filt +import qualified Synthesizer.Dimensional.RateAmplitude.Displacement as Disp +import qualified Synthesizer.Dimensional.RateAmplitude.Noise as Noise +-- import qualified Synthesizer.SampleRateDimension.Filter.Recursive as FiltR +-- import qualified Synthesizer.SampleRateDimension.Filter.NonRecursive as FiltNR +import qualified Synthesizer.Dimensional.RateAmplitude.Filter as FiltA +import qualified Synthesizer.Dimensional.RateAmplitude.Cut as Cut +import qualified Synthesizer.Dimensional.Amplitude.Cut as CutA + +import qualified Synthesizer.Dimensional.RateAmplitude.Control as Ctrl +import qualified Synthesizer.Dimensional.Rate.Control as CtrlR + +import qualified Synthesizer.Dimensional.Straight.Displacement as DispS + +import qualified Synthesizer.Dimensional.Amplitude.Analysis as Ana + +import qualified Synthesizer.Dimensional.Process as Proc +import qualified Synthesizer.Dimensional.Cyclic.Signal as SigC +import qualified Synthesizer.Dimensional.Straight.Signal as SigS +import qualified Synthesizer.Dimensional.RateAmplitude.Signal as SigA + +import Synthesizer.Dimensional.RateAmplitude.Signal (($-), ($&), (&*^), (&*>^), ) +import Synthesizer.Dimensional.RateAmplitude.Control ((-|#), ( #|-), (|#), ( #|), ) + +import Synthesizer.Dimensional.Process (($:), ($::), (.:), ($^), ($#)) +import Synthesizer.Dimensional.Amplitude.Control (mapLinear, mapExponential, ) + +import qualified Synthesizer.Generic.SampledValue as Sample + +import qualified Algebra.DimensionTerm as Dim +import qualified Number.DimensionTerm as DN + +import Number.DimensionTerm ((*&), (&*&), ) + +import qualified Synthesizer.State.Interpolation as Interpolation +import Synthesizer.Plain.Instrument (choirWave) +import qualified Synthesizer.Basic.Wave as Wave +import qualified Synthesizer.Basic.Phase as Phase + +import qualified Number.NonNegative as NonNeg + +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Module as Module +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring + +import System.Random (Random, randoms, randomRs, mkStdGen, ) +import Synthesizer.Utility (randomRsBalanced, balanceLevel, ) + +import Data.List(zip4) + +import PreludeBase +import NumericPrelude + + + +{-| Create a sound of a slightly changed frequency + just as needed for a simple stereo sound. -} +{-# INLINE stereoPhaser #-} +stereoPhaser :: Ring.C a => + (DN.T Dim.Frequency a -> + Proc.T s Dim.Time a (SigA.R s u b b)) + {- ^ A function mapping a frequency to a signal. -} + -> a {- ^ The factor to the frequency, should be close to 1. -} + -> DN.T Dim.Frequency a + {- ^ The base (undeviated) frequency of the sound. -} + -> Proc.T s Dim.Time a (SigA.R s u b b) +stereoPhaser sound dif freq = + sound (dif *& freq) + + + +{- +allpassPlain :: (RealField.C a, Trans.C a, Module.C a a) => + a -> a -> a -> a -> [a] +allpassPlain sampleRate halfLife k freq = + Filt.allpassCascade 10 + (map Filt.AllpassParam (exponential2 (halfLife*sampleRate) k)) + (simpleSaw sampleRate freq) +-} + +{-# INLINE allpassDown #-} +allpassDown :: + (RealField.C a, Trans.C a, Module.C a a) => + NonNeg.Int -> DN.T Dim.Time a -> + DN.T Dim.Frequency a -> DN.T Dim.Frequency a -> + Proc.T s Dim.Time a (SigA.R s Dim.Voltage a a) +allpassDown order halfLife filterfreq freq = + do x <- simpleSaw freq + FiltA.amplify 0.3 $: + (Disp.mix + $# x + $: (Filt.allpassCascade order (-2*pi) + $: filterfreq &*^ CtrlR.exponential2 halfLife + $# x)) + + +{-# INLINE moogDown #-} +{-# INLINE moogReso #-} +moogDown, moogReso :: + (RealField.C a, Trans.C a, Module.C a a) => + NonNeg.Int -> DN.T Dim.Time a -> + DN.T Dim.Frequency a -> DN.T Dim.Frequency a -> + Proc.T s Dim.Time a (SigA.R s Dim.Voltage a a) +moogDown order halfLife filterfreq freq = + Filt.moogLowpass order + $- DN.fromNumber 10 + $: filterfreq &*^ CtrlR.exponential2 halfLife + $: simpleSaw freq + +moogReso order halfLife filterfreq freq = + Filt.moogLowpass order + $: DN.fromNumber 100 &*^ CtrlR.exponential2 halfLife + $- filterfreq + $: simpleSaw freq + + +{-# INLINE bell #-} +bell :: (Trans.C a, RealField.C a, Module.C a a) => + DN.T Dim.Frequency a -> + Proc.T s Dim.Time a (SigA.R s Dim.Voltage a a) +bell freq = + let halfLife = DN.time 0.5 + in FiltA.amplify (1/3) $: + (Disp.mixMulti $:: + (bellHarmonic 1 halfLife freq : + bellHarmonic 4 halfLife freq : + bellHarmonic 7 halfLife freq : + [])) + + + +{-# INLINE bellHarmonic #-} +bellHarmonic :: (Trans.C a, RealField.C a, Module.C a a) => + a -> DN.T Dim.Time a -> DN.T Dim.Frequency a -> + Proc.T s Dim.Time a (SigA.R s Dim.Voltage a a) +bellHarmonic n halfLife freq = + Filt.envelope + $: CtrlR.exponential2 (recip n *& halfLife) + $: (DN.voltage 1 + &*^ (Osci.freqMod Wave.sine zero + $: (mapLinear 0.005 (DN.frequency 5) + $^ Osci.static Wave.sine zero (n *& freq)))) + + +{-# INLINE fastBell #-} +{-# INLINE squareBell #-} +{-# INLINE moogGuitar #-} +{-# INLINE moogGuitarSoft #-} +{-# INLINE fatSaw #-} + +fastBell, squareBell, moogGuitar, moogGuitarSoft, fatSaw :: + (RealField.C a, Trans.C a, Module.C a a) => + DN.T Dim.Frequency a -> Proc.T s Dim.Time a (SigA.R s Dim.Voltage a a) +fastBell freq = + Filt.envelope + $: CtrlR.exponential2 (DN.time 0.2) + $: (DN.voltage 1 &*^ Osci.static Wave.sine zero freq) + +{-# INLINE filterSaw #-} +filterSaw :: (Module.C a a, Trans.C a, RealField.C a) => + DN.T Dim.Frequency a -> DN.T Dim.Frequency a -> + Proc.T s Dim.Time a (SigA.R s Dim.Voltage a a) +filterSaw filterFreq freq = + FiltA.amplify 0.1 $: + (Filt.lowpassFromUniversal $: + (Filt.universal + $- DN.fromNumber 10 + $: filterFreq &*^ CtrlR.exponential2 (DN.time 0.1) + $: (DN.voltage 1 &*^ Osci.static Wave.saw zero freq))) + + +squareBell freq = + Filt.firstOrderLowpass + $: DN.frequency 4000 &*^ CtrlR.exponential2 (DN.time (1/10)) +-- (Osci.freqModSample Interpolation.cubic [0, 0.7, -0.3, 0.7, 0, -0.7, 0.3, -0.7] zero + $: (DN.voltage 1 &*^ + (Osci.freqModSample Interpolation.linear + (SigC.fromPeriodList [0, 0.5, 0.6, 0.8, 0, -0.5, -0.6, -0.8]) zero + $: (mapLinear 0.01 freq + $^ (Osci.static Wave.sine zero (DN.frequency 5.0))))) + + +{-# INLINE fmBell #-} +fmBell :: (RealField.C a, Trans.C a, Module.C a a) => + a -> a -> DN.T Dim.Frequency a -> + Proc.T s Dim.Time a (SigA.R s Dim.Voltage a a) +fmBell depth freqRatio freq = + let modul = + Filt.envelope + $: CtrlR.exponential2 (DN.time 0.2) + $: DN.fromNumber depth &*^ Osci.static Wave.sine zero (freqRatio *& freq) + in Filt.envelope + $: CtrlR.exponential2 (DN.time 0.5) + $: (DN.voltage 1 &*^ (Osci.phaseMod Wave.sine freq $& modul)) + + +moogGuitar freq = + let filterControl = + DN.frequency 4000 &*^ CtrlR.exponential2 (DN.time 0.5) + tone = + DN.voltage 1 &*^ + (Osci.freqMod Wave.saw zero + $: (mapLinear 0.005 freq $^ + Osci.static Wave.sine zero (DN.frequency 5))) + in Filt.moogLowpass 4 $- DN.fromNumber 10 $: filterControl $: tone + +moogGuitarSoft freq = + Filt.envelope + $: (fmap (1-) $^ CtrlR.exponential2 (DN.time 0.003)) + $: moogGuitar freq + + +{- | +Phase modulation using a ring modulated signal. +May be used as some kind of e-guitar. +-} +fmRing :: + (RealField.C a, Trans.C a, Module.C a a) => + DN.T Dim.Frequency a -> Proc.T s Dim.Time a (SigA.R s Dim.Voltage a a) +fmRing freq = + DN.voltage 1 &*^ + (Osci.phaseMod (Wave.sineSawSmooth 1) freq + $: (DN.fromNumber 1 &*^ -- 0.2 for no distortion + (Filt.envelope + $: CtrlR.exponential2 (DN.time 0.2) + $: (Filt.envelope + $: Osci.static (Wave.raise one Wave.sine) (Phase.fromRepresentative 0.75) freq + $: Osci.static Wave.sine zero (5.001 *& freq))))) + +fatPad :: + (RealField.C a, Trans.C a, Module.C a a, Random a) => + DN.T Dim.Frequency a -> Proc.T s Dim.Time a (SigA.R s Dim.Voltage a a) +fatPad freq = + let env = + Cut.append + $: (Cut.take (DN.time 0.7) $: + Ctrl.cubicHermite + (DN.time 0, (DN.fromNumber 0, DN.frequency 1 &*& DN.fromNumber 5)) + (DN.time 0.7, (DN.fromNumber 0.5, DN.frequency 1 &*& DN.fromNumber 0))) + $: Ctrl.constant (DN.fromNumber 0.5) + osci f = + DN.voltage 0.3 &*^ + (Osci.phaseMod Wave.sine f + $: (DN.fromNumber 2 &*^ + (Filt.envelope + $: env + $: Osci.static (Wave.sineSawSmooth 1) zero f))) + freqs = randomRsBalanced (mkStdGen 384) 3 1 0.03 + in Disp.mixMulti $:: map (\k -> osci (k *& freq)) freqs +{- +renderTimeVoltageMonoDouble (DN.frequency 44100) "fat-pad" (Cut.take (DN.time 1.5) $: fatPad (DN.frequency 220)) +-} + + +brass :: + (RealField.C a, Trans.C a, Module.C a a, Random a) => + DN.T Dim.Frequency a -> Proc.T s Dim.Time a (SigA.R s Dim.Voltage a a) +brass freq = + let blobEnv = Ctrl.piecewise + (DN.fromNumber 0 |# (DN.time 0.05, Ctrl.cosinePiece) #|- + DN.fromNumber 1 -|# (DN.time 0.05, Ctrl.cosinePiece) #| + DN.fromNumber 0) + adsr = Ctrl.piecewise + (DN.fromNumber 0 |# (DN.time 0.1, Ctrl.cubicPiece (DN.frequency 1 &*& DN.fromNumber 10) (DN.frequency 1 &*& DN.fromNumber 0)) #|- + DN.fromNumber 0.5 -|# (DN.time 1, Ctrl.stepPiece) #|- + DN.fromNumber 0.5 -|# (DN.time 0.3, Ctrl.exponentialPiece (DN.fromNumber 0)) #| + DN.fromNumber 0.01) + osci b f = + DN.voltage 0.5 &*^ + (Osci.freqMod Wave.saw zero $: + (Disp.mix + $: (mapLinear 0.01 f $^ Osci.static Wave.sine zero (DN.frequency 2)) + $: ((b *& f) &*^ blobEnv))) + n = 4 + freqs = randomRsBalanced (mkStdGen 295) n 1 0.03 + blobAmps = balanceLevel 0 (take n (iterate (0.1+) 0)) + in Filt.envelope + $: adsr + $: (Disp.mixMulti $:: zipWith (\b k -> osci b (k *& freq)) blobAmps freqs) +{- +Synthesizer.Dimensional.RateAmplitude.File.renderTimeVoltageMonoDouble (DN.frequency 44100) "brass" (brass (DN.frequency 440)) +-} + + +{-| low pass with resonance -} +{-# INLINE filterSweep #-} +filterSweep :: (Module.C a v, Trans.C a, RealField.C a) => + Phase.T a -> + Proc.T s Dim.Time a ( + SigA.R s Dim.Voltage a v -> + SigA.R s Dim.Voltage a v) +filterSweep phase = + Filt.lowpassFromUniversal .: + (Filt.universal + $- DN.fromNumber 10 + $: (mapExponential 2 (DN.frequency 1800) $^ + Osci.static Wave.sine phase (DN.frequency (1/16)))) + + +{-# INLINE fatSawChordFilter #-} +{-# INLINE fatSawChord #-} +fatSawChordFilter, fatSawChord :: + (RealField.C a, Trans.C a, Module.C a a) => + DN.T Dim.Frequency a -> Proc.T s Dim.Time a (SigA.R s Dim.Voltage a a) + +fatSawChordFilter freq = + FiltA.amplify (1/2) $: + (Filt.lowpassFromUniversal $: + (Filt.universal + $- DN.fromNumber 10 + $: filterDown + $: fatSawChord freq)) + +fatSawChord freq = + FiltA.amplify (1/3) $: + (Disp.mixMulti $:: + [fatSaw ( 1 *& freq), + fatSaw ((5/4) *& freq), + fatSaw ((3/2) *& freq)]) + +{-# INLINE filterDown #-} +filterDown :: (RealField.C a, Trans.C a) => + Proc.T s Dim.Time a (SigA.R s Dim.Frequency a a) +filterDown = + DN.frequency 4000 &*^ CtrlR.exponential2 (DN.time (1/3)) + +{-# INLINE simpleSaw #-} +simpleSaw :: (Ring.C a, Dim.C u, RealField.C v) => + DN.T (Dim.Recip u) v -> + Proc.T s u v (SigA.R s Dim.Voltage a v) +simpleSaw freq = + DN.voltage 1 &*>^ Osci.static Wave.saw zero freq + + +{-| accumulate multiple similar saw sounds and observe the increase of volume + The oscillator @osc@ must accept relative frequencies. -} +{-# INLINE modulatedWave #-} +modulatedWave :: (Trans.C a, RealField.C a, Dim.C u) => + Proc.T s u a (SigA.R s (Dim.Recip u) a a -> SigA.R s Dim.Voltage a a) -> + DN.T (Dim.Recip u) a -> + a -> Phase.T a -> + DN.T (Dim.Recip u) a -> + Proc.T s u a (SigA.R s Dim.Voltage a a) +modulatedWave osc freq depth phase speed = + osc $: (mapLinear depth freq $^ + Osci.static Wave.sine phase speed) + + +{-# INLINE accumulationParameters #-} +accumulationParameters :: (Random a, Trans.C a, RealField.C a, Module.C a a) => + [(Phase.T a, a, Phase.T a, DN.T Dim.Frequency a)] +accumulationParameters = + let starts = randoms (mkStdGen 48251) + depths = randomRs (0,0.02) (mkStdGen 12354) + phases = randoms (mkStdGen 74389) + speeds = randomRs (DN.frequency 0.1, DN.frequency 0.3) + (mkStdGen 03445) + in zip4 starts depths phases speeds + +{-# INLINE accumulatedSaws #-} +{-# INLINE choir #-} +accumulatedSaws, choir :: + (Random a, Trans.C a, RealField.C a, Module.C a a) => + DN.T Dim.Frequency a -> + Proc.T s Dim.Time a (SigA.R s Dim.Voltage a a) +accumulatedSaws freq = + Disp.mixMulti $:: + (map + (\(start, depth, phase, speed) -> + modulatedWave + (ampVolt (Osci.freqMod Wave.saw start)) + freq depth phase speed) + accumulationParameters) + +choir freq = + FiltA.amplify 0.2 $: (Disp.mixMulti $:: + take 10 + (map + (\(start, depth, phase, speed) -> + modulatedWave + (ampVolt (Osci.freqModSample Interpolation.constant + (SigC.fromPeriodList choirWave) start)) + freq depth phase speed) + accumulationParameters)) + + +fatSaw freq = + {- a simplified version of modulatedWave -} + let partial depth modPhase modFreq = + osciDoubleSaw $: + (mapLinear depth freq $^ + Osci.static Wave.sine (Phase.fromRepresentative modPhase) modFreq) + in Disp.mixMulti $:: + [partial 0.00311 0.0 (DN.frequency 20), + partial 0.00532 0.3 (DN.frequency 17), + partial 0.00981 0.9 (DN.frequency 6)] + + +{-# INLINE wasp #-} +{- | +A good choice is @freq = DN.frequency 110@ +-} +wasp :: + (RealField.C q, Trans.C q, Module.C q q, Random q, Sample.C q, Dim.C u) => + DN.T (Dim.Recip u) q -> + Proc.T s u q (SigA.R s Dim.Voltage q q) +wasp freq = + Filt.envelope + $: (mapLinear 1 (DN.scalar 0.5) $^ Osci.static Wave.saw zero (recip 2.01 *& freq)) + $: DN.voltage 0.7 &*^ Osci.static Wave.saw zero freq + + +{-# INLINE osciDoubleSaw #-} +osciDoubleSaw :: (RealField.C a, Module.C a a, Dim.C u) => + Proc.T s u a ( + SigA.R s (Dim.Recip u) a a -> + SigA.R s Dim.Voltage a a) +osciDoubleSaw = + ampVolt $ + Osci.freqModSample Interpolation.linear + (SigC.fromPeriodList [-1, -0.2, 0.5, -0.5, 0.2, 1.0]) zero + +{-# INLINE ampVolt #-} +ampVolt :: (Ring.C y, Dim.C u) => + Proc.T s u y (a -> SigS.R s y) -> + Proc.T s u y (a -> SigA.R s Dim.Voltage y y) +ampVolt p = + Proc.withParam $ \x -> + DN.voltage 1 &*^ (p $# x) + +{-| +A tone with a waveform with roughly the dependency @x -> x^?p@, +where the waveform is normalized to constant quadratic norm +-} +{-# INLINE osciSharp #-} +osciSharp :: (RealField.C a, Trans.C a) => + DN.T Dim.Frequency a -> + Proc.T s Dim.Time a (SigA.R s Dim.Voltage a a) +osciSharp freq = + let control = DN.fromNumber 10 &*^ CtrlR.exponential2 (DN.time 0.01) + in DN.voltage 1 &*^ + (Osci.shapeMod Wave.powerNormed zero freq $& control) + +{-| +Build a saw sound from its harmonics and modulate it. +Different to normal modulation +I modulate each harmonic with the same depth rather than a proportional one. +-} +{-# INLINE osciAbsModSaw #-} +osciAbsModSaw :: (RealField.C a, Trans.C a, Module.C a a) => + DN.T Dim.Frequency a -> + Proc.T s Dim.Time a (SigA.R s Dim.Voltage a a) +osciAbsModSaw freq = + let harmonic n = + DN.voltage (0.25 / fromInteger n) + &*^ (Osci.freqMod Wave.sine zero + $: (mapLinear 0.03 freq $^ + (Osci.static Wave.sine zero (DN.frequency 1)))) + in Disp.mixMulti $:: map harmonic [1..20] + +{-| +Short pulsed Noise.white, +i.e. Noise.white amplified with pulses of varying H\/L ratio. +-} +{-# INLINE pulsedNoise #-} +pulsedNoise :: (Random a, RealField.C a, Trans.C a, Module.C a a) => + DN.T Dim.Frequency a {-^ frequency of the pulses, interesting ones are around 100 Hz and below -} -> + Proc.T s Dim.Time a (SigA.R s Dim.Voltage a a) +pulsedNoise freq = + let raisedSine = Wave.raise one Wave.sine + c = Proc.pure Ana.lessOrEqual + $: (DN.voltage 1.0 &*^ Osci.static raisedSine zero freq) + $: (DN.voltage 0.2 &*^ Osci.static raisedSine zero (DN.frequency 0.1)) + in Proc.pure CutA.selectBool + $- DN.voltage 0 + $: Noise.white (DN.frequency 20000) (DN.voltage 1.0) + $: c + + +{-# INLINE noisePerc #-} +noisePerc :: (Random a, RealField.C a, Trans.C a) => + Proc.T s Dim.Time a (SigA.R s Dim.Voltage a a) +noisePerc = + Filt.envelope + $: CtrlR.exponential2 (DN.time 0.1) + $: Noise.white (DN.frequency 20000) (DN.voltage 1.0) + +{-# INLINE noiseBass #-} +noiseBass :: (Random a, RealField.C a, Trans.C a, Module.C a a, Sample.C a) => + DN.T Dim.Frequency a -> + Proc.T s Dim.Time a (SigA.R s Dim.Voltage a a) +noiseBass freq = + FiltA.combProc (DN.unrecip freq) + (Filt.firstOrderLowpass $- DN.frequency 2000) + $: noisePerc + +{-| +Drum sound using the Karplus-Strong-Algorithm +This is a Noise.white enveloped by an exponential2 +which is piped through the Karplus-Strong machine +for generating some frequency. +The whole thing is then frequency modulated +to give a falling frequency. +-} +{-# INLINE electroTom #-} +electroTom :: (Ring.C a, Random a, RealField.C a, Trans.C a, Module.C a a, Sample.C a) => + Proc.T s Dim.Time a (SigA.R s Dim.Voltage a a) +electroTom = + let ks = + FiltA.combProc (DN.time (1/30)) + (Filt.firstOrderLowpass $- (DN.frequency 1000)) + $: noisePerc + in Filt.frequencyModulation Interpolation.linear + $: CtrlR.exponential2 (DN.time 0.3) + $: ks + +{-# INLINE bassDrum #-} +bassDrum :: + (RealField.C q, Trans.C q, Module.C q q, Random q) => + Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q) +bassDrum = + Cut.take (DN.time 0.15) $: + (Disp.mix + $: (Filt.firstOrderLowpass + $- (DN.frequency 5000) + $: (Filt.envelope + $: (DispS.raise 0.03 $^ CtrlR.exponential2 (DN.time 0.002)) + $: (Noise.white (DN.frequency 20000) (DN.voltage 1)))) + $: (DN.voltage 0.5 &*^ + (Filt.envelope + $: (CtrlR.exponential2 (DN.time 0.05)) + $: (Osci.freqMod Wave.sine zero + $: (Ctrl.exponential2 + (DN.time 0.15) (DN.frequency 100)))))) diff --git a/src/Synthesizer/Dimensional/RateAmplitude/Noise.hs b/src/Synthesizer/Dimensional/RateAmplitude/Noise.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Dimensional/RateAmplitude/Noise.hs @@ -0,0 +1,143 @@ +{-# OPTIONS -fno-implicit-prelude #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +-} +module Synthesizer.Dimensional.RateAmplitude.Noise + (white, whiteBandEnergy, randomPeeks, + whiteGen, whiteBandEnergyGen, randomPeeksGen, + ) where + + +import qualified Synthesizer.State.NoiseCustom as Noise +import qualified Synthesizer.State.Signal as Sig + +import qualified Synthesizer.RandomKnuth as Knuth + +import qualified Synthesizer.Dimensional.RateAmplitude.Signal as SigA +import qualified Synthesizer.Dimensional.Process as Proc + +import Synthesizer.Dimensional.Process (($#), ) + +import qualified Number.DimensionTerm as DN +import qualified Algebra.DimensionTerm as Dim +import Number.DimensionTerm ((&*&)) + +import qualified Algebra.Algebraic as Algebraic +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring + +import System.Random (Random, RandomGen, mkStdGen) + +import NumericPrelude +import PreludeBase as P + + + +{-# INLINE white #-} +{- The Field.C constraint could be replaced by Ring.C + if Noise instead of faster NoiseCustom would be used -} +white :: (Field.C yv, Random yv, Algebraic.C q, Dim.C u, Dim.C v) => + DN.T (Dim.Recip u) q + {-^ width of the frequency band -} + -> DN.T v q + {-^ volume caused by the given frequency band -} + -> Proc.T s u q (SigA.R s v q yv) + {-^ noise -} +white = + -- FIXME: there was a bug in GHC-6.4's standard random generator where genRange returned minBound::Int as lower bound but actually generated numbers were always positive + -- this is fixed in GHC-6.6 and thus the standard generator can be used + whiteGen (Knuth.cons 6746) +-- whiteGen (mkStdGen 6746) + +{-# INLINE whiteGen #-} +whiteGen :: + (Field.C yv, Random yv, RandomGen g, Algebraic.C q, Dim.C u, Dim.C v) => + g {-^ random generator, can be used to choose a seed -} + -> DN.T (Dim.Recip u) q + {-^ width of the frequency band -} + -> DN.T v q + {-^ volume caused by the given frequency band -} + -> Proc.T s u q (SigA.R s v q yv) + {-^ noise -} +whiteGen gen bandWidth volume = + do bw <- SigA.toFrequencyScalar bandWidth + return $ + SigA.fromSamples + (DN.scale (sqrt $ 3 / bw) volume) + (Noise.whiteGen gen) + + +{-# INLINE whiteBandEnergy #-} +whiteBandEnergy :: (Field.C yv, Random yv, Algebraic.C q, Dim.C u, Dim.C v) => + DN.T (Dim.Mul u (Dim.Sqr v)) q + {-^ energy per frequency band -} + -> Proc.T s u q (SigA.R s v q yv) + {-^ noise -} +whiteBandEnergy = whiteBandEnergyGen (mkStdGen 6746) + +{-# INLINE whiteBandEnergyGen #-} +whiteBandEnergyGen :: + (Field.C yv, Random yv, RandomGen g, Algebraic.C q, Dim.C u, Dim.C v) => + g {-^ random generator, can be used to choose a seed -} + -> DN.T (Dim.Mul u (Dim.Sqr v)) q + {-^ energy per frequency band -} + -> Proc.T s u q (SigA.R s v q yv) + {-^ noise -} +whiteBandEnergyGen gen energy = + do rate <- Proc.getSampleRate + return $ + SigA.fromSamples + (DN.sqrt $ DN.scale 3 $ + DN.rewriteDimension + (Dim.identityLeft . Dim.applyLeftMul Dim.cancelLeft . + Dim.associateLeft) $ + rate &*& energy) + (Noise.whiteGen gen) + + +{- +The Field.C q constraint could be lifted to Ring.C +if we would use direct division instead of toFrequencyScalar. +-} +{-# INLINE randomPeeks #-} +randomPeeks :: + (Field.C q, Random q, Ord q, Dim.C u) => + Proc.T s u q ( + SigA.R s (Dim.Recip u) q q + {- v momentary densities (frequency), + @p@ means that there is about one peak + in the time range of @1\/p@. -} + -> SigA.R s (Dim.Recip u) q q) + {- ^ Every occurence is represented by a peak of area 1. + If you smooth the input and the output signal to the same degree + they should be rather similar. -} +randomPeeks = + randomPeeksGen (mkStdGen 876) + + +{-# INLINE randomPeeksGen #-} +randomPeeksGen :: + (Field.C q, Random q, Ord q, Dim.C u, + RandomGen g) => + g {- ^ random generator, can be used to choose a seed -} + -> Proc.T s u q ( + SigA.R s (Dim.Recip u) q q + {- v momentary densities (frequency), + @p@ means that there is about one peak + in the time range of @1\/p@. -} + -> SigA.R s (Dim.Recip u) q q) + {- ^ Every occurence is represented by a peak of area 1. -} +randomPeeksGen g = + Proc.withParam $ \ dens -> + do freq <- SigA.toFrequencyScalar (SigA.amplitude dens) + SigA.fromPeaks $# + (SigA.Peaks $ + Sig.zipWith (<) + (Noise.randomRs (0, recip freq) g) + (SigA.samples dens)) diff --git a/src/Synthesizer/Dimensional/RateAmplitude/Play.hs b/src/Synthesizer/Dimensional/RateAmplitude/Play.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Dimensional/RateAmplitude/Play.hs @@ -0,0 +1,101 @@ +{-# OPTIONS -fno-implicit-prelude -fglasgow-exts #-} +-- glasgow-exts for all quantifier +module Synthesizer.Dimensional.RateAmplitude.Play ( + timeVoltageMonoDouble, + timeVoltageStereoDouble, + timeVoltageMonoDoubleR, + timeVoltageStereoDoubleR, + ) where + +import qualified Sox +-- import qualified Sox.File +import qualified Sox.Play +-- import qualified BinarySample as BinSmp + +import qualified Synthesizer.Dimensional.Process as Proc + +import qualified Synthesizer.Dimensional.Amplitude.Signal as SigA +import qualified Synthesizer.Dimensional.RateAmplitude.Signal as SigRA +import qualified Synthesizer.Dimensional.RateWrapper as SigP + +import qualified Synthesizer.Storable.Signal as SigSt + +-- import qualified Synthesizer.Dimensional.Straight.Signal as SigS +-- import qualified Synthesizer.State.Signal as Sig + +-- import qualified Algebra.Transcendental as Trans +-- import qualified Algebra.Module as Module +import qualified Algebra.RealField as RealField +-- import qualified Algebra.Field as Field +-- import qualified Algebra.Ring as Ring + +import qualified Algebra.DimensionTerm as Dim +import qualified Number.DimensionTerm as DN + +import qualified Synthesizer.Frame.Stereo as Stereo + +-- import System.Exit(ExitCode) +import Control.Exception(bracket) +import Foreign.Storable (Storable) + +import qualified System.IO as IO +import qualified System.Process as Proc + +import NumericPrelude +import PreludeBase + + +raw :: (RealField.C a, Storable y) => + [String] -> a -> Int -> SigSt.T y -> IO () +raw args sampleRate numChannels stream = + bracket + (Proc.runInteractiveProcess "play" + (args ++ + Sox.sampleRateOption sampleRate ++ + Sox.channelOption numChannels ++ + ["-t","sw","-"]) + Nothing Nothing) + (\(input,output,err,proc) -> do + mapM IO.hClose [input, output, err] + -- wait for end of replay + Proc.waitForProcess proc) + (\(input,_,_,_) -> + Sox.Play.catchCtrlC >> + SigSt.hPut input stream) + + +{-# INLINE timeVoltageMonoDouble #-} +timeVoltageMonoDouble :: + SigP.T Dim.Time Double (SigA.S Dim.Voltage Double) Double -> + IO () +timeVoltageMonoDouble sig = + let rate = DN.toNumberWithDimension Dim.frequency (SigP.sampleRate sig) + in raw [] rate 1 + (SigP.signal (SigRA.toStorableInt16Mono sig)) + + +{-# INLINE timeVoltageStereoDouble #-} +timeVoltageStereoDouble :: + SigP.T Dim.Time Double (SigA.S Dim.Voltage Double) (Stereo.T Double) -> +-- SigP.T Dim.Time t (SigA.T Dim.Voltage y (SigS.T Sig.T)) yv -> + IO () +timeVoltageStereoDouble sig = + let rate = DN.toNumberWithDimension Dim.frequency (SigP.sampleRate sig) + in raw [] rate 2 + (SigP.signal (SigRA.toStorableInt16Stereo sig)) + +{-# INLINE timeVoltageMonoDoubleR #-} +timeVoltageMonoDoubleR :: + DN.T Dim.Frequency Double -> + (forall s. Proc.T s Dim.Time Double (SigA.R s Dim.Voltage Double Double)) -> + IO () +timeVoltageMonoDoubleR rate sig = + timeVoltageMonoDouble (SigP.runProcess rate sig) + +{-# INLINE timeVoltageStereoDoubleR #-} +timeVoltageStereoDoubleR :: + DN.T Dim.Frequency Double -> + (forall s. Proc.T s Dim.Time Double (SigA.R s Dim.Voltage Double (Stereo.T Double))) -> + IO () +timeVoltageStereoDoubleR rate sig = + timeVoltageStereoDouble (SigP.runProcess rate sig) diff --git a/src/Synthesizer/Dimensional/RateAmplitude/Signal.hs b/src/Synthesizer/Dimensional/RateAmplitude/Signal.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Dimensional/RateAmplitude/Signal.hs @@ -0,0 +1,216 @@ +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +For a description see "Synthesizer.Dimensional.Process". +-} +module Synthesizer.Dimensional.RateAmplitude.Signal ( + T, R, + Proc.toTimeScalar, + Proc.toFrequencyScalar, + toAmplitudeScalar, + toGradientScalar, + DimensionGradient, + amplitude, samples, + fromSignal, fromSamples, + scalarSamples, fromScalarSamples, scalarSamplesGeneric, + vectorSamples, fromVectorSamples, + replaceAmplitude, + replaceSamples, + processSamples, + asTypeOfAmplitude, + ($-), ($&), + (&*^), (&*>^), + Peaks(Peaks), fromPeaks, + cache, bindCached, share, + + toStorableInt16Mono, + toStorableInt16Stereo, + ) where + +import Synthesizer.Dimensional.Process (($:), ($^), ($#), ) +import qualified Synthesizer.Dimensional.Process as Proc + +import qualified Synthesizer.Dimensional.Abstraction.Flat as Flat +import qualified Synthesizer.Dimensional.Abstraction.RateIndependent as Ind +import qualified Synthesizer.Dimensional.RatePhantom as RP + +import Synthesizer.Dimensional.Amplitude.Signal as SigA +import qualified Synthesizer.Dimensional.Amplitude.Control as CtrlV +import qualified Synthesizer.Dimensional.Straight.Signal as SigS +import qualified Synthesizer.State.Signal as Sig +import qualified Synthesizer.Storable.Signal as SigSt +import qualified Synthesizer.Generic.SampledValue as Sample +import qualified Synthesizer.Frame.Stereo as Stereo + +import qualified BinarySample as BinSmp +import Data.Int (Int16) + +import qualified Number.DimensionTerm as DN +import qualified Algebra.DimensionTerm as Dim +import Number.DimensionTerm ((&/&)) + +import qualified Algebra.Module as Module +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Real as Real +import qualified Algebra.Ring as Ring + +-- import qualified Data.List as List + +import NumericPrelude (zero, one, ) +-- import PreludeBase +import Prelude (($), (.), Bool, Ord, fmap, return, (=<<), ) + + + +type DimensionGradient u v = Dim.Mul (Dim.Recip u) v + +{-# INLINE toGradientScalar #-} +toGradientScalar :: (Field.C q, Dim.C u, Dim.C v) => + DN.T v q -> DN.T (DimensionGradient u v) q -> Proc.T s u q q +toGradientScalar amp steepness = + Proc.toFrequencyScalar + (DN.rewriteDimension (Dim.identityRight . Dim.applyRightMul Dim.cancelRight . Dim.associateRight) $ + steepness &/& amp) + + +{- | +We want to represent streams of discrete events +in a manner that is more safe than plain @[Bool]@. +Each peak can be imagined as a Dirac impulse. + +A @[Bool]@ could be used accidentally for 'Synthesizer.Dimensional.Amplitude.Cut.selectBool', +where @selectBool@ is intended for piecewise constant control curves. + +You may think that a type like @Peak = Peak Bool@ as sample type +in @T s Peak@ would also do the job. +Actually, this wouldn't be a good idea +since you can apply constant interpolation on it, +which obviously fools the idea of a peak. +-} +newtype Peaks s = Peaks {getPeaks :: Sig.T Bool} + +{- | +This is the most frequently needed transformation (if not the only one) +of a stream of peaks. +It converts to a signal of peaks with area 1. +This convention is especially useful for smoothing filters +that eventually produce frequency progress curves. +-} +{-# INLINE fromPeaks #-} +fromPeaks :: + (Ord q, Ring.C q, Dim.C u) => + Proc.T s u q (Peaks s -> R s (Dim.Recip u) q q) +fromPeaks = + do rate <- Proc.getSampleRate + return $ + fromScalarSamples rate . + Sig.map (\c -> if c then one else zero) . + getPeaks + + +infixl 0 $-, $& + +{- | +Take a scalar argument where a process expects a signal. +Only possible for non-negative values so far. +-} +{-# INLINE ($-) #-} +($-) :: (Field.C y, Real.C y, Dim.C u, Dim.C v) => + Proc.T s u t (R s v y y -> a) -> DN.T v y -> Proc.T s u t a +($-) f x = f $: Proc.pure (CtrlV.constant x) + +{- | +Take a signal with 'DN.Scalar' unit in amplitude +where the process expects a plain 'Sig.T'. +-} +{-# INLINE ($&) #-} +($&) :: (Ring.C y) => + Proc.T s u t (SigS.R s y -> a) -> + Proc.T s u t (R s Dim.Scalar y y) -> + Proc.T s u t a +($&) f arg = + do x <- arg + f $# SigS.fromSamples (scalarSamples DN.toNumber x) +-- f $# toScalarSignal one x + + +infix 7 &*^, &*>^ + +{-# INLINE (&*^) #-} +(&*^) :: (Flat.C flat y) => + DN.T v y -> + Proc.T s u t (RP.T s flat y) -> + Proc.T s u t (R s v y y) +(&*^) v x = fromSamples v . Flat.toSamples $^ x + +{- +{-# INLINE (&*^) #-} +(&*^) :: (Flat.C flat y) => + DN.T v y -> + Proc.T s u t (SigS.R s y) -> + Proc.T s u t (R s v y y) +(&*^) v x = fromSignal v $^ x +-} + +{-# INLINE (&*>^) #-} +(&*>^) :: + DN.T v y -> + Proc.T s u t (SigS.R s yv) -> + Proc.T s u t (R s v y yv) +(&*>^) v x = fromSignal v $^ x + +{-# INLINE cache #-} +cache :: + (Dim.C v, Ind.C w, Sample.C yv0) => + Proc.T s u t (w (T v y (SigS.T Sig.T)) yv0) -> + Proc.T s u t (w (T v y (SigS.T Sig.T)) yv0) +cache = + fmap (processSamples + (Sig.fromStorableSignal . Sig.toStorableSignal SigSt.defaultChunkSize)) + +{-# INLINE bindCached #-} +bindCached :: + (Dim.C v, Ind.C w, Sample.C yv0) => + Proc.T s u t (w (T v y (SigS.T Sig.T)) yv0) -> + (w (T v y (SigS.T Sig.T)) yv0 -> Proc.T s u t b) -> + Proc.T s u t b +bindCached x y = + y =<< cache x + +{-# INLINE share #-} +share :: + (Dim.C v, Ind.C w, Sample.C yv0) => + Proc.T s u t (w (T v y (SigS.T Sig.T)) yv0) -> + (Proc.T s u t (w (T v y (SigS.T Sig.T)) yv0) -> Proc.T s u t b) -> + Proc.T s u t b +share x y = bindCached x (y . return) + + + +{-# INLINE toStorableInt16Mono #-} +toStorableInt16Mono :: + (Ind.C w, RealField.C a, BinSmp.C a) => + w (SigA.S Dim.Voltage a) a -> + w SigSt.T Int16 +toStorableInt16Mono = + Ind.processSignal + (Sig.toStorableSignal SigSt.defaultChunkSize . + Sig.map BinSmp.numToInt16Packed . + SigA.scalarSamplesPrivate (DN.toNumberWithDimension Dim.voltage)) + +{-# INLINE toStorableInt16Stereo #-} +toStorableInt16Stereo :: + (Ind.C w, Module.C a a, RealField.C a, BinSmp.C a) => + w (SigA.S Dim.Voltage a) (Stereo.T a) -> + w SigSt.T (Stereo.T Int16) +toStorableInt16Stereo = + Ind.processSignal + (Sig.toStorableSignal SigSt.defaultChunkSize . + Sig.map (Stereo.map BinSmp.numToInt16Packed) . + SigA.vectorSamplesPrivate (DN.toNumberWithDimension Dim.voltage)) diff --git a/src/Synthesizer/Dimensional/RateAmplitude/Traumzauberbaum.hs b/src/Synthesizer/Dimensional/RateAmplitude/Traumzauberbaum.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Dimensional/RateAmplitude/Traumzauberbaum.hs @@ -0,0 +1,465 @@ +{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-} +module Main (main) where +-- module Synthesizer.Dimensional.RateAmplitude.Traumzauberbaum where + +-- import qualified Synthesizer.Dimensional.RateAmplitude.Instrument as Instr + +import qualified Synthesizer.Dimensional.Rate.Oscillator as Osci +import qualified Synthesizer.Dimensional.Rate.Filter as Filt +import qualified Synthesizer.Dimensional.RateAmplitude.Displacement as Disp +import qualified Synthesizer.Dimensional.RateAmplitude.Noise as Noise +-- import qualified Synthesizer.SampleRateDimension.Filter.Recursive as FiltR +-- import qualified Synthesizer.SampleRateDimension.Filter.NonRecursive as FiltNR +import qualified Synthesizer.Dimensional.RateAmplitude.Filter as FiltA +import qualified Synthesizer.Dimensional.RateAmplitude.Cut as Cut +-- import qualified Synthesizer.Dimensional.Amplitude.Cut as CutA + +import qualified Synthesizer.Dimensional.RateAmplitude.Control as Ctrl +-- import qualified Synthesizer.Dimensional.Rate.Control as CtrlR + +-- import qualified Synthesizer.Dimensional.Straight.Displacement as DispS + +import qualified Synthesizer.Dimensional.Process as Proc +import qualified Synthesizer.Dimensional.Straight.Signal as SigS +import qualified Synthesizer.Dimensional.RateAmplitude.Signal as SigA + +import qualified Synthesizer.Dimensional.RateAmplitude.File as File +import qualified Synthesizer.Dimensional.RateAmplitude.Play as Play +import qualified Synthesizer.Dimensional.RateWrapper as SigP + +import Synthesizer.Dimensional.RateAmplitude.Signal (($-), (&*^), ) +import Synthesizer.Dimensional.Process (($:), ($::), ($^), ($#)) +import Synthesizer.Dimensional.Amplitude.Control (mapExponential, ) + +import qualified Synthesizer.Generic.SampledValue as Sample + +import qualified Synthesizer.Frame.Stereo as Stereo + +-- import qualified Synthesizer.State.Interpolation as Interpolation +import qualified Synthesizer.Basic.Wave as Wave + +import qualified Algebra.DimensionTerm as Dim +import qualified Number.DimensionTerm as DN + +import Number.DimensionTerm ((*&)) + +-- import qualified Number.NonNegative as NonNeg + +-- import qualified Algebra.Transcendental as Trans +-- import qualified Algebra.Module as Module +-- import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring + +-- import System.Random (Random, randomRs, mkStdGen) + +import PreludeBase +import NumericPrelude + + +type PitchClass = Int + +type Pitch = (PitchClass, Int) + +c, d, e, f, g, a, h :: PitchClass +c = 0 +d = 2 +e = 4 +f = 5 +g = 7 +a = 9 +h = 11 + +melody :: [(Pitch, Int)] +melody = + ((g,4),4) : ((g,4),2) : ((c,4),4) : ((d,4),2) : ((e,4),12) : + ((g,4),4) : ((g,4),2) : ((c,4),4) : ((d,4),2) : ((e,4),12) : + ((c,4),4) : ((c,4),2) : ((d,4),4) : ((d,4),2) : ((e,4),12) : + ((c,4),4) : ((c,4),2) : ((d,4),4) : ((d,4),2) : ((e,4),12) : + ((a,4),4) : ((a,4),2) : ((f,4),4) : ((f,4),2) : ((d,4),12) : + ((g,4),4) : ((g,4),2) : ((c,4),4) : ((d,4),2) : ((e,4),12) : + ((a,4),4) : ((a,4),2) : ((g,4),4) : ((g,4),2) : ((f,4),12) : + ((g,4),4) : ((g,4),2) : ((c,4),4) : ((d,4),2) : ((c,4),12) : + [] + + +type Chord = [Pitch] + +chords :: [(Chord, Int)] +chords = + ([(c,4),(e,4),(g,4)], 6) : + ([(a,3),(c,4),(f,4)], 4) : + ([(g,3),(h,3),(d,4)], 2) : + ([(g,3),(c,4),(e,4)], 12) : + + ([(c,4),(e,4),(g,4)], 6) : + ([(a,3),(c,4),(f,4)], 4) : + ([(g,3),(h,3),(d,4)], 2) : + ([(g,3),(c,4),(e,4)], 12) : + + ([(a,3),(c,4),(e,4)], 6) : + ([(g,3),(h,3),(d,4)], 6) : + ([(g,3),(c,4),(e,4)], 12) : + + ([(a,3),(c,4),(e,4)], 6) : + ([(g,3),(h,3),(d,4)], 6) : + ([(g,3),(c,4),(e,4)], 12) : + + ([(a,3),(c,4),(f,4)], 6) : + ([(a,3),(d,4),(f,4)], 6) : + ([(g,3),(h,3),(d,4)], 12) : + + ([(c,4),(e,4),(g,4)], 6) : + ([(a,3),(c,4),(f,4)], 4) : + ([(g,3),(h,3),(d,4)], 2) : + ([(g,3),(c,4),(e,4)], 12) : + + ([(a,3),(c,4),(f,4)], 6) : + ([(g,3),(h,3),(e,4)], 6) : + ([(f,3),(a,3),(d,4)], 12) : + + ([(c,4),(e,4),(g,4)], 6) : + ([(a,3),(c,4),(f,4)], 4) : + ([(g,3),(h,3),(d,4)], 2) : + ([(e,3),(g,3),(c,4)], 12) : + + [] + + +bass :: [(Pitch, Int)] +bass = + ((c,5), 6) : ((f,4), 4) : ((g,4), 2) : ((c,5), 12) : + ((c,5), 6) : ((f,4), 4) : ((g,4), 2) : ((c,5), 12) : + ((a,4), 4) : ((a,4), 2) : ((g,4), 4) : ((g,4), 2) : ((c,5), 12) : + ((a,4), 4) : ((a,4), 2) : ((g,4), 4) : ((g,4), 2) : ((c,5), 12) : + ((f,4), 4) : ((f,4), 2) : ((d,4), 4) : ((d,4), 2) : ((g,4), 12) : + ((c,5), 6) : ((f,4), 4) : ((g,4), 2) : ((c,5), 12) : + ((f,5), 6) : ((e,5), 6) : ((d,5), 12) : + ((c,5), 6) : ((f,4), 4) : ((g,4), 2) : ((c,4), 12) : + [] + + +harmony :: [Pitch] +harmony = + (c,4) : (g,4) : (c,5) : (f,3) : (c,4) : (g,3) : + (c,4) : (g,4) : (c,5) : (c,4) : (g,4) : (c,5) : + (c,4) : (g,4) : (c,5) : (f,3) : (c,4) : (g,3) : + (c,4) : (g,4) : (c,5) : (c,4) : (g,4) : (c,5) : + + (a,3) : (e,4) : (a,4) : (g,3) : (d,4) : (g,4) : + (c,4) : (g,4) : (c,5) : (c,4) : (g,4) : (c,5) : + (a,3) : (e,4) : (a,4) : (g,3) : (d,4) : (g,4) : + (c,4) : (g,4) : (c,5) : (c,4) : (g,4) : (c,5) : + + (f,3) : (c,4) : (f,4) : (a,3) : (d,4) : (a,4) : + (g,3) : (d,4) : (g,4) : (g,3) : (d,4) : (g,4) : + (c,4) : (g,4) : (c,5) : (f,3) : (c,4) : (g,3) : + (c,4) : (g,4) : (c,5) : (c,4) : (g,4) : (c,5) : + + (f,3) : (c,4) : (f,4) : (e,3) : (h,3) : (e,4) : + (d,3) : (a,3) : (d,4) : (a,3) : (d,4) : (a,4) : + (c,4) : (g,4) : (c,5) : (f,3) : (c,4) : (g,3) : + (c,4) : (g,4) : (c,5) : (c,4) : (c,4) : (c,4) : +-- (c,4) : (g,4) : (c,5) : (c,4) : (g,4) : (c,5) : + + [] + + + +{-# INLINE assemblePitch #-} +assemblePitch :: Pitch -> Double +assemblePitch (pc, oct) = + fromIntegral pc / 12 + fromIntegral oct - 4 + + +{-# INLINE timeUnit #-} +timeUnit :: DN.T Dim.Time Double +timeUnit = DN.time 0.2 + +{-# INLINE pitchControl #-} +pitchControl :: + Proc.T s Dim.Time Double (SigA.R s Dim.Scalar Double Double) +-- Proc.T s Dim.Time Double (SigS.R s Double) +pitchControl = + Cut.concatVolume (DN.scalar 1) $: + (mapM (\(p,dur) -> + Cut.take (fromIntegral dur *& timeUnit) + $: Ctrl.constant (DN.scalar (assemblePitch p))) melody) + + +{-# INLINE simpleMusic #-} +simpleMusic :: + Proc.T s Dim.Time Double (SigA.R s Dim.Voltage Double Double) +simpleMusic = + DN.voltage 1 &*^ + (Osci.freqMod (Wave.trapezoid 0.9) zero + $: (mapExponential 2 (DN.frequency 440) $^ pitchControl)) + + +{-# INLINE filteredPitchControl #-} +filteredPitchControl :: + Proc.T s Dim.Time Double (SigA.R s Dim.Scalar Double Double) +filteredPitchControl = + Filt.lowpassFromUniversal $: + (Filt.universal + $- DN.scalar 3 + $- DN.frequency 4 + $: pitchControl) + + +{-# INLINE envelope #-} +envelope :: + Proc.T s Dim.Time Double (SigA.R s Dim.Scalar Double Double) +envelope = + Filt.firstOrderLowpass + $- DN.frequency 10 + $: (Filt.firstOrderHighpass + $- DN.frequency 0.3 + $: pitchControl) + + +{-# INLINE envelopedMelody #-} +envelopedMelody :: + Proc.T s Dim.Time Double (SigA.R s Dim.Voltage Double Double) +envelopedMelody = + DN.voltage 1 &*^ + (Filt.envelope $: envelope $: + (Osci.freqMod (Wave.trapezoid 0.9) zero + $: (mapExponential 2 (DN.frequency 440) $^ filteredPitchControl))) + + +{-# INLINE filteredMusic #-} +filteredMusic :: + Proc.T s Dim.Time Double (SigA.R s Dim.Voltage Double Double) +filteredMusic = + Filt.lowpassFromUniversal $: + (Filt.universal + $- DN.scalar 10 + $: (mapExponential 20 (DN.frequency 100) $^ envelope) + $: DN.voltage 1 &*^ (Osci.freqMod (Wave.trapezoid 0.9) zero + $: (mapExponential 2 (DN.frequency 440) $^ pitchControl))) + + + +{-# INLINE makeChordPhaser #-} +makeChordPhaser :: + Chord -> + Proc.T s Dim.Time Double (SigA.R s Dim.Voltage Double (Stereo.T Double)) +makeChordPhaser chord = + Disp.mixMulti $:: + (map (\p -> + Cut.mergeStereo + $: (DN.voltage 1 &*^ + Osci.static (Wave.triangleAsymmetric 0.9) zero + (2 ** assemblePitch p *& DN.frequency 439)) + $: (DN.voltage 1 &*^ + Osci.static (Wave.triangleAsymmetric 0.9) zero + (2 ** assemblePitch p *& DN.frequency 441))) + chord) + +{-# INLINE makeChord #-} +makeChord :: + Chord -> + Proc.T s Dim.Time Double (SigA.R s Dim.Voltage Double (Stereo.T Double)) +makeChord chord = + Disp.mixMulti $:: + (map (\p -> + let {-# INLINE tone #-} + tone noise = + DN.voltage 1 &*^ + (Osci.freqMod (Wave.triangleAsymmetric 0.9) zero $: +-- (Osci.freqMod (Wave.saw) zero $: + (mapExponential 2 (DN.frequency 440) $^ + (Disp.raise (DN.scalar (assemblePitch p)) 1 $: + (Filt.firstOrderLowpass + $- DN.frequency 2 + $: noise)))) +{- + in Cut.mergeStereo + $: (tone (Ctrl.constant (DN.scalar 0.01))) + $: (tone (Ctrl.constant (DN.scalar (-0.01))))) +-} +{- + in Cut.mergeStereo + $: (tone (Noise.white (DN.frequency 10000) (DN.scalar 0.5))) + $: (tone (Filt.negate $: Noise.white (DN.frequency 10000) (DN.scalar 0.5)))) +-} + in SigA.share + (Noise.white (DN.frequency 10000) (DN.scalar 0.5)) + (\ns -> + Cut.mergeStereo + $: (tone ns) + $: (tone (Filt.negate $: ns)))) +{- + in Cut.mergeStereo + $: (tone (Noise.white (DN.frequency 10000) (DN.scalar 0.5))) + $: (tone (Ctrl.constant (DN.scalar (-0.02))))) +-} +{- + in Cut.mergeStereo + $: (tone (DN.scalar 1 &*^ Osci.static Wave.sine zero (DN.frequency 3))) + $: (tone (DN.scalar (-1) &*^ Osci.static Wave.sine zero (DN.frequency 3)))) +-} + chord) + +{-# INLINE chordAccompaniment #-} +chordAccompaniment :: + Proc.T s Dim.Time Double (SigA.R s Dim.Voltage Double (Stereo.T Double)) +chordAccompaniment = + Cut.concat $:: + (map (\(chd,dur) -> Cut.take (fromIntegral dur *& timeUnit) $: makeChord chd) chords) + + + +{-# INLINE bassControl #-} +bassControl :: + Proc.T s Dim.Time Double (SigA.R s Dim.Scalar Double Double) +-- Proc.T s Dim.Time Double (SigS.R s Double) +bassControl = + Cut.concatVolume (DN.scalar 1) $:: + (map (\(p,dur) -> + Cut.take (fromIntegral dur *& timeUnit) + $: Ctrl.constant (DN.scalar (assemblePitch p))) bass) +{- + Cut.concatVolume (DN.scalar 1) $: + (mapM (\(p,dur) -> + Cut.take (fromIntegral dur *& timeUnit) + $: Ctrl.constant (DN.scalar (assemblePitch p))) bass) +-} + +{-# INLINE bassPhaserSignal #-} +bassPhaserSignal :: + Proc.T s Dim.Time Double (SigA.R s Dim.Voltage Double (Stereo.T Double)) +bassPhaserSignal = + Cut.mergeStereo + $: DN.voltage 1 &*^ + (Osci.freqMod (Wave.triangleAsymmetric 0.8) zero $: + (mapExponential 2 (DN.frequency 54.7) $^ bassControl)) + $: DN.voltage 1 &*^ + (Osci.freqMod (Wave.triangleAsymmetric 0.8) zero $: + (mapExponential 2 (DN.frequency 55.3) $^ bassControl)) + +{-# INLINE bassSignal #-} +bassSignal :: + Proc.T s Dim.Time Double (SigA.R s Dim.Voltage Double (Stereo.T Double)) +bassSignal = +{- + SigA.share + (DN.voltage 1 &*^ + (Osci.freqMod (Wave.triangleAsymmetric 0.9) zero $: + (mapExponential 2 (DN.frequency 110) $^ bassControl))) + (\b -> Cut.mergeStereo $: b $: b) +-} +{- + SigA.share + bassControl + (\b -> + let {-# INLINE channel #-} + channel p = + DN.voltage 1 &*^ + (Osci.freqMod (Wave.triangleAsymmetric 0.9) zero $: p) + in Cut.mergeStereo + $: channel (mapExponential 2 (DN.frequency 109.7) $^ b) + $: channel (mapExponential 2 (DN.frequency 110.3) $^ b)) +-} +{- + SigA.share + bassControl + (\b -> + Filt.envelopeVector + $: (Osci.freqMod ((1+) . Wave.triangleAsymmetric 0.9) zero $: + (mapExponential 2 (DN.frequency 27.5) $^ b)) + $: (Cut.mergeStereo + $: DN.voltage 1 &*^ + (Osci.freqMod (Wave.triangleAsymmetric 0.9) zero $: + (mapExponential 2 (DN.frequency 109.7) $^ b)) + $: DN.voltage 1 &*^ + (Osci.freqMod (Wave.triangleAsymmetric 0.9) zero $: + (mapExponential 2 (DN.frequency 110.3) $^ b)))) +-} + SigA.share + (Filt.firstOrderLowpass $- DN.frequency 2 $: bassControl) + (\b -> + Filt.envelopeVector + $: (Osci.freqMod (Wave.raise one $ Wave.triangleAsymmetric 0.9) zero $: + (mapExponential 2 (DN.frequency 27.5) $^ b)) + $: (let {-# INLINE channel #-} + channel p = + DN.voltage 1 &*^ + (Osci.freqMod (Wave.triangleAsymmetric 0.9) zero $: p) + in Cut.mergeStereo + $: channel (mapExponential 2 (DN.frequency 109.7) $^ b) + $: channel (mapExponential 2 (DN.frequency 110.3) $^ b))) + + +{-# INLINE accompaniment #-} +accompaniment :: + Proc.T s Dim.Time Double (SigA.R s Dim.Voltage Double (Stereo.T Double)) +accompaniment = + Disp.mix + $: (FiltA.amplify 0.3 $: bassSignal) + $: (FiltA.amplify 0.1 $: chordAccompaniment) +{- + FiltA.amplify 0.1 $: chordAccompaniment +-} +{- + FiltA.amplify 0.3 $: bassSignal +-} + + +{-# INLINE filteredAccompaniment #-} +filteredAccompaniment :: + Proc.T s Dim.Time Double (SigA.R s Dim.Voltage Double (Stereo.T Double)) +filteredAccompaniment = + Filt.lowpassFromUniversal $: + (Filt.universal + $- DN.scalar 5 + $: (mapExponential 2 (DN.frequency 440) $^ + (Cut.concatVolume (DN.scalar 1) $: + (mapM (\p -> + Cut.take (2 *& timeUnit) + $: Ctrl.constant (DN.scalar (assemblePitch p))) harmony))) + $: accompaniment) + + + + +{-# INLINE songSignal #-} +songSignal :: + Proc.T s Dim.Time Double (SigA.R s Dim.Voltage Double (Stereo.T Double)) +songSignal = + Disp.mixMulti $:: + (SigA.share envelopedMelody (\m -> Cut.mergeStereo $: m $: m)) : + (FiltA.amplify 0.6 $: filteredAccompaniment) : + [] + + + +main :: IO () +main = + Play.timeVoltageStereoDoubleR + (DN.frequency (44100::Double)) +-- (Cut.take (DN.time 2) $: songSignal) + songSignal +-- accompaniment +-- bassSignal + +{- + File.writeTimeVoltage "traumzauberbaum" + (SigP.runProcess + (DN.frequency (44100::Double)) + songSignal) + >> return () +-} + +{- +import installed synthesizer package + +ghc -o dist/build/traumzauberbaum/traumzauberbaum -O -Wall -fexcess-precision -ddump-simpl-stats -package synthesizer src/Synthesizer/Dimensional/RateAmplitude/Traumzauberbaum.hs + +ghc -o dist/build/traumzauberbaum/traumzauberbaum-prof -prof -auto-all -O -Wall -fexcess-precision -ddump-simpl-stats -package synthesizer src/Synthesizer/Dimensional/RateAmplitude/Traumzauberbaum.hs + +ghc -o dist/build/traumzauberbaum/traumzauberbaum -O -Wall -fexcess-precision -ddump-simpl-iterations -package synthesizer src/Synthesizer/Dimensional/RateAmplitude/Traumzauberbaum.hs >dist/build/Traumzauberbaum.log + +ghc-core -f html -- -o dist/build/traumzauberbaum/traumzauberbaum -O -Wall -fexcess-precision -fvia-C -optc-O2 -package synthesizer src/Synthesizer/Dimensional/RateAmplitude/Traumzauberbaum.hs >dist/build/traumzauberbaum/traumzauberbaum.html +-} diff --git a/src/Synthesizer/Dimensional/RatePhantom.hs b/src/Synthesizer/Dimensional/RatePhantom.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Dimensional/RatePhantom.hs @@ -0,0 +1,62 @@ +{- | + +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + + +-} +module Synthesizer.Dimensional.RatePhantom where + +import qualified Synthesizer.Format as Format +import qualified Synthesizer.Dimensional.Abstraction.RateIndependent as Ind + +-- import qualified Number.DimensionTerm as DN +-- import qualified Algebra.DimensionTerm as Dim + +{- +import NumericPrelude +import PreludeBase as P +-} + + +{- | +Wraps a signal and adds a phantom type +that identifies signals of the same sample rate. +We provide the phantom type this way +in order to flexibly replace it by a material sample rate. +-} +newtype T s sig y = Cons {signal :: sig y} +-- deriving (Eq, Ord, Show) + +instance Functor sig => Functor (T s sig) where + fmap f = fromSignal . fmap f . toSignal + +instance (Format.C sig) => Format.C (T s sig) where + format p (Cons sig) = + showParen (p >= 10) + (showString "ratePhantom " . Format.format 11 sig) + +instance (Format.C sig, Show y) => Show (T s sig y) where + showsPrec = Format.format + + +{-# INLINE fromSignal #-} +fromSignal :: sig y -> T s sig y +fromSignal = Cons + +{-# INLINE toSignal #-} +toSignal :: T s sig y -> sig y +toSignal = signal + +{-# INLINE processSignal #-} +processSignal :: (sig0 y0 -> sig1 y1) -> (T s sig0 y0 -> T s sig1 y1) +processSignal f = fromSignal . f . toSignal + + +instance Ind.C (T s) where + toSignal = signal + processSignal = processSignal diff --git a/src/Synthesizer/Dimensional/RateWrapper.hs b/src/Synthesizer/Dimensional/RateWrapper.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Dimensional/RateWrapper.hs @@ -0,0 +1,186 @@ +{-# OPTIONS -fglasgow-exts #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +Signals equipped with a sample rate information that carry a physical dimension. +-} +module Synthesizer.Dimensional.RateWrapper where + +import qualified Synthesizer.Format as Format +import qualified Synthesizer.Dimensional.Abstraction.RateIndependent as Ind + +import qualified Synthesizer.Dimensional.RatePhantom as RP +-- import qualified Synthesizer.Dimensional.Straight.Signal as SigS +-- import qualified Synthesizer.Dimensional.Amplitude.Signal as SigA +import qualified Synthesizer.Dimensional.Process as Proc +import qualified Synthesizer.Dimensional.Rate as Rate +-- import qualified Synthesizer.State.Signal as Sig + +import Synthesizer.Dimensional.Process (($:), ($#), ) + +-- import qualified Synthesizer.State.Filter.NonRecursive as Filt + +import qualified Number.DimensionTerm as DN +import qualified Algebra.DimensionTerm as Dim + +-- import Number.DimensionTerm ((&/&)) + +{- +import qualified Algebra.Module as Module +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +-} + +-- import NumericPrelude +import PreludeBase +import Prelude () + + +data T u t sig y = + Cons { + sampleRate :: DN.T (Dim.Recip u) t + {-^ number of samples per unit -} + , signal :: sig y {-^ the embedded signal -} + } +-- deriving (Eq, Show) + +instance Functor sig => Functor (T u t sig) where + fmap f = processSignal (fmap f) + +instance (Dim.C u, Show t, Format.C sig) => Format.C (T u t sig) where + format p (Cons rate sig) = + showParen (p >= 10) + (showString "rateWrapper " . showsPrec 11 rate . + showString " " . Format.format 11 sig) + +instance (Dim.C u, Show t, Format.C sig, Show y) => Show (T u t sig y) where + showsPrec = Format.format + + +{-# INLINE fromProcess #-} +fromProcess :: (Dim.C u) => + Proc.T s u t (RP.T s sig yv -> T u t sig yv) +fromProcess = + fmap + (\rate -> Cons rate . RP.toSignal) + Proc.getSampleRate + + +{-# INLINE runProcess #-} +runProcess :: (Dim.C u) => + DN.T (Dim.Recip u) t -> + (forall s. Proc.T s u t (RP.T s sig yv)) -> + T u t sig yv +runProcess rate p = + Proc.run rate (fromProcess $: p) + + +{-# INLINE runProcessOn #-} +runProcessOn :: (Dim.C u) => + (forall s. Proc.T s u t (RP.T s sig0 yv0 -> RP.T s sig1 yv1)) -> + T u t sig0 yv0 -> T u t sig1 yv1 +runProcessOn p x = + runProcess + (sampleRate x) + (p $# RP.fromSignal (signal x)) + + +{-# INLINE toProcess #-} +toProcess :: (Dim.C u) => + (T u t sig yv -> a) -> + Proc.T s u t (RP.T s sig yv -> a) +toProcess f = + fmap (f.) fromProcess + +{- +infixl 0 $% + +Apply a process that depends on (at least) two physical signals. +It is checked dynamically whether the sample rates of both signals are equal. +If the sample rates differ, this is an runtime error. +For more than one physical signal as input you can apply this operator repeatedly. +Try to avoid it due to the dynamic check. + +($%) :: + Proc.T s u t (SigA.R s v0 y0 yv0 -> SigA.R s v1 y1 yv1 -> a) -> + T u t v0 y0 yv0 -> + Proc.T s u t (SigA.R s v1 y1 yv1 -> a) +($%) +-} + + +{- | +internal function +-} + +{-# INLINE fromSignal #-} +fromSignal :: (Dim.C u) => + Rate.T s u t -> RP.T s sig yv -> T u t sig yv +fromSignal rate x = + Cons (Rate.toDimensionNumber rate) (RP.toSignal x) + +{-# INLINE toSignal #-} +toSignal :: (Dim.C u) => + T u t sig yv -> (Rate.T s u t, RP.T s sig yv) +toSignal x = + (Rate.fromDimensionNumber (sampleRate x), + RP.fromSignal (signal x)) + + +{- +rewriteDimension :: (Dim.C v0, Dim.C v1) => + (v0 -> v1) -> T u t v0 y yv -> T u t v1 y yv +rewriteDimension f (Cons amp ss) = + Cons (DN.rewriteDimension f amp) ss + + +toScalarSignal :: (Field.C y, Dim.C v) => + DN.T v y -> T u t y y -> RP.T s sig y +toScalarSignal amp = SigS.cons . scalarSamples (flip DN.divToScalar amp) + +toVectorSignal :: (Field.C y, Module.C y yv, Dim.C v) => + DN.T v y -> T u t y yv -> RP.T s sig yv +toVectorSignal amp = SigS.cons . vectorSamples (flip DN.divToScalar amp) + + +cons :: DN.T v y -> Sig.T yv -> T u t y yv +cons = Cons + +consScalar :: DN.T v y -> Sig.T y -> T u t y y +consScalar = cons + +consVector :: DN.T v y -> Sig.T yv -> T u t y yv +consVector = cons + +replaceAmplitude :: DN.T v1 y -> T u t v0 y yv -> T u t v1 y yv +replaceAmplitude amp (Cons _ ss) = Cons amp ss + +replaceSamples :: Sig.T yv1 -> T u t y yv0 -> T u t y yv1 +replaceSamples ss (Cons amp _) = Cons amp ss + + +processSamples :: (Dim.C v) => + (Sig.T yv0 -> Sig.T yv1) -> T u t y yv0 -> T u t y yv1 +processSamples f x = + replaceSamples (f $ samples x) x + + +asTypeOfAmplitude :: y -> T u t y yv -> y +asTypeOfAmplitude = const +-} + +{-# INLINE processSignal #-} +processSignal :: + (sig0 yv0 -> sig1 yv1) -> T u t sig0 yv0 -> T u t sig1 yv1 +processSignal f x = + Cons (sampleRate x) (f $ signal x) + + +instance (Dim.C u) => Ind.C (T u t) where + toSignal = signal + processSignal = processSignal diff --git a/src/Synthesizer/Dimensional/Straight/Displacement.hs b/src/Synthesizer/Dimensional/Straight/Displacement.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Dimensional/Straight/Displacement.hs @@ -0,0 +1,65 @@ +module Synthesizer.Dimensional.Straight.Displacement where + +import qualified Synthesizer.Dimensional.Abstraction.RateIndependent as Ind +import qualified Synthesizer.Dimensional.Abstraction.Flat as Flat + +import qualified Synthesizer.Dimensional.Straight.Signal as SigS +import qualified Synthesizer.State.Displacement as Disp +import qualified Synthesizer.State.Signal as Sig + +import qualified Algebra.Additive as Additive + +-- import qualified Prelude as P +-- import PreludeBase +-- import NumericPrelude + + +{- * Mixing -} + +{-| +Mix two signals. +In opposition to 'zipWith' the result has the length of the longer signal. +-} +{-# INLINE mix #-} +mix :: (Additive.C v) => SigS.R s v -> SigS.R s v -> SigS.R s v +{- we can't assert equal sample rates of mixer inputs if 'w = RateWrapper' +mix :: (Ind.C w, Additive.C v) => + w (SigS.T Sig.T) v -> w (SigS.T Sig.T) v -> w (SigS.T Sig.T) v +-} +mix x = SigS.processSamples (SigS.toSamples x Additive.+) + +{-| Add a number to all of the signal values. + This is useful for adjusting the center of a modulation. -} +{-# INLINE raise #-} +raise :: (Ind.C w, Additive.C v) => + v -> w (SigS.T Sig.T) v -> w (SigS.T Sig.T) v +raise x = SigS.processSamples (Disp.raise x) + + +{- * Distortion -} + +{-# INLINE map #-} +map :: (Ind.C w, Flat.C flat y0) => + (y0 -> y1) -> + w flat y0 -> + w (SigS.T Sig.T) y1 +map f = + Ind.processSignal + (SigS.Cons . + Sig.map f . + Flat.unwrappedToSamples) + +{- | +In "Synthesizer.State.Distortion" you find a collection +of appropriate distortion functions. +-} +{-# INLINE distort #-} +distort :: (c -> a -> a) -> SigS.R s c -> SigS.R s a -> SigS.R s a +{- we can't assert equal sample rates of inputs if 'w = RateWrapper' +distort :: (Ind.C w) => + (c -> a -> a) -> + w (SigS.T Sig.T) c -> + w (SigS.T Sig.T) a -> + w (SigS.T Sig.T) a +-} +distort f c = SigS.processSamples (Disp.distort f (SigS.toSamples c)) diff --git a/src/Synthesizer/Dimensional/Straight/Signal.hs b/src/Synthesizer/Dimensional/Straight/Signal.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Dimensional/Straight/Signal.hs @@ -0,0 +1,89 @@ +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +Signals equipped with a phantom type parameter that reflects the sample rate. +-} +module Synthesizer.Dimensional.Straight.Signal where + +import qualified Synthesizer.Dimensional.Abstraction.RateIndependent as Ind + +import qualified Synthesizer.Format as Format +import qualified Synthesizer.Dimensional.RatePhantom as RP + +import qualified Synthesizer.State.Signal as Sig + +-- import qualified Number.DimensionTerm as DN +-- import qualified Algebra.DimensionTerm as Dim + +{- +import qualified Algebra.Module as Module +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +-} + +-- import Number.DimensionTerm ((&/&)) + + +-- import NumericPrelude +import PreludeBase +-- import Prelude () + + +newtype T seq yv = + Cons { + samples :: seq yv {-^ the sampled values -} + } +-- deriving (Eq, Show) + +instance Functor seq => Functor (T seq) where + fmap f = Cons . fmap f . samples + +instance Format.C seq => Format.C (T seq) where + format p = Format.format p . samples + +instance (Format.C seq, Show y) => Show (T seq y) where + showsPrec = Format.format + + +type R s yv = RP.T s (T Sig.T) yv + +{- | +In contrast to 'Synthesizer.Dimensional.RateAmplitude.Peaks' +where only booleans are possible (peak or not peak) +we can also have signals of booleans or other enumerations. +In this case we consider the signal as piecewise constant. +-} +type Binary s = R s Bool + + + +{-# INLINE replaceSamples #-} +replaceSamples :: Sig.T yv1 -> R s yv0 -> R s yv1 +replaceSamples ss _ = fromSamples ss + + +{-# INLINE processSamples #-} +processSamples :: Ind.C w => + (seq0 yv0 -> seq1 yv1) -> w (T seq0) yv0 -> w (T seq1) yv1 +processSamples f = + Ind.processSignal (processSamplesPrivate f) + +{-# INLINE processSamplesPrivate #-} +processSamplesPrivate :: + (seq0 yv0 -> seq1 yv1) -> T seq0 yv0 -> T seq1 yv1 +processSamplesPrivate f = + Cons . f . samples + + +{-# INLINE fromSamples #-} +fromSamples :: Sig.T yv -> R s yv +fromSamples = RP.fromSignal . Cons + +{-# INLINE toSamples #-} +toSamples :: Ind.C w => w (T seq) yv -> seq yv +toSamples = samples . Ind.toSignal 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,66 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +{- +This data type can be used as sample type for stereo signals. +-} +module Synthesizer.Frame.Stereo (T, left, right, cons, map, ) where + +import qualified Synthesizer.Generic.SampledValue as Sample + +import qualified Algebra.Module as Module +import qualified Algebra.Additive as Additive + +import Foreign.Storable (Storable (..), ) + +import NumericPrelude +import PreludeBase hiding (map) +import Prelude () + + +data T a = Cons {left, right :: !a} + + +{-# INLINE cons #-} +cons :: a -> a -> T a +cons = Cons + +{-# INLINE map #-} +map :: (a -> b) -> T a -> T b +map f (Cons l r) = Cons (f l) (f r) + + +{-# INLINE roundUp #-} +roundUp :: Int -> Int -> Int +roundUp m x = x + mod (-x) m + +-- cf. StorableInstances +instance (Storable a) => Storable (T a) where + sizeOf ~(Cons l r) = + roundUp (alignment r) (sizeOf l) + sizeOf r + alignment x = alignment (left x) + peek ptr = + do l <- peekByteOff ptr 0 + let peekSecond :: Storable b => b -> IO b + peekSecond ru = + peekByteOff ptr (roundUp (alignment ru) (sizeOf l)) + r <- peekSecond undefined + return (Cons l r) + poke ptr (Cons l r) = + pokeByteOff ptr 0 l >> + pokeByteOff ptr (roundUp (alignment r) (sizeOf l)) r + + +instance (Additive.C a) => Additive.C (T a) where + {-# INLINE zero #-} + {-# INLINE negate #-} + {-# INLINE (+) #-} + {-# INLINE (-) #-} + zero = Cons zero zero + (+) (Cons xl xr) (Cons yl yr) = Cons (xl+yl) (xr+yr) + (-) (Cons xl xr) (Cons yl yr) = Cons (xl-yl) (xr-yr) + negate (Cons xl xr) = Cons (negate xl) (negate xr) + +instance (Module.C a b) => Module.C a (T b) where + {-# INLINE (*>) #-} + s *> (Cons l r) = Cons (s *> l) (s *> r) + +instance (Sample.C a) => Sample.C (T a) -- where 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 @@ +{-# OPTIONS_GHC -O2 -fglasgow-exts -fno-implicit-prelude #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes +-} +module Synthesizer.FusionList.Control where + +import qualified Synthesizer.Plain.Control as Ctrl +import qualified Synthesizer.Piecewise as Piecewise + +-- import Synthesizer.FusionList.Displacement (raise) +import qualified Synthesizer.FusionList.Signal as Sig + +import qualified Algebra.Module as Module +import qualified Algebra.Transcendental as Trans +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Algebra.Module((*>)) + +-- import Number.Complex (cis,real) +-- import qualified Number.Complex as Complex +-- import Data.List (zipWith4, tails) +-- import NumericPrelude.List (iterateAssoc) + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +{- * Control curve generation -} + +{-# INLINE constant #-} +constant :: a -> Sig.T a +constant = Sig.repeat + +{-# INLINE linear #-} +linear :: Additive.C a => + a {-^ steepness -} + -> a {-^ initial value -} + -> Sig.T a + {-^ linear progression -} +linear d y0 = Sig.iterate (d+) y0 + +{- | +As stable as the addition of time values. +-} +{-# INLINE linearMultiscale #-} +linearMultiscale :: Additive.C y => + y + -> y + -> Sig.T y +linearMultiscale = curveMultiscale (+) + +{- | +Linear curve starting at zero. +-} +{-# INLINE linearMultiscaleNeutral #-} +linearMultiscaleNeutral :: Additive.C y => + y + -> Sig.T y +linearMultiscaleNeutral slope = + curveMultiscaleNeutral (+) slope zero + +{-# INLINE exponential #-} +{-# INLINE exponentialMultiscale #-} +exponential, exponentialMultiscale :: Trans.C a => + a {-^ time where the function reaches 1\/e of the initial value -} + -> a {-^ initial value -} + -> Sig.T a + {-^ exponential decay -} +exponential time = + Sig.iterate (exp (- recip time) *) + +exponentialMultiscale time = curveMultiscale (*) (exp (- recip time)) + +{-# INLINE exponentialMultiscaleNeutral #-} +exponentialMultiscaleNeutral :: Trans.C y => + y {-^ time where the function reaches 1\/e of the initial value -} + -> Sig.T y {-^ exponential decay -} +exponentialMultiscaleNeutral time = + curveMultiscaleNeutral (*) (exp (- recip time)) one + + +{-# INLINE exponential2 #-} +{-# INLINE exponential2Multiscale #-} +exponential2, exponential2Multiscale :: Trans.C a => + a {-^ half life -} + -> a {-^ initial value -} + -> Sig.T a + {-^ exponential decay -} +exponential2 halfLife = + Sig.iterate (((Ring.one+Ring.one) ** (- recip halfLife)) *) +-- Sig.iterate (((Ring.one/(Ring.one+Ring.one)) ** recip halfLife) *) + +exponential2Multiscale halfLife = curveMultiscale (*) (0.5 ** recip halfLife) + +{- the 0.5 constant seems to block fusion + Sig.iterate ((0.5 ** recip halfLife) *) +-} +{- dito fromInteger + Sig.iterate ((fromInteger 2 ** (- recip halfLife)) *) +-} + +{-# INLINE exponential2MultiscaleNeutral #-} +exponential2MultiscaleNeutral :: Trans.C y => + y {-^ half life -} + -> Sig.T y {-^ exponential decay -} +exponential2MultiscaleNeutral halfLife = + curveMultiscaleNeutral (*) (0.5 ** recip halfLife) one + + +{-# INLINE exponentialFromTo #-} +{-# INLINE exponentialFromToMultiscale #-} +exponentialFromTo, exponentialFromToMultiscale :: Trans.C y => + y {-^ time where the function reaches 1\/e of the initial value -} + -> y {-^ initial value -} + -> y {-^ value after given time -} + -> Sig.T y {-^ exponential decay -} +exponentialFromTo time y0 y1 = + Sig.iterate (* (y1/y0) ** recip time) y0 +exponentialFromToMultiscale time y0 y1 = + curveMultiscale (*) ((y1/y0) ** recip time) y0 + + + + +{-| This is an extension of 'exponential' to vectors + which is straight-forward but requires more explicit signatures. + But since it is needed rarely I setup a separate function. -} +{-# INLINE vectorExponential #-} +vectorExponential :: (Trans.C a, Module.C a v) => + a {-^ time where the function reaches 1\/e of the initial value -} + -> v {-^ initial value -} + -> Sig.T v + {-^ exponential decay -} +vectorExponential time y0 = + Sig.iterate (exp (-1/time) *>) y0 + +{-# INLINE vectorExponential2 #-} +vectorExponential2 :: (Trans.C a, Module.C a v) => + a {-^ half life -} + -> v {-^ initial value -} + -> Sig.T v + {-^ exponential decay -} +vectorExponential2 halfLife y0 = + Sig.iterate (0.5**(1/halfLife) *>) y0 + + + +{-# INLINE cosine #-} +cosine :: Trans.C a => + a {-^ time t0 where 1 is approached -} + -> a {-^ time t1 where -1 is approached -} + -> Sig.T a + {-^ a cosine wave where one half wave is between t0 and t1 -} +cosine = Ctrl.cosineWithSlope $ + \d x -> Sig.map cos (linear d x) + + + +{-# INLINE cubicHermite #-} +cubicHermite :: Field.C a => (a, (a,a)) -> (a, (a,a)) -> Sig.T a +cubicHermite node0 node1 = + Sig.map (Ctrl.cubicFunc node0 node1) (linear 1 0) + + + +-- * piecewise curves + + +splitDurations :: (RealField.C t) => + [t] -> [(Int, t)] +splitDurations ts0 = + let (ds,ts) = + unzip $ scanl + (\(_,fr) d -> splitFraction (fr+d)) + (0,1) ts0 + in zip (tail ds) (map (subtract 1) ts) + +{-# INLINE piecewise #-} +piecewise :: (RealField.C a) => + Piecewise.T a a (a -> Sig.T a) -> Sig.T a +piecewise xs = + Sig.concat $ zipWith + (\(n, t) (Piecewise.PieceData c yi0 yi1 d) -> + Sig.take n $ Piecewise.computePiece c yi0 yi1 d t) + (splitDurations $ map Piecewise.pieceDur xs) + xs + + +type Piece a = + Piecewise.Piece a a + (a {- fractional start time -} -> Sig.T a) + + +{-# INLINE stepPiece #-} +stepPiece :: Piece a +stepPiece = + Piecewise.pieceFromFunction $ \ y0 _y1 _d _t0 -> + constant y0 + +{-# INLINE linearPiece #-} +linearPiece :: (Field.C a) => Piece a +linearPiece = + Piecewise.pieceFromFunction $ \ y0 y1 d t0 -> + let s = (y1-y0)/d in linear s (y0-t0*s) + +{-# INLINE exponentialPiece #-} +exponentialPiece :: (Trans.C a) => a -> Piece a +exponentialPiece saturation = + Piecewise.pieceFromFunction $ \ y0 y1 d t0 -> + let y0' = y0-saturation + y1' = y1-saturation + yd = y0'/y1' + in raise saturation + (exponential (d / log yd) (y0' * yd**(t0/d))) + +{-# INLINE cosinePiece #-} +cosinePiece :: (Trans.C a) => Piece a +cosinePiece = + Piecewise.pieceFromFunction $ \ y0 y1 d t0 -> + Sig.map + (\y -> (1+y)*(y0/2)+(1-y)*(y1/2)) + (cosine t0 (t0+d)) + +{-# INLINE cubicPiece #-} +cubicPiece :: (Field.C a) => a -> a -> Piece a +cubicPiece yd0 yd1 = + Piecewise.pieceFromFunction $ \ y0 y1 d t0 -> + cubicHermite (t0,(y0,yd0)) (t0+d,(y1,yd1)) + +raise :: Additive.C a => a -> Sig.T a -> Sig.T a +raise = Sig.map . (+) + +-- * auxiliary functions + +{-# INLINE curveMultiscale #-} +curveMultiscale :: (y -> y -> y) -> y -> y -> Sig.T y +curveMultiscale op d y0 = + Sig.cons y0 (Sig.map (op y0) (Sig.iterateAssoc op d)) + +{-# INLINE curveMultiscaleNeutral #-} +curveMultiscaleNeutral :: (y -> y -> y) -> y -> y -> Sig.T y +curveMultiscaleNeutral op d neutral = + Sig.cons neutral (Sig.iterateAssoc op d) 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,315 @@ +{-# OPTIONS -fno-implicit-prelude #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes +-} +module Synthesizer.FusionList.Filter.NonRecursive where + +import qualified Synthesizer.FusionList.Control as Ctrl +import qualified Synthesizer.FusionList.Signal as Sig +import qualified Synthesizer.Generic.SampledValue as Sample + +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Module as Module +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Algebra.Module( {- linearComb, -} (*>)) + +import Synthesizer.Utility (nest) + +import PreludeBase +import NumericPrelude + + + +{- * Envelope application -} + +{-# INLINE amplify #-} +amplify :: (Ring.C a) => a -> Sig.T a -> Sig.T a +amplify v = Sig.map (v*) + +{-# INLINE amplifyVector #-} +amplifyVector :: (Module.C a v) => a -> Sig.T v -> Sig.T v +amplifyVector v = Sig.map (v*>) + + +{-# INLINE envelope #-} +envelope :: (Ring.C a) => + Sig.T a {-^ the envelope -} + -> Sig.T a {-^ the signal to be enveloped -} + -> Sig.T a +envelope = Sig.zipWith (*) + +{-# INLINE envelopeVector #-} +envelopeVector :: (Module.C a v) => + Sig.T a {-^ the envelope -} + -> Sig.T v {-^ the signal to be enveloped -} + -> Sig.T v +envelopeVector = Sig.zipWith (*>) + + + +{-# INLINE fadeInOut #-} +fadeInOut :: (Field.C a) => + Int -> Int -> Int -> Sig.T a -> Sig.T a +fadeInOut tIn tHold tOut = + let leadIn = Sig.take tIn $ Ctrl.linear ( recip (fromIntegral tIn)) zero + leadOut = Sig.take tOut $ Ctrl.linear (- recip (fromIntegral tOut)) one + hold = Sig.replicate tHold one + in envelope (leadIn `Sig.append` hold `Sig.append` leadOut) + +{-# INLINE fadeInOutStored #-} +fadeInOutStored :: (Field.C a, Sample.C a) => + Int -> Int -> Int -> Sig.T a -> Sig.T a +fadeInOutStored tIn tHold tOut xs = + let leadIn = Sig.take tIn $ Ctrl.linear ( recip (fromIntegral tIn)) 0 + leadOut = Sig.take tOut $ Ctrl.linear (- recip (fromIntegral tOut)) 1 + (partIn, partHoldOut) = Sig.splitAt tIn xs + (partHold, partOut) = Sig.splitAt tHold partHoldOut + in envelope leadIn partIn `Sig.append` + partHold `Sig.append` + envelope leadOut partOut + + +{- * Shift -} + +{-# INLINE delay #-} +delay :: Additive.C y => Int -> Sig.T y -> Sig.T y +delay = delayPad zero + +{-# INLINE delayPad #-} +delayPad :: y -> Int -> Sig.T y -> Sig.T y +delayPad z n = + if n<0 + then Sig.drop (negate n) + else Sig.append (Sig.replicate n z) + + +{- * Smoothing -} + + +{-| Unmodulated non-recursive filter -} +{-# INLINE generic #-} +generic :: (Module.C a v, Sample.C a) => + Sig.T a -> Sig.T v -> Sig.T v +generic m x = + let mr = Sig.reverse m + xp = delay (pred (Sig.length m)) x + in Sig.mapTails (Sig.linearComb mr) xp + +{- +genericSlow :: Module.C a v => + Sig.T a -> Sig.T v -> Sig.T v +genericSlow m x = + let mr = Sig.reverse m + xp = delay (pred (Sig.length m)) x + in Sig.fromList (map (Sig.linearComb mr) (init (Sig.tails xp))) +-} + +{- +{- | +@eps@ is the threshold relatively to the maximum. +That is, if the gaussian falls below @eps * gaussian 0@, +then the function truncated. +-} +gaussian :: + (Trans.C a, RealField.C a, Module.C a v) => + a -> a -> a -> Sig.T v -> Sig.T v +gaussian eps ratio freq = + let var = ratioFreqToVariance ratio freq + area = var * sqrt (2*pi) + gau t = exp (-(t/var)^2/2) / area + width = ceiling (var * sqrt (-2 * log eps)) -- inverse gau + gauSmp = map (gau . fromIntegral) [-width .. width] + in drop width . generic gauSmp +-} + +{- +GNUPlot.plotList [] (take 1000 $ gaussian 0.001 0.5 0.04 (Filter.Test.chirp 5000) :: [Double]) + +The filtered chirp must have amplitude 0.5 at 400 (0.04*10000). +-} + +{- + We want to approximate a Gaussian by a binomial filter. + The latter one can be implemented by a convolutional power. + However we still require a number of operations per sample + which is proportional to the variance. +-} +{-# INLINE binomial #-} +binomial :: + (Trans.C a, RealField.C a, Module.C a v) => + a -> a -> Sig.T v -> Sig.T v +binomial ratio freq = + let width = ceiling (2 * ratioFreqToVariance ratio freq ^ 2) + in Sig.drop width . nest (2*width) ((asTypeOf 0.5 freq *>) . binomial1) + +{- +exp (-(t/var)^2/2) / area *> cis (2*pi*f*t) + == exp (-(t/var)^2/2 +: 2*pi*f*t) / area + == exp ((-t^2 +: 2*var^2*2*pi*f*t) / (2*var^2)) / area + == exp ((t^2 - i*2*var^2*2*pi*f*t) / (-2*var^2)) / area + == exp (((t^2 - i*var^2*2*pi*f)^2 + (var^2*2*pi*f)^2) / (-2*var^2)) / area + == exp (((t^2 - i*var^2*2*pi*f)^2 / (-2*var^2) - (var*2*pi*f)^2/2)) / area + +sumMap (\t -> exp (-(t/var)^2/2) / area *> cis (2*pi*f*t)) + [-infinity..infinity] + ~ sumMap (\t -> exp (-(t/var)^2/2)) [-infinity..infinity] + * exp (-(var*2*pi*f)^2/2) / area + = exp (-(var*2*pi*f)^2/2) +-} +{- | + Compute the variance of the Gaussian + such that its Fourier transform has value @ratio@ at frequency @freq@. +-} +{-# INLINE ratioFreqToVariance #-} +ratioFreqToVariance :: (Trans.C a) => a -> a -> a +ratioFreqToVariance ratio freq = + sqrt (-2 * log ratio) / (2*pi*freq) + -- inverse of the fourier transformed gaussian + +{-# INLINE binomial1 #-} +binomial1 :: (Additive.C v) => Sig.T v -> Sig.T v +binomial1 = Sig.zapWith (+) + + + + + +{- | +Moving (uniformly weighted) average in the most trivial form. +This is very slow and needs about @n * length x@ operations. +-} +{-# INLINE sums #-} +sums :: (Additive.C v) => Int -> Sig.T v -> Sig.T v +sums n = Sig.mapTails (Sig.sum . Sig.take n) + + +{- +sumsDownsample2 :: (Additive.C v) => Sig.T v -> Sig.T v +sumsDownsample2 (x0:x1:xs) = (x0+x1) : sumsDownsample2 xs +sumsDownsample2 xs = xs + +downsample2 :: Sig.T a -> Sig.T a +downsample2 (x0:_:xs) = x0 : downsample2 xs +downsample2 xs = xs + + +{- | +Given a list of numbers +and a list of sums of (2*k) of successive summands, +compute a list of the sums of (2*k+1) or (2*k+2) summands. + +Eample for 2*k+1 + +@ + [0+1+2+3, 2+3+4+5, 4+5+6+7, ...] -> + [0+1+2+3+4, 1+2+3+4+5, 2+3+4+5+6, 3+4+5+6+7, 4+5+6+7+8, ...] +@ + +Example for 2*k+2 + +@ + [0+1+2+3, 2+3+4+5, 4+5+6+7, ...] -> + [0+1+2+3+4+5, 1+2+3+4+5+6, 2+3+4+5+6+7, 3+4+5+6+7+8, 4+5+6+7+8+9, ...] +@ +-} +sumsUpsampleOdd :: (Additive.C v) => Int -> Sig.T v -> Sig.T v -> Sig.T v +sumsUpsampleOdd n {- 2*k -} xs ss = + let xs2k = drop n xs + in (head ss + head xs2k) : + concat (zipWith3 (\s x0 x2k -> [x0+s, s+x2k]) + (tail ss) + (downsample2 (tail xs)) + (tail (downsample2 xs2k))) + +sumsUpsampleEven :: (Additive.C v) => Int -> Sig.T v -> Sig.T v -> Sig.T v +sumsUpsampleEven n {- 2*k -} xs ss = + sumsUpsampleOdd (n+1) xs (zipWith (+) ss (downsample2 (drop n xs))) + +sumsPyramid :: (Additive.C v) => Int -> Sig.T v -> Sig.T v +sumsPyramid n xs = + let aux 1 ys = ys + aux 2 ys = ys + tail ys + aux m ys = + let ysd = sumsDownsample2 ys + in if even m + then sumsUpsampleEven (m-2) ys (aux (div (m-2) 2) ysd) + else sumsUpsampleOdd (m-1) ys (aux (div (m-1) 2) ysd) + in aux n xs + + +propSums :: Bool +propSums = + let n = 1000 + xs = [0::Double ..] + naive = sums n xs + rec = drop (n-1) $ sumsRec n xs + pyramid = sumsPyramid n xs + in and $ take 1000 $ + zipWith3 (\x y z -> x==y && y==z) naive rec pyramid + +-} + + + +{- * Filter operators from calculus -} + +{- | +Forward difference quotient. +Shortens the signal by one. +Inverts 'Synthesizer.Plain.Filter.Recursive.Integration.run' in the sense that +@differentiate (zero : integrate x) == x@. +The signal is shifted by a half time unit. +-} +{-# INLINE differentiate #-} +differentiate :: Additive.C v => Sig.T v -> Sig.T v +differentiate x = Sig.zapWith subtract x + +{- | +Central difference quotient. +Shortens the signal by two elements, +and shifts the signal by one element. +(Which can be fixed by prepending an appropriate value.) +For linear functions this will yield +essentially the same result as 'differentiate'. +You obtain the result of 'differentiateCenter' +if you smooth the one of 'differentiate' +by averaging pairs of adjacent values. + +ToDo: Vector variant +-} +{-# INLINE differentiateCenter #-} +differentiateCenter :: Field.C v => Sig.T v -> Sig.T v +differentiateCenter = + Sig.zapWith (\(x0,_) (_,x1) -> (x1 - x0) * (1/2)) . + Sig.zapWith (,) +{- +differentiateCenter :: Field.C v => Sig.T v -> Sig.T v +differentiateCenter x = + Sig.map ((1/2)*) $ + Sig.zipWith subtract x (Sig.tail (Sig.tail x)) +-} + +{- | +Second derivative. +It is @differentiate2 == differentiate . differentiate@ +but 'differentiate2' should be faster. +-} +{-# INLINE differentiate2 #-} +differentiate2 :: Additive.C v => Sig.T v -> Sig.T v +differentiate2 = differentiate . differentiate +{- +differentiate2 :: Additive.C v => Sig.T v -> Sig.T v +differentiate2 xs0 = + let xs1 = Sig.tail xs0 + xs2 = Sig.tail xs1 + in Sig.zipWith3 (\x0 x1 x2 -> x0+x2-(x1+x1)) xs0 xs1 xs2 +-} 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 @@ +{-# OPTIONS_GHC -O2 -fno-implicit-prelude #-} +{- | +Copyright : (c) Henning Thielemann 2006 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +Tone generators +-} +module Synthesizer.FusionList.Oscillator where + +import qualified Synthesizer.Basic.Wave as Wave +import qualified Synthesizer.Basic.Phase as Phase + +import qualified Synthesizer.FusionList.Signal as Sig + +-- import qualified Synthesizer.FusionList.Interpolation as Interpolation + +{- +import qualified Algebra.RealTranscendental as RealTrans +import qualified Algebra.Module as Module +import qualified Algebra.VectorSpace as VectorSpace + +import Algebra.Module((*>)) +-} +import qualified Algebra.Transcendental as Trans +import qualified Algebra.RealField as RealField +-- import qualified Algebra.Field as Field +-- import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import NumericPrelude + +import qualified Prelude as P +import PreludeBase + + + +{- * Oscillators with arbitrary but constant waveforms -} + +{-# INLINE freqToPhase #-} +{- | Convert a list of phase steps into a list of momentum phases + phase is a number in the interval [0,1) + freq contains the phase steps -} +freqToPhase :: RealField.C a => Phase.T a -> Sig.T a -> Sig.T (Phase.T a) +freqToPhase phase freq = Sig.scanL (flip Phase.increment) phase freq + + +{- Inlining blocks fusion of map and iterate - on the other hand it enables fusion in the main program -} +{-# INLINE static #-} +{- | oscillator with constant frequency -} +static :: (RealField.C a) => Wave.T a b -> (Phase.T a -> a -> Sig.T b) +static wave phase freq = + Sig.map (Wave.apply wave) (Sig.iterate (Phase.increment freq) phase) + +{-# INLINE phaseMod #-} +{- | oscillator with modulated phase -} +phaseMod :: (RealField.C a) => Wave.T a b -> a -> Sig.T a -> Sig.T b +phaseMod wave = shapeMod (Wave.phaseOffset wave) zero + +{-# INLINE shapeMod #-} +{- | oscillator with modulated shape -} +shapeMod :: (RealField.C a) => + (c -> Wave.T a b) -> Phase.T a -> a -> Sig.T c -> Sig.T b +shapeMod wave phase freq parameters = + Sig.zipWith (Wave.apply . wave) parameters (Sig.iterate (Phase.increment freq) phase) + +{-# INLINE freqMod #-} +{- | oscillator with modulated frequency -} +freqMod :: (RealField.C a) => Wave.T a b -> Phase.T a -> Sig.T a -> Sig.T b +freqMod wave phase freqs = + Sig.map (Wave.apply wave) (freqToPhase phase freqs) + +{-# INLINE phaseFreqMod #-} +{- | oscillator with both phase and frequency modulation -} +phaseFreqMod :: (RealField.C a) => + Wave.T a b -> Sig.T a -> Sig.T a -> Sig.T b +phaseFreqMod wave = shapeFreqMod (Wave.phaseOffset wave) zero + +{-# INLINE shapeFreqMod #-} +{- | oscillator with both shape and frequency modulation -} +shapeFreqMod :: (RealField.C a) => + (c -> Wave.T a b) -> Phase.T a -> Sig.T c -> Sig.T a -> Sig.T b +shapeFreqMod wave phase parameters freqs = + Sig.zipWith (Wave.apply . wave) parameters (freqToPhase phase freqs) + +{- +{- | oscillator with a sampled waveform with constant frequency + This essentially an interpolation with cyclic padding. -} +{-# INLINE staticSample #-} +staticSample :: RealField.C a => + Interpolation.T a b -> Sig.T b -> Phase.T a -> a -> Sig.T b +staticSample ip wave phase freq = + freqModSample ip wave phase (Sig.repeat freq) + +{- | oscillator with a sampled waveform with modulated frequency + Should behave homogenously for different types of interpolation. -} +{-# INLINE freqModSample #-} +freqModSample :: RealField.C a => + Interpolation.T a b -> Sig.T b -> Phase.T a -> Sig.T a -> Sig.T b +freqModSample ip wave phase freqs = + let len = Sig.length wave + in Interpolation.multiRelativeCyclicPad + ip (Phase.toRepresentative $ Phase.multiply len phase) + (Sig.map (* fromIntegral len) freqs) wave +-} + + + +{- * Oscillators with specific waveforms -} + +{-# INLINE staticSine #-} +{- | sine oscillator with static frequency -} +staticSine :: (Trans.C a, RealField.C a) => Phase.T a -> a -> Sig.T a +staticSine = static Wave.sine + +{-# INLINE freqModSine #-} +{- | sine oscillator with modulated frequency -} +freqModSine :: (Trans.C a, RealField.C a) => Phase.T a -> Sig.T a -> Sig.T a +freqModSine = freqMod Wave.sine + +{-# INLINE phaseModSine #-} +{- | sine oscillator with modulated phase, useful for FM synthesis -} +phaseModSine :: (Trans.C a, RealField.C a) => a -> Sig.T a -> Sig.T a +phaseModSine = phaseMod Wave.sine + +{-# INLINE staticSaw #-} +{- | saw tooth oscillator with modulated frequency -} +staticSaw :: RealField.C a => Phase.T a -> a -> Sig.T a +staticSaw = static Wave.saw + +{-# INLINE freqModSaw #-} +{- | saw tooth oscillator with modulated frequency -} +freqModSaw :: RealField.C a => Phase.T a -> Sig.T a -> Sig.T a +freqModSaw = freqMod Wave.saw 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,733 @@ +{-# OPTIONS_GHC -O -fglasgow-exts -fno-implicit-prelude #-} +{- glasgow-exts are for the rules -} +module Synthesizer.FusionList.Signal where + +import qualified Synthesizer.Generic.Signal as SigG + +import qualified Synthesizer.Plain.Signal as Sig +import qualified Synthesizer.Plain.Modifier as Modifier +import qualified Data.List as List + +import qualified Data.StorableVector.Lazy as Vector +import Data.StorableVector.Lazy (ChunkSize, Vector) +import Foreign.Storable (Storable, ) + +import qualified Algebra.Module as Module +import qualified Algebra.Additive as Additive +import Algebra.Additive (zero) + +import Algebra.Module ((*>)) + +import qualified Synthesizer.Format as Format + +import Control.Monad.State (State, runState, ) + +import Synthesizer.Utility + (viewListL, viewListR, mapFst, mapSnd, mapPair, fst3, snd3, thd3) + +import NumericPrelude.Condition (toMaybe) +import NumericPrelude (fromInteger, ) + +import Text.Show (Show(showsPrec), showParen, showString, ) +import Data.Maybe (Maybe(Just, Nothing), maybe) +import Prelude + ((.), ($), id, const, flip, curry, uncurry, fst, snd, error, + (>), (>=), max, Ord, + succ, pred, Bool, not, Int, Functor, fmap, + (>>), (>>=), fail, return, (=<<), +-- fromInteger, + ) +-- import qualified Prelude as P +{- +import Prelude hiding + ((++), iterate, foldl, map, repeat, replicate, + zipWith, zipWith3, take, takeWhile) +-} + + +newtype T y = Cons {decons :: [y]} + +instance (Show y) => Show (T y) where + showsPrec p x = + showParen (p >= 10) + (showString "FusionList.fromList " . showsPrec 11 (toList x)) + +instance Format.C T where + format = showsPrec + +instance Functor T where + fmap = map + + + +instance SigG.C T where + empty = empty + null = null + cons = cons + fromList = fromList + toList = toList + repeat = repeat + cycle = cycle + replicate = replicate + iterate = iterate + iterateAssoc op x = iterate (op x) x -- should be optimized + unfoldR = generate + map = map + mix = mix + zipWith = zipWith + scanL = scanL + viewL = viewL + viewR = viewR + foldL = foldL + length = length + take = take + drop = drop + splitAt = splitAt + dropMarginRem = dropMarginRem + takeWhile = takeWhile + dropWhile = dropWhile + span = span + append = append + concat = concat + reverse = reverse +{- + mapAccumL = mapAccumL + mapAccumR = mapAccumR +-} + crochetL = crochetL + + + +{- * functions based on 'generate' -} + +{-# NOINLINE [0] generate #-} +generate :: (acc -> Maybe (y, acc)) -> acc -> T y +generate f = Cons . snd . Sig.unfoldR f + +{-# INLINE unfoldR #-} +unfoldR :: (acc -> Maybe (y, acc)) -> acc -> T y +unfoldR = generate + +{-# INLINE generateInfinite #-} +generateInfinite :: (acc -> (y, acc)) -> acc -> T y +generateInfinite f = generate (Just . f) + +{-# INLINE fromList #-} +fromList :: [y] -> T y +fromList = generate viewListL + +{-# INLINE toList #-} +toList :: T y -> [y] +toList = decons + + +toStorableSignal :: Storable y => ChunkSize -> T y -> Vector y +toStorableSignal size = Vector.pack size . decons + +fromStorableSignal :: Storable y => Vector y -> T y +fromStorableSignal = Cons . Vector.unpack + + +{-# INLINE iterate #-} +iterate :: (a -> a) -> a -> T a +iterate f = generateInfinite (\x -> (x, f x)) + +{-# INLINE iterateAssoc #-} +iterateAssoc :: (a -> a -> a) -> a -> T a +iterateAssoc op x = iterate (op x) x -- should be optimized + +{-# INLINE repeat #-} +repeat :: a -> T a +repeat = iterate id + + +{- * functions based on 'crochetL' -} + +{-# NOINLINE [0] crochetL #-} +crochetL :: (x -> acc -> Maybe (y, acc)) -> acc -> T x -> T y +crochetL f a = Cons . Sig.crochetL f a . decons + +{-# INLINE scanL #-} +scanL :: (acc -> x -> acc) -> acc -> T x -> T acc +{- +scanL f start xs = + cons start + (crochetL (\x acc -> let y = f acc x in Just (y, y)) start xs) +-} +scanL f start = + cons start . + crochetL (\x acc -> let y = f acc x in Just (y, y)) start + +-- | input and output have equal length, that's better for fusion +scanLClip :: (acc -> x -> acc) -> acc -> T x -> T acc +scanLClip f start = + crochetL (\x acc -> Just (acc, f acc x)) start + +{-# INLINE map #-} +map :: (a -> b) -> (T a -> T b) +map f = crochetL (\x _ -> Just (f x, ())) () + +{-# RULEZ + "FusionList.map-crochetL" forall f. + map f = crochetL (\x _ -> Just (f x, ())) () ; + + "FusionList.repeat-iterate" + repeat = iterate id ; + + "FusionList.iterate-generate" forall f. + iterate f = generate (\x -> Just (x, f x)) ; + + "FusionList.take-crochetL" + take = crochetL (\x n -> toMaybe (n>zero) (x, pred n)) ; + + "FusionList.unfold-dollar" forall f x. + f $ x = f x ; + + "FusionList.unfold-dot" forall f g. + f . g = \x -> f (g x) ; + #-} + +{-# INLINE unzip #-} +unzip :: T (a,b) -> (T a, T b) +unzip x = (map fst x, map snd x) + +{-# INLINE unzip3 #-} +unzip3 :: T (a,b,c) -> (T a, T b, T c) +unzip3 xs = (map fst3 xs, map snd3 xs, map thd3 xs) + + +{-# INLINE delay1 #-} +{- | +This is a fusion friendly implementation of delay. +However, in order to be a 'crochetL' +the output has the same length as the input, +that is, the last element is removed - at least for finite input. +-} +delay1 :: a -> T a -> T a +delay1 = crochetL (flip (curry Just)) + +{-# INLINE delay #-} +delay :: y -> Int -> T y -> T y +delay z n = append (replicate n z) + + +{-# INLINE take #-} +take :: Int -> T a -> T a +take = crochetL (\x n -> toMaybe (n>zero) (x, pred n)) + +{-# INLINE takeWhile #-} +takeWhile :: (a -> Bool) -> T a -> T a +takeWhile p = crochetL (\x _ -> toMaybe (p x) (x, ())) () + +{-# INLINE replicate #-} +replicate :: Int -> a -> T a +replicate n = take n . repeat + +{-# RULES + "FusionList.map/repeat" forall f x. + map f (repeat x) = repeat (f x) ; + + "FusionList.map/replicate" forall f n x. + map f (replicate n x) = replicate n (f x) ; + + "FusionList.map/cons" forall f x xs. + map f (cons x xs) = cons (f x) (map f xs) ; + + "FusionList.map/append" forall f xs ys. + map f (append xs ys) = append (map f xs) (map f ys) ; + + {- should be subsumed by the map/cons rule, + but it doesn't fire sometimes + "FusionList.map/cons/compose" forall f g x xs. + map f ((cons x . g) xs) = cons (f x) (map f (g xs)) ; + -} + + {- this does not fire, since 'map' is inlined, crochetL/cons should fire instead -} + "FusionList.map/scanL" forall f g x0 xs. + map g (scanL f x0 xs) = + cons (g x0) + (crochetL (\x acc -> let y = f acc x in Just (g y, y)) x0 xs) ; + + "FusionList.map/zipWith" forall f g x y. + map f (zipWith g x y) = + zipWith (\xi yi -> f (g xi yi)) x y ; + + "FusionList.zipWith/map,*" forall f g x y. + zipWith g (map f x) y = + zipWith (\xi yi -> g (f xi) yi) x y ; + + "FusionList.zipWith/*,map" forall f g x y. + zipWith g x (map f y) = + zipWith (\xi yi -> g xi (f yi)) x y ; + #-} + +{- * functions consuming multiple lists -} + +{-# NOINLINE [0] zipWith #-} +zipWith :: (a -> b -> c) -> (T a -> T b -> T c) +zipWith f s0 s1 = + Cons $ List.zipWith f (decons s0) (decons s1) + +{-# INLINE zipWith3 #-} +zipWith3 :: (a -> b -> c -> d) -> (T a -> T b -> T c -> T d) +zipWith3 f s0 s1 = + zipWith (uncurry f) (zip s0 s1) + +{-# INLINE zipWith4 #-} +zipWith4 :: (a -> b -> c -> d -> e) -> (T a -> T b -> T c -> T d -> T e) +zipWith4 f s0 s1 = + zipWith3 (uncurry f) (zip s0 s1) + + +{-# INLINE zip #-} +zip :: T a -> T b -> T (a,b) +zip = zipWith (,) + +{-# INLINE zip3 #-} +zip3 :: T a -> T b -> T c -> T (a,b,c) +zip3 = zipWith3 (,,) + +{-# INLINE zip4 #-} +zip4 :: T a -> T b -> T c -> T d -> T (a,b,c,d) +zip4 = zipWith4 (,,,) + + +{- * functions based on 'reduceL' -} + +reduceL :: (x -> acc -> Maybe acc) -> acc -> T x -> acc +reduceL f x = Sig.reduceL f x . decons + +{-# INLINE foldL' #-} +foldL' :: (x -> acc -> acc) -> acc -> T x -> acc +foldL' f = reduceL (\x -> Just . f x) + +{-# INLINE foldL #-} +foldL :: (acc -> x -> acc) -> acc -> T x -> acc +foldL f = foldL' (flip f) + +{-# INLINE lengthSlow #-} +{- | can be used to check against native length implementation -} +lengthSlow :: T a -> Int +lengthSlow = foldL' (const succ) zero + + +{- +Do we still need rules for fusion of + map f (repeat x) + zipWith f (repeat x) ys +? +-} + +{- * Fusion helpers -} + +{-# INLINE zipWithGenerate #-} +zipWithGenerate :: + (a -> b -> c) + -> (acc -> Maybe (a, acc)) + -> acc + -> T b -> T c +zipWithGenerate h f a y = + crochetL (\y0 a0 -> + do (x0,a1) <- f a0 + Just (h x0 y0, a1)) a y + +{-# INLINE zipWithCrochetL #-} +zipWithCrochetL :: + (a -> b -> c) + -> (x -> acc -> Maybe (a, acc)) + -> acc + -> T x -> T b -> T c +zipWithCrochetL h f a x y = + crochetL (\(x0,y0) a0 -> + do (z0,a1) <- f x0 a0 + Just (h z0 y0, a1)) + a (zip x y) + +{-# INLINE mixGenerate #-} +mixGenerate :: (Additive.C a) => + (a -> a -> a) + -> (acc -> Maybe (a, acc)) + -> acc + -> T a -> T a +mixGenerate plus f a = + crochetL + (\y0 a0 -> + Just (maybe + (y0, Nothing) + (\(x0,a1) -> (plus x0 y0, Just a1)) + (f =<< a0))) + (Just a) + +{-# INLINE crochetLCons #-} +crochetLCons :: + (a -> acc -> Maybe (b, acc)) + -> acc + -> a -> T a -> T b +crochetLCons f a0 x xs = + maybe + empty + (\(y,a1) -> cons y (crochetL f a1 xs)) + (f x a0) + +{- +{-# INLINE crochetLAppend #-} +crochetLAppend :: + (a -> acc -> Maybe (b, acc)) + -> acc + -> a -> T a -> T a -> T b +crochetLAppend f a0 x xs ys = + maybe + empty + (\(y,a1) -> cons y (crochetL f a1 xs)) + (f x a0) +-} + +{-# INLINE reduceLCons #-} +reduceLCons :: + (a -> acc -> Maybe acc) + -> acc + -> a -> T a -> acc +reduceLCons f a0 x xs = + maybe a0 (flip (reduceL f) xs) (f x a0) + + +{- +applyThroughCons :: + (a -> Maybe (b,acc)) -> (T a -> acc -> T b) -> T a -> T b +applyThroughCons f g = + maybe empty + (\(x,xs) -> cons (f x) (g xs)) . viewL +-} + +{-# INLINE zipWithCons #-} +zipWithCons :: + (a -> b -> c) + -> a -> T a -> T b -> T c +zipWithCons f x xs = + maybe + empty + (\(y,ys) -> cons (f x y) (zipWith f xs ys)) + . viewL + + +{-# RULES + "FusionList.crochetL/generate" forall f g a b. + crochetL g b (generate f a) = + generate (\(a0,b0) -> + do (y0,a1) <- f a0 + (z0,b1) <- g y0 b0 + Just (z0, (a1,b1))) (a,b) ; + + "FusionList.crochetL/crochetL" forall f g a b x. + crochetL g b (crochetL f a x) = + crochetL (\x0 (a0,b0) -> + do (y0,a1) <- f x0 a0 + (z0,b1) <- g y0 b0 + Just (z0, (a1,b1))) (a,b) x ; + + "FusionList.crochetL/cons" forall g b x xs. + crochetL g b (cons x xs) = + crochetLCons g b x xs ; + + + "FusionList.tail/generate" forall f a. + tail (generate f a) = + maybe (error "FusionList.tail: empty list") + (generate f . snd) (f a) ; + + "FusionList.tail/cons" forall x xs. + tail (cons x xs) = xs ; + + "FusionList.zipWith/generate,*" forall f h a y. + zipWith h (generate f a) y = + zipWithGenerate h f a y ; + + "FusionList.zipWith/crochetL,*" forall f h a x y. + zipWith h (crochetL f a x) y = + zipWithCrochetL h f a x y ; + + "FusionList.zipWith/*,generate" forall f h a y. + zipWith h y (generate f a) = + zipWithGenerate (flip h) f a y ; + + "FusionList.zipWith/*,crochetL" forall f h a x y. + zipWith h y (crochetL f a x) = + zipWithCrochetL (flip h) f a x y ; + + "FusionList.mix/generate,*" forall f a y. + mix (generate f a) y = + mixGenerate (Additive.+) f a y ; + + "FusionList.mix/*,generate" forall f a y. + mix y (generate f a) = + mixGenerate (flip (Additive.+)) f a y ; + + +{- this blocks further fusion and + is not necessary if the non-cons operand is a 'generate' + "FusionList.zipWith/cons,*" forall h x xs ys. + zipWith h (cons x xs) ys = + zipWithCons h x xs ys ; + + "FusionList.zipWith/*,cons" forall h x xs ys. + zipWith h ys (cons x xs) = + zipWithCons (flip h) x xs ys ; +-} + + "FusionList.zipWith/cons,cons" forall h x xs y ys. + zipWith h (cons x xs) (cons y ys) = + cons (h x y) (zipWith h xs ys) ; + + "FusionList.zipWith/share" forall (h :: a->a->b) (x :: T a). + zipWith h x x = map (\xi -> h xi xi) x ; + + + + "FusionList.reduceL/generate" forall f g a b. + reduceL g b (generate f a) = + snd + (recurse (\(a0,b0) -> + do (y,a1) <- f a0 + b1 <- g y b0 + Just (a1, b1)) (a,b)) ; + + "FusionList.reduceL/crochetL" forall f g a b x. + reduceL g b (crochetL f a x) = + snd + (reduceL (\x0 (a0,b0) -> + do (y,a1) <- f x0 a0 + b1 <- g y b0 + Just (a1, b1)) (a,b) x) ; + + "FusionList.reduceL/cons" forall g b x xs. + reduceL g b (cons x xs) = + reduceLCons g b x xs ; + + + "FusionList.viewL/cons" forall x xs. + viewL (cons x xs) = Just (x,xs) ; + + "FusionList.viewL/generateInfinite" forall f x. + viewL (generateInfinite f x) = + Just (mapSnd (generateInfinite f) (f x)) ; + + "FusionList.viewL/generate" forall f x. + viewL (generate f x) = + fmap (mapSnd (generate f)) (f x) ; + + "FusionList.viewL/crochetL" forall f a xt. + viewL (crochetL f a xt) = + do (x,xs) <- viewL xt + (y,a') <- f x a + return (y, crochetL f a' xs) ; + #-} + + +{- * Other functions -} + +null :: T a -> Bool +null = List.null . decons + +empty :: T a +empty = Cons [] + +singleton :: a -> T a +singleton = Cons . (: []) + +{-# NOINLINE [0] cons #-} +cons :: a -> T a -> T a +cons x = Cons . (x :) . decons + +length :: T a -> Int +length = List.length . decons + +viewL :: T a -> Maybe (a, T a) +viewL = + fmap (mapSnd Cons) . viewListL . decons + +viewR :: T a -> Maybe (T a, a) +viewR = + fmap (mapFst Cons) . viewListR . decons + +extendConstant :: T a -> T a +extendConstant xt = + maybe empty (append xt . repeat . snd) $ + viewR xt + +{-# NOINLINE [0] tail #-} +tail :: T a -> T a +tail = Cons . List.tail . decons + +head :: T a -> a +head = List.head . decons + +drop :: Int -> T a -> T a +drop n = Cons . List.drop n . decons + +dropMarginRem :: Int -> Int -> T a -> (Int, T a) +dropMarginRem n m = mapSnd Cons . Sig.dropMarginRem n m . decons + +{- +This implementation does only walk once through the dropped prefix. +It is maximally lazy and minimally space consuming. +-} +dropMargin :: Int -> Int -> T a -> T a +dropMargin n m = Cons . Sig.dropMargin n m . decons + + +index :: Int -> T a -> a +index n = (List.!! n) . decons + + +splitAt :: Int -> T a -> (T a, T a) +splitAt n = mapPair (Cons, Cons) . List.splitAt n . decons + +dropWhile :: (a -> Bool) -> T a -> T a +dropWhile p = Cons . List.dropWhile p . decons + +span :: (a -> Bool) -> T a -> (T a, T a) +span p = mapPair (Cons, Cons) . List.span p . decons + +mapAccumL :: (acc -> x -> (acc, y)) -> acc -> T x -> (acc, T y) +mapAccumL f acc = mapSnd Cons . List.mapAccumL f acc . decons + +mapAccumR :: (acc -> x -> (acc, y)) -> acc -> T x -> (acc, T y) +mapAccumR f acc = mapSnd Cons . List.mapAccumR f acc . decons + + +cycle :: T a -> T a +cycle = Cons . List.cycle . decons + +{-# NOINLINE [0] mix #-} +mix :: Additive.C a => T a -> T a -> T a +mix (Cons xs) (Cons ys) = Cons (xs Additive.+ ys) + +{-# NOINLINE [0] sub #-} +sub :: Additive.C a => T a -> T a -> T a +sub (Cons xs) (Cons ys) = Cons (xs Additive.- ys) + +{-# NOINLINE [0] neg #-} +neg :: Additive.C a => T a -> T a +neg (Cons xs) = Cons (Additive.negate xs) + +instance Additive.C y => Additive.C (T y) where + zero = empty + (+) = mix + (-) = sub + negate = neg + +instance Module.C y yv => Module.C y (T yv) where + (*>) x y = map (x*>) y + + +infixr 5 `append` + +{-# NOINLINE [0] append #-} +append :: T a -> T a -> T a +append (Cons xs) (Cons ys) = Cons (xs List.++ ys) + +concat :: [T a] -> T a +concat = Cons . List.concat . List.map decons + +reverse :: T a -> T a +reverse = Cons . List.reverse . decons + + + +sum :: (Additive.C a) => T a -> a +sum = foldL' (Additive.+) Additive.zero + +maximum :: (Ord a) => T a -> a +maximum = + maybe + (error "FusionList.maximum: empty list") + (uncurry (foldL' max)) + . viewL + +tails :: T y -> [T y] +tails = List.map Cons . List.tails . decons + +init :: T y -> T y +init = Cons . List.init . decons + +sliceVert :: Int -> T y -> [T y] +sliceVert n = + List.map (take n) . List.takeWhile (not . null) . List.iterate (drop n) + + +zapWith :: (a -> a -> b) -> T a -> T b +zapWith f xs0 = + let xs1 = maybe empty snd (viewL xs0) + in zipWith f xs0 xs1 + +modifyStatic :: Modifier.Simple s ctrl a b -> ctrl -> T a -> T b +modifyStatic modif control x = + crochetL + (\a acc -> + Just (runState (Modifier.step modif control a) acc)) + (Modifier.init modif) x + +{-| Here the control may vary over the time. -} +modifyModulated :: Modifier.Simple s ctrl a b -> T ctrl -> T a -> T b +modifyModulated modif control x = + crochetL + (\ca acc -> + Just (runState (uncurry (Modifier.step modif) ca) acc)) + (Modifier.init modif) + (zip control x) + + +-- cf. Module.linearComb +linearComb :: + (Module.C t y) => + T t -> T y -> y +linearComb ts ys = + sum $ zipWith (*>) ts ys + + +-- comonadic 'bind' +-- only non-empty suffixes are processed +mapTails :: + (T y0 -> y1) -> T y0 -> T y1 +mapTails f = + generate (\xs -> + do (_,ys) <- viewL xs + return (f xs, ys)) + +-- only non-empty suffixes are processed +zipWithTails :: + (y0 -> T y1 -> y2) -> T y0 -> T y1 -> T y2 +zipWithTails f = + curry $ generate (\(xs0,ys0) -> + do (x,xs) <- viewL xs0 + (_,ys) <- viewL ys0 + return (f x ys0, (xs,ys))) + +delayLoop :: + (T y -> T y) + -- ^ processor that shall be run in a feedback loop + -> T y -- ^ prefix of the output, its length determines the delay + -> T y +delayLoop proc prefix = + let ys = append prefix (proc ys) + in ys + +delayLoopOverlap :: + (Additive.C y) => + Int + -> (T y -> T y) + -- ^ processor that shall be run in a feedback loop + -> T y -- ^ input + -> T y -- ^ output has the same length as the input +delayLoopOverlap time proc xs = + let ys = zipWith (Additive.+) xs (delay zero time (proc ys)) + in ys + + +-- maybe candidate for Utility + +recurse :: (acc -> Maybe acc) -> acc -> acc +recurse f = + let aux x = maybe x aux (f x) + in aux + 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,334 @@ +{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-} +module Synthesizer.Generic.Analysis where + +import qualified Synthesizer.Generic.Signal as SigG +import qualified Synthesizer.Generic.SampledValue as Sample + +-- import qualified Synthesizer.Plain.Control as Ctrl + +-- import qualified Algebra.Module as Module +-- import qualified Algebra.Transcendental as Trans +import qualified Algebra.Algebraic as Algebraic +-- import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Real as Real +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import qualified Algebra.NormedSpace.Maximum as NormedMax +import qualified Algebra.NormedSpace.Euclidean as NormedEuc +import qualified Algebra.NormedSpace.Sum as NormedSum + +-- import qualified Data.Array as Array + +-- import qualified Data.IntMap as IntMap + +-- import Algebra.Module((*>)) + +-- import Data.Array (accumArray) + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +{- * Notions of volume -} + +{- | +Volume based on Manhattan norm. +-} +volumeMaximum :: (Real.C y, Sample.C y, SigG.C sig) => sig y -> y +volumeMaximum = + SigG.foldL max zero . rectify +-- maximum . rectify + +{- | +Volume based on Energy norm. +-} +volumeEuclidean :: (Algebraic.C y, Sample.C y, SigG.C sig) => sig y -> y +volumeEuclidean = + Algebraic.sqrt . volumeEuclideanSqr + +volumeEuclideanSqr :: (Field.C y, Sample.C y, SigG.C sig) => sig y -> y +volumeEuclideanSqr = + average . SigG.map sqr + +{- | +Volume based on Sum norm. +-} +volumeSum :: (Field.C y, Real.C y, Sample.C y, SigG.C sig) => sig y -> y +volumeSum = average . rectify + + + +{- | +Volume based on Manhattan norm. +-} +volumeVectorMaximum :: + (NormedMax.C y yv, Ord y, Sample.C y, Sample.C yv, SigG.C sig) => + sig yv -> y +volumeVectorMaximum = + SigG.foldL max zero . SigG.map NormedMax.norm +-- NormedMax.norm +-- maximum . SigG.map NormedMax.norm + +{- | +Volume based on Energy norm. +-} +volumeVectorEuclidean :: + (Algebraic.C y, NormedEuc.C y yv, Sample.C y, Sample.C yv, SigG.C sig) => + sig yv -> y +volumeVectorEuclidean = + Algebraic.sqrt . volumeVectorEuclideanSqr + +volumeVectorEuclideanSqr :: + (Field.C y, NormedEuc.Sqr y yv, Sample.C y, Sample.C yv, SigG.C sig) => + sig yv -> y +volumeVectorEuclideanSqr = + average . SigG.map NormedEuc.normSqr + +{- | +Volume based on Sum norm. +-} +volumeVectorSum :: + (NormedSum.C y yv, Field.C y, Sample.C y, Sample.C yv, SigG.C sig) => + sig yv -> y +volumeVectorSum = + average . SigG.map NormedSum.norm + + + + +{- | +Compute minimum and maximum value of the stream the efficient way. +Input list must be non-empty and finite. +-} +bounds :: (Ord y, Sample.C y, SigG.C sig) => sig y -> (y,y) +bounds = + maybe + (error "Analysis.bounds: List must contain at least one element.") + (\(x,xs) -> + SigG.foldL (\(minX,maxX) y -> (min y minX, max y maxX)) (x,x) xs) + . SigG.viewL + + + + +{- * Miscellaneous -} + +{- +histogram: + length x = sum (histogramDiscrete x) + + units: + 1) histogram (amplify k x) = timestretch k (amplify (1/k) (histogram x)) + 2) histogram (timestretch k x) = amplify k (histogram x) + timestretch: k -> (s -> V) -> (k*s -> V) + amplify: k -> (s -> V) -> (s -> k*V) + histogram: (a -> b) -> (a^ia*b^ib -> a^ja*b^jb) + x: (s -> V) + 1) => (s^ia*(k*V)^ib -> s^ja*(k*V)^jb) + = (s^ia*V^ib*k -> s^ja*V^jb/k) + => ib=1, jb=-1 + 2) => ((k*s)^ia*V^ib -> (k*s)^ja*V^jb) + = (s^ia*V^ib -> s^ja*V^jb*k) + => ia=0, ja=1 + histogram: (s -> V) -> (V -> s/V) +histogram': + integral (histogram' x) = integral x + histogram' (amplify k x) = timestretch k (histogram' x) + histogram' (timestretch k x) = amplify k (histogram' x) + -> this does only apply if we slice the area horizontally + and sum the slice up at each level, + we must also restrict to the positive values, + this is not quite the usual histogram +-} + +{- +{- | +Input list must be finite. +List is scanned twice, but counting may be faster. +-} +histogramDiscreteArray :: sig Int -> (Int, sig Int) +histogramDiscreteArray [] = + (error "histogramDiscreteArray: no bounds found", []) +histogramDiscreteArray x = + let hist = + accumArray (+) zero + (bounds x) (attachOne x) + in (fst (Array.bounds hist), Array.elems hist) + + +{- | +Input list must be finite. +If the input signal is empty, the offset is @undefined@. +List is scanned twice, but counting may be faster. +The sum of all histogram values is one less than the length of the signal. +-} +histogramLinearArray :: RealField.C y => sig y -> (Int, sig y) +histogramLinearArray [] = + (error "histogramLinearArray: no bounds found", []) +histogramLinearArray [x] = (floor x, []) +histogramLinearArray x = + let (xMin,xMax) = bounds x + hist = + accumArray (+) zero + (floor xMin, floor xMax) + (meanValues x) + in (fst (Array.bounds hist), Array.elems hist) + +{- | +Input list must be finite. +If the input signal is empty, the offset is @undefined@. +List is scanned once, counting may be slower. +-} +histogramDiscreteIntMap :: sig Int -> (Int, sig Int) +histogramDiscreteIntMap [] = + (error "histogramDiscreteIntMap: no bounds found", []) +histogramDiscreteIntMap x = + let hist = IntMap.fromListWith (+) (attachOne x) + in case IntMap.toAscList hist of + [] -> error "histogramDiscreteIntMap: the list was non-empty before processing ..." + fAll@((fIndex,fHead):fs) -> (fIndex, fHead : + concat (zipWith + (\(i0,_) (i1,f1) -> replicate (i1-i0-1) zero ++ [f1]) + fAll fs)) + +histogramLinearIntMap :: RealField.C y => sig y -> (Int, sig y) +histogramLinearIntMap [] = + (error "histogramLinearIntMap: no bounds found", []) +histogramLinearIntMap [x] = (floor x, []) +histogramLinearIntMap x = + let hist = IntMap.fromListWith (+) (meanValues x) + -- we can rely on the fact that the keys are contiguous + (startKey:_, elems) = unzip (IntMap.toAscList hist) + in (startKey, elems) + -- This doesn't work, due to a bug in IntMap of GHC-6.4.1 + -- in (head (IntMap.keys hist), IntMap.elems hist) +-} + +{- +The bug in IntMap GHC-6.4.1 is: + +*Synthesizer.Plain.Analysis> IntMap.keys $ IntMap.fromList $ [(0,0),(-1,-1::Int)] +[0,-1] +*Synthesizer.Plain.Analysis> IntMap.elems $ IntMap.fromList $ [(0,0),(-1,-1::Int)] +[0,-1] +*Synthesizer.Plain.Analysis> IntMap.assocs $ IntMap.fromList $ [(0,0),(-1,-1::Int)] +[(0,0),(-1,-1)] + +The bug has gone in IntMap as shipped with GHC-6.6. +-} + +{- +histogramIntMap :: (RealField.C y, Sample.C y, SigG.C sig) => + y -> sig y -> (Int, sig Int) +histogramIntMap binsPerUnit = + histogramDiscreteIntMap . quantize binsPerUnit + +quantize :: (RealField.C y, Sample.C y, SigG.C sig) => + y -> sig y -> sig Int +quantize binsPerUnit = SigG.map (floor . (binsPerUnit*)) + +attachOne :: (Sample.C i, SigG.C sig) => sig i -> sig (i,Int) +attachOne = SigG.map (\i -> (i,one)) + +meanValues :: + (RealField.C y, Sample.C y, SigG.C sig) => sig y -> [(Int,y)] +meanValues x = concatMap spread (zip x (tail x)) + +spread :: + (RealField.C y, Sample.C y, SigG.C sig) => (y,y) -> [(Int,y)] +spread (l0,r0) = + let (l,r) = if l0<=r0 then (l0,r0) else (r0,l0) + (li,lf) = splitFraction l + (ri,rf) = splitFraction r + k = recip (r-l) + nodes = + (li,k*(1-lf)) : + zip [li+1 ..] (replicate (ri-li-1) k) ++ + (ri, k*rf) : + [] + in if li==ri + then [(li,one)] + else nodes +-} + +{- | +Requires finite length. +This is identical to the arithmetic mean. +-} +directCurrentOffset :: + (Field.C y, Sample.C y, SigG.C sig) => sig y -> y +directCurrentOffset = average + + +scalarProduct :: + (Ring.C y, Sample.C y, SigG.C sig) => sig y -> sig y -> y +scalarProduct xs ys = + SigG.sum (SigG.zipWith (*) xs ys) + +{- | +'directCurrentOffset' must be non-zero. +-} +centroid :: (Field.C y, Sample.C y, SigG.C sig) => sig y -> y +centroid xs = + scalarProduct (SigG.iterate (one+) zero) xs / SigG.sum xs + +{- +centroidAlt :: (Field.C y, Sample.C y, SigG.C sig) => sig y -> y +centroidAlt xs = + SigG.sum (scanr (+) zero (tail xs)) / sum xs +-} + +average :: (Field.C y, Sample.C y, SigG.C sig) => sig y -> y +average x = + SigG.sum x / fromIntegral (SigG.length x) + +rectify :: (Real.C y, Sample.C y, SigG.C sig) => sig y -> sig y +rectify = SigG.map abs + +{- | +Detects zeros (sign changes) in a signal. +This can be used as a simple measure of the portion +of high frequencies or noise in the signal. +It ca be used as voiced\/unvoiced detector in a vocoder. + +@zeros x !! n@ is @True@ if and only if +@(x !! n >= 0) \/= (x !! (n+1) >= 0)@. +The result will be one value shorter than the input. +-} +zeros :: (Ord y, Ring.C y, Sample.C y, SigG.C sig) => + sig y -> sig Bool +zeros = + SigG.zapWith (/=) . SigG.map (>=zero) + + + +{- | +Detect thresholds with a hysteresis. +-} +flipFlopHysteresis :: (Ord y, Sample.C y, SigG.C sig) => + (y,y) -> Bool -> sig y -> sig Bool +flipFlopHysteresis (lower,upper) = + SigG.scanL + (\state x -> + if state + then not(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,294 @@ +{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-} +module Synthesizer.Generic.Control where + +import qualified Synthesizer.Generic.Signal as SigG +import qualified Synthesizer.Generic.SampledValue as Sample + +import Synthesizer.Generic.Displacement (raise) + +import qualified Algebra.Module as Module +import qualified Algebra.Transcendental as Trans +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Algebra.Module((*>)) + +import Number.Complex (cis,real) +-- import qualified Number.Complex as Complex +-- import Data.List (zipWith4, tails) +-- import NumericPrelude.List (iterateAssoc) + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +{- * Control curve generation -} + +constant :: (Sample.C y, SigG.C sig) => y -> sig y +constant = SigG.repeat + + +linear :: (Additive.C y, Sample.C y, SigG.C sig) => + y {-^ steepness -} + -> y {-^ initial value -} + -> sig y {-^ linear progression -} +linear d y0 = SigG.iterate (d+) y0 + +{- | +Minimize rounding errors by reducing number of operations per element +to a logarithmuc number. +-} +linearMultiscale :: (Additive.C y, Sample.C y, SigG.C sig) => + y + -> y + -> sig y +linearMultiscale = curveMultiscale (+) + +{- | +Linear curve starting at zero. +-} +linearMultiscaleNeutral :: (Additive.C y, Sample.C y, SigG.C sig) => + y + -> sig y +linearMultiscaleNeutral slope = + curveMultiscaleNeutral (+) slope zero + + +exponential, exponentialMultiscale :: (Trans.C y, Sample.C y, SigG.C sig) => + y {-^ time where the function reaches 1\/e of the initial value -} + -> y {-^ initial value -} + -> sig y {-^ exponential decay -} +exponential time = SigG.iterate (* exp (- recip time)) +exponentialMultiscale time = curveMultiscale (*) (exp (- recip time)) + +exponentialMultiscaleNeutral :: (Trans.C y, Sample.C y, SigG.C sig) => + y {-^ time where the function reaches 1\/e of the initial value -} + -> sig y {-^ exponential decay -} +exponentialMultiscaleNeutral time = + curveMultiscaleNeutral (*) (exp (- recip time)) one + +exponential2, exponential2Multiscale :: (Trans.C y, Sample.C y, SigG.C sig) => + y {-^ half life -} + -> y {-^ initial value -} + -> sig y {-^ exponential decay -} +exponential2 halfLife = SigG.iterate (* 0.5 ** recip halfLife) +exponential2Multiscale halfLife = curveMultiscale (*) (0.5 ** recip halfLife) + +exponential2MultiscaleNeutral :: (Trans.C y, Sample.C y, SigG.C sig) => + y {-^ half life -} + -> sig y {-^ exponential decay -} +exponential2MultiscaleNeutral halfLife = + curveMultiscaleNeutral (*) (0.5 ** recip halfLife) one + + + + +{-| This is an extension of 'exponential' to vectors + which is straight-forward but requires more explicit signatures. + But since it is needed rarely I setup a separate function. -} +vectorExponential :: + (Trans.C y, Module.C y v, Sample.C v, SigG.C sig) => + y {-^ time where the function reaches 1\/e of the initial value -} + -> v {-^ initial value -} + -> sig v {-^ exponential decay -} +vectorExponential time y0 = SigG.iterate (exp (-1/time) *>) y0 + +vectorExponential2 :: + (Trans.C y, Module.C y v, Sample.C v, SigG.C sig) => + y {-^ half life -} + -> v {-^ initial value -} + -> sig v {-^ exponential decay -} +vectorExponential2 halfLife y0 = SigG.iterate (0.5**(1/halfLife) *>) y0 + + + +cosine, cosineMultiscale :: (Trans.C y, Sample.C y, SigG.C sig) => + y {-^ time t0 where 1 is approached -} + -> y {-^ time t1 where -1 is approached -} + -> sig y {-^ a cosine wave where one half wave is between t0 and t1 -} +cosine = cosineWithSlope $ + \d x -> SigG.map cos (linear d x) + +cosineMultiscale = cosineWithSlope $ + \d x -> SigG.map real (curveMultiscale (*) (cis d) (cis x)) + + +cosineWithSlope :: (Trans.C y) => + (y -> y -> signal) + -> y + -> y + -> signal +cosineWithSlope c t0 t1 = + let inc = pi/(t1-t0) + in c inc (-t0*inc) + + +cubicHermite :: (Field.C y, Sample.C y, SigG.C sig) => + (y, (y,y)) -> (y, (y,y)) -> sig y +cubicHermite node0 node1 = + SigG.map (cubicFunc node0 node1) (linear 1 0) + +{- | +0 16 +0 8 16 +0 4 8 12 16 +0 2 4 6 8 10 12 14 16 +0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 +-} +cubicFunc :: (Field.C y) => + (y, (y,y)) -> (y, (y,y)) -> y -> y +cubicFunc (t0, (y0,dy0)) (t1, (y1,dy1)) t = + let dt = t0-t1 + dt0 = t-t0 + dt1 = t-t1 + x0 = dt1^2 + x1 = dt0^2 + in ((dy0*dt0 + y0 * (1-2/dt*dt0)) * x0 + + (dy1*dt1 + y1 * (1+2/dt*dt1)) * x1) / dt^2 +{- +cubic t0 (y0,dy0) t1 (y1,dy1) t = + let x0 = ((t-t1) / (t0-t1))^2 + x1 = ((t-t0) / (t1-t0))^2 + in y0 * x0 + y1 * x1 + + (dy0 - y0*2/(t0-t1)) * (t-t0)*x0 + + (dy1 - y1*2/(t1-t0)) * (t-t1)*x1 +-} + + + +{- | +The curve type of a piece of a piecewise defined control curve. +-} +data Control y = + CtrlStep + | CtrlLin + | CtrlExp {ctrlExpSaturation :: y} + | CtrlCos + | CtrlCubic {ctrlCubicGradient0 :: y, + ctrlCubicGradient1 :: y} + deriving (Eq, Show) + +{- | +The full description of a control curve piece. +-} +data ControlPiece y = + ControlPiece {pieceType :: Control y, + pieceY0 :: y, + pieceY1 :: y, + pieceDur :: y} + deriving (Eq, Show) + + +newtype PieceRightSingle y = PRS y +newtype PieceRightDouble y = PRD y + +type ControlDist y = (y, Control y, y) + + +-- precedence and associativity like (:) +infixr 5 -|#, #|-, =|#, #|=, |#, #| + +{- | +The 6 operators simplify constructing a list of @ControlPiece a@. +The description consists of nodes (namely the curve values at nodes) +and the connecting curve types. +The naming scheme is as follows: +In the middle there is a bar @|@. +With respect to the bar, +the pad symbol @\#@ is at the side of the curve type, +at the other side there is nothing, a minus sign @-@, or an equality sign @=@. + + (1) Nothing means that here is the start or the end node of a curve. + + (2) Minus means that here is a node where left and right curve meet at the same value. + The node description is thus one value. + + (3) Equality sign means that here is a split node, + where left and right curve might have different ending and beginning values, respectively. + The node description consists of a pair of values. +-} + +-- the leading space is necessary for the Haddock parser + +( #|-) :: (y, Control y) -> (PieceRightSingle y, [ControlPiece y]) -> + (ControlDist y, [ControlPiece y]) +(d,c) #|- (PRS y1, xs) = ((d,c,y1), xs) + +(-|#) :: y -> (ControlDist y, [ControlPiece y]) -> + (PieceRightSingle y, [ControlPiece y]) +y0 -|# ((d,c,y1), xs) = (PRS y0, ControlPiece c y0 y1 d : xs) + +( #|=) :: (y, Control y) -> (PieceRightDouble y, [ControlPiece y]) -> + (ControlDist y, [ControlPiece y]) +(d,c) #|= (PRD y1, xs) = ((d,c,y1), xs) + +(=|#) :: (y,y) -> (ControlDist y, [ControlPiece y]) -> + (PieceRightDouble y, [ControlPiece y]) +(y01,y10) =|# ((d,c,y11), xs) = (PRD y01, ControlPiece c y10 y11 d : xs) + +( #|) :: (y, Control y) -> y -> + (ControlDist y, [ControlPiece y]) +(d,c) #| y1 = ((d,c,y1), []) + +(|#) :: y -> (ControlDist y, [ControlPiece y]) -> + [ControlPiece y] +y0 |# ((d,c,y1), xs) = ControlPiece c y0 y1 d : xs + + +piecewise :: (Trans.C y, RealField.C y, Sample.C y, SigG.C sig) => + [ControlPiece y] -> sig y +piecewise xs = + let ts = scanl (\(_,fr) d -> splitFraction (fr+d)) + (0,1) (map pieceDur xs) + in SigG.concat (zipWith3 + (\n t (ControlPiece c yi0 yi1 d) -> + piecewisePart yi0 yi1 t d n c) + (map fst (tail ts)) (map (subtract 1 . snd) ts) + xs) + + +piecewisePart :: (Trans.C y, Sample.C y, SigG.C sig) => + y -> y -> y -> y -> Int -> Control y -> sig y +piecewisePart y0 y1 t0 d n ctrl = + SigG.take n + (case ctrl of + CtrlStep -> constant y0 + CtrlLin -> let s = (y1-y0)/d in linearMultiscale s (y0-t0*s) + CtrlExp s -> let y0' = y0-s; y1' = y1-s; yd = y0'/y1' + in raise s (exponentialMultiscale (d / log yd) + (y0' * yd**(t0/d))) + CtrlCos -> SigG.map + (\y -> (1+y)*(y0/2)+(1-y)*(y1/2)) + (cosineMultiscale t0 (t0+d)) + CtrlCubic yd0 yd1 -> + cubicHermite (t0,(y0,yd0)) (t0+d,(y1,yd1))) + +{- + exp (-1/time) == yd**(-1/d) + 1/time == log yd / d + time == d / log yd +-} + +{- + piecewise (0 |# (10.21, CtrlExp 1.1) #|- 1 -|# (10,CtrlExp 0.49) #|- 0.5 -|# (30, CtrlLin) #|- 0.5 -|# (20, CtrlCos) #| 0) + + piecewise (0 |# (10.21, CtrlExp 1.1) #|- 1 -|# (10,CtrlCubic (-0.1) 0) #|- 0.5 -|# (30, CtrlLin) #|- 0.5 -|# (20, CtrlCos) #| 0) +-} + + +{- * Auxiliary functions -} + + +curveMultiscale :: (Sample.C y, SigG.C sig) => + (y -> y -> y) -> y -> y -> sig y +curveMultiscale op d y0 = + SigG.cons y0 (SigG.map (op y0) (SigG.iterateAssoc op d)) + + +curveMultiscaleNeutral :: (Sample.C y, SigG.C sig) => + (y -> y -> y) -> y -> y -> sig y +curveMultiscaleNeutral op d neutral = + SigG.cons neutral (SigG.iterateAssoc op d) 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,52 @@ +{-# OPTIONS -fno-implicit-prelude #-} +{- | + +-} +module Synthesizer.Generic.Displacement where + +import qualified Algebra.Additive as Additive + +import qualified Synthesizer.Generic.Signal as SigG +import qualified Synthesizer.Generic.SampledValue as Sample + +-- import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +{- * Mixing -} + +{-| Mix two signals. + In opposition to 'zipWith' the result has the length of the longer signal. -} +mix :: (Additive.C v, Sample.C v, SigG.C sig) => + sig v -> sig v -> sig v +mix = SigG.mix + +{- relict from Prelude98's Num +mixMono :: Ring.C a => [a] -> [a] -> [a] +mixMono [] x = x +mixMono x [] = x +mixMono (x:xs) (y:ys) = x+y : mixMono xs ys +-} + +{-| Mix an arbitrary number of signals. -} +mixMulti :: (Additive.C v, Sample.C v, SigG.C sig) => + [sig v] -> sig v +mixMulti = foldl mix SigG.empty + + +{-| Add a number to all of the signal values. + This is useful for adjusting the center of a modulation. -} +raise :: (Additive.C v, Sample.C v, SigG.C sig) => + v -> sig v -> sig v +raise x = SigG.map ((+) x) + + +{- * Distortion -} +{- | +In "Synthesizer.Basic.Distortion" you find a collection +of appropriate distortion functions. +-} +distort :: (Sample.C c, Sample.C v, SigG.C sig) => + (c -> v -> v) -> sig c -> sig v -> sig v +distort = SigG.zipWith 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,63 @@ +{-# OPTIONS -fno-implicit-prelude #-} +module Synthesizer.Generic.Filter.Delay where + +import qualified Synthesizer.Generic.Interpolation as Interpolation +import qualified Synthesizer.Generic.SampledValue as Sample +import qualified Synthesizer.Generic.Signal as SigG + +import qualified Algebra.RealField as RealField +import qualified Algebra.Additive as Additive + +-- import qualified Prelude as P +-- import PreludeBase +import NumericPrelude + + + +{- * Shift -} + +{-# INLINE static #-} +static :: (Additive.C y, Sample.C y, SigG.C sig) => Int -> sig y -> sig y +static = staticPad zero + +{-# INLINE staticPad #-} +staticPad :: (Sample.C y, SigG.C sig) => y -> Int -> sig y -> sig y +staticPad = Interpolation.delayPad + +{-# INLINE staticPos #-} +staticPos :: (Additive.C y, Sample.C y, SigG.C sig) => Int -> sig y -> sig y +staticPos n = SigG.append (SigG.replicate n zero) + +{-# INLINE staticNeg #-} +staticNeg :: (Sample.C y, SigG.C sig) => Int -> sig y -> sig y +staticNeg = SigG.drop + + + + +{-# INLINE modulatedCore #-} +modulatedCore :: + (RealField.C a, Additive.C v, Sample.C a, Sample.C v, SigG.C sig) => + Interpolation.T sig a v -> Int -> sig a -> sig v -> sig v +modulatedCore ip size = + SigG.zipWithTails + (\t -> Interpolation.single ip (fromIntegral size + t)) + + +{- | +This is essentially different for constant interpolation, +because this function "looks forward" +whereas the other two variants "look backward". +For the symmetric interpolation functions +of linear and cubic interpolation, this does not really matter. +-} +{-# INLINE modulated #-} +modulated :: + (RealField.C a, Additive.C v, Sample.C a, Sample.C v, SigG.C sig) => + Interpolation.T sig a v -> Int -> sig a -> sig v -> sig v +modulated ip minDev ts xs = + let size = Interpolation.number ip - minDev + in modulatedCore ip + (size - Interpolation.offset ip) + ts + (staticPos size xs) 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,297 @@ +{-# OPTIONS -fno-implicit-prelude #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes +-} +module Synthesizer.Generic.Filter.NonRecursive where + +import qualified Synthesizer.Generic.Signal as SigG +import qualified Synthesizer.Generic.SampledValue as Sample + +import qualified Synthesizer.Generic.Filter.Delay as Delay +import qualified Synthesizer.Generic.Control as Ctrl + +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Module as Module +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Algebra.Module( {- linearComb, -} (*>)) + +import Synthesizer.Utility (nest) + +import PreludeBase +import NumericPrelude + + + +{- * Envelope application -} + +{-# INLINE negate #-} +negate :: + (Additive.C a, Sample.C a, SigG.C sig) => + sig a -> sig a +negate = SigG.map Additive.negate + +{-# INLINE amplify #-} +amplify :: + (Ring.C a, Sample.C a, SigG.C sig) => + a -> sig a -> sig a +amplify v = SigG.map (v*) + +{-# INLINE amplifyVector #-} +amplifyVector :: + (Module.C a v, Sample.C v, SigG.C sig) => + a -> sig v -> sig v +amplifyVector v = SigG.map (v*>) + +{-# INLINE envelope #-} +envelope :: + (Ring.C a, Sample.C a, SigG.C sig) => + sig a {-^ the envelope -} + -> sig a {-^ the signal to be enveloped -} + -> sig a +envelope = SigG.zipWith (*) + +{-# INLINE envelopeVector #-} +envelopeVector :: + (Module.C a v, Sample.C a, Sample.C v, SigG.C sig) => + sig a {-^ the envelope -} + -> sig v {-^ the signal to be enveloped -} + -> sig v +envelopeVector = SigG.zipWith (*>) + + + +{-# INLINE fadeInOut #-} +fadeInOut :: + (Field.C a, Sample.C a, SigG.C sig) => + Int -> Int -> Int -> sig a -> sig a +fadeInOut tIn tHold tOut xs = + let slopeIn = recip (fromIntegral tIn) + slopeOut = Additive.negate (recip (fromIntegral tOut)) + leadIn = SigG.take tIn $ Ctrl.linear slopeIn 0 + leadOut = SigG.take tOut $ Ctrl.linear slopeOut 1 + (partIn, partHoldOut) = SigG.splitAt tIn xs + (partHold, partOut) = SigG.splitAt tHold partHoldOut + in envelope leadIn partIn `SigG.append` + partHold `SigG.append` + envelope leadOut partOut + + +{- * Smoothing -} + + +{-| Unmodulated non-recursive filter -} +{-# INLINE generic #-} +generic :: + (Module.C a v, Sample.C a, Sample.C v, SigG.C sig) => + sig a -> sig v -> sig v +generic m x = + let mr = SigG.reverse m + xp = Delay.staticPos (pred (SigG.length m)) x + in SigG.mapTails (SigG.linearComb mr) xp + +{- +{- | +@eps@ is the threshold relatively to the maximum. +That is, if the gaussian falls below @eps * gaussian 0@, +then the function truncated. +-} +gaussian :: + (Trans.C a, RealField.C a, Module.C a v) => + a -> a -> a -> sig v -> sig v +gaussian eps ratio freq = + let var = ratioFreqToVariance ratio freq + area = var * sqrt (2*pi) + gau t = exp (-(t/var)^2/2) / area + width = ceiling (var * sqrt (-2 * log eps)) -- inverse gau + gauSmp = map (gau . fromIntegral) [-width .. width] + in drop width . generic gauSmp +-} + +{- +GNUPlot.plotList [] (take 1000 $ gaussian 0.001 0.5 0.04 (Filter.Test.chirp 5000) :: [Double]) + +The filtered chirp must have amplitude 0.5 at 400 (0.04*10000). +-} + +{- + We want to approximate a Gaussian by a binomial filter. + The latter one can be implemented by a convolutional power. + However we still require a number of operations per sample + which is proportional to the variance. +-} +{-# INLINE binomial #-} +binomial :: + (Trans.C a, RealField.C a, Module.C a v, Sample.C v, SigG.C sig) => + a -> a -> sig v -> sig v +binomial ratio freq = + let width = ceiling (2 * ratioFreqToVariance ratio freq ^ 2) + in SigG.drop width . + nest (2*width) (amplifyVector (asTypeOf 0.5 freq) . binomial1) + +{- +exp (-(t/var)^2/2) / area *> cis (2*pi*f*t) + == exp (-(t/var)^2/2 +: 2*pi*f*t) / area + == exp ((-t^2 +: 2*var^2*2*pi*f*t) / (2*var^2)) / area + == exp ((t^2 - i*2*var^2*2*pi*f*t) / (-2*var^2)) / area + == exp (((t^2 - i*var^2*2*pi*f)^2 + (var^2*2*pi*f)^2) / (-2*var^2)) / area + == exp (((t^2 - i*var^2*2*pi*f)^2 / (-2*var^2) - (var*2*pi*f)^2/2)) / area + +sumMap (\t -> exp (-(t/var)^2/2) / area *> cis (2*pi*f*t)) + [-infinity..infinity] + ~ sumMap (\t -> exp (-(t/var)^2/2)) [-infinity..infinity] + * exp (-(var*2*pi*f)^2/2) / area + = exp (-(var*2*pi*f)^2/2) +-} +{- | + Compute the variance of the Gaussian + such that its Fourier transform has value @ratio@ at frequency @freq@. +-} +{-# INLINE ratioFreqToVariance #-} +ratioFreqToVariance :: (Trans.C a) => a -> a -> a +ratioFreqToVariance ratio freq = + sqrt (Additive.negate (2 * log ratio)) / (2*pi*freq) + -- inverse of the fourier transformed gaussian + +{-# INLINE binomial1 #-} +binomial1 :: + (Additive.C v, Sample.C v, SigG.C sig) => sig v -> sig v +binomial1 = SigG.zapWith (+) + + + + + +{- | +Moving (uniformly weighted) average in the most trivial form. +This is very slow and needs about @n * length x@ operations. +-} +{-# INLINE sums #-} +sums :: + (Additive.C v, Sample.C v, SigG.C sig) => + Int -> sig v -> sig v +sums n = SigG.mapTails (SigG.sum . SigG.take n) + + +{- +sumsDownsample2 :: (Additive.C v) => sig v -> sig v +sumsDownsample2 (x0:x1:xs) = (x0+x1) : sumsDownsample2 xs +sumsDownsample2 xs = xs + +downsample2 :: sig a -> sig a +downsample2 (x0:_:xs) = x0 : downsample2 xs +downsample2 xs = xs + + +{- | +Given a list of numbers +and a list of sums of (2*k) of successive summands, +compute a list of the sums of (2*k+1) or (2*k+2) summands. + +Eample for 2*k+1 + +@ + [0+1+2+3, 2+3+4+5, 4+5+6+7, ...] -> + [0+1+2+3+4, 1+2+3+4+5, 2+3+4+5+6, 3+4+5+6+7, 4+5+6+7+8, ...] +@ + +Example for 2*k+2 + +@ + [0+1+2+3, 2+3+4+5, 4+5+6+7, ...] -> + [0+1+2+3+4+5, 1+2+3+4+5+6, 2+3+4+5+6+7, 3+4+5+6+7+8, 4+5+6+7+8+9, ...] +@ +-} +sumsUpsampleOdd :: (Additive.C v) => Int -> sig v -> sig v -> sig v +sumsUpsampleOdd n {- 2*k -} xs ss = + let xs2k = drop n xs + in (head ss + head xs2k) : + concat (zipWith3 (\s x0 x2k -> [x0+s, s+x2k]) + (tail ss) + (downsample2 (tail xs)) + (tail (downsample2 xs2k))) + +sumsUpsampleEven :: (Additive.C v) => Int -> sig v -> sig v -> sig v +sumsUpsampleEven n {- 2*k -} xs ss = + sumsUpsampleOdd (n+1) xs (zipWith (+) ss (downsample2 (drop n xs))) + +sumsPyramid :: (Additive.C v) => Int -> sig v -> sig v +sumsPyramid n xs = + let aux 1 ys = ys + aux 2 ys = ys + tail ys + aux m ys = + let ysd = sumsDownsample2 ys + in if even m + then sumsUpsampleEven (m-2) ys (aux (div (m-2) 2) ysd) + else sumsUpsampleOdd (m-1) ys (aux (div (m-1) 2) ysd) + in aux n xs + + +propSums :: Bool +propSums = + let n = 1000 + xs = [0::Double ..] + naive = sums n xs + rec = drop (n-1) $ sumsRec n xs + pyramid = sumsPyramid n xs + in and $ take 1000 $ + zipWith3 (\x y z -> x==y && y==z) naive rec pyramid + +-} + + + +{- * Filter operators from calculus -} + +{- | +Forward difference quotient. +Shortens the signal by one. +Inverts 'Synthesizer.Generic.Filter.Recursive.Integration.run' in the sense that +@differentiate (zero : integrate x) == x@. +The signal is shifted by a half time unit. +-} +{-# INLINE differentiate #-} +differentiate :: + (Additive.C v, Sample.C v, SigG.C sig) => + sig v -> sig v +differentiate x = SigG.zapWith subtract x + +{- | +Central difference quotient. +Shortens the signal by two elements, +and shifts the signal by one element. +(Which can be fixed by prepending an appropriate value.) +For linear functions this will yield +essentially the same result as 'differentiate'. +You obtain the result of 'differentiateCenter' +if you smooth the one of 'differentiate' +by averaging pairs of adjacent values. + +ToDo: Vector variant +-} +{-# INLINE differentiateCenter #-} +differentiateCenter :: + (Field.C v, Sample.C v, SigG.C sig) => + sig v -> sig v +differentiateCenter = + SigG.zapWith (\(x0,_) (_,x1) -> (x1 - x0) * (1/2)) . + SigG.zapWith (,) + +{- | +Second derivative. +It is @differentiate2 == differentiate . differentiate@ +but 'differentiate2' should be faster. +-} +{-# INLINE differentiate2 #-} +differentiate2 :: + (Additive.C v, Sample.C v, SigG.C sig) => + sig v -> sig v +differentiate2 = differentiate . differentiate 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,48 @@ +{-# OPTIONS -fno-implicit-prelude #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +Filter operators from calculus +-} +module Synthesizer.Generic.Filter.Recursive.Integration where + +import qualified Synthesizer.Generic.Signal as SigG +import qualified Synthesizer.Generic.SampledValue as Sample + +-- import qualified Algebra.Field as Field +-- import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import PreludeBase +import NumericPrelude + + + +{- | +Integrate with initial value zero. +However the first emitted value is the value of the input signal. +It maintains the length of the signal. +-} +{-# INLINE run #-} +run :: (Additive.C v, Sample.C v, SigG.C sig) => + sig v -> sig v +run = + SigG.crochetL (\x acc -> let y = x+acc in Just (y,y)) zero + -- scanl1 (+) + +{- | +Integrate with initial condition. +First emitted value is the initial condition. +The signal become one element longer. +-} +{-# INLINE runInit #-} +runInit :: (Additive.C v, Sample.C v, SigG.C sig) => + v -> sig v -> sig v +runInit = SigG.scanL (+) + +{- other quadrature methods may follow -} 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,169 @@ +{-# OPTIONS -fno-implicit-prelude #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +-} +module Synthesizer.Generic.Filter.Recursive.MovingAverage + (sumsStaticInt, + modulatedFrac, + ) where + +import qualified Synthesizer.Generic.Signal as SigG +import qualified Synthesizer.Generic.SampledValue as Sample + +import qualified Synthesizer.Generic.Filter.Recursive.Integration as Integration +import qualified Synthesizer.Generic.Filter.Delay as Delay + +import Synthesizer.Utility (nest, ) + +import qualified Algebra.Module as Module +import qualified Algebra.RealField as RealField + +-- import qualified Algebra.Field as Field +-- import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import PreludeBase +import NumericPrelude + + + +{- | +Like 'Synthesizer.Generic.Filter.NonRecursive.sums' but in a recursive form. +This needs only linear time (independent of the window size) +but may accumulate rounding errors. + +@ +ys = xs * (1,0,0,0,-1) \/ (1,-1) +ys * (1,-1) = xs * (1,0,0,0,-1) +ys = xs * (1,0,0,0,-1) + ys * (0,1) +@ +-} +{-# INLINE sumsStaticInt #-} +sumsStaticInt :: (Additive.C v, Sample.C v, SigG.C sig) => + Int -> sig v -> sig v +sumsStaticInt n xs = + Integration.run (sub xs (Delay.staticPos n xs)) + + +{-# INLINE sub #-} +sub :: (Additive.C v, Sample.C v, SigG.C sig) => + sig v -> sig v -> sig v +sub xs ys = + SigG.mix xs (SigG.map Additive.negate ys) + + +{- +Sum of a part of a vector with negative sign for reverse order. +It adds from @from@ (inclusively) to @to@ (exclusively), +that is, it sums up @abs (to-from)@ values + +{-# INLINE sumFromTo #-} +sumFromTo :: (Additive.C v) => Int -> Int -> sig v -> v +sumFromTo from to = + if from <= to + then Sig.sum . Sig.take (to-from) . Sig.drop from + else negate . Sig.sum . Sig.take (from-to) . Sig.drop to +-} + +{-# INLINE sumFromToFrac #-} +sumFromToFrac :: + (RealField.C a, Module.C a v, Sample.C v, SigG.C sig) => + a -> a -> sig v -> v +sumFromToFrac from to xs = + let (fromInt, fromFrac) = splitFraction from + (toInt, toFrac) = splitFraction to + in case compare fromInt toInt of + EQ -> (to-from) *> index zero fromInt xs + LT -> + (addNext ((1-fromFrac) *>) $ + nest (toInt-fromInt-1) (addNext id) $ + addNext (toFrac *>) $ + const) + zero (SigG.drop fromInt xs) + GT -> + (addNext ((1-toFrac) *>) $ + nest (fromInt-toInt-1) (addNext id) $ + addNext (fromFrac *>) $ + const) + zero (SigG.drop toInt xs) + + +{-# INLINE index #-} +index :: + (SigG.C sig, Sample.C y) => + y -> Int -> sig y -> y +index deflt n = + maybe deflt fst . SigG.viewL . SigG.drop n + + +{-# INLINE addNext #-} +addNext :: + (Additive.C v, Sample.C a, SigG.C sig) => + (a -> v) -> (v -> sig a -> v) -> v -> sig a -> v +addNext f next s xs = + maybe s + (\(y,ys) -> next (s + f y) ys) + (SigG.viewL xs) + + +{- | +@sig a@ must contain only non-negative elements. +-} +{-# INLINE sumDiffsModulated #-} +sumDiffsModulated :: + (RealField.C a, Module.C a v, Sample.C a, Sample.C v, SigG.C sig) => + a -> sig a -> sig v -> sig v +sumDiffsModulated d ds = + maybe (error "MovingAverage: signal must be non-empty because we prepended a zero before") fst . + SigG.viewR . + -- prevent negative d's since 'drop' cannot restore past values + SigG.zipWithTails (uncurry sumFromToFrac) + (SigG.zip (SigG.cons (d+1) ds) (SigG.map (1+) ds)) . + SigG.cons zero + +{- + SigG.zipWithTails (uncurry sumFromToFrac) + (SigG.zip (SigG.cons d (SigG.map (subtract 1) ds)) ds) +-} + +{- +{-# INLINE sumsModulated #-} +sumsModulated :: (RealField.C a, Module.C a v) => + Int -> sig a -> sig v -> sig v +sumsModulated maxDInt ds xs = + let maxD = fromIntegral maxDInt + posXs = sumDiffsModulated 0 ds xs + negXs = sumDiffsModulated maxD (SigG.map (maxD-) ds) (Delay.static maxDInt xs) + in Integration.run (sub posXs negXs) +-} + +{- | +Shift sampling points by a half sample period +in order to preserve signals for window widths below 1. +-} +{-# INLINE sumsModulatedHalf #-} +sumsModulatedHalf :: + (RealField.C a, Module.C a v, Sample.C a, Sample.C v, SigG.C sig) => + Int -> sig a -> sig v -> sig v +sumsModulatedHalf maxDInt ds xs = + let maxD = fromIntegral maxDInt + d0 = maxD+0.5 + delXs = Delay.staticPos maxDInt xs + posXs = sumDiffsModulated d0 (SigG.map (d0+) ds) delXs + negXs = sumDiffsModulated d0 (SigG.map (d0-) ds) delXs + in Integration.run (sub posXs negXs) + +{-# INLINE modulatedFrac #-} +modulatedFrac :: + (RealField.C a, Module.C a v, Sample.C a, Sample.C v, SigG.C sig) => + Int -> sig a -> sig v -> sig v +modulatedFrac maxDInt ds xs = + SigG.zipWith (\d y -> recip (2*d) *> y) ds $ + sumsModulatedHalf maxDInt ds xs + 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,348 @@ +{-# OPTIONS -fno-implicit-prelude #-} +{- | +ToDo: +use AffineSpace instead of Module for the particular interpolation types, +since affine combinations assert reconstruction of constant functions. +They are more natural for interpolation of internal control parameters. +However, how can cubic interpolation expressed by affine combinations +without divisions? +-} +module Synthesizer.Generic.Interpolation where + +import qualified Synthesizer.Generic.Control as Ctrl +import qualified Synthesizer.Generic.SampledValue as Sample +import qualified Synthesizer.Generic.Signal as SigG + +import qualified Algebra.Module as Module +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Algebra.Additive(zero) +import Algebra.Module((*>)) +import Data.Maybe (fromMaybe) + +import Control.Monad.State (StateT(StateT), evalStateT, ap, ) +import Control.Applicative (Applicative(pure, (<*>)), (<$>), liftA2, ) +import Synthesizer.ApplicativeUtility (liftA4, ) +import Synthesizer.Utility (affineComb, ) + +import PreludeBase +import NumericPrelude + + +{- | interpolation as needed for resampling -} +data T sig t y = + Cons { + number :: Int, -- interpolation requires a total number of 'number' + offset :: Int, -- interpolation requires 'offset' values before the current + func :: t -> sig y -> y + } + + +{-* Interpolation with various padding methods -} + +{-# INLINE zeroPad #-} +zeroPad :: (RealField.C t, Sample.C y, SigG.C sig) => + (T sig t y -> t -> sig y -> a) -> + y -> T sig t y -> t -> sig y -> a +zeroPad interpolate z ip phase x = + let (phInt, phFrac) = splitFraction phase + in interpolate ip phFrac + (delayPad z (offset ip - phInt) (SigG.append x (SigG.repeat z))) + +{-# INLINE constantPad #-} +constantPad :: (RealField.C t, Sample.C y, SigG.C sig) => + (T sig t y -> t -> sig y -> a) -> + T sig t y -> t -> sig y -> a +constantPad interpolate ip phase x = + let (phInt, phFrac) = splitFraction phase + xPad = + do (xFirst,_) <- SigG.viewL x + return (delayPad xFirst (offset ip - phInt) (SigG.extendConstant x)) + in interpolate ip phFrac + (fromMaybe SigG.empty xPad) + + +{- | +Only for finite input signals. +-} +{-# INLINE cyclicPad #-} +cyclicPad :: (RealField.C t, Sample.C y, SigG.C sig) => + (T sig t y -> t -> sig y -> a) -> + T sig t y -> t -> sig y -> a +cyclicPad interpolate ip phase x = + let (phInt, phFrac) = splitFraction phase + in interpolate ip phFrac + (SigG.drop (mod (phInt - offset ip) (SigG.length x)) (SigG.cycle x)) + +{- | +The extrapolation may miss some of the first and some of the last points +-} +{-# INLINE extrapolationPad #-} +extrapolationPad :: (RealField.C t, Sample.C y, SigG.C sig) => + (T sig t y -> t -> sig y -> a) -> + T sig t y -> t -> sig y -> a +extrapolationPad interpolate ip phase = + interpolate ip (phase - fromIntegral (offset ip)) +{- + This example shows pikes, although there shouldn't be any: + plotList (take 100 $ interpolate (Zero (0::Double)) ipCubic (-0.9::Double) (repeat 0.03) [1,0,1,0.8]) +-} + + +{-* Interpolation of multiple values with various padding methods -} + +{-# INLINE skip #-} +skip :: (RealField.C t, Sample.C y, SigG.C sig) => + T sig t y -> (t, sig y) -> (t, sig y) +skip ip (phase0, x0) = + let (n, frac) = splitFraction phase0 + (m, x1) = SigG.dropMarginRem (number ip) n x0 + in (fromIntegral m + frac, x1) + +{-# INLINE single #-} +single :: (RealField.C t, Sample.C y, SigG.C sig) => + T sig t y -> t -> sig y -> y +single ip phase0 x0 = + uncurry (func ip) $ skip ip (phase0, x0) +-- curry (uncurry (func ip) . skip ip) +{- +GNUPlot.plotFunc [] (GNUPlot.linearScale 1000 (0,2)) (\t -> single linear (t::Double) [0,4,1::Double]) +-} + + +{-* Interpolation of multiple values with various padding methods -} + +{- | All values of frequency control must be non-negative. -} +{-# INLINE multiRelative #-} +multiRelative :: + (RealField.C t, Sample.C t, Sample.C y, SigG.C sig) => + T sig t y -> t -> sig y -> sig t -> sig y +multiRelative ip phase0 x0 = + SigG.crochetL + (\freq pos -> + let (phase,x) = skip ip pos + in Just (func ip phase x, (phase+freq,x))) + (phase0,x0) + + +{-# INLINE multiRelativeZeroPad #-} +multiRelativeZeroPad :: + (RealField.C t, Sample.C t, Sample.C y, SigG.C sig) => + y -> T sig t y -> t -> sig t -> sig y -> sig y +multiRelativeZeroPad z ip phase fs x = + zeroPad multiRelative z ip phase x fs + +{-# INLINE multiRelativeConstantPad #-} +multiRelativeConstantPad :: + (RealField.C t, Sample.C t, Sample.C y, SigG.C sig) => + T sig t y -> t -> sig t -> sig y -> sig y +multiRelativeConstantPad ip phase fs x = + constantPad multiRelative ip phase x fs + +{-# INLINE multiRelativeCyclicPad #-} +multiRelativeCyclicPad :: + (RealField.C t, Sample.C t, Sample.C y, SigG.C sig) => + T sig t y -> t -> sig t -> sig y -> sig y +multiRelativeCyclicPad ip phase fs x = + cyclicPad multiRelative ip phase x fs + +{- | +The extrapolation may miss some of the first and some of the last points +-} +{-# INLINE multiRelativeExtrapolationPad #-} +multiRelativeExtrapolationPad :: + (RealField.C t, Sample.C t, Sample.C y, SigG.C sig) => + T sig t y -> t -> sig t -> sig y -> sig y +multiRelativeExtrapolationPad ip phase fs x = + extrapolationPad multiRelative ip phase x fs +{- + This example shows pikes, although there shouldn't be any: + plotList (take 100 $ interpolate (Zero (0::Double)) ipCubic (-0.9::Double) (repeat 0.03) [1,0,1,0.8]) +-} + +{-* All-in-one interpolation functions -} + +{-# INLINE multiRelativeZeroPadConstant #-} +multiRelativeZeroPadConstant :: + (RealField.C t, Additive.C y, Sample.C t, Sample.C y, SigG.C sig) => + t -> sig t -> sig y -> sig y +multiRelativeZeroPadConstant = multiRelativeZeroPad zero constant + +{-# INLINE multiRelativeZeroPadLinear #-} +multiRelativeZeroPadLinear :: + (RealField.C t, Module.C t y, Sample.C t, Sample.C y, SigG.C sig) => + t -> sig t -> sig y -> sig y +multiRelativeZeroPadLinear = multiRelativeZeroPad zero linear + +{-# INLINE multiRelativeZeroPadCubic #-} +multiRelativeZeroPadCubic :: + (RealField.C t, Module.C t y, Sample.C t, Sample.C y, SigG.C sig) => + t -> sig t -> sig y -> sig y +multiRelativeZeroPadCubic = multiRelativeZeroPad zero cubic + + +{-* Different kinds of interpolation -} + +{-** Hard-wired interpolations -} + +data PrefixReader sig a = + PrefixReader Int (StateT sig Maybe a) + +instance Functor (PrefixReader sig) where + fmap f (PrefixReader count parser) = + PrefixReader count (fmap f parser) + +instance Applicative (PrefixReader sig) where + pure = PrefixReader 0 . return + (PrefixReader count0 parser0) <*> (PrefixReader count1 parser1) = + PrefixReader (count0+count1) (parser0 `ap` parser1) + +{-# INLINE getNode #-} +getNode :: (Sample.C y, SigG.C sig) => + PrefixReader (sig y) y +getNode = PrefixReader 1 (StateT SigG.viewL) + +{-# INLINE fromPrefixReader #-} +fromPrefixReader :: (Sample.C y, SigG.C sig) => + String -> Int -> PrefixReader (sig y) (t -> y) -> T sig t y +fromPrefixReader name off (PrefixReader count parser) = + Cons count off + (\t xs -> + maybe + (error (name ++ " interpolation: not enough nodes")) + ($t) + (evalStateT parser xs)) + +{-| Consider the signal to be piecewise constant. -} +{-# INLINE constant #-} +constant :: (Sample.C y, SigG.C sig) => T sig t y +constant = + fromPrefixReader "constant" 0 (const <$> getNode) + +{-| Consider the signal to be piecewise linear. -} +{-# INLINE linear #-} +linear :: (Module.C t y, Sample.C y, SigG.C sig) => T sig t y +linear = + fromPrefixReader "linear" 0 + (liftA2 + (\x0 x1 phase -> affineComb phase (x0,x1)) + getNode getNode) + +{-| Consider the signal to be piecewise cubic, + with smooth connections at the nodes. + It uses a cubic curve which has node values + x0 at 0 and x1 at 1 and derivatives + (x1-xm1)/2 and (x2-x0)/2, respectively. + You can see how it works + if you evaluate the expression for t=0 and t=1 + as well as the derivative at these points. -} +{-# INLINE cubic #-} +cubic :: (Field.C t, Module.C t y, Sample.C y, SigG.C sig) => T sig t y +cubic = + fromPrefixReader "cubic" 1 + (liftA4 + (\xm1 x0 x1 x2 t -> + let lipm12 = affineComb t (xm1,x2) + lip01 = affineComb t (x0, x1) + three = 3 `asTypeOf` t + in lip01 + (t*(t-1)/2) *> + (lipm12 + (x0+x1) - three *> lip01)) + getNode getNode getNode getNode) + +{-# INLINE cubicAlt #-} +cubicAlt :: (Field.C t, Module.C t y, Sample.C y, SigG.C sig) => T sig t y +cubicAlt = + fromPrefixReader "cubicAlt" 1 + (liftA4 + (\xm1 x0 x1 x2 t -> + let half = 1/2 `asTypeOf` t + in cubicHalf t x0 (half *> (x1-xm1)) + + cubicHalf (1-t) x1 (half *> (x0-x2))) + getNode getNode getNode getNode) + + +{- \t -> cubicHalf t x x' has a double zero at 1 and + at 0 it has value x and steepness x' -} +{-# INLINE cubicHalf #-} +cubicHalf :: (Module.C t y) => t -> y -> y -> y +cubicHalf t x x' = + (t-1)^2 *> ((1+2*t)*>x + t*>x') + + + +{-** Interpolation based on piecewise defined functions -} + +{-# INLINE piecewise #-} +piecewise :: (Module.C t y, Sample.C t, Sample.C y, SigG.C sig) => + Int -> [t -> t] -> T sig t y +piecewise center ps = + Cons (length ps) (center-1) + (\t -> linearComb (SigG.reverse (SigG.fromList (map ($t) ps)))) + +{-# INLINE piecewiseConstant #-} +piecewiseConstant :: + (Module.C t y, Sample.C t, Sample.C y, SigG.C sig) => T sig t y +piecewiseConstant = + piecewise 1 [const 1] + +{-# INLINE piecewiseLinear #-} +piecewiseLinear :: + (Module.C t y, Sample.C t, Sample.C y, SigG.C sig) => T sig t y +piecewiseLinear = + piecewise 1 [id, (1-)] + +{-# INLINE piecewiseCubic #-} +piecewiseCubic :: + (Field.C t, Module.C t y, Sample.C t, Sample.C y, SigG.C sig) => T sig t y +piecewiseCubic = + piecewise 2 $ + Ctrl.cubicFunc (0,(0,0)) (1,(0,1/2)) : + Ctrl.cubicFunc (0,(0,1/2)) (1,(1,0)) : + Ctrl.cubicFunc (0,(1,0)) (1,(0,-1/2)) : + Ctrl.cubicFunc (0,(0,-1/2)) (1,(0,0)) : + [] + +{- +GNUPlot.plotList [] $ take 100 $ interpolate (Zero 0) piecewiseCubic (-2.3 :: Double) (repeat 0.1) [2,1,2::Double] +-} + + +{-** Interpolation based on arbitrary functions -} + +{- | with this wrapper you can use the collection of interpolating functions from Donadio's DSP library -} +{-# INLINE function #-} +function :: (Module.C t y, Sample.C t, Sample.C y, SigG.C sig) => + (Int,Int) {- ^ @(left extent, right extent)@, e.g. @(1,1)@ for linear hat -} + -> (t -> t) + -> T sig t y +function (left,right) f = + let len = left+right + in Cons len left + (\t -> linearComb $ SigG.reverse $ + SigG.map + (\x -> f (t + fromIntegral x)) + (SigG.take len (SigG.iterate succ (-left)))) +{- +GNUPlot.plotList [] $ take 300 $ interpolate (Zero 0) (function (1,1) (\x -> exp (-6*x*x))) (-2.3 :: Double) (repeat 0.03) [2,1,2::Double] +-} + + +-- cf. Module.linearComb +{-# INLINE linearComb #-} +linearComb :: + (SigG.C sig, Sample.C t, Sample.C y, Module.C t y) => + sig t -> sig y -> y +linearComb ts ys = + SigG.sum $ SigG.zipWith (*>) ts ys + + + +{-* Helper functions -} + +{-# INLINE delayPad #-} +delayPad :: (Sample.C y, SigG.C sig) => y -> Int -> sig y -> sig y +delayPad z n = + if n<0 then SigG.drop (negate n) else SigG.append (SigG.replicate n z) 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,64 @@ +{-# OPTIONS -fno-implicit-prelude #-} +{- | Noise and random processes. -} +module Synthesizer.Generic.Noise where + +import qualified Synthesizer.Generic.Signal as SigG +import qualified Synthesizer.Generic.SampledValue as Sample + +import qualified Algebra.Real as Real +import qualified Algebra.Ring as Ring + +import System.Random (Random, RandomGen, randomR, mkStdGen, ) +import qualified System.Random as Rnd + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +{-| +Deterministic white noise, uniformly distributed between -1 and 1. +That is, variance is 1\/3. +-} +white :: + (Ring.C y, Random y, Sample.C y, SigG.C sig) => + sig y +white = whiteGen (mkStdGen 12354) + +whiteGen :: + (Ring.C y, Random y, RandomGen g, Sample.C y, SigG.C sig) => + g -> sig y +whiteGen = + SigG.unfoldR (Just . randomR (-1,1)) + + +{- | +Approximates normal distribution with variance 1 +by a quadratic B-spline distribution. +-} +whiteQuadraticBSplineGen :: + (Ring.C y, Random y, RandomGen g, Sample.C y, SigG.C sig) => + g -> sig y +whiteQuadraticBSplineGen g = + let (g0,gr) = Rnd.split g + (g1,g2) = Rnd.split gr + in whiteGen g0 `SigG.mix` + whiteGen g1 `SigG.mix` + whiteGen g2 + + +randomPeeks :: + (Real.C y, Random y, Sample.C y, SigG.C sig) => + sig y {- ^ momentary densities, @p@ means that there is about one peak + in the time range of @1\/p@ samples -} + -> sig Bool {- ^ Every occurence of 'True' represents a peak. -} +randomPeeks = + randomPeeksGen (mkStdGen 876) + +randomPeeksGen :: + (Real.C y, Random y, RandomGen g, Sample.C y, SigG.C sig) => + g + -> sig y + -> sig Bool +randomPeeksGen = + SigG.zipWith (<) . SigG.unfoldR (Just . randomR (0,1)) 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,214 @@ +{-# OPTIONS -fno-implicit-prelude #-} +{- | +Copyright : (c) Henning Thielemann 2006 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +Tone generators + +Frequencies are always specified in ratios of the sample rate, +e.g. the frequency 0.01 for the sample rate 44100 Hz +means a physical frequency of 441 Hz. +-} +module Synthesizer.Generic.Oscillator where + +-- import qualified Synthesizer.Plain.ToneModulation as ToneMod +import qualified Synthesizer.Basic.Wave as Wave +import qualified Synthesizer.Basic.Phase as Phase + +import qualified Synthesizer.Generic.Interpolation as Interpolation + +import qualified Synthesizer.Generic.Signal as SigG +import qualified Synthesizer.Generic.SampledValue as Sample + +{- +import qualified Algebra.RealTranscendental as RealTrans +import qualified Algebra.Module as Module +import qualified Algebra.VectorSpace as VectorSpace + +import Algebra.Module((*>)) +-} +import qualified Algebra.Transcendental as Trans +import qualified Algebra.RealField as RealField +-- import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +-- import qualified Number.NonNegative as NonNeg + +import NumericPrelude + +-- import qualified Prelude as P +import PreludeBase + + + +{- * Oscillators with arbitrary but constant waveforms -} + +freqToPhase :: (RealField.C a, Sample.C a, SigG.C sig) => + Phase.T a -> sig a -> sig (Phase.T a) +freqToPhase phase freq = + SigG.scanL (flip Phase.increment) phase freq + + +{- | oscillator with constant frequency -} +static :: (RealField.C a, Sample.C a, Sample.C b, SigG.C sig) => + Wave.T a b -> (Phase.T a -> a -> sig b) +static wave phase freq = + SigG.map (Wave.apply wave) (SigG.iterate (Phase.increment freq) phase) + +{- | oscillator with modulated frequency -} +freqMod :: (RealField.C a, Sample.C a, Sample.C b, SigG.C sig) => + Wave.T a b -> Phase.T a -> sig a -> sig b +freqMod wave phase freqs = + SigG.map (Wave.apply wave) (freqToPhase phase freqs) + +{- | oscillator with modulated phase -} +phaseMod :: (RealField.C a, Sample.C a, Sample.C b, SigG.C sig) => + Wave.T a b -> a -> sig a -> sig b +phaseMod wave = shapeMod (Wave.phaseOffset wave) zero + +{- | oscillator with modulated shape -} +shapeMod :: (RealField.C a, Sample.C a, Sample.C b, Sample.C c, SigG.C sig) => + (c -> Wave.T a b) -> Phase.T a -> a -> sig c -> sig b +shapeMod wave phase freq parameters = + SigG.zipWith (Wave.apply . wave) parameters (SigG.iterate (Phase.increment freq) phase) + +{- | oscillator with both phase and frequency modulation -} +phaseFreqMod :: (RealField.C a, Sample.C a, Sample.C b, SigG.C sig) => + Wave.T a b -> sig a -> sig a -> sig b +phaseFreqMod wave = shapeFreqMod (Wave.phaseOffset wave) zero + +{- | oscillator with both shape and frequency modulation -} +shapeFreqMod :: (RealField.C a, Sample.C a, Sample.C b, Sample.C c, SigG.C sig) => + (c -> Wave.T a b) -> Phase.T a -> sig c -> sig a -> sig b +shapeFreqMod wave phase parameters freqs = + SigG.zipWith (Wave.apply . wave) parameters (freqToPhase phase freqs) + + +{- | oscillator with a sampled waveform with constant frequency + This is essentially an interpolation with cyclic padding. -} +staticSample :: (RealField.C a, Sample.C a, Sample.C b, SigG.C sig) => + Interpolation.T sig a b -> [b] -> Phase.T a -> a -> sig b +staticSample ip wave phase freq = + freqModSample ip wave phase (SigG.repeat freq) + +{- | oscillator with a sampled waveform with modulated frequency + Should behave homogenously for different types of interpolation. -} +freqModSample :: (RealField.C a, Sample.C a, Sample.C b, SigG.C sig) => + Interpolation.T sig a b -> [b] -> Phase.T a -> sig a -> sig b +freqModSample ip wave phase freqs = + let len = length wave + in Interpolation.multiRelativeCyclicPad + ip (Phase.toRepresentative $ Phase.multiply len phase) + (SigG.map (* fromIntegral len) freqs) + (SigG.fromList wave) + +{- +{- | +Shape control is a list of relative changes, +each of which must be non-negative in order to allow lazy processing. +'1' advances by one wave. +Frequency control can be negative. +If you want to use sampled waveforms as well +then use 'Wave.sample' in the list of waveforms. +With sampled waves this function is identical to HunkTranspose in Assampler. + +Example: interpolate different versions +of 'Wave.oddCosine' and 'Wave.oddTriangle'. + +You could also chop a tone into single waves +and use the waves as input for this function +but you certainly want to use +'Wave.sampledTone' or 'shapeFreqModFromSampledTone' instead, +because in the wave information for 'shapeFreqModSample' +shape and phase are strictly separated. +-} +shapeFreqModSample :: (RealField.C c, RealField.C b, Sample.C a, SigG.C sig) => + Interpolation.T c (b -> a) -> [b -> a] -> c -> b -> sig c -> sig b -> sig a +shapeFreqModSample ip waves shape0 phase shapes freqs = + SigG.zipWith ($) + (Interpolation.multiRelativeConstantPad ip shape0 shapes waves) + (freqToPhase phase freqs) +{- +GNUPlot.plotList [] $ take 500 $ shapeFreqModSample Interpolation.cubic (SigG.map Wave.truncOddCosine [0..3]) (0.1::Double) (0::Double) (repeat 0.005) (repeat 0.02) +-} + +{- | +Time stretching and frequency modulation of a pure tone. + +We consider a tone as the result of a shape modulated oscillator, +and virtually reconstruct the waveform function +(a function of time and phase) by interpolation and resample it. +This way we can alter frequency and time progress of the tone independently. + +This function is identical to using 'shapeFreqMod' +with a wave function constructed by 'Wave.sampledTone' +but it consumes the sampled source tone lazily +and thus allows only relative shape control with non-negative control steps. + +The function is similar to 'shapeFreqModSample' but respects +that in a sampled tone, phase and shape control advance synchronously. +Actually we could re-use 'shapeFreqModSample' with modified phase values. +But we would have to cope with negative shape control jumps, +and waves would be padded locally cyclically. +The latter one is not wanted +since we want padding according to the adjacencies in the source tone. + +Although the shape difference values must be non-negative +I hesitate to give them the type @Number.NonNegative.T t@ +because then you cannot call this function with other types +of non-negative numbers like 'Number.NonNegativeChunky.T'. + +The prototype tone signal is reproduced if +@freqs == repeat (1\/period)@ and @shapes == repeat 1@. +-} +shapeFreqModFromSampledTone :: (RealField.C t, Sample.C a, SigG.C sig) => + Interpolation.T t y -> + Interpolation.T t y -> + t -> sig y -> t -> t -> sig t -> sig t -> sig y +shapeFreqModFromSampledTone + ipLeap ipStep period sampledTone + shape0 phase shapes freqs = + SigG.map + (uncurry (ToneMod.interpolateCell ipLeap ipStep)) + (ToneMod.oscillatorCells + ipLeap ipStep period sampledTone + (shape0, shapes) (phase, freqs)) +{- +GNUPlot.plotList [] $ take 1000 $ shapeFreqModFromSampledTone Interpolation.linear Interpolation.linear (1/0.07::Double) (staticSine (0::Double) 0.07) 0 0 (repeat 0.1) (repeat 0.01) +GNUPlot.plotList [] $ take 1000 $ shapeFreqModFromSampledTone Interpolation.linear Interpolation.linear (1/0.07::Double) (staticSine (0::Double) 0.07) 0 0 (repeat 0.1) (SigG.iterate (*(1-2e-3)) 0.01) +GNUPlot.plotList [] $ take 101 $ shapeFreqModFromSampledTone Interpolation.linear Interpolation.linear (1/0.07::Double) (SigG.iterate (1+) (0::Double)) 0 0 (repeat 1) (repeat 0.7) +-} +-} + + +{- * Oscillators with specific waveforms -} + +{- | sine oscillator with static frequency -} +staticSine :: (Trans.C a, RealField.C a, Sample.C a, SigG.C sig) => + Phase.T a -> a -> sig a +staticSine = static Wave.sine + +{- | sine oscillator with modulated frequency -} +freqModSine :: (Trans.C a, RealField.C a, Sample.C a, SigG.C sig) => + Phase.T a -> sig a -> sig a +freqModSine = freqMod Wave.sine + +{- | sine oscillator with modulated phase, useful for FM synthesis -} +phaseModSine :: (Trans.C a, RealField.C a, Sample.C a, SigG.C sig) => + a -> sig a -> sig a +phaseModSine = phaseMod Wave.sine + +{- | saw tooth oscillator with modulated frequency -} +staticSaw :: (RealField.C a, Sample.C a, SigG.C sig) => + Phase.T a -> a -> sig a +staticSaw = static Wave.saw + +{- | saw tooth oscillator with modulated frequency -} +freqModSaw :: (RealField.C a, Sample.C a, SigG.C sig) => + Phase.T a -> sig a -> sig a +freqModSaw = freqMod Wave.saw diff --git a/src/Synthesizer/Generic/SampledValue.hs b/src/Synthesizer/Generic/SampledValue.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Generic/SampledValue.hs @@ -0,0 +1,20 @@ +module Synthesizer.Generic.SampledValue where + +import Foreign.Storable (Storable) +import StorableInstance () + +import qualified Number.Complex as Complex +import qualified Number.Ratio as Ratio +import qualified Algebra.PrincipalIdealDomain as PID + + +class Storable a => C a -- where + +instance C Bool -- where +instance C Int -- where +instance C Float -- where +instance C Double -- where +instance (C a, C b) => C (a,b) -- where +instance (C a, C b, C c) => C (a,b,c) -- where +instance (C a) => C (Complex.T a) -- where +instance (C a, PID.C a) => C (Ratio.T a) -- where 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,197 @@ +{- OPTIONS_GHC -fglasgow-exts -} +{- +Unfortunately we have to use the SampledValue constraint also for lists, +which means that we can only use Storable values for signals. +Maybe we can improve this situation using associated types. +-} +module Synthesizer.Generic.Signal where + +import qualified Algebra.Module as Module +import qualified Algebra.Additive as Additive + +import qualified Synthesizer.Generic.SampledValue as Sample + +import qualified Synthesizer.Plain.Modifier as Modifier + +import Control.Monad.State (State, runState, ) + +import qualified Data.List as List + +import Synthesizer.Utility (fst3, snd3, thd3) +import Prelude + (Bool, Int, Maybe(Just), maybe, + fst, snd, flip, uncurry, (.), not, ) + + +class C sig where + empty :: (Sample.C y) => sig y + null :: (Sample.C y) => sig y -> Bool + cons :: (Sample.C y) => y -> sig y -> sig y + fromList :: (Sample.C y) => [y] -> sig y + toList :: (Sample.C y) => sig y -> [y] + repeat :: (Sample.C y) => y -> sig y + cycle :: (Sample.C y) => sig y -> sig y + replicate :: (Sample.C y) => Int -> y -> sig y + iterate :: (Sample.C y) => (y -> y) -> y -> sig y + iterateAssoc :: (Sample.C y) => (y -> y -> y) -> y -> sig y + unfoldR :: (Sample.C b) => (a -> Maybe (b,a)) -> a -> sig b + map :: (Sample.C a, Sample.C b) => (a -> b) -> (sig a -> sig b) + mix :: (Sample.C y, Additive.C y) => sig y -> sig y -> sig y + zipWith :: (Sample.C a, Sample.C b, Sample.C c) => + (a -> b -> c) -> (sig a -> sig b -> sig c) +{- + zipWithTails :: (Sample.C a, Sample.C b, Sample.C c) => + (a -> T b -> c) -> T a -> T b -> T c +-} + scanL :: (Sample.C a, Sample.C b) => + (a -> b -> a) -> a -> sig b -> sig a + foldL :: (Sample.C b) => (a -> b -> a) -> a -> sig b -> a + viewL :: (Sample.C a) => sig a -> Maybe (a, sig a) + viewR :: (Sample.C a) => sig a -> Maybe (sig a, a) + length :: (Sample.C y) => sig y -> Int + take :: (Sample.C y) => Int -> sig y -> sig y + drop :: (Sample.C y) => Int -> sig y -> sig y + dropMarginRem :: (Sample.C y) => Int -> Int -> sig y -> (Int, sig y) + splitAt :: (Sample.C y) => Int -> sig y -> (sig y, sig y) + takeWhile :: (Sample.C y) => (y -> Bool) -> sig y -> sig y + dropWhile :: (Sample.C y) => (y -> Bool) -> sig y -> sig y + span :: (Sample.C y) => (y -> Bool) -> sig y -> (sig y, sig y) + append :: (Sample.C y) => sig y -> sig y -> sig y + concat :: (Sample.C y) => [sig y] -> sig y + reverse :: (Sample.C y) => sig y -> sig y +{- + mapAccumL :: (Sample.C x, Sample.C y) => + (acc -> x -> (acc, y)) -> acc -> sig x -> (acc, sig y) + mapAccumR :: (Sample.C x, Sample.C y) => + (acc -> x -> (acc, y)) -> acc -> sig x -> (acc, sig y) +-} + crochetL :: (Sample.C x, Sample.C y) => + (x -> acc -> Maybe (y, acc)) -> acc -> sig x -> sig y + + +{-# INLINE sum #-} +sum :: (Additive.C a, Sample.C a, C sig) => sig a -> a +sum = foldL (Additive.+) Additive.zero + +{- +{-# INLINE tails #-} +tails :: (Sample.C y, C sig) => sig y -> [sig y] +tails = + List.unfoldr (fmap (\x -> (x, fmap snd (viewL x)))) . Just +-} + +{-# INLINE zapWith #-} +zapWith :: (Sample.C a, Sample.C b, C sig) => + (a -> a -> b) -> sig a -> sig b +zapWith f xs0 = + let xs1 = maybe empty snd (viewL xs0) + in zipWith f xs0 xs1 + +{-# INLINE zip #-} +zip :: (Sample.C a, Sample.C b, C sig) => + sig a -> sig b -> sig (a,b) +zip = zipWith (,) + + +{-# INLINE unzip #-} +unzip :: (Sample.C a, Sample.C b, C sig) => + sig (a,b) -> (sig a, sig b) +unzip xs = + (map fst xs, map snd xs) + +{-# INLINE unzip3 #-} +unzip3 :: (Sample.C a, Sample.C b, Sample.C c, C sig) => + sig (a,b,c) -> (sig a, sig b, sig c) +unzip3 xs = + (map fst3 xs, map snd3 xs, map thd3 xs) + + +{-# INLINE modifyStatic #-} +modifyStatic :: (Sample.C a, Sample.C b, C sig) => + Modifier.Simple s ctrl a b -> ctrl -> sig a -> sig b +modifyStatic (Modifier.Simple state proc) control x = + crochetL (\a acc -> Just (runState (proc control a) acc)) state x + +{-| Here the control may vary over the time. -} +{-# INLINE modifyModulated #-} +modifyModulated :: (Sample.C a, Sample.C b, Sample.C ctrl, C sig) => + Modifier.Simple s ctrl a b -> sig ctrl -> sig a -> sig b +modifyModulated (Modifier.Simple state proc) control x = + crochetL + (\ca acc -> Just (runState (uncurry proc ca) acc)) + state (zip control x) + + +-- cf. Module.linearComb +{-# INLINE linearComb #-} +linearComb :: + (Module.C t y, Sample.C t, Sample.C y, C sig) => + sig t -> sig y -> y +linearComb ts ys = + sum (zipWith (Module.*>) ts ys) + + +{-# INLINE sliceVert #-} +sliceVert :: (Sample.C y, C sig) => + Int -> sig y -> [sig y] +sliceVert n = + List.map (take n) . List.takeWhile (not . null) . List.iterate (drop n) + + +{-# INLINE extendConstant #-} +extendConstant :: (Sample.C y, C sig) => + sig y -> sig y +extendConstant xt = + maybe empty + (append xt . repeat . snd) + (viewR xt) + + +-- comonadic 'bind' +-- only non-empty suffixes are processed +{-# INLINE mapTails #-} +mapTails :: (Sample.C a, Sample.C b, C sig) => + (sig a -> b) -> sig a -> sig b +mapTails f = + unfoldR (\xs -> + do (_,ys) <- viewL xs + Just (f xs, ys)) + +-- only non-empty suffixes are processed +{-# INLINE zipWithTails #-} +zipWithTails :: (Sample.C a, Sample.C b, Sample.C c, C sig) => + (a -> sig b -> c) -> sig a -> sig b -> sig c +zipWithTails f = + flip (crochetL (\x ys0 -> + do (_,ys) <- viewL ys0 + Just (f x ys0, ys))) + + +{- +instance (Additive.C y, Sample.C y, C sig) => Additive.C (sig y) where + (+) = mix + negate = map Additive.negate +-} + + +{- +This does not work, because we can constrain only the instances of Data +but this is not checked when implementing methods of C. + +class Data sig y where + +class C sig where + add :: (Data sig y, Additive.C y) => sig y -> sig y -> sig y + map :: (Data sig a, Data sig b) => (a -> b) -> (sig a -> sig b) + zipWith :: (Data sig a, Data sig b, Data sig c) => + (a -> b -> c) -> (sig a -> sig b -> sig c) +-} + +{- +This does not work, because we would need type parameters for all occuring element types. + +class C sig y where + add :: (Additive.C y) => sig y -> sig y -> sig y + map :: C sig a => (a -> y) -> (sig a -> sig y) + zipWith :: (a -> b -> y) -> (sig a -> sig b -> sig y) +-} diff --git a/src/Synthesizer/Inference/DesignStudy/Applicative.hs b/src/Synthesizer/Inference/DesignStudy/Applicative.hs new file mode 100644 --- /dev/null +++ b/src/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/Synthesizer/Inference/DesignStudy/Arrow.hs b/src/Synthesizer/Inference/DesignStudy/Arrow.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Inference/DesignStudy/Arrow.hs @@ -0,0 +1,45 @@ +module Synthesizer.Inference.DesignStudy.Arrow where + +{- + A hint from Haskell cafe about how to design signal processors + that adapt to a common sample rate. +-} + +{- +Date: Fri, 12 Nov 2004 02:59:31 +0900 +From: Koji Nakahara +To: haskell-cafe@haskell.org +-} + +import Control.Arrow +import Data.List (intersect) +data Rates = Rates [Int] | Any deriving Show +data Processor b c = P Rates (Rates -> b -> c) + +-- test Stream +type Stream = String + +intersectRates :: Rates -> Rates -> Rates +intersectRates Any y = y +intersectRates x Any = x +intersectRates (Rates xs) (Rates ys) = Rates $ intersect xs ys + +instance Arrow Processor where + arr f = P Any (const f) + (P r0 f0) >>> (P r1 f1) = + P (intersectRates r0 r1) (\r -> f1 r . f0 r) + first (P r0 f) = P r0 (\r (x, s) -> (f r x, s)) + +runProcessor :: Processor b c -> b -> c +runProcessor (P r f) s = f r s + +-- test processors +process, processor1, processor2, processor3 :: Processor String String +processor1 = P (Rates [44100, 48000]) (\r -> ( ++ show r)) +processor2 = P Any (\r -> ( ++ show r)) +processor3 = P (Rates [48000]) (\r -> ( ++ show r)) + +process = processor1 >>> processor2 >>> processor3 + +test :: String +test = runProcessor process "bla" diff --git a/src/Synthesizer/Inference/DesignStudy/Monad.hs b/src/Synthesizer/Inference/DesignStudy/Monad.hs new file mode 100644 --- /dev/null +++ b/src/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.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/Inference/Func/Cut.hs b/src/Synthesizer/Inference/Func/Cut.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Inference/Func/Cut.hs @@ -0,0 +1,276 @@ +{-# OPTIONS -fno-implicit-prelude #-} +{- | +Copyright : (c) Henning Thielemann 2006, 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes +-} +module Synthesizer.Inference.Func.Cut ( + {- * dissection -} + -- splitAt, + -- take, + -- drop, + takeUntilPause, + -- unzip, + -- unzip3, + + {- * glueing -} + concat, + concatVolume, + append, + zip, + -- zip3, + arrange, + arrangeVolume, + ) where + +import qualified Synthesizer.Physical.Signal as SigP +import qualified Synthesizer.Physical.Cut as CutP +import qualified Synthesizer.Inference.Func.Signal as SigF + +import qualified Synthesizer.SampleRateContext.Signal as SigC +import qualified Synthesizer.SampleRateContext.Rate as Rate +import qualified Synthesizer.SampleRateContext.Cut as CutC + +import qualified Data.EventList.Relative.TimeBody as EventList +import qualified Numeric.NonNegative.Class as NonNeg + +import qualified Algebra.NormedSpace.Maximum as NormedMax +import qualified Algebra.OccasionallyScalar as OccScalar +import qualified Algebra.Module as Module +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Real as Real +import qualified Algebra.Ring as Ring + +-- import qualified Data.List as List + +-- import Control.Monad.Fix(mfix) + +import PreludeBase hiding (zip, zip3, concat, ) +-- import NumericPrelude +import Prelude (RealFrac) + +{- +{- * dissection -} + +splitAt :: (RealField.C a, Field.C q, OccScalar.C a q) => + q -> SigI.T a q v -> Process.T q (SigI.T a q v, SigI.T a q v) +splitAt t0 x@(Cons sr amp ss) = + do t <- SigI.toTimeScalar x (Expr.constant t0) + let (ss0,ss1) = List.splitAt (round t) ss + return (Cons sr amp ss0, Cons sr amp ss1) + +take :: (RealField.C a, Field.C q, OccScalar.C a q) => + q -> SigI.T a q v -> SigI.Process a q v +take t = fmap fst . splitAt t + +drop :: (RealField.C a, Field.C q, OccScalar.C a q) => + q -> SigI.T a q v -> SigI.Process a q v +drop t = fmap snd . splitAt t +-} + +takeUntilPause :: (RealField.C t, Ring.C t', OccScalar.C t t', + Field.C y', NormedMax.C y yv, OccScalar.C y y') => + y' -> t' -> SigF.T t t' y y' yv -> SigF.T t t' y y' yv +takeUntilPause y' t' x = + SigF.cons $ \infered@(isr,iamp) -> + let x' = SigF.eval x infered + xp = SigP.replaceParameters isr iamp x' + zp = CutP.takeUntilPause y' t' xp + in SigP.replaceParameters + (SigP.sampleRate x') (SigP.amplitude x') zp + + +{- +How can we assert sharing of the input signal +with the output signals? + +unzip :: + SigF.T t t' y y' (yv0, yv1) + -> (SigF.T t t' y y' yv0, SigF.T t t' y y' yv1) +unzip x = + (SigF.cons $ \inferedY@(isrY,iampY) -> , + SigF.cons $ \inferedZ@(isrZ,iampZ) -> ) + + +unzip3 :: + SigF.T t t' y y' (yv0, yv1, yv2) + -> (SigF.T t t' y y' yv0, SigF.T t t' y y' yv1, SigF.T t t' y y' yv2) +unzip3 = return . CutC.unzip3 +-} + + +{- * glueing -} + +{- | + Similar to @foldr1 append@ but more efficient and accurate, + because it reduces the number of amplifications. + Does not work for infinite lists, + because in this case a maximum amplitude cannot be computed. +-} +concat :: + (Eq t', Real.C y', Field.C y', Module.C y yv, OccScalar.C y y') => + [SigF.T t t' y y' yv] + -> SigF.T t t' y y' yv +concat xs = + SigF.cons $ \(isr,iamp) -> + let xs' = zipWith (\x amp -> SigF.eval x (isr, amp)) xs amps + amps = map SigF.guessAmplitude xs' + xps = zipWith SigF.contextFixAmplitude amps xs' + sampleRate = SigF.mergeSampleRates xs' + in SigF.fromContextCheckAmplitude sampleRate iamp + (CutC.concat (Rate.fromNumber isr) xps) + +{- | + Like 'concat' but it expects a fixed output amplitude. + This way it can also handle infinitely many inputs + if one input or the output has a fixed sample rate. + + 'concatVolume' is one reason for the complicated handling + of sampling rates by lists of @Maybe@s. + + The problem of finding an apropriate sampling rate is that + we must have an order of processing parallel signal processors + which guarantees termination if termination is possible. + Say @mix (concat infinitelist0) (concat infinitelist1)@. + Either infinite list can have signal with fixed sample rate or not. + There is no way to determine this a priori. + The only safe way is to process them in parallel. + That's why we must have a @[Maybe t']@ instead of @Maybe t'@. + Also @[t']@ is not enough, + because e.g. a concatenation of infinitely many sounds + with undetermined sampling rate + would have an empty list representing the sampling rate, + but computing the empty list needs infinite time. +-} +concatVolume :: + (Eq t', Real.C y', Field.C y', Module.C y yv, OccScalar.C y y') => + [SigF.T t t' y y' yv] + -> SigF.T t t' y y' yv +concatVolume xs = + SigF.cons $ \(isr,iamp) -> + let xs' = zipWith (\x amp -> SigF.eval x (isr, amp)) xs amps + amps = map SigF.guessAmplitude xs' + xps = zipWith SigF.contextFixAmplitude amps xs' + sampleRate = SigF.mergeSampleRates xs' + in SigF.fromContextFreeAmplitude sampleRate + (CutC.concatVolume iamp (Rate.fromNumber isr) xps) + + +merge :: (Eq t', Real.C y', Field.C y', OccScalar.C y y', + Module.C y v0, Module.C y v1) => + (Rate.T t t' -> SigC.T y y' v0 -> SigC.T y y' v1 -> SigC.T y y' v2) + -> SigF.T t t' y y' v0 + -> SigF.T t t' y y' v1 + -> SigF.T t t' y y' v2 +merge f x y = + SigF.cons $ \(isr,iamp) -> + let x' = SigF.eval x (isr, ampX) + y' = SigF.eval y (isr, ampY) + ampX = SigF.guessAmplitude x' + ampY = SigF.guessAmplitude y' + xp = SigF.contextFixAmplitude ampX x' + yp = SigF.contextFixAmplitude ampY y' + sampleRate = SigF.mergeSampleRate x' y' + in SigF.fromContextCheckAmplitude sampleRate iamp + (f (Rate.fromNumber isr) xp yp) + + +append :: (Eq t', Real.C y', Field.C y', OccScalar.C y y', + Module.C y yv) => + SigF.T t t' y y' yv + -> SigF.T t t' y y' yv + -> SigF.T t t' y y' yv +append = merge CutC.append + + +zip :: (Eq t', Real.C y', Field.C y', OccScalar.C y y', + Module.C y v0, Module.C y v1) => + SigF.T t t' y y' v0 + -> SigF.T t t' y y' v1 + -> SigF.T t t' y y' (v0,v1) +zip = merge CutC.zip + +{- +zip3 :: (Real.C q, Field.C q, Ord q, OccScalar.C a q, + Module.C a v0, Module.C a v1, Module.C a v2) + => SigI.T a q v0 + -> SigI.T a q v1 + -> SigI.T a q v2 + -> SigI.Process a q (v0, v1, v2) +zip3 x0 x1 x2 = + mfix (\z -> + do sampleRate <- Process.equalValues + [SigP.sampleRate x0, SigP.sampleRate x1, SigP.sampleRate x2] + amplitude <- Process.fromExpr + (Expr.maximum [amplitudeExpr x0, amplitudeExpr x1, amplitudeExpr x2]) + samp0 <- SigI.vectorSamples (toAmplitudeScalar z) x0 + samp1 <- SigI.vectorSamples (toAmplitudeScalar z) x1 + samp2 <- SigI.vectorSamples (toAmplitudeScalar z) x2 + SigI.returnCons sampleRate amplitude + (List.zip3 samp0 samp1 samp2)) +-} + + + +scheduleToContext :: + t' + -> EventList.T time (SigF.T t t' y y' yv) + -> (SigF.Parameter t', + EventList.T time (SigC.T y y' yv)) +scheduleToContext isr sched = + let xps = + EventList.mapBody + (\x -> + let y = SigF.eval x (isr, amp) + amp = SigF.guessAmplitude y + z = SigF.contextFixAmplitude amp y + in (y,z)) sched + schedp = EventList.mapBody snd xps + sampleRate = SigF.mergeSampleRates (map fst (EventList.getBodies xps)) + in (sampleRate, schedp) + + +{- | + Given a list of signals with time stamps, + mix them into one signal as they occur in time. + Ideally for composing music. + Infinite schedules are not supported, + because no maximum amplitude can be computed. +-} +arrange :: + (RealFrac t, NonNeg.C t, Eq t', Ring.C t, Ring.C t', OccScalar.C t t', + Ord y', Field.C y', OccScalar.C y y', + Module.C y yv) => + t' + -> EventList.T t (SigF.T t t' y y' yv) + {-^ A list of pairs: (relative start time, signal part), + The start time is relative + to the start time of the previous event. -} + -> SigF.T t t' y y' yv + {-^ The mixed signal. -} +arrange unit sched = + SigF.cons $ \(isr,iamp) -> + let (sampleRate, schedp) = scheduleToContext isr sched + in SigF.fromContextCheckAmplitude sampleRate iamp + (CutC.arrange unit (Rate.fromNumber isr) schedp) + +arrangeVolume :: + (RealFrac t, NonNeg.C t, Eq t', Ring.C t, Ring.C t', OccScalar.C t t', + Field.C y', OccScalar.C y y', + Module.C y yv) => + t' + -> EventList.T t (SigF.T t t' y y' yv) + {-^ A list of pairs: (relative start time, signal part), + The start time is relative + to the start time of the previous event. -} + -> SigF.T t t' y y' yv + {-^ The mixed signal. -} +arrangeVolume unit sched = + SigF.cons $ \(isr,iamp) -> + let (sampleRate, schedp) = scheduleToContext isr sched + in SigF.fromContextFreeAmplitude sampleRate + (CutC.arrangeVolume iamp unit (Rate.fromNumber isr) schedp) diff --git a/src/Synthesizer/Inference/Func/Signal.hs b/src/Synthesizer/Inference/Func/Signal.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Inference/Func/Signal.hs @@ -0,0 +1,297 @@ +{-# OPTIONS -fno-implicit-prelude -fglasgow-exts #-} +{- | + +Copyright : (c) Henning Thielemann 2006, 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +-} +module Synthesizer.Inference.Func.Signal where + +import qualified Synthesizer.Physical.Signal as SigP +import qualified Synthesizer.SampleRateContext.Signal as SigC + +-- import qualified Algebra.OccasionallyScalar as OccScalar +-- import qualified Algebra.Module as Module +-- import qualified Algebra.Field as Field +-- import qualified Algebra.Ring as Ring + +-- import Algebra.OccasionallyScalar (toScalar) + +import Control.Monad.Fix (fix) +import Data.Maybe (catMaybes, isJust) +import Data.List (transpose) +import NumericPrelude.List (shearTranspose) + +-- import NumericPrelude +import PreludeBase as P + +{- | +Each process must work the following way: +If the signal processor has a fixed sample rate or amplitude +either implied by its parameters or its inputs +then this parameter should be set as @Just@ +in the corresponding fields of @SigP.T@. +These fields must be computed +independently from the function argument of type @(t',y')@. +This function argument is the pair of eventually used signal parameters +sample rate and amplitude. +If you set signal parameters to @Just@ with a value, +then you can expect that the corresponding pair member has the same value. +-} +newtype T t t' y y' yv = + Cons {eval :: (t',y') -> Evaluated t t' y y' yv} + +type Evaluated t t' y y' yv = SigP.T t (Parameter t') y (Parameter y') yv +{- | +Since all 'Just' values must contain the same value, +we could also use the data structure '(Peano, a)' +just like in the @unique-logic@ package. +-} +newtype Parameter a = Parameter {parameterDesc :: [Maybe a]} + +liftParam2 :: + ([Maybe a] -> [Maybe b] -> [Maybe c]) -> + Parameter a -> Parameter b -> Parameter c +liftParam2 f (Parameter x) (Parameter y) = Parameter (f x y) + +cons :: ((t',y') -> SigP.T t (Parameter t') y (Parameter y') yv) -> T t t' y y' yv +cons = Cons + + +contextFixAmplitude :: + y' + -> Evaluated t t' y y' yv + -> SigC.T y y' yv +contextFixAmplitude amp = + SigC.replaceAmplitude amp . SigP.content + +fromContextFreeAmplitude :: + Parameter t' + -> SigC.T y y' yv + -> Evaluated t t' y y' yv +fromContextFreeAmplitude sr (SigC.Cons _amp ss) = + SigP.cons sr anyParameter ss + +fromContextCheckAmplitude :: (Eq y') => + Parameter t' + -> y' + -> SigC.T y y' yv + -> Evaluated t t' y y' yv +fromContextCheckAmplitude sr iamp (SigC.Cons amp ss) = + SigP.cons sr (justParameter amp) + (if iamp==amp then ss else error "fromContextCheckAmplitude: amplitudes differ") + + +anyParameter :: Parameter q +anyParameter = Parameter [] + +justParameter :: q -> Parameter q +justParameter x = Parameter [Just x] + +inSampleRate :: (t',y') -> t' +inSampleRate = fst + +inAmplitude :: (t',y') -> y' +inAmplitude = snd + + + +{- +vectorSamples :: (Eq t', Module.C y yv) => + (y' -> y) -> T t t' y y' yv -> (t' -> [yv]) +vectorSamples toAmpScalar sig = + \inferedSampleRate -> + let x' = eval sig (inferedSampleRate, amp') + amp' = guessParameter + "vectorSamples: input amplitude" + (SigP.amplitude x') + amp = toAmpScalar amp' `SigP.asTypeOfAmplitude` x' + in amp *> SigP.samples x' + +scalarSamples :: (Eq t', Ring.C y) => + (y' -> y) -> T t t' y y' y -> (t' -> [y]) +scalarSamples toAmpScalar sig = + \inferedSampleRate -> + let x' = sig (inferParameter inferedSampleRate (SigP.sampleRate x'), + amp') + amp' = fromMaybe (error "scalarSamples: undetermined input amplitude") + (SigP.amplitude x') + amp = toAmpScalar amp' `SigP.asTypeOfAmplitude` x' + in map (amp*) (SigP.samples x') + + + +inferParameter :: Eq q => q -> Maybe q -> q +inferParameter infered = + maybe infered + (\x -> if x == infered + then x + else error ("inferParameter:" ++ + " requested value and infered one differ")) +-} + +equalParameter :: Eq q => String -> Maybe q -> Maybe q -> Maybe q +equalParameter name x y = + case (x,y) of + (Nothing,_) -> y + (_,Nothing) -> x + (Just xv, Just yv) -> + if xv == yv + then Just xv + else error ("equalParameter: " ++ name ++ " differ") + +equalSampleRate :: Eq t' => Maybe t' -> Maybe t' -> Maybe t' +equalSampleRate = equalParameter "sample rate" + + +zipJut :: (a -> a -> a) -> [a] -> [a] -> [a] +zipJut f = + let aux (x:xs) (y:ys) = f x y : aux xs ys + aux [] ys = ys + aux xs [] = xs + in aux + +{-| + Merge the @Just@s of two lists. + It does not check for validity of the data. +-} +mergeParameter :: Parameter q -> Parameter q -> Parameter q +mergeParameter = + liftParam2 (zipJut (\x y -> if isJust x then x else y)) + +mergeSampleRate :: + Evaluated t t' y0 y0' yv0 -> Evaluated t t' y1 y1' yv1 -> Parameter t' +mergeSampleRate x y = + mergeParameter (SigP.sampleRate x) (SigP.sampleRate y) + + +mergeParameterEq :: Eq q => String -> Parameter q -> Parameter q -> Parameter q +mergeParameterEq name = + liftParam2 (zipJut (equalParameter name)) + +mergeSampleRateEq :: Eq t' => Parameter t' -> Parameter t' -> Parameter t' +mergeSampleRateEq = mergeParameterEq "sample rate" + +-- cf. Examples.merge +merge :: [a] -> [a] -> [a] +merge (x:xs) ys = x : merge ys xs +merge [] ys = ys + +propMerge :: Eq a => [a] -> [a] -> Bool +propMerge xs ys = merge xs ys == concat (transpose [xs,ys]) + +mergeParameter' :: Parameter t' -> Parameter t' -> Parameter t' +mergeParameter' = liftParam2 merge + +checkParameter :: Eq q => String -> q -> Maybe q -> q +checkParameter name x = + maybe x (\y -> if x == y + then x + else error ("checkParameter: deviation from common " ++ name)) + +checkSampleRate :: Eq t' => t' -> Maybe t' -> t' +checkSampleRate = checkParameter "sample rate" + +checkAmplitude :: Eq y' => y' -> Maybe y' -> y' +checkAmplitude = checkParameter "amplitude" + + +{-| + This routine is prepared for infinite lists. + In order to handle them we employ a Cantor diagonalization scheme. + It does not check for validity of the data + (i.e. equal @Just@ values) + but it does only keep some @Just@s, + and thus allows for a quick search of a guess of a parameter value. +-} +mergeParameters :: [Parameter q] -> Parameter q +mergeParameters = + Parameter . map (head . (++[Nothing]) . filter isJust) + . shearTranspose . map parameterDesc + +mergeSampleRates :: [Evaluated t t' y y' yv] -> Parameter t' +mergeSampleRates = + mergeParameters . map SigP.sampleRate + +mergeParametersEq :: Eq q => String -> [Parameter q] -> Parameter q +mergeParametersEq name = + Parameter . map (foldl (equalParameter name) Nothing) + . shearTranspose . map parameterDesc + +mergeSampleRatesEq :: Eq t' => [Parameter t'] -> Parameter t' +mergeSampleRatesEq = mergeParametersEq "sample rate" + +{- | +This is a simple working version of 'mergeParameters', +which does not need @Eq@ constraint. +However, flattening a three-dimensional list +does handle different dimensions differently, +that is slower than the others. +-} +mergeParameters' :: [Parameter q] -> Parameter q +mergeParameters' = + Parameter . concat . shearTranspose . map parameterDesc + + +{- +equalParameters :: Eq q => String -> [Parameter q] -> Parameter q +equalParameters name xs = + let cxs = catMaybes xs + in if and (zipWith (==) cxs (tail cxs)) + then listToMaybe cxs + else error ("equalParameters: " ++ name ++ " differ") + +equalSampleRates :: Eq t' => [Maybe t'] -> Maybe t' +equalSampleRates = equalParameters "sample rates" +-} + +guessParameter :: String -> Parameter q -> q +guessParameter context = + head . (++ error (context ++ " undetermined")) . catMaybes . parameterDesc + +guessSampleRate :: Evaluated t t' y y' yv -> t' +guessSampleRate = guessParameter "sample rate" . SigP.sampleRate + +guessAmplitude :: Evaluated t t' y y' yv -> y' +guessAmplitude = guessParameter "amplitude" . SigP.amplitude + + + +{- | + A complex signal graph can be built without ever mentioning a sampling rate. + However when it comes to playing or writing a file, + we must determine the sampling rate eventually. + This function simply passes a signal through + while forcing it to the given sampling rate. +-} +fixSampleRate :: (Eq t') => + t' {-^ sample rate -} + -> T t t' y y' yv {-^ passed through signal -} + -> T t t' y y' yv +fixSampleRate forcedSampleRate input = + Cons $ \infered -> + let inputSig = eval input infered + in SigP.cons + (justParameter forcedSampleRate) + (SigP.amplitude inputSig) + (if inSampleRate infered == forcedSampleRate + then SigP.samples inputSig + else error "fixSampleRate: sampleRates differ") + +-- ***** Is this one correct? Has the usage of 'infered' a cycle? +{- | Create a loop (feedback) from one node to another one. + That is, compute the fix point of a process iteration. -} +loop :: (Eq t') => + (T t t' y y' yv -> T t t' y y' yv) + {-^ process chain that shall be looped -} + -> T t t' y y' yv +loop f = + fix (\x -> f (Cons $ \infered -> + SigP.cons anyParameter anyParameter + (SigP.samples (eval x infered)))) + +-- example: loop (\y -> x + delay y) diff --git a/src/Synthesizer/Inference/Reader/Control.hs b/src/Synthesizer/Inference/Reader/Control.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Inference/Reader/Control.hs @@ -0,0 +1,167 @@ +{-# OPTIONS -fno-implicit-prelude -fglasgow-exts #-} +{- | +Copyright : (c) Henning Thielemann 2007 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + + +Control curves which can be used +as envelopes, for controlling filter parameters and so on. +-} +module Synthesizer.Inference.Reader.Control + ({- * Primitives -} + constant, constantVector, linear, line, exponential, exponential2, + {- * Piecewise -} + piecewise, piecewiseVolume, Control(..), ControlPiece(..), + (-|#), ( #|-), (=|#), ( #|=), (|#), ( #|), -- spaces before # for Haddock + {- * Preparation -} + mapLinear, mapExponential, ) + where + + +import Synthesizer.Plain.Control + (Control(..), ControlPiece(..), (-|#), ( #|-), (=|#), ( #|=), (|#), ( #|)) + +import qualified Synthesizer.SampleRateContext.Control as CtrlC + +{- +if we import that, then GHC-6.4.1 will no longer complain, +that Synthesizer.Plain.Control is unnecessarily imported +import qualified Synthesizer.Plain.Control as Ctrl +-} + +import qualified Synthesizer.Inference.Reader.Signal as SigR +import qualified Synthesizer.Inference.Reader.Process as Proc + +import qualified Algebra.OccasionallyScalar as OccScalar +import qualified Algebra.Module as Module +import qualified Algebra.Transcendental as Trans +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Real as Real +import qualified Algebra.Ring as Ring + +-- import NumericPrelude +-- import PreludeBase as P + + +constant :: (Field.C y', Real.C y', OccScalar.C y y') => + y' {-^ value -} + -> Proc.T t t' (SigR.T y y' y) +constant y = + SigR.lift (CtrlC.constant y) + +{- | +The amplitude must be positive! +This is not checked. +-} +constantVector :: -- (Field.C y', Real.C y', OccScalar.C y y') => + y' {-^ amplitude -} + -> yv {-^ value -} + -> Proc.T t t' (SigR.T y y' yv) +constantVector y yv = + SigR.lift (CtrlC.constantVector y yv) + +{- Using the 'Ctrl.linear' instead of 'Ctrl.linearStable' + the type class constraints would be weaker. +linear :: (Additive.C y, Field.C y', Real.C y', OccScalar.C y y') => +-} + +{- | +Caution: This control curve can contain samples +with an absolute value greater than 1. + +Linear curves starting with zero are impossible. +Maybe you prefer using 'line'. +-} +linear :: + (Field.C q, Field.C q', + Real.C q', OccScalar.C q q') => + q' {-^ slope of the curve -} + -> q' {-^ initial value -} + -> Proc.T q q' (SigR.T q q' q) +linear slope y0 = + SigR.lift (CtrlC.linear slope y0) + +{- | +Generates a finite ramp. +-} +line :: + (RealField.C q, Field.C q', + Real.C q', OccScalar.C q q') => + q' {-^ duration of the ramp -} + -> (q',q') {-^ initial and final value -} + -> Proc.T q q' (SigR.T q q' q) +line dur (y0,y1) = + SigR.lift (CtrlC.line dur (y0,y1)) + +exponential :: (Trans.C q, Field.C q', Real.C q', OccScalar.C q q') => + q' {-^ time where the function reaches 1\/e of the initial value -} + -> q' {-^ initial value -} + -> Proc.T q q' (SigR.T q q' q) +exponential time y0 = + SigR.lift (CtrlC.exponential time y0) + +{- + take 1000 $ show (run (fixSampleRate 100 (exponential 0.1 1)) :: SigDouble) +-} + +exponential2 :: (Trans.C q, Field.C q', Real.C q', OccScalar.C q q') => + q' {-^ half life, time where the function reaches 1\/2 of the initial value -} + -> q' {-^ initial value -} + -> Proc.T q q' (SigR.T q q' q) +exponential2 time y0 = + SigR.lift (CtrlC.exponential2 time y0) + + + +{- | +Since this function looks for the maximum node value, +and since the signal parameter inference phase must be completed before signal processing, +infinite descriptions cannot be used here. +-} +piecewise :: (Trans.C q, RealField.C q, + Real.C q', Field.C q', OccScalar.C q q') => + [ControlPiece q'] + -> Proc.T q q' (SigR.T q q' q) +piecewise cs = + SigR.lift (CtrlC.piecewise cs) + +piecewiseVolume :: + (Trans.C q, RealField.C q, + Real.C q', Field.C q', OccScalar.C q q') => + [ControlPiece q'] + -> q' + -> Proc.T q q' (SigR.T q q' q) +piecewiseVolume cs amplitude = + SigR.lift (CtrlC.piecewiseVolume cs amplitude) + + +{- | +Map a control curve without amplitude unit +by a linear (affine) function with a unit. +-} +mapLinear :: (Ring.C y, Field.C y', Real.C y', OccScalar.C y y') => + y' {- ^ range: one is mapped to @center+range@ -} + -> y' {- ^ center: zero is mapped to @center@ -} + -> Proc.T t t' + (SigR.T y y' y + -> SigR.T y y' y) +mapLinear range center = + SigR.lift (CtrlC.mapLinear range center) + +{- | +Map a control curve without amplitude unit +exponentially to one with a unit. +-} +mapExponential :: (Field.C y', Trans.C y, Module.C y y') => + y {- ^ range: one is mapped to @center*range@, must be positive -} + -> y' {- ^ center: zero is mapped to @center@ -} + -> Proc.T t t' + (SigR.T y y y + -> SigR.T y y' y) +mapExponential range center = + SigR.lift (CtrlC.mapExponential range center) diff --git a/src/Synthesizer/Inference/Reader/Cut.hs b/src/Synthesizer/Inference/Reader/Cut.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Inference/Reader/Cut.hs @@ -0,0 +1,194 @@ +{-# OPTIONS -fno-implicit-prelude #-} +{- | +Copyright : (c) Henning Thielemann 2006 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes +-} +module Synthesizer.Inference.Reader.Cut ( + {- * dissection -} + splitAt, + take, + drop, + takeUntilPause, + unzip, + unzip3, + + {- * glueing -} + concat, concatVolume, + append, appendVolume, + zip, zipVolume, + zip3, zip3Volume, + arrange, arrangeVolume, + ) where + +import qualified Synthesizer.SampleRateContext.Cut as CutC + +import qualified Synthesizer.Inference.Reader.Signal as SigR +import qualified Synthesizer.Inference.Reader.Process as Proc + +import qualified Data.EventList.Relative.TimeBody as EventList +import qualified Numeric.NonNegative.Class as NonNeg + +import qualified Algebra.NormedSpace.Maximum as NormedMax +import qualified Algebra.OccasionallyScalar as OccScalar +import qualified Algebra.Module as Module +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Real as Real +import qualified Algebra.Ring as Ring + +-- import qualified Data.List as List + +import PreludeBase ((.), Ord) +-- import NumericPrelude +import Prelude (RealFrac) + + +{- * dissection -} + +splitAt :: (RealField.C t, Field.C t', OccScalar.C t t') => + t' -> Proc.T t t' (SigR.T y y' yv -> (SigR.T y y' yv, SigR.T y y' yv)) +splitAt t = SigR.lift (CutC.splitAt t) + +take :: (RealField.C t, Field.C t', OccScalar.C t t') => + t' -> Proc.T t t' (SigR.T y y' yv -> SigR.T y y' yv) +take t = SigR.lift (CutC.take t) + +drop :: (RealField.C t, Field.C t', OccScalar.C t t') => + t' -> Proc.T t t' (SigR.T y y' yv -> SigR.T y y' yv) +drop t = SigR.lift (CutC.drop t) + +takeUntilPause :: + (RealField.C t, Ring.C t', OccScalar.C t t', + Field.C y', NormedMax.C y yv, OccScalar.C y y') => + y' -> t' -> Proc.T t t' (SigR.T y y' yv -> SigR.T y y' yv) +takeUntilPause y' t' = SigR.lift (CutC.takeUntilPause y' t') + + +unzip :: + Proc.T t t' + (SigR.T y y' (yv0, yv1) -> + (SigR.T y y' yv0, SigR.T y y' yv1)) +unzip = SigR.lift CutC.unzip + +unzip3 :: + Proc.T t t' + (SigR.T y y' (yv0, yv1, yv2) -> + (SigR.T y y' yv0, SigR.T y y' yv1, SigR.T y y' yv2)) +unzip3 = SigR.lift CutC.unzip3 + + +{- * glueing -} + +{- | +Similar to @foldr1 append@ but more efficient and accurate, +because it reduces the number of amplifications. +Does not work for infinite lists, +because no maximum amplitude can be computed. +-} +concat :: + (Real.C y, Ord y', Field.C y', OccScalar.C y y', + Module.C y yv) => + Proc.T t t' ([SigR.T y y' yv] -> SigR.T y y' yv) +concat = SigR.lift CutC.concat + +{- | +Give the output volume explicitly. +Does also work for infinite lists. +-} +concatVolume :: + (Field.C y', OccScalar.C y y', + Module.C y yv) => + y' -> Proc.T t t' ([SigR.T y y' yv] -> SigR.T y y' yv) +concatVolume = SigR.lift . CutC.concatVolume + + +append :: + (Real.C y, Ord y', Field.C y', OccScalar.C y y', + Module.C y yv) => + Proc.T t t' (SigR.T y y' yv -> SigR.T y y' yv -> SigR.T y y' yv) +append = SigR.lift CutC.append + +appendVolume :: + (Field.C y', OccScalar.C y y', + Module.C y yv) => + y' -> + Proc.T t t' (SigR.T y y' yv -> SigR.T y y' yv -> SigR.T y y' yv) +appendVolume = SigR.lift . CutC.appendVolume + + +zip :: + (Real.C y, Ord y', Field.C y', OccScalar.C y y', + Module.C y yv0, Module.C y yv1) => + Proc.T t t' (SigR.T y y' yv0 -> SigR.T y y' yv1 -> SigR.T y y' (yv0,yv1)) +zip = SigR.lift CutC.zip + +zipVolume :: + (Field.C y', OccScalar.C y y', + Module.C y yv0, Module.C y yv1) => + y' -> + Proc.T t t' (SigR.T y y' yv0 -> SigR.T y y' yv1 -> SigR.T y y' (yv0,yv1)) +zipVolume = SigR.lift . CutC.zipVolume + + +zip3 :: + (Real.C y, Ord y', Field.C y', OccScalar.C y y', + Module.C y yv0, Module.C y yv1, Module.C y yv2) => + Proc.T t t' (SigR.T y y' yv0 -> SigR.T y y' yv1 -> SigR.T y y' yv2 -> + SigR.T y y' (yv0,yv1,yv2)) +zip3 = SigR.lift CutC.zip3 + +zip3Volume :: + (Field.C y', OccScalar.C y y', + Module.C y yv0, Module.C y yv1, Module.C y yv2) => + y' -> + Proc.T t t' (SigR.T y y' yv0 -> SigR.T y y' yv1 -> SigR.T y y' yv2 -> + SigR.T y y' (yv0,yv1,yv2)) +zip3Volume = SigR.lift . CutC.zip3Volume + + +{- | +Uses maximum input volume as output volume. +-} +arrange :: + (Ring.C t', OccScalar.C t t', + RealFrac t, NonNeg.C t, + Ord y', Field.C y', OccScalar.C y y', + Module.C y yv) => + t' {-^ Unit of the time values in the time ordered list. -} + -> Proc.T t t' + (EventList.T t (SigR.T y y' yv) + {- A list of pairs: (relative start time, signal part), + The start time is relative + to the start time of the previous event. -} + -> SigR.T y y' yv + {- The mixed signal. -} ) +arrange = SigR.lift . CutC.arrange + + +{- | +Given a list of signals with time stamps, +mix them into one signal as they occur in time. +Ideally for composing music. +Infinite schedules are not supported. +Does not work for infinite lists, +because no maximum amplitude can be computed. +-} +arrangeVolume :: + (Ring.C t', OccScalar.C t t', + RealFrac t, NonNeg.C t, + Field.C y', OccScalar.C y y', + Module.C y yv) => + y' {-^ Output volume. -} + -> t' {-^ Unit of the time values in the time ordered list. -} + -> Proc.T t t' + (EventList.T t (SigR.T y y' yv) + {- A list of pairs: (relative start time, signal part), + The start time is relative + to the start time of the previous event. -} + -> SigR.T y y' yv + {- The mixed signal. -} ) +arrangeVolume amp = SigR.lift . CutC.arrangeVolume amp diff --git a/src/Synthesizer/Inference/Reader/Filter.hs b/src/Synthesizer/Inference/Reader/Filter.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Inference/Reader/Filter.hs @@ -0,0 +1,340 @@ +{-# OPTIONS -fno-implicit-prelude -fglasgow-exts #-} +{- | +Copyright : (c) Henning Thielemann 2007 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes +-} +module Synthesizer.Inference.Reader.Filter ( + {- * Non-recursive -} + + {- ** Amplification -} + amplify, + negate, + envelope, + {- ** Filter operators from calculus -} + differentiate, + +{- + {- ** Smooth -} + mean, + + {- ** Delay -} + delay, + phaseModulation, + phaser, + phaserStereo, + + + {- * Recursive -} + + {- ** Without resonance -} + firstOrderLowpass, + firstOrderHighpass, + butterworthLowpass, + butterworthHighpass, + chebyshevALowpass, + chebyshevAHighpass, + chebyshevBLowpass, + chebyshevBHighpass, + {- ** With resonance -} + universal, + moogLowpass, + {- ** Allpass -} + allpassCascade, +-} + {- ** Reverb -} + comb, + + {- ** Filter operators from calculus -} + integrate, +) where + + +import qualified Synthesizer.SampleRateContext.Filter as FiltC + +import qualified Synthesizer.Inference.Reader.Signal as SigR +import qualified Synthesizer.Inference.Reader.Process as Proc + +{- +import Synthesizer.Inference.Reader.Signal + (toTimeScalar, toFrequencyScalar) + +import qualified Synthesizer.Physical.Signal as SigP +import qualified Synthesizer.Plain.Displacement as Syn +import qualified Synthesizer.Plain.Interpolation as Interpolation +import qualified Synthesizer.Plain.Filter.Delay.Block as Delay +import qualified Synthesizer.Plain.Filter.NonRecursive as Filt +import qualified Synthesizer.Inference.Monad.Signal.Displacement as SynI +import qualified Synthesizer.Inference.Monad.Signal.Cut as CutI +-} + +import qualified Algebra.OccasionallyScalar as OccScalar +-- import qualified Algebra.Transcendental as Trans +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +-- import qualified Algebra.Real as Real +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive +import qualified Algebra.Module as Module +-- import qualified Algebra.VectorSpace as VectorSpace + +{- +import Synthesizer.Utility(clip) + +import Control.Monad(liftM2) + +import NumericPrelude hiding (negate) +import PreludeBase as P +-} + + +{- | The amplification factor must be positive. -} +amplify :: (Field.C y') => + y' + -> Proc.T t t' + (SigR.T y y' yv + -> SigR.T y y' yv) +amplify volume = SigR.lift (FiltC.amplify volume) + +negate :: (Additive.C yv) => + Proc.T t t' + (SigR.T y y' yv + -> SigR.T y y' yv) +negate = SigR.lift FiltC.negate + + +envelope :: (Module.C y yv, Field.C y') => + Proc.T t t' ( + SigR.T y y' y {- the envelope -} + -> SigR.T y y' yv {- the signal to be enveloped -} + -> SigR.T y y' yv) +envelope = SigR.lift FiltC.envelope + + +differentiate :: (Additive.C v, Field.C q') => + Proc.T q q' ( + SigR.T q q' v + -> SigR.T q q' v) +differentiate = SigR.lift FiltC.differentiate + + +{- +{- | needs a good handling of boundaries, yet -} +mean :: (Additive.C yv, Field.C y', RealField.C a, + Module.C a v, OccScalar.C a q) => + q {- ^ time length of the window -} + -> SigR.T y y' yv + -> Proc.T t t' (SigR.T y y' yv) +mean time x = + do t <- toTimeScalar x (Expr.constant time) + let tInt = round ((t-1)/2) + let width = tInt*2+1 + returnModified [] + ((SigP.asTypeOfAmplitude (recip (fromIntegral width)) x *> ) . + Filt.sums width . FiltNR.delay tInt) x + + +delay :: (Additive.C yv, Field.C y', RealField.C a, OccScalar.C a q) => + q + -> SigR.T y y' yv + -> Proc.T t t' (SigR.T y y' yv) +delay time x = + do t <- toTimeScalar x (Expr.constant time) + returnModified [] (FiltNR.delay (round t)) x + + +phaseModulation :: + (Additive.C yv, Field.C y', RealField.C a, OccScalar.C a q) => + Interpolation.T a v + -> q {- ^ minDelay, minimal delay, may be negative -} + -> q {- ^ maxDelay, maximal delay, it must be @minDelay <= maxDelay@ + and the modulation must always be + in the range [minDelay,maxDelay]. -} + -> SigI.T a q a + {- ^ delay control, positive numbers mean delay, + negative numbers mean prefetch -} + -> SigR.T y y' yv + -> Proc.T t t' (SigR.T y y' yv) +phaseModulation ip minDelay maxDelay delays x = + do t0 <- toTimeScalar x (Expr.constant minDelay) + t1 <- toTimeScalar x (Expr.constant maxDelay) + let tInt0 = floor t0 + let tInt1 = ceiling t1 + let tInt0Neg = Additive.negate tInt0 + ds <- SigI.scalarSamples (toTimeScalar delays) delays + returnModified [SigP.sampleRate delays] + (FiltNR.delay tInt0 . + Delay.modulated ip (tInt1-tInt0+1) + (FiltNR.delay tInt0Neg + (Syn.raise (fromIntegral tInt0Neg) + (map (clip t0 t1) ds)))) x + + +{- | symmetric phaser -} +phaser :: (Additive.C yv, Field.C y', RealField.C a, + Module.C a v, OccScalar.C a q) => + Interpolation.T a v + -> q {- ^ maxDelay, must be positive -} + -> SigI.T a q a + {- ^ delay control -} + -> SigR.T y y' yv + -> Proc.T t t' (SigR.T y y' yv) +phaser ip maxDelay delays x = + amplify (asTypeOf 0.5 maxDelay) =<< + uncurry SynI.mix =<< phaserCore ip maxDelay delays x + +phaserStereo :: (Additive.C yv, Field.C y', Real.C q, RealField.C a, + Module.C a v, OccScalar.C a q) => + Interpolation.T a v + -> q {- ^ maxDelay, must be positive -} + -> SigI.T a q a + {- ^ delay control -} + -> SigR.T y y' yv + -> SigI.Process a q (v,v) +phaserStereo ip maxDelay delays x = + uncurry CutI.zip =<< phaserCore ip maxDelay delays x + +phaserCore :: (Additive.C yv, Field.C y', RealField.C a, + Module.C a v, OccScalar.C a q) => + Interpolation.T a v + -> q {- ^ maxDelay, must be positive -} + -> SigI.T a q a + {- ^ delay control -} + -> SigR.T y y' yv + -> Process.T q (SigR.T y y' yv, SigR.T y y' yv) +phaserCore ip maxDelay delays x = + do let minDelay = Additive.negate maxDelay + negDelays <- Inference.Signal.Filter.negate delays + liftM2 (,) + (phaseModulation ip minDelay maxDelay delays x) + (phaseModulation ip minDelay maxDelay negDelays x) + + + +firstOrderLowpass, firstOrderHighpass :: + (Trans.C a, Trans.C q, Module.C a v, OccScalar.C a q) => + SigI.T a q a {- ^ Control signal for the cut-off frequency. -} + -> SigR.T y y' yv {- ^ Input signal -} + -> Proc.T t t' (SigR.T y y' yv) +firstOrderLowpass = firstOrderGen Syn.lowpass1stOrder +firstOrderHighpass = firstOrderGen Syn.highpass1stOrder + +firstOrderGen :: (Trans.C a, Trans.C q, Module.C a v, OccScalar.C a q) => + ([a] -> [v] -> [v]) + -> SigI.T a q a + -> SigR.T y y' yv + -> Proc.T t t' (SigR.T y y' yv) +firstOrderGen filt freq x = + do freqs <- SigI.scalarSamples (toFrequencyScalar x) freq + returnModified [SigP.sampleRate freq] + (filt (map Syn.lowpass1stOrderParam freqs)) x + + +butterworthLowpass, butterworthHighpass, + chebyshevALowpass, chebyshevAHighpass, + chebyshevBLowpass, chebyshevBHighpass :: + (Field.C y', Trans.C a, VectorSpace.C a v, OccScalar.C a q) => + Int {- ^ Order of the filter, must be even, + the higher the order, the sharper is the separation of frequencies. -} + -> a {- ^ The attenuation at the cut-off frequency. + Should be between 0 and 1. -} + -> SigI.T a q a {- ^ Control signal for the cut-off frequency. -} + -> SigR.T y y' yv {- ^ Input signal -} + -> Proc.T t t' (SigR.T y y' yv) + +butterworthLowpass = higherOrderNoResoGen Syn.butterworthLowpass +butterworthHighpass = higherOrderNoResoGen Syn.butterworthHighpass +chebyshevALowpass = higherOrderNoResoGen Syn.chebyshevALowpass +chebyshevAHighpass = higherOrderNoResoGen Syn.chebyshevAHighpass +chebyshevBLowpass = higherOrderNoResoGen Syn.chebyshevBLowpass +chebyshevBHighpass = higherOrderNoResoGen Syn.chebyshevBHighpass + +higherOrderNoResoGen :: + (Field.C y', Ring.C a, OccScalar.C a q) => + (Int -> a -> [a] -> [v] -> [v]) + -> Int + -> a + -> SigI.T a q a + -> SigR.T y y' yv + -> Proc.T t t' (SigR.T y y' yv) +higherOrderNoResoGen filt order ratio freq x = + do freqs <- SigI.scalarSamples (toFrequencyScalar x) freq + returnModified [SigP.sampleRate freq] + (filt order ratio freqs) x + + + +universal :: (Trans.C a, Module.C a v, Field.C y', OccScalar.C a q) => + SigI.T a q a {- ^ signal for resonance, + i.e. factor of amplification at the resonance frequency + relatively to the transition band. -} + -> SigI.T a q a {- ^ signal for cut off and band center frequency -} + -> SigR.T y y' yv {- ^ input signal -} + -> SigI.Process a q (v,v,v) {- ^ highpass, bandpass, lowpass filter -} +universal reso freq x = + do resos <- SigI.scalarSamples (Process.exprToScalar) reso + freqs <- SigI.scalarSamples (toFrequencyScalar x) freq + let params = + map UniFilter.parameter + (zipWith Syn.Pole resos freqs) + returnModified [SigP.sampleRate reso, SigP.sampleRate freq] + (UniFilter.run params) x + +moogLowpass :: (Trans.C a, Module.C a v, Field.C y', OccScalar.C a q) => + Int + -> SigI.T a q a {- ^ signal for resonance, + i.e. factor of amplification at the resonance frequency + relatively to the transition band. -} + -> SigI.T a q a {- ^ signal for cut off and band center frequency -} + -> SigR.T y y' yv + -> Proc.T t t' (SigR.T y y' yv) +moogLowpass order reso freq x = + do resos <- SigI.scalarSamples (Process.exprToScalar) reso + freqs <- SigI.scalarSamples (toFrequencyScalar x) freq + let params = + map (Moog.parameter order) + (zipWith Syn.Pole resos freqs) + returnModified [SigP.sampleRate reso, SigP.sampleRate freq] + (Moog.lowpass order params) x + +allpassCascade :: (Trans.C a, Module.C a v, Field.C y', OccScalar.C a q) => + Int {- ^ order, number of filters in the cascade -} + -> a {- ^ the phase shift to be achieved for the given frequency -} + -> SigI.T a q a {- ^ lowest comb frequency -} + -> SigR.T y y' yv + -> Proc.T t t' (SigR.T y y' yv) +allpassCascade order phase freq x = + do freqs <- SigI.scalarSamples (toFrequencyScalar x) freq + let params = map (Syn.allpassCascadeParam order phase) freqs + returnModified [SigP.sampleRate freq] + (Syn.allpassCascade order params) x +-} + + + +{- | Infinitely many equi-delayed exponentially decaying echos. -} +comb :: (RealField.C t, Ring.C t', OccScalar.C t t', Module.C y yv) => + t' -> y -> Proc.T t t' (SigR.T y y' yv -> SigR.T y y' yv) +comb time gain = SigR.lift (FiltC.comb time gain) + + +integrate :: (Additive.C v, Field.C q') => + Proc.T q q' + (SigR.T q q' v + -> SigR.T q q' v) +integrate = SigR.lift FiltC.integrate + + +{- +returnModified :: (Eq q) => + [Process.Value q] -> ([v] -> [w]) -> SigR.T y y' yv -> SigI.Process a q w +returnModified sampleRates proc x = + do let sampleRate = SigP.sampleRate x + mapM_ (Process.equalValue sampleRate) sampleRates + SigI.returnCons + sampleRate (SigP.amplitude x) + (proc (SigP.samples x)) +-} diff --git a/src/Synthesizer/Inference/Reader/Noise.hs b/src/Synthesizer/Inference/Reader/Noise.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Inference/Reader/Noise.hs @@ -0,0 +1,62 @@ +{-# OPTIONS -fno-implicit-prelude -fglasgow-exts #-} +{- | +Copyright : (c) Henning Thielemann 2006 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +-} +module Synthesizer.Inference.Reader.Noise + (white, + whiteGen, + randomPeeks) where + + +import qualified Synthesizer.SampleRateContext.Noise as NoiseC + +import qualified Synthesizer.Inference.Reader.Signal as SigR +import qualified Synthesizer.Inference.Reader.Process as Proc + +import qualified Algebra.OccasionallyScalar as OccScalar +import qualified Algebra.Algebraic as Algebraic +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring + +import System.Random (Random, RandomGen) + +-- import NumericPrelude +import PreludeBase as P + + + +white :: (Ring.C yv, Random yv, Algebraic.C q') => + q' {-^ width of the frequency band -} + -> q' {-^ volume caused by the given frequency band -} + -> Proc.T t q' (SigR.T y q' yv) + {-^ noise -} +white bandWidth volume = SigR.lift $ NoiseC.white bandWidth volume + +whiteGen :: (Ring.C yv, Random yv, RandomGen g, Algebraic.C q') => + g {-^ random generator, can be used to choose a seed -} + -> q' {-^ width of the frequency band -} + -> q' {-^ volume caused by the given frequency band -} + -> Proc.T t q' (SigR.T y q' yv) + {-^ noise -} +whiteGen gen bandWidth volume = SigR.lift (NoiseC.whiteGen gen bandWidth volume) + +{- +The Field.C q constraint could be lifted to Ring.C +if we would use direct division instead of toFrequencyScalar. +-} +randomPeeks :: + (Field.C q, Random q, Ord q, + Field.C q', OccScalar.C q q') => + Proc.T q q' + ( SigR.T q q' q {- momentary densities (frequency), + @p@ means that there is about one peak + in the time range of @1\/p@. -} + -> [Bool]) + {- Every occurence of 'True' represents a peak. -} +randomPeeks = SigR.lift NoiseC.randomPeeks diff --git a/src/Synthesizer/Inference/Reader/Oscillator.hs b/src/Synthesizer/Inference/Reader/Oscillator.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Inference/Reader/Oscillator.hs @@ -0,0 +1,79 @@ +{-# OPTIONS -fno-implicit-prelude -fglasgow-exts #-} +{- | +Copyright : (c) Henning Thielemann 2006, 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +-} +module Synthesizer.Inference.Reader.Oscillator ( + {- * Oscillators with constant waveforms -} + static, + freqMod, + phaseMod, + phaseFreqMod, +) where + +import qualified Synthesizer.SampleRateContext.Oscillator as OsciC + +-- import qualified Synthesizer.Plain.Oscillator as Osci +import qualified Synthesizer.Basic.Wave as Wave + +import qualified Synthesizer.Inference.Reader.Signal as SigR +import qualified Synthesizer.Inference.Reader.Process as Proc + +import qualified Algebra.OccasionallyScalar as OccScalar +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field + +-- import NumericPrelude +-- import PreludeBase as P + + +{- * Oscillators with constant waveforms -} + +{- | oscillator with a functional waveform with constant frequency -} +static :: (RealField.C t, Field.C t', OccScalar.C t t') => + Wave.T t yv {- ^ waveform -} + -> y' {- ^ amplitude -} + -> t {- ^ start phase from the range [0,1] -} + -> t' {- ^ frequency -} + -> Proc.T t t' (SigR.T y y' yv) +static wave amplitude phase freq = + SigR.lift (OsciC.static wave amplitude phase freq) + +{- | oscillator with a functional waveform with modulated frequency -} +freqMod :: (RealField.C t, Field.C t', OccScalar.C t t') => + Wave.T t yv {- ^ waveform -} + -> y' {- ^ amplitude -} + -> t {- ^ start phase from the range [0,1] -} + -> Proc.T t t' ( + SigR.T t t' t {- frequency control -} + -> SigR.T y y' yv) +freqMod wave amplitude phase = + SigR.lift (OsciC.freqMod wave amplitude phase) + +{- | oscillator with modulated phase -} +phaseMod :: (RealField.C t, Field.C t', OccScalar.C t t') => + Wave.T t yv {- ^ waveform -} + -> y' {- ^ amplitude -} + -> t' {- ^ frequency control -} + -> Proc.T t t' ( + SigR.T t t t {- phase modulation, phases must have no unit and + are from range [0,1] -} + -> SigR.T y y' yv) +phaseMod wave amplitude freq = + SigR.lift (OsciC.phaseMod wave amplitude freq) + +{- | oscillator with a functional waveform with modulated phase and frequency -} +phaseFreqMod :: (RealField.C t, Field.C t', OccScalar.C t t') => + Wave.T t yv {- ^ waveform -} + -> y' {- ^ amplitude -} + -> Proc.T t t' ( + SigR.T t t t {- phase control -} + -> SigR.T t t' t {- frequency control -} + -> SigR.T y y' yv) +phaseFreqMod wave amplitude = + SigR.lift (OsciC.phaseFreqMod wave amplitude) diff --git a/src/Synthesizer/Inference/Reader/Play.hs b/src/Synthesizer/Inference/Reader/Play.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Inference/Reader/Play.hs @@ -0,0 +1,21 @@ +module Synthesizer.Inference.Reader.Play where + +import qualified BinarySample as BinSmp + +import qualified Synthesizer.Inference.Reader.Signal as SigR +import qualified Synthesizer.Inference.Reader.Process as ProcR +import qualified Synthesizer.Physical.Play as PlayP + +import qualified Algebra.OccasionallyScalar as OccScalar +import qualified Algebra.VectorSpace as VectorSpace +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field + + +auto :: (RealField.C t, BinSmp.C yv, + Field.C t', OccScalar.C t t', + Field.C y', OccScalar.C y y', + VectorSpace.C y yv) => + t' -> y' -> t' -> ProcR.T t t' (SigR.T y y' yv) -> IO () +auto freqUnit amp sampleRate proc = + PlayP.auto freqUnit amp (SigR.run sampleRate proc) diff --git a/src/Synthesizer/Inference/Reader/Process.hs b/src/Synthesizer/Inference/Reader/Process.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Inference/Reader/Process.hs @@ -0,0 +1,110 @@ +{- | + +Copyright : (c) Henning Thielemann 2007 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes (OccasionallyScalar) + + + +Light-weight sample parameter inference which will fit most needs. +We only do \"poor man's inference\", only for sample rates. +The sample rate will be provided in a Reader monad. +We almost do not need monad functionality +but only "Control.Applicative" functionality. + +In contrast to the run-time inference approach, +we have the static guarantee that the sample rate is fixed +before passing a signal to the outside world. +-} +module Synthesizer.Inference.Reader.Process ( + T(..), + run, share, + injectParam, extractParam, convertTimeParam, + loop, pure, + ($:), ($::), ($^), ($#), + (.:), (.^), + liftP, liftP2, liftP3, liftP4, + ) where + +import Control.Monad.Fix (MonadFix(mfix), ) +import Synthesizer.ApplicativeUtility +import qualified Control.Applicative as App +import Control.Applicative (Applicative) + +{- +import NumericPrelude +import PreludeBase as P +-} + + +{- | +This wraps a function which computes a sample rate dependent result. +Sample rate tells how many values per unit are stored +for representation of a signal. +-} +newtype T t t' a = Cons {process :: t' -> a} + + +instance Functor (T t t') where + fmap f x = Cons (f . process x) + +instance Applicative (T t t') where + pure = pure + (<*>) = apply + +instance Monad (T t t') where + return = pure + (>>=) = share + +instance MonadFix (T t t') where + mfix = loop . injectParam + + + +run :: + t' -> T t t' a -> (t', a) +run sr (Cons p) = (sr, p sr) + + +{- | +Re-use a result several times without recomputing. +With a simple @let@ you can re-use a result +but it must be recomputed due to the dependency on the sample rate. +-} +share :: + T t t' a {-^ process that provides a result -} + -> (a -> T t t' b) {-^ function that can re-use that result as much as it wants -} + -> T t t' b +share p f = Cons $ \sr -> + process (f (process p sr)) sr + + + +{- | +This corresponds to 'Control.Applicative.pure' +-} +pure :: a -> T t t' a +pure x = Cons $ const x + +apply :: T t t' (a -> b) -> T t t' a -> T t t' b +apply f proc = Cons $ \sr -> + process f sr (process proc sr) + +extractParam :: T t t' (a -> b) -> (a -> T t t' b) +extractParam = ($#) + +injectParam :: (a -> T t t' b) -> T t t' (a -> b) +injectParam f = Cons $ \sr x -> + process (f x) sr + +{- | +The first argument will be a function like 'InferenceReader.Signal.toTimeScalar'. +If you use this function instead of 'InferenceReader.Signal.toTimeScalar' directly, +the type @t@ can be automatically infered. +-} +convertTimeParam :: (t' -> t' -> t) -> t' -> (t -> a) -> T t t' a +convertTimeParam convert t' f = Cons $ \sr -> + f (convert sr t') diff --git a/src/Synthesizer/Inference/Reader/Signal.hs b/src/Synthesizer/Inference/Reader/Signal.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Inference/Reader/Signal.hs @@ -0,0 +1,136 @@ +{-# OPTIONS -fno-implicit-prelude -fglasgow-exts #-} +{- | + +Copyright : (c) Henning Thielemann 2007 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes (OccasionallyScalar) +-} +module Synthesizer.Inference.Reader.Signal ( + T(..), + run, + addSampleRate, + apply, + lift, + returnCons, + + toTimeScalar, + toFrequencyScalar, + toAmplitudeScalar, + toGradientScalar, + + scalarSamples, + vectorSamples, + + ($-), + constant, + ) where + +import Synthesizer.Inference.Reader.Process (($:)) +import qualified Synthesizer.Inference.Reader.Process as Proc + +import qualified Synthesizer.SampleRateContext.Rate as Rate +import qualified Synthesizer.SampleRateContext.Signal as SigC +import qualified Synthesizer.Physical.Signal as SigP + +import Synthesizer.SampleRateContext.Signal (T(Cons, samples, amplitude)) + +import qualified Algebra.OccasionallyScalar as OccScalar +import qualified Algebra.Module as Module +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring + +import Algebra.OccasionallyScalar (toScalar) + +import NumericPrelude +import PreludeBase as P + + + +run :: + t' -> Proc.T t t' (T y y' yv) -> SigP.T t t' y y' yv +run sr proc = + uncurry addSampleRate (Proc.run sr proc) + +{- +run :: + Rate.T t t' -> Proc.T t t' (T y y' yv) -> SigP.T t t' y y' yv +run sr proc = + uncurry addSampleRate (Proc.run (Rate.toNumber sr) proc) +-} + +addSampleRate :: + t' -> T y y' yv -> SigP.T t t' y y' yv +addSampleRate = SigP.addPlainSampleRate + +apply :: + (Proc.T t t' (T y0 y0' y0v -> T y1 y1' y1v)) + -> SigP.T t t' y0 y0' y0v + -> SigP.T t t' y1 y1' y1v +apply proc (SigP.Cons sr sig) = + let (sr', f) = Proc.run (Rate.toNumber sr) proc + in addSampleRate sr' (f sig) + + +lift :: (Rate.T t t' -> a) -> Proc.T t t' a +lift f = Proc.Cons $ f . Rate.fromNumber + + +returnCons :: + y' -> [yv] -> Proc.T t t' (T y y' yv) +returnCons amp sig = Proc.pure (Cons amp sig) + +{- +sampleRateExpr :: SigP.T t (Value t') y (Value y') yv -> Expr t' +sampleRateExpr x = Expr.fromValue (SigP.sampleRate x) + +amplitudeExpr :: SigP.T t (Value t') y (Value y') yv -> Expr y' +amplitudeExpr x = Expr.fromValue (SigP.amplitude x) +-} + +toTimeScalar :: (Ring.C t', OccScalar.C t t') => + t' -> t' -> t +toTimeScalar sampleRate t = toScalar (t * sampleRate) + +toFrequencyScalar :: (Field.C t', OccScalar.C t t') => + t' -> t' -> t +toFrequencyScalar sampleRate f = toScalar (f / sampleRate) + +toAmplitudeScalar :: (Field.C y', OccScalar.C y y') => + T y y' yv -> y' -> y +toAmplitudeScalar sig y = + toScalar (y / amplitude sig) + +toGradientScalar :: (Field.C q', OccScalar.C q q') => + q' -> q' -> q' -> q +toGradientScalar amp sampleRate steepness = + toFrequencyScalar sampleRate (steepness / amp) + + +scalarSamples :: (Ring.C y) => + (y' -> y) -> T y y' y -> [y] +scalarSamples toAmpScalar sig = + let y = toAmpScalar (amplitude sig) + in map (y*) (samples sig) + +vectorSamples :: (Module.C y yv) => + (y' -> y) -> T y y' yv -> [yv] +vectorSamples toAmpScalar sig = + let y = toAmpScalar (amplitude sig) + in y *> samples sig + + +{- | +Take a scalar argument where a process expects a signal. +-} +($-) :: Ring.C yv => + Proc.T t t' (T y y' yv -> a) -> y' -> Proc.T t t' a +($-) f x = f $: Proc.pure (constant x) + +{- +Should be in Control module. +-} +constant :: Ring.C yv => y' -> T y y' yv +constant x = Cons x (repeat 1) diff --git a/src/Synthesizer/Physical.hs b/src/Synthesizer/Physical.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Physical.hs @@ -0,0 +1,25 @@ +{- | + +Copyright : (c) Henning Thielemann 2006 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + + + +This module is for documentation purposes. +But the modules below are exported +in order to let you easily navigate to them. +-} + + +module Synthesizer.Physical + (module Synthesizer.Physical.Signal, + module Synthesizer.Physical.Cut, + module Synthesizer.Physical.Displacement) where + +import Synthesizer.Physical.Signal +import Synthesizer.Physical.Cut +import Synthesizer.Physical.Displacement diff --git a/src/Synthesizer/Physical/Control.hs b/src/Synthesizer/Physical/Control.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Physical/Control.hs @@ -0,0 +1,72 @@ +{-# OPTIONS -fno-implicit-prelude #-} +{-| +Control curve generation +-} + +module Synthesizer.Physical.Control where + +import qualified Synthesizer.SampleRateContext.Control as CtrlC +import qualified Synthesizer.Plain.Control as Ctrl +import qualified Synthesizer.Physical.Signal as SigP +import Synthesizer.Physical.Signal(toTimeScalar) + +import qualified Algebra.OccasionallyScalar as OccScalar +import qualified Algebra.Module as Module +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Real as Real +import qualified Algebra.Ring as Ring + +-- import PreludeBase +-- import NumericPrelude + + +exponential :: (Trans.C a, Ring.C a', Real.C a', OccScalar.C a a') => + a' {-^ sample rate -} + -> a' {-^ time where the function reaches 1\/e of the initial value -} + -> a' {-^ initial value -} + -> SigP.T a a' a a' a + {-^ exponential decay -} +exponential sampleRate time y0 = + SigP.lift0 (CtrlC.exponential time y0) sampleRate + + +exponential2 :: (Trans.C a, Ring.C a', Real.C a', OccScalar.C a a') => + a' {-^ sample rate -} + -> a' {-^ half life -} + -> a' {-^ initial value -} + -> SigP.T a a' a a' a + {-^ exponential decay -} +exponential2 sampleRate halfLife y0 = + SigP.lift0 (CtrlC.exponential2 halfLife y0) sampleRate + + +vectorExponential :: + (Trans.C t, Ring.C t', + OccScalar.C t t', Module.C t yv) => + t' {-^ sample rate -} + -> t' {-^ time where the function reaches 1\/e of the initial value -} + -> y' {-^ amplitude unit -} + -> yv {-^ initial value -} + -> SigP.T t t' y y' yv + {-^ exponential decay -} +vectorExponential sampleRate time amplitude y0 = + let z = SigP.cons sampleRate amplitude + (Ctrl.vectorExponential + (toTimeScalar z time) y0) + in z + + +vectorExponential2 :: + (Trans.C t, Ring.C t', + OccScalar.C t t', Module.C t yv) => + t' {-^ sample rate -} + -> t' {-^ half life -} + -> y' {-^ amplitude unit -} + -> yv {-^ initial value -} + -> SigP.T t t' y y' yv + {-^ exponential decay -} +vectorExponential2 sampleRate halfLife amplitude y0 = + let z = SigP.cons sampleRate amplitude + (Ctrl.vectorExponential2 + (toTimeScalar z halfLife) y0) + in z diff --git a/src/Synthesizer/Physical/Cut.hs b/src/Synthesizer/Physical/Cut.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Physical/Cut.hs @@ -0,0 +1,224 @@ +{- | +Copyright : (c) Henning Thielemann 2006, 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +Cut signals + +-} +module Synthesizer.Physical.Cut where + +import qualified Synthesizer.SampleRateContext.Cut as CutC +import qualified Synthesizer.SampleRateContext.Signal as SigC +import qualified Synthesizer.SampleRateContext.Rate as Rate + +import qualified Synthesizer.Physical.Signal as SigP + +import qualified Data.EventList.Relative.TimeBody as EventList +import qualified Numeric.NonNegative.Class as NonNeg + +import qualified Algebra.NormedSpace.Maximum as NormedMax +import qualified Algebra.OccasionallyScalar as OccScalar +import qualified Algebra.Module as Module +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Real as Real +import qualified Algebra.Ring as Ring + +-- import qualified Data.List as List + +import Synthesizer.Utility (mapSnd) + +import PreludeBase (Eq, Ord, Bool, uncurry, (.), (==), flip, fst, error) +-- import NumericPrelude + +import Prelude (RealFrac) + + +{- * Dissection -} + +splitAt :: (RealField.C t, Ring.C t', OccScalar.C t t') => + t' -> SigP.T t t' y y' yv -> (SigP.T t t' y y' yv, SigP.T t t' y y' yv) +splitAt t = SigP.liftR2 (CutC.splitAt t) + +take :: (RealField.C t, Ring.C t', OccScalar.C t t') => + t' -> SigP.T t t' y y' yv -> SigP.T t t' y y' yv +take t = SigP.lift1 (CutC.take t) + +drop :: (RealField.C t, Ring.C t', OccScalar.C t t') => + t' -> SigP.T t t' y y' yv -> SigP.T t t' y y' yv +drop t = SigP.lift1 (CutC.drop t) + + +propSplit :: (Eq t', Eq y', Eq yv, + OccScalar.C t t', Ring.C t', RealField.C t) => + t' -> SigP.T t t' y y' yv -> Bool +propSplit t x = splitAt t x == (take t x, drop t x) + + +takeUntilPause :: (RealField.C t, Ring.C t', OccScalar.C t t', + Field.C y', NormedMax.C y yv, OccScalar.C y y') => + y' -> t' -> SigP.T t t' y y' yv -> SigP.T t t' y y' yv +takeUntilPause y' t' = + SigP.lift1 (CutC.takeUntilPause y' t') + + +unzip :: + SigP.T t t' y y' (yv0, yv1) -> (SigP.T t t' y y' yv0, SigP.T t t' y y' yv1) +unzip = SigP.liftR2 CutC.unzip + +unzip3 :: + SigP.T t t' y y' (yv0, yv1, yv2) + -> (SigP.T t t' y y' yv0, SigP.T t t' y y' yv1, SigP.T t t' y y' yv2) +unzip3 = SigP.liftR3 CutC.unzip3 + + +{- * Glueing -} + + +{- | + Similar to @foldr1 append@ but more efficient and accurate, + because it reduces the number of amplifications. + Does not work for infinite lists, + because in this case a maximum amplitude cannot be computed. +-} +concat :: (Real.C y', Field.C y', Eq t', OccScalar.C y y', + Module.C y yv) => + [SigP.T t t' y y' yv] + -> SigP.T t t' y y' yv +concat = SigP.liftList CutC.concat + +{- | + Like 'concat', but you have to specify the amplitude of the resulting signal. + This way we can process infinite lists, too. + The list must contain at least one element for getting a sample rate. +-} +concatVolume :: (Field.C y', Eq t', OccScalar.C y y', + Module.C y yv) => + y' + -> [SigP.T t t' y y' yv] + -> SigP.T t t' y y' yv +concatVolume amp = SigP.liftList (CutC.concatVolume amp) + +append :: (Eq t', Real.C y', Field.C y', OccScalar.C y y', + Module.C y yv) => + SigP.T t t' y y' yv -> SigP.T t t' y y' yv -> SigP.T t t' y y' yv +append = SigP.lift2 CutC.append + + +propConcatAppend :: (Eq t', Eq y', Eq yv, + Module.C y yv, OccScalar.C y y', + Ring.C t', RealField.C y') => + SigP.T t t' y y' yv + -> SigP.T t t' y y' yv + -> Bool +propConcatAppend x y = append x y == concat [x,y] + + +propAppendSplit :: (Eq t', Eq y', Eq yv, + Module.C y yv, OccScalar.C y y', + RealField.C y', OccScalar.C t t', + Ring.C t', RealField.C t) => + t' -> SigP.T t t' y y' yv -> Bool +propAppendSplit t x = uncurry append (splitAt t x) == x + + + + +zip :: (Eq t', Real.C y', Field.C y', OccScalar.C y y', + Module.C y yv0, Module.C y yv1) + => SigP.T t t' y y' yv0 + -> SigP.T t t' y y' yv1 + -> SigP.T t t' y y' (yv0, yv1) +zip = SigP.lift2 CutC.zip + + +zip3 :: (Eq t', Real.C y', Field.C y', OccScalar.C y y', + Module.C y yv0, Module.C y yv1, Module.C y yv2) + => SigP.T t t' y y' yv0 + -> SigP.T t t' y y' yv1 + -> SigP.T t t' y y' yv2 + -> SigP.T t t' y y' (yv0, yv1, yv2) +zip3 = SigP.lift3 CutC.zip3 + + +propZip :: (Eq t', Eq y', Field.C y', Real.C y', + Eq yv0, Eq yv1, + Module.C y yv1, Module.C y yv0, + OccScalar.C y y') => + SigP.T t t' y y' (yv0, yv1) -> Bool +propZip x = uncurry zip (unzip x) == x + +propZip3 :: (Eq t', Eq y', Field.C y', Real.C y', + Eq yv0, Eq yv1, Eq yv2, + Module.C y yv2, Module.C y yv1, Module.C y yv0, + OccScalar.C y y') => + SigP.T t t' y y' (yv0, yv1, yv2) -> Bool +propZip3 x = (\(a,b,c) -> zip3 a b c) (unzip3 x) == x + + +splitSampleRateEventList :: (Eq t') => + EventList.T time (SigP.T t t' y y' yv) + -> (Rate.T t t', EventList.T time (SigC.T y y' yv)) +splitSampleRateEventList xs = + case EventList.getBodies xs of + [] -> error "splitSampleRateEventList: empty list" + (x:_) -> + let sr = fst (SigP.splitSampleRate x) + in (sr, EventList.mapBody (SigP.checkSampleRate "splitSampleRateEventList" sr) xs) + + +{- | + Given a list of signals with time stamps, + mix them into one signal as they occur in time. + Ideally for composing music. + The amplitude of the output is designed for the worst case + (all signals coincide). + This is usually too pessimistic. + Maybe you prefer 'arrangeVolume'. + + Infinite schedules are not supported, + because no maximum amplitude can be computed. + If you want infinite schedules, + then 'arrangeVolume' is your friend, again. +-} +arrange :: + (RealFrac t, NonNeg.C t, Eq t', Ring.C t, Ring.C t', OccScalar.C t t', + Ord y', Field.C y', OccScalar.C y y', + Module.C y yv) => + t' {-^ Unit of the time values in the time ordered list. -} + -> EventList.T t (SigP.T t t' y y' yv) + {-^ A list of pairs: (relative start time, signal part), + The start time is relative + to the start time of the previous event. -} + -> SigP.T t t' y y' yv + {-^ The mixed signal. -} +arrange unit = + uncurry SigP.run . + mapSnd (flip (CutC.arrange unit)) . + splitSampleRateEventList + + +{- | + Similar to 'arrange' but allows for infinite schedules. + To this end it needs the amplitude of the resulting signal. +-} +arrangeVolume :: + (RealFrac t, NonNeg.C t, Eq t', Ring.C t, Ring.C t', OccScalar.C t t', + Field.C y', OccScalar.C y y', + Module.C y yv) => + y' {-^ Amplitude of output. -} + -> t' {-^ Unit of the time values in the time ordered list. -} + -> EventList.T t (SigP.T t t' y y' yv) + {-^ A list of pairs: (relative start time, signal part), + The start time is relative + to the start time of the previous event. -} + -> SigP.T t t' y y' yv + {-^ The mixed signal. -} +arrangeVolume amp unit = + uncurry SigP.run . + mapSnd (flip (CutC.arrangeVolume amp unit)) . + splitSampleRateEventList diff --git a/src/Synthesizer/Physical/Displacement.hs b/src/Synthesizer/Physical/Displacement.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Physical/Displacement.hs @@ -0,0 +1,45 @@ +module Synthesizer.Physical.Displacement where + +import qualified Synthesizer.SampleRateContext.Displacement as MiscC + +import qualified Synthesizer.Physical.Signal as SigP + +import qualified Algebra.OccasionallyScalar as OccScalar +import qualified Algebra.Module as Module +-- import qualified Algebra.Transcendental as Trans +import qualified Algebra.Field as Field +import qualified Algebra.Real as Real +-- import qualified Algebra.Ring as Ring +-- import qualified Algebra.Additive as Additive + +-- import Algebra.Module ((*>)) + +import PreludeBase +-- import NumericPrelude +import Prelude () + + +{- * Mixing -} + +{-| Mix two signals. + In opposition to 'zipWith' the result has the length of the longer signal. -} +mix :: (Eq t', Real.C y', Field.C y', Module.C y yv, OccScalar.C y y') => + SigP.T t t' y y' yv + -> SigP.T t t' y y' yv + -> SigP.T t t' y y' yv +mix = SigP.lift2 MiscC.mix + +{-| Mix one or more signals. -} +mixMulti :: (Eq t', Real.C y', Field.C y', Module.C y yv, OccScalar.C y y') => + [SigP.T t t' y y' yv] + -> SigP.T t t' y y' yv +mixMulti = SigP.liftList MiscC.mixMulti + +{-| Add a number to all of the signal values. + This is useful for adjusting the center of a modulation. -} +raise :: (Eq t', Field.C y', Module.C y yv, OccScalar.C y y') => + y' + -> yv + -> SigP.T t t' y y' yv + -> SigP.T t t' y y' yv +raise y' yv = SigP.lift1 (MiscC.raise y' yv) diff --git a/src/Synthesizer/Physical/File.hs b/src/Synthesizer/Physical/File.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Physical/File.hs @@ -0,0 +1,27 @@ +{-# OPTIONS -fno-implicit-prelude #-} +module Synthesizer.Physical.File where + +import qualified Sox.File +import qualified BinarySample as BinSmp + +import qualified Synthesizer.Physical.Signal as SigP + +import qualified Algebra.OccasionallyScalar as OccScalar +import qualified Algebra.VectorSpace as VectorSpace +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field + +import System.Exit(ExitCode) + +-- import NumericPrelude +import PreludeBase + + + +write :: (RealField.C t, BinSmp.C yv, + Field.C t', OccScalar.C t t', + Field.C y', OccScalar.C y y', + VectorSpace.C y yv) => + t' -> y' -> FilePath -> SigP.T t t' y y' yv -> IO ExitCode +write freqUnit amp name sig = + uncurry (Sox.File.write name) (SigP.pureData freqUnit amp sig) diff --git a/src/Synthesizer/Physical/Filter.hs b/src/Synthesizer/Physical/Filter.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Physical/Filter.hs @@ -0,0 +1,51 @@ +{-# OPTIONS -fno-implicit-prelude #-} +module Synthesizer.Physical.Filter where + +import qualified Synthesizer.SampleRateContext.Filter as FiltC +import qualified Synthesizer.Physical.Signal as SigP + +import qualified Algebra.OccasionallyScalar as OccScalar +import qualified Algebra.Module as Module +-- import qualified Algebra.Transcendental as Trans +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import PreludeBase +-- import NumericPrelude + + +{- * Amplification -} + +amplify :: (Ring.C y') => + y' + -> SigP.T t t' y y' yv + -> SigP.T t t' y y' yv +amplify volume = SigP.lift1 (FiltC.amplify volume) + +envelope :: (Eq t', Module.C y0 yv, Ring.C y') => + SigP.T t t' y y' y0 {-^ the envelope -} + -> SigP.T t t' y y' yv {-^ the signal to be enveloped -} + -> SigP.T t t' y y' yv +envelope = SigP.lift2 FiltC.envelope + + + +{- * Filter operators from calculus -} + +differentiate :: (Additive.C yv, Ring.C a') + => SigP.T t a' y a' yv -> SigP.T t a' y a' yv +differentiate = SigP.lift1 FiltC.differentiate + +integrate :: (Additive.C yv, Field.C a') + => SigP.T t a' y a' yv -> SigP.T t a' y a' yv +integrate = SigP.lift1 FiltC.integrate + + +{- * Echo -} + +{- | Infinitely many equi-delayed exponentially decaying echos. -} +comb :: (RealField.C t, Ring.C t', OccScalar.C t t', Module.C y yv) => + t' -> y -> SigP.T t t' y y' yv -> SigP.T t t' y y' yv +comb time gain = SigP.lift1 (FiltC.comb time gain) diff --git a/src/Synthesizer/Physical/Noise.hs b/src/Synthesizer/Physical/Noise.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Physical/Noise.hs @@ -0,0 +1,27 @@ +{-# OPTIONS -fno-implicit-prelude #-} +module Synthesizer.Physical.Noise where + +import qualified Synthesizer.SampleRateContext.Noise as NoiseC +-- import qualified Synthesizer.SampleRateContext.Signal as SigC + +import qualified Synthesizer.Physical.Signal as SigP + +import System.Random (Random) + +import qualified Algebra.Algebraic as Algebraic +import qualified Algebra.Ring as Ring + +-- import PreludeBase +-- import NumericPrelude + + +{- * Noise -} + +white :: (Ring.C yv, Random yv, Algebraic.C q') => + q' {-^ sample rate -} + -> q' {-^ width of the frequency band -} + -> q' {-^ volume caused by the given frequency band -} + -> SigP.T t q' y q' yv + {-^ noise -} +white sampleRate bandWidth volume = + SigP.lift0 (NoiseC.white bandWidth volume) sampleRate diff --git a/src/Synthesizer/Physical/Oscillator.hs b/src/Synthesizer/Physical/Oscillator.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Physical/Oscillator.hs @@ -0,0 +1,66 @@ +{-# OPTIONS -fno-implicit-prelude #-} +{- | +Copyright : (c) Henning Thielemann 2006, 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +Tone generators + +-} +module Synthesizer.Physical.Oscillator where + +import qualified Synthesizer.SampleRateContext.Oscillator as OsciC +-- import qualified Synthesizer.Plain.Oscillator as Osci +import qualified Synthesizer.Basic.Wave as Wave +import qualified Synthesizer.Physical.Signal as SigP + +import qualified Algebra.OccasionallyScalar as OccScalar +import qualified Algebra.Module as Module +import qualified Algebra.Transcendental as Trans +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +-- import qualified Algebra.Ring as Ring + +-- import PreludeBase +-- import NumericPrelude + + + +{- * Oscillators with constant waveforms -} + +{- | oscillator with a functional waveform with constant frequency -} +static :: (RealField.C t, Field.C t', OccScalar.C t t') + => Wave.T t yv + -> (t' -> y' -> t -> t' -> SigP.T t t' y y' yv) +static wave sampleRate amplitude phase freq = + SigP.lift0 (OsciC.static wave amplitude phase freq) sampleRate + +{- | oscillator with a functional waveform with modulated frequency -} +freqMod :: (RealField.C t, Field.C t', OccScalar.C t t') + => Wave.T t yv + -> (y' -> t -> SigP.T t t' t t' t -> SigP.T t t' y y' yv) +freqMod wave amplitude phase = + SigP.lift1 (OsciC.freqMod wave amplitude phase) + +{- | sine oscillator with static frequency -} +staticSine :: (RealField.C a, Trans.C a, Field.C t', OccScalar.C a t') + => t' -> y' -> a -> t' -> SigP.T a t' a y' a +staticSine = static Wave.sine + +{- | sine oscillator with modulated frequency -} +freqModSine :: (RealField.C a, Trans.C a, Module.C a a, Field.C t', OccScalar.C a t') + => y' -> a -> SigP.T a t' a t' a -> SigP.T a t' a y' a +freqModSine = freqMod Wave.sine + +{- | saw tooth oscillator with modulated frequency -} +staticSaw :: (RealField.C a, Field.C t', OccScalar.C a t') + => t' -> y' -> a -> t' -> SigP.T a t' a y' a +staticSaw = static Wave.saw + +{- | saw tooth oscillator with modulated frequency -} +freqModSaw :: (RealField.C a, Field.C t', Module.C a a, OccScalar.C a t') + => y' -> a -> SigP.T a t' a t' a -> SigP.T a t' a y' a +freqModSaw = freqMod Wave.saw diff --git a/src/Synthesizer/Physical/Play.hs b/src/Synthesizer/Physical/Play.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Physical/Play.hs @@ -0,0 +1,25 @@ +{-# OPTIONS -fno-implicit-prelude #-} +module Synthesizer.Physical.Play where + +import qualified Sox.Play +import qualified BinarySample as BinSmp + +import qualified Synthesizer.Physical.Signal as SigP + +import qualified Algebra.OccasionallyScalar as OccScalar +import qualified Algebra.VectorSpace as VectorSpace +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field + +-- import NumericPrelude +import PreludeBase + + + +auto :: (RealField.C t, BinSmp.C yv, + Field.C t', OccScalar.C t t', + Field.C y', OccScalar.C y y', + VectorSpace.C y yv) => + t' -> y' -> SigP.T t t' y y' yv -> IO () +auto freqUnit amp sig = + uncurry Sox.Play.auto (SigP.pureData freqUnit amp sig) diff --git a/src/Synthesizer/Physical/Signal.hs b/src/Synthesizer/Physical/Signal.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Physical/Signal.hs @@ -0,0 +1,336 @@ +{-# OPTIONS -fno-implicit-prelude #-} +{-| +Copyright : (c) Henning Thielemann 2006, 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + + This module equips a list of values + with a sampling rate and an amplitude. + Since sampling rate and amplitude need not to be of the same type + and need not to be of the type of the values + one can choose physical quantities for sampling rate and amplitude + but low level types like Double and Float for the values. + The only thing we need is the conversion to scalar types + provided by the 'Algebra.OccasionallyScalar.C' type class. + This conversion may fail in which case we encountered a unit error. + We can also use this module with plain number types. + Then toScalar cannot fail. + + The conversion to scalars is very general + and might support applications I can currently not imagine. +-} + +module Synthesizer.Physical.Signal where + +import qualified Synthesizer.SampleRateContext.Signal as SigC +import qualified Synthesizer.SampleRateContext.Rate as Rate + +import qualified Algebra.OccasionallyScalar as OccScalar +import qualified Algebra.VectorSpace as VectorSpace +import qualified Algebra.Module as Module +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring + +import Algebra.OccasionallyScalar(toScalar) +import Algebra.Module((*>)) + +import Synthesizer.Utility (mapSnd, common, ) + +import PreludeBase +import NumericPrelude + +{-| t and y are plain number types, + t' and y' may be physical quantities. + yv may be a vector type. + It should hold: + @(OccScalar.C t t', + OccScalar.C y y', + Module.C y yv)@ + There are no values of type t and type y in T + but they are essential to computation of intermediate results. +-} +data T t t' y y' yv = + Cons { + fullSampleRate :: Rate.T t t' + {-^ how many values per unit are stored -} + , content :: SigC.T y y' yv + {-^ the signal with a unit-equipped volume -} + } + deriving (Eq, Show) + +{- | Construct a signal. -} +cons :: + t' {- ^ sampling rate, must be positive (unchecked) -} + -> y' {- ^ amplitude, must be positive (unchecked) -} + -> [yv] {- ^ samples, values should be between -1 and 1 (unchecked) -} + -> T t t' y y' yv +cons sr amp ss = + Cons (Rate.fromNumber sr) (SigC.Cons amp ss) + +sampleRate :: T t t' y y' yv -> t' +sampleRate = Rate.toNumber . fullSampleRate + +amplitude :: T t t' y y' yv -> y' +amplitude = SigC.amplitude . content + +samples :: T t t' y y' yv -> [yv] +samples = SigC.samples . content + +{- | +Replace sample rate and amplitude +with different representations of their values. +This is needed for internal purposes, +especially for preserving the phantom types. +Do not use it for arbitrary changes of sample rate or amplitude! +-} +replaceParameters :: t1' -> y1' -> T t t0' y y0' yv -> T t t1' y y1' yv +replaceParameters sr amp (Cons _ (SigC.Cons _ ss)) = cons sr amp ss + +replaceSampleRate :: t1' -> T t t0' y y' yv -> T t t1' y y' yv +replaceSampleRate sr (Cons _ sig) = Cons (Rate.fromNumber sr) sig + +replaceAmplitude :: y1' -> T t t' y y0' yv -> T t t' y y1' yv +replaceAmplitude amp (Cons sr sig) = + Cons sr (SigC.replaceAmplitude amp sig) + +replaceSamples :: [yv1] -> T t t' y y' yv0 -> T t t' y y' yv1 +replaceSamples ss (Cons sr sig) = + Cons sr (SigC.replaceSamples ss sig) + + +{- | +Assert a condition before shipping the first sample. +-} +assert :: String -> Bool -> T t t' y y' yv -> T t t' y y' yv +assert msg cond x = + replaceSamples (if cond then samples x else error msg) x + +{- | +Assert that the amplitude of the signal matches the given one. +Otherwise give an error when the first sample is fetched. +-} +assertAmplitude :: Eq y' => y' -> T t t' y y' yv -> T t t' y y' yv +assertAmplitude amp x = + replaceSamples + (if amp == amplitude x + then samples x + else error "assertAmplitude: amplitudes differ") x + +{- | +Assert that the sample rate of the signal matches the given one. +-} +assertSampleRate :: Eq t' => t' -> T t t' y y' yv -> T t t' y y' yv +assertSampleRate sr0 (Cons sr sig) = + Cons sr $ + if sr0 == Rate.toNumber sr + then sig + else error "assertSampleRate: sample rates differ" + +{- | Fix the type of a value to the scalar time type of a signal. -} +asTypeOfTime :: + t {- ^ time value, of with a type to be fixed -} + -> T t t' y y' yv + {- ^ signal, whose time type shall be matched -} + -> t {- ^ the time value, again -} +asTypeOfTime = const + +{- | Fix the type of a value to the scalar amplitude type of a signal. -} +asTypeOfAmplitude :: y -> T t t' y y' yv -> y +asTypeOfAmplitude = const + +{- | Express a time value as a multiple of the sampling period. + The multiplicity is returned. + It is a checked error, + if the units of time value and sampling period mismatch. -} +toTimeScalar :: (Ring.C t', OccScalar.C t t') => + T t t' y y' yv -> t' -> t +toTimeScalar x t = + toScalar (t * sampleRate x) `asTypeOfTime` x + +{- | Express a frequency value as a multiple of the sampling frequency. + The multiplicity is returned. + In many applications the multiplicity is below 1. + It is a checked error, + if the units of frequency value and sampling frequency mismatch. -} +toFrequencyScalar :: (Field.C t', OccScalar.C t t') => + T t t' y y' yv -> t' -> t +toFrequencyScalar x f = + toScalar (f / sampleRate x) `asTypeOfTime` x + +{- | Express an amplitude value as a multiple of the signal amplitude. + The multiplicity is returned. + It is a checked error, + if the units of amplitude value and signal amplitude mismatch. -} +toAmplitudeScalar :: (Field.C y', OccScalar.C y y') => + T t t' y y' yv -> y' -> y +toAmplitudeScalar x y = + toScalar (y / amplitude x) `asTypeOfAmplitude` x + +{-| If all signals share the same sampleRate, then return it, + otherwise raise an error. -} +commonSampleRate :: (Eq t') => + T t t' y0 y'0 yv0 -> T t t' y1 y'1 yv1 -> t' +commonSampleRate x y = + commonSampleRate' (sampleRate x) (sampleRate y) + -- "The sample rates "++show sr0++" and "++show sr1++" differ." + +commonSampleRate' :: (Eq a) => a -> a -> a +commonSampleRate' x y = + common "The sample rates differ." x y + +{- | Extract data for further processing that is not aware of physical units, + such as playing and creating files. -} +pureData :: (Field.C t', OccScalar.C t t', + Field.C y', OccScalar.C y y', + VectorSpace.C y yv) => + t' {- ^ The unit of the sampling frequency, say 'Number.SI.hertz' -} + -> y' {- ^ The maximum expected value. + The data is normalized to this value, + in order to preserve that all output samples + are at most 1 in magnitude. -} + -> T t t' y y' yv + {- ^ The input signal. -} + -> (t, [yv]) + {- ^ The sampling frequency without unit and + the list of normalized samples. + This information should suffice for playback + or writing the signal to a file. -} +pureData freqUnit amp sig = + (toTimeScalar sig (recip freqUnit), + recip (toAmplitudeScalar sig amp) *> samples sig) + + +instance Functor (T t t' y y') where + fmap f (Cons sr sig) = Cons sr (fmap f sig) + + + +{- * Conversion from and to signals with sample rate context -} + + +runPlain :: + t' -> (Rate.T t t' -> SigC.T y y' yv) -> T t t' y y' yv +runPlain sr f = + addPlainSampleRate sr (f (Rate.fromNumber sr)) + +addPlainSampleRate :: + t' -> SigC.T y y' yv -> T t t' y y' yv +addPlainSampleRate sr = Cons (Rate.fromNumber sr) + +run :: + Rate.T t t' -> (Rate.T t t' -> SigC.T y y' yv) -> T t t' y y' yv +run sr f = + addSampleRate sr (f sr) + +addSampleRate :: + Rate.T t t' -> SigC.T y y' yv -> T t t' y y' yv +addSampleRate = Cons + +splitSampleRate :: + T t t' y y' yv -> (Rate.T t t', SigC.T y y' yv) +splitSampleRate (Cons sr sig) = (sr, sig) + +{- | +If the given sample rate matches the one of the signal, +then return the core signal, otherwise 'undefined'. +-} +checkSampleRate :: (Eq t') => + String -> + Rate.T t t' -> + T t t' y y' yv -> SigC.T y y' yv +checkSampleRate funcName sr0 (Cons sr sig) = + if sr0 == sr + then sig + else error ("checkSampleRate for " ++ funcName ++ ": sample rates differ") + +splitSampleRateList :: (Eq t') => + [T t t' y y' yv] -> (Rate.T t t', [SigC.T y y' yv]) +splitSampleRateList [] = error "splitSampleRateList: empty list" +splitSampleRateList xt@(x:_) = + let sr = fst (splitSampleRate x) + in (sr, map (checkSampleRate "splitSampleRateList" sr) xt) + + +apply :: + (Rate.T t t' -> SigC.T y0 y'0 y0v -> SigC.T y1 y'1 y1v) + -> T t t' y0 y'0 y0v + -> T t t' y1 y'1 y1v +apply f (Cons sr sig) = + run sr (flip f sig) + + +{- +commonSampleRate :: (Eq t') => + T t t' y0 y'0 yv0 -> T t t' y1 y'1 yv1 -> Rate.T t t' +commonSampleRate x0 x1 = Rate.fromNumber (SigP.commonSampleRate x0 x1) +-} + + +lift0 :: + (Rate.T t t' -> SigC.T y y' yv) + -> t' -> T t t' y y' yv +lift0 = flip runPlain + +lift1 :: + (Rate.T t t' -> SigC.T y0 y0' yv0 -> SigC.T y1 y1' yv1) + -> (T t t' y0 y0' yv0 -> T t t' y1 y1' yv1) +lift1 = apply + +lift2 :: (Eq t') => + (Rate.T t t' -> SigC.T y0 y'0 yv0 -> SigC.T y1 y'1 yv1 -> SigC.T y2 y'2 yv2) + -> (T t t' y0 y'0 yv0 -> T t t' y1 y'1 yv1 -> T t t' y2 y'2 yv2) +lift2 f x0 x1 = + let (_, y0) = splitSampleRate x0 + (_, y1) = splitSampleRate x1 + in runPlain (commonSampleRate x0 x1) (\sr -> f sr y0 y1) +{- + let (sr0, y0) = splitSampleRate x0 + (sr1, y1) = splitSampleRate x1 + sr = SigP.commonSampleRate' sr0 sr1 + in addSampleRate sr (f sr y0 y1) +-} + +lift3 :: (Eq t') => + (Rate.T t t' -> SigC.T y0 y'0 yv0 -> SigC.T y1 y'1 yv1 -> SigC.T y2 y'2 yv2 -> SigC.T y3 y'3 yv3) + -> (T t t' y0 y'0 yv0 -> T t t' y1 y'1 yv1 -> T t t' y2 y'2 yv2 -> T t t' y3 y'3 yv3) +lift3 f x0 x1 x2 = + let (sr0, y0) = splitSampleRate x0 + (sr1, y1) = splitSampleRate x1 + (sr2, y2) = splitSampleRate x2 + in run + (sr0 `commonSampleRate'` sr1 `commonSampleRate'` sr2) + (\sr -> f sr y0 y1 y2) + + +liftList :: Eq t' => + (Rate.T t t' -> [SigC.T y1 y'1 yv1] -> SigC.T y y' yv) + -> ([T t t' y1 y'1 yv1] -> T t t' y y' yv) +liftList f = + uncurry run . + mapSnd (flip f) . + splitSampleRateList + + + +liftR2 :: + (Rate.T t t' -> SigC.T y y' yv -> (SigC.T y0 y'0 yv0, SigC.T y1 y'1 yv1)) + -> T t t' y y' yv + -> (T t t' y0 y'0 yv0, T t t' y1 y'1 yv1) +liftR2 f x0 = + let (sr,x1) = splitSampleRate x0 + (y0,y1) = f sr x1 + in (addSampleRate sr y0, addSampleRate sr y1) + +liftR3 :: + (Rate.T t t' -> SigC.T y y' yv -> (SigC.T y0 y'0 yv0, SigC.T y1 y'1 yv1, SigC.T y2 y'2 yv2)) + -> T t t' y y' yv + -> (T t t' y0 y'0 yv0, T t t' y1 y'1 yv1, T t t' y2 y'2 yv2) +liftR3 f x0 = + let (sr,x1) = splitSampleRate x0 + (y0,y1,y2) = f sr x1 + in (addSampleRate sr y0, addSampleRate sr y1, addSampleRate sr y2) + + 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,336 @@ +{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-} +module Synthesizer.Plain.Analysis where + +import qualified Synthesizer.Plain.Signal as Sig +import qualified Synthesizer.Plain.Control as Ctrl +import qualified Synthesizer.Plain.Filter.Recursive.Integration as Integration + +-- import qualified Algebra.Module as Module +-- import qualified Algebra.Transcendental as Trans +import qualified Algebra.Algebraic as Algebraic +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Real as Real +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import qualified Algebra.NormedSpace.Maximum as NormedMax +import qualified Algebra.NormedSpace.Euclidean as NormedEuc +import qualified Algebra.NormedSpace.Sum as NormedSum + +import qualified Data.Array as Array + +import qualified Data.IntMap as IntMap + +-- import Algebra.Module((*>)) + +import Data.Array (accumArray) +import Data.List (foldl', ) + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +{- * Notions of volume -} + +{- | +Volume based on Manhattan norm. +-} +volumeMaximum :: (Real.C y) => Sig.T y -> y +volumeMaximum = + foldl max zero . rectify +-- maximum . rectify + +{- | +Volume based on Energy norm. +-} +volumeEuclidean :: (Algebraic.C y) => Sig.T y -> y +volumeEuclidean = + Algebraic.sqrt . volumeEuclideanSqr + +volumeEuclideanSqr :: (Field.C y) => Sig.T y -> y +volumeEuclideanSqr = + average . map sqr + +{- | +Volume based on Sum norm. +-} +volumeSum :: (Field.C y, Real.C y) => Sig.T y -> y +volumeSum = average . rectify + + + +{- | +Volume based on Manhattan norm. +-} +volumeVectorMaximum :: (NormedMax.C y yv, Ord y) => Sig.T yv -> y +volumeVectorMaximum = + NormedMax.norm +-- maximum . map NormedMax.norm + +{- | +Volume based on Energy norm. +-} +volumeVectorEuclidean :: (Algebraic.C y, NormedEuc.C y yv) => Sig.T yv -> y +volumeVectorEuclidean = + Algebraic.sqrt . volumeVectorEuclideanSqr + +volumeVectorEuclideanSqr :: (Field.C y, NormedEuc.Sqr y yv) => Sig.T yv -> y +volumeVectorEuclideanSqr = + average . map NormedEuc.normSqr + +{- | +Volume based on Sum norm. +-} +volumeVectorSum :: (NormedSum.C y yv, Field.C y) => Sig.T yv -> y +volumeVectorSum = + average . map NormedSum.norm + + + + +{- | +Compute minimum and maximum value of the stream the efficient way. +Input list must be non-empty and finite. +-} +bounds :: Ord y => Sig.T y -> (y,y) +bounds [] = error "Analysis.bounds: List must contain at least one element." +bounds (x:xs) = + foldl' (\(minX,maxX) y -> (min y minX, max y maxX)) (x,x) xs + + + + +{- * Miscellaneous -} + +{- +histogram: + length x = sum (histogramDiscrete x) + + units: + 1) histogram (amplify k x) = timestretch k (amplify (1/k) (histogram x)) + 2) histogram (timestretch k x) = amplify k (histogram x) + timestretch: k -> (s -> V) -> (k*s -> V) + amplify: k -> (s -> V) -> (s -> k*V) + histogram: (a -> b) -> (a^ia*b^ib -> a^ja*b^jb) + x: (s -> V) + 1) => (s^ia*(k*V)^ib -> s^ja*(k*V)^jb) + = (s^ia*V^ib*k -> s^ja*V^jb/k) + => ib=1, jb=-1 + 2) => ((k*s)^ia*V^ib -> (k*s)^ja*V^jb) + = (s^ia*V^ib -> s^ja*V^jb*k) + => ia=0, ja=1 + histogram: (s -> V) -> (V -> s/V) +histogram': + integral (histogram' x) = integral x + histogram' (amplify k x) = timestretch k (histogram' x) + histogram' (timestretch k x) = amplify k (histogram' x) + -> this does only apply if we slice the area horizontally + and sum the slice up at each level, + we must also restrict to the positive values, + this is not quite the usual histogram +-} + +{- | +Input list must be finite. +List is scanned twice, but counting may be faster. +-} +histogramDiscreteArray :: Sig.T Int -> (Int, Sig.T Int) +histogramDiscreteArray [] = + (error "histogramDiscreteArray: no bounds found", []) +histogramDiscreteArray x = + let hist = + accumArray (+) zero + (bounds x) (attachOne x) + in (fst (Array.bounds hist), Array.elems hist) + + +{- | +Input list must be finite. +If the input signal is empty, the offset is @undefined@. +List is scanned twice, but counting may be faster. +The sum of all histogram values is one less than the length of the signal. +-} +histogramLinearArray :: RealField.C y => Sig.T y -> (Int, Sig.T y) +histogramLinearArray [] = + (error "histogramLinearArray: no bounds found", []) +histogramLinearArray [x] = (floor x, []) +histogramLinearArray x = + let (xMin,xMax) = bounds x + hist = + accumArray (+) zero + (floor xMin, floor xMax) + (meanValues x) + in (fst (Array.bounds hist), Array.elems hist) + + +{- | +Input list must be finite. +If the input signal is empty, the offset is @undefined@. +List is scanned once, counting may be slower. +-} +histogramDiscreteIntMap :: Sig.T Int -> (Int, Sig.T Int) +histogramDiscreteIntMap [] = + (error "histogramDiscreteIntMap: no bounds found", []) +histogramDiscreteIntMap x = + let hist = IntMap.fromListWith (+) (attachOne x) + in case IntMap.toAscList hist of + [] -> error "histogramDiscreteIntMap: the list was non-empty before processing ..." + fAll@((fIndex,fHead):fs) -> (fIndex, fHead : + concat (zipWith + (\(i0,_) (i1,f1) -> replicate (i1-i0-1) zero ++ [f1]) + fAll fs)) + +histogramLinearIntMap :: RealField.C y => Sig.T y -> (Int, Sig.T y) +histogramLinearIntMap [] = + (error "histogramLinearIntMap: no bounds found", []) +histogramLinearIntMap [x] = (floor x, []) +histogramLinearIntMap x = + let hist = IntMap.fromListWith (+) (meanValues x) + -- we can rely on the fact that the keys are contiguous + (startKey:_, elems) = unzip (IntMap.toAscList hist) + in (startKey, elems) + -- This doesn't work, due to a bug in IntMap of GHC-6.4.1 + -- in (head (IntMap.keys hist), IntMap.elems hist) + +{- +The bug in IntMap GHC-6.4.1 is: + +*Synthesizer.Plain.Analysis> IntMap.keys $ IntMap.fromList $ [(0,0),(-1,-1::Int)] +[0,-1] +*Synthesizer.Plain.Analysis> IntMap.elems $ IntMap.fromList $ [(0,0),(-1,-1::Int)] +[0,-1] +*Synthesizer.Plain.Analysis> IntMap.assocs $ IntMap.fromList $ [(0,0),(-1,-1::Int)] +[(0,0),(-1,-1)] + +The bug has gone in IntMap as shipped with GHC-6.6. +-} + +histogramIntMap :: (RealField.C y) => y -> Sig.T y -> (Int, Sig.T Int) +histogramIntMap binsPerUnit = + histogramDiscreteIntMap . quantize binsPerUnit + +quantize :: (RealField.C y) => y -> Sig.T y -> Sig.T Int +quantize binsPerUnit = map (floor . (binsPerUnit*)) + +attachOne :: Sig.T i -> Sig.T (i,Int) +attachOne = map (\i -> (i,one)) + +meanValues :: RealField.C y => Sig.T y -> [(Int,y)] +meanValues x = concatMap spread (zip x (tail x)) + +spread :: RealField.C y => (y,y) -> [(Int,y)] +spread (l0,r0) = + let (l,r) = if l0<=r0 then (l0,r0) else (r0,l0) + (li,lf) = splitFraction l + (ri,rf) = splitFraction r + k = recip (r-l) + nodes = + (li,k*(1-lf)) : + zip [li+1 ..] (replicate (ri-li-1) k) ++ + (ri, k*rf) : + [] + in if li==ri + then [(li,one)] + else nodes + +{- | +Requires finite length. +This is identical to the arithmetic mean. +-} +directCurrentOffset :: Field.C y => Sig.T y -> y +directCurrentOffset = average + + +scalarProduct :: Ring.C y => Sig.T y -> Sig.T y -> y +scalarProduct xs ys = + sum (zipWith (*) xs ys) + +{- | +'directCurrentOffset' must be non-zero. +-} +centroid :: Field.C y => Sig.T y -> y +centroid xs = + scalarProduct (iterate (one+) zero) xs / sum xs + +centroidAlt :: Field.C y => Sig.T y -> y +centroidAlt xs = + sum (scanr (+) zero (tail xs)) / sum xs + + +average :: Field.C y => Sig.T y -> y +average x = + sum x / fromIntegral (length x) + +rectify :: Real.C y => Sig.T y -> Sig.T y +rectify = map abs + +{- | +Detects zeros (sign changes) in a signal. +This can be used as a simple measure of the portion +of high frequencies or noise in the signal. +It ca be used as voiced\/unvoiced detector in a vocoder. + +@zeros x !! n@ is @True@ if and only if +@(x !! n >= 0) \/= (x !! (n+1) >= 0)@. +The result will be one value shorter than the input. +-} +zeros :: (Ord y, Ring.C y) => Sig.T y -> Sig.T Bool +zeros xs = + let signs = map (>=zero) xs + in zipWith (/=) signs (tail signs) + + + +data BinaryLevel = Low | High + deriving (Eq, Show, Enum) + +binaryLevelFromBool :: Bool -> BinaryLevel +binaryLevelFromBool False = Low +binaryLevelFromBool True = High + +binaryLevelToNumber :: Ring.C a => BinaryLevel -> a +binaryLevelToNumber Low = negate one +binaryLevelToNumber High = one + + +{- | +Detect thresholds with a hysteresis. +-} +flipFlopHysteresis :: (Ord y) => + (y,y) -> BinaryLevel -> Sig.T y -> Sig.T BinaryLevel +flipFlopHysteresis (lower,upper) = + scanl + (\state x -> binaryLevelFromBool $ + case state of + High -> not(x 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/Control.hs b/src/Synthesizer/Plain/Control.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Plain/Control.hs @@ -0,0 +1,476 @@ +{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-} +module Synthesizer.Plain.Control where + +import Synthesizer.Plain.Displacement (raise) + +import qualified Synthesizer.Plain.Signal as Sig + +import qualified Algebra.Module as Module +import qualified Algebra.Transcendental as Trans +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Algebra.Module((*>)) + +import Number.Complex (cis,real) +-- import qualified Number.Complex as Complex +import Data.List (zipWith4, tails) +import NumericPrelude.List (iterateAssoc) + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +{- * Control curve generation -} + +constant :: y -> Sig.T y +constant = repeat + + +linear :: Additive.C y => + y {-^ steepness -} + -> y {-^ initial value -} + -> Sig.T y {-^ linear progression -} +linear d y0 = iterate (d+) y0 + +{- | +Minimize rounding errors by reducing number of operations per element +to a logarithmuc number. +-} +linearMultiscale :: Additive.C y => + y + -> y + -> Sig.T y +linearMultiscale = curveMultiscale (+) + +{- | +Linear curve starting at zero. +-} +linearMultiscaleNeutral :: Additive.C y => + y + -> Sig.T y +linearMultiscaleNeutral slope = + curveMultiscaleNeutral (+) slope zero + +{- | +As stable as the addition of time values. +-} +linearStable :: Ring.C y => + y + -> y + -> Sig.T y +linearStable d y0 = + curveStable (d*) (+) 1 y0 + + +{- | +It computes the same like 'linear' but in a numerically more stable manner, +namely using a subdivision scheme. +The division needed is a division by two. + +0 4 8 +0 2 4 6 8 +0 1 2 3 4 5 6 7 8 +-} +linearMean :: Field.C y => + y + -> y + -> Sig.T y +linearMean d y0 = y0 : + foldr (\pow xs -> y0+pow : linearSubdivision xs) + unreachable (iterate (2*) d) + +{- | Intersperse linearly interpolated values. -} +linearSubdivision :: Field.C y => + Sig.T y + -> Sig.T y +linearSubdivision = subdivide (\x0 x1 -> (x0+x1)/2) + + + +exponential, exponentialMultiscale, exponentialStable :: Trans.C y => + y {-^ time where the function reaches 1\/e of the initial value -} + -> y {-^ initial value -} + -> Sig.T y {-^ exponential decay -} +exponential time = iterate (* exp (- recip time)) +exponentialMultiscale time = curveMultiscale (*) (exp (- recip time)) +exponentialStable time = exponentialStableGen exp (- recip time) + +exponentialMultiscaleNeutral :: Trans.C y => + y {-^ time where the function reaches 1\/e of the initial value -} + -> Sig.T y {-^ exponential decay -} +exponentialMultiscaleNeutral time = + curveMultiscaleNeutral (*) (exp (- recip time)) one + +exponential2, exponential2Multiscale, exponential2Stable :: Trans.C y => + y {-^ half life -} + -> y {-^ initial value -} + -> Sig.T y {-^ exponential decay -} +exponential2 halfLife = iterate (* 0.5 ** recip halfLife) +exponential2Multiscale halfLife = curveMultiscale (*) (0.5 ** recip halfLife) +exponential2Stable halfLife = exponentialStableGen (0.5 **) (recip halfLife) + +exponential2MultiscaleNeutral :: Trans.C y => + y {-^ half life -} + -> Sig.T y {-^ exponential decay -} +exponential2MultiscaleNeutral halfLife = + curveMultiscaleNeutral (*) (0.5 ** recip halfLife) one + + +exponentialFromTo, exponentialFromToMultiscale :: Trans.C y => + y {-^ time where the function reaches 1\/e of the initial value -} + -> y {-^ initial value -} + -> y {-^ value after given time -} + -> Sig.T y {-^ exponential decay -} +exponentialFromTo time y0 y1 = + iterate (* (y1/y0) ** recip time) y0 +exponentialFromToMultiscale time y0 y1 = + curveMultiscale (*) ((y1/y0) ** recip time) y0 + + +exponentialStableGen :: (Ring.C y, Ring.C t) => + (t -> y) + -> t + -> y + -> Sig.T y +exponentialStableGen expFunc = curveStable expFunc (*) + + + + +{-| This is an extension of 'exponential' to vectors + which is straight-forward but requires more explicit signatures. + But since it is needed rarely I setup a separate function. -} +vectorExponential :: (Trans.C y, Module.C y v) => + y {-^ time where the function reaches 1\/e of the initial value -} + -> v {-^ initial value -} + -> Sig.T v {-^ exponential decay -} +vectorExponential time y0 = iterate (exp (-1/time) *>) y0 + +vectorExponential2 :: (Trans.C y, Module.C y v) => + y {-^ half life -} + -> v {-^ initial value -} + -> Sig.T v {-^ exponential decay -} +vectorExponential2 halfLife y0 = iterate (0.5**(1/halfLife) *>) y0 + + + +cosine, cosineMultiscale, cosineSubdiv, cosineStable :: Trans.C y => + y {-^ time t0 where 1 is approached -} + -> y {-^ time t1 where -1 is approached -} + -> Sig.T y {-^ a cosine wave where one half wave is between t0 and t1 -} +cosine = cosineWithSlope $ + \d x -> map cos (linear d x) + +cosineMultiscale = cosineWithSlope $ + \d x -> map real (curveMultiscale (*) (cis d) (cis x)) + + +{- + cos (a-b) = cos a * cos b + sin a * sin b + cos (a+b) = cos a * cos b - sin a * sin b + cos a = (cos (a-b) + cos (a+b)) / (2 * cos b) + + Problem: (cos b) might be close to zero, + example: Syn.cosineStable 1 (9::Double) +-} +cosineSubdiv = + let aux d y0 = + cos y0 : + foldr (\pow xs -> cos(y0+pow) : cosineSubdivision pow xs) + unreachable (iterate (2*) d) + in cosineWithSlope aux + +cosineSubdivision :: Trans.C y => + y + -> Sig.T y + -> Sig.T y +cosineSubdivision angle = + let k = recip (2 * cos angle) + in subdivide (\x0 x1 -> (x0+x1)*k) + +cosineStable = cosineWithSlope $ + \d x -> map real (exponentialStableGen cis d (cis x)) + + +cosineWithSlope :: Trans.C y => + (y -> y -> signal) + -> y + -> y + -> signal +cosineWithSlope c t0 t1 = + let inc = pi/(t1-t0) + in c inc (-t0*inc) + + +cubicHermite :: Field.C y => (y, (y,y)) -> (y, (y,y)) -> Sig.T y +cubicHermite node0 node1 = + map (cubicFunc node0 node1) (linear 1 0) + +{- | +0 16 +0 8 16 +0 4 8 12 16 +0 2 4 6 8 10 12 14 16 +0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 +-} +cubicFunc :: Field.C y => (y, (y,y)) -> (y, (y,y)) -> y -> y +cubicFunc (t0, (y0,dy0)) (t1, (y1,dy1)) t = + let dt = t0-t1 + dt0 = t-t0 + dt1 = t-t1 + x0 = dt1^2 + x1 = dt0^2 + in ((dy0*dt0 + y0 * (1-2/dt*dt0)) * x0 + + (dy1*dt1 + y1 * (1+2/dt*dt1)) * x1) / dt^2 +{- +cubic t0 (y0,dy0) t1 (y1,dy1) t = + let x0 = ((t-t1) / (t0-t1))^2 + x1 = ((t-t0) / (t1-t0))^2 + in y0 * x0 + y1 * x1 + + (dy0 - y0*2/(t0-t1)) * (t-t0)*x0 + + (dy1 - y1*2/(t1-t0)) * (t-t1)*x1 +-} + +cubicHermiteStable :: Field.C y => (y, (y,y)) -> (y, (y,y)) -> Sig.T y +cubicHermiteStable node0 node1 = + cubicFunc node0 node1 0 : + foldr (\pow xs -> + cubicFunc node0 node1 pow : head xs : + cubicFunc node0 node1 (3*pow) : cubicSubdivision xs) + unreachable (iterate (2*) 1) + +cubicSubdivision :: Field.C y => Sig.T y -> Sig.T y +cubicSubdivision xs = + let xs0:xs1:xs2:xs3:_ = tails xs + inter = zipWith4 (\x0 x1 x2 x3 -> (9*(x1+x2) - (x0+x3))/16) + xs0 xs1 xs2 xs3 + in head xs1 : flattenPairs (zip inter xs2) + +{- + foldr (\(pow0:pow1:_) ~(_:xs) -> + cos (y0+pow0) : cos (y0+pow1) : cos (y0+pow0+pow1) : + cosineSubdivision pow0 xs) + unreachable (tails (iterate (2*) d)) +-} + + +{- +maybe cubicHermite could also be implemented in a Multiscale manner +using a difference scheme. + +cubicHermiteMultiscale :: Field.C y => (y, (y,y)) -> (y, (y,y)) -> Sig.T y +cubicHermiteMultiscale node0@(t0,y0) node1@(t1,y1) = + let -- could be inlined and simplified + ys = map (cubicFunc node0 node1) [0,1,2,3] + (d0:d1:d2:d3:_) = iterate (zapWith substract) ys + +I thought multiplying difference schemes could help somehow, +but it doesn't. :-( + +cubicHermiteMultiscale + +Leibniz rule for differences + +D3(s+r) = D0(s)*D3(r) + 3*D1(s)*D2(r) + 3*D2(s)*D1(r) + D3(s)*D0(r) + + +mulDiffs4 :: Ring.C a => (a,a,a,a) -> (a,a,a,a) -> (a,a,a,a) +mulDiffs4 (r0,r1,r2,r3) (s0,s1,s2,s3) = + (r0*s0, + r0*s1 + r1*s0, + r0*s2 + 2*r1*s1 + r2*s0, + r0*s3 + 3*r1*s2 + 3*r2*s1 + r3*s0) + +mulDiffs4zero :: Ring.C a => (a,a,a) -> (a,a,a) -> (a,a,a) +mulDiffs4zero (r0,r1,r2,r3) (s0,s1,s2,s3) = + (r0*s0, + r0*s1 + r1*s0, + r0*s2 + 2*r1*s1 + r2*s0, + r0*s3 + 3*r1*s2 + 3*r2*s1 + r3*s0) + +mulDiffs3 :: Ring.C a => (a,a,a) -> (a,a,a) -> (a,a,a) +mulDiffs3 (r0,r1,r2) (s0,s1,s2) = + (r0*s0, + r0*s1 + r1*s0, + r0*s2 + 2*r1*s1 + r2*s0) + +mulDiffs3Karatsuba :: Ring.C a => (a,a,a) -> (a,a,a) -> (a,a,a) +mulDiffs3Karatsuba (r0,r1,r2) (s0,s1,s2) = + let r0s0 = r0*s0 + r1s1 = r1*s1 + in (r0s0, + (r0+r1)*(s0+s1) - r0s0 - r1s1, + r0*s2 + 2*r1s1 + r2*s0) +-} + + + +{- | +The curve type of a piece of a piecewise defined control curve. +-} +data Control y = + CtrlStep + | CtrlLin + | CtrlExp {ctrlExpSaturation :: y} + | CtrlCos + | CtrlCubic {ctrlCubicGradient0 :: y, + ctrlCubicGradient1 :: y} + deriving (Eq, Show) + +{- | +The full description of a control curve piece. +-} +data ControlPiece y = + ControlPiece {pieceType :: Control y, + pieceY0 :: y, + pieceY1 :: y, + pieceDur :: y} + deriving (Eq, Show) + + +newtype PieceRightSingle y = PRS y +newtype PieceRightDouble y = PRD y + +type ControlDist y = (y, Control y, y) + + +-- precedence and associativity like (:) +infixr 5 -|#, #|-, =|#, #|=, |#, #| + +{- | +The 6 operators simplify constructing a list of @ControlPiece a@. +The description consists of nodes (namely the curve values at nodes) +and the connecting curve types. +The naming scheme is as follows: +In the middle there is a bar @|@. +With respect to the bar, +the pad symbol @\#@ is at the side of the curve type, +at the other side there is nothing, a minus sign @-@, or an equality sign @=@. + + (1) Nothing means that here is the start or the end node of a curve. + + (2) Minus means that here is a node where left and right curve meet at the same value. + The node description is thus one value. + + (3) Equality sign means that here is a split node, + where left and right curve might have different ending and beginning values, respectively. + The node description consists of a pair of values. +-} + +-- the leading space is necessary for the Haddock parser + +( #|-) :: (y, Control y) -> (PieceRightSingle y, [ControlPiece y]) -> + (ControlDist y, [ControlPiece y]) +(d,c) #|- (PRS y1, xs) = ((d,c,y1), xs) + +(-|#) :: y -> (ControlDist y, [ControlPiece y]) -> + (PieceRightSingle y, [ControlPiece y]) +y0 -|# ((d,c,y1), xs) = (PRS y0, ControlPiece c y0 y1 d : xs) + +( #|=) :: (y, Control y) -> (PieceRightDouble y, [ControlPiece y]) -> + (ControlDist y, [ControlPiece y]) +(d,c) #|= (PRD y1, xs) = ((d,c,y1), xs) + +(=|#) :: (y,y) -> (ControlDist y, [ControlPiece y]) -> + (PieceRightDouble y, [ControlPiece y]) +(y01,y10) =|# ((d,c,y11), xs) = (PRD y01, ControlPiece c y10 y11 d : xs) + +( #|) :: (y, Control y) -> y -> + (ControlDist y, [ControlPiece y]) +(d,c) #| y1 = ((d,c,y1), []) + +(|#) :: y -> (ControlDist y, [ControlPiece y]) -> + [ControlPiece y] +y0 |# ((d,c,y1), xs) = ControlPiece c y0 y1 d : xs + + +piecewise :: (Trans.C y, RealField.C y) => + [ControlPiece y] -> Sig.T y +piecewise xs = + let ts = scanl (\(_,fr) d -> splitFraction (fr+d)) + (0,1) (map pieceDur xs) + in concat (zipWith3 + (\n t (ControlPiece c yi0 yi1 d) -> + piecewisePart yi0 yi1 t d n c) + (map fst (tail ts)) (map (subtract 1 . snd) ts) + xs) + + +piecewisePart :: (Trans.C y) => + y -> y -> y -> y -> Int -> Control y -> Sig.T y +piecewisePart y0 y1 t0 d n ctrl = + take n + (case ctrl of + CtrlStep -> constant y0 + CtrlLin -> let s = (y1-y0)/d in linearStable s (y0-t0*s) + CtrlExp s -> let y0' = y0-s; y1' = y1-s; yd = y0'/y1' + in raise s (exponentialStable (d / log yd) + (y0' * yd**(t0/d))) + CtrlCos -> map (\y -> (1+y)*(y0/2)+(1-y)*(y1/2)) + (cosineStable t0 (t0+d)) + CtrlCubic yd0 yd1 -> + cubicHermiteStable (t0,(y0,yd0)) (t0+d,(y1,yd1))) + +{- + exp (-1/time) == yd**(-1/d) + 1/time == log yd / d + time == d / log yd +-} + +{- + piecewise (0 |# (10.21, CtrlExp 1.1) #|- 1 -|# (10,CtrlExp 0.49) #|- 0.5 -|# (30, CtrlLin) #|- 0.5 -|# (20, CtrlCos) #| 0) + + piecewise (0 |# (10.21, CtrlExp 1.1) #|- 1 -|# (10,CtrlCubic (-0.1) 0) #|- 0.5 -|# (30, CtrlLin) #|- 0.5 -|# (20, CtrlCos) #| 0) +-} + + +{- * Auxiliary functions -} + +curveStable :: (Additive.C t) => + (t -> y) + -> (y -> y -> y) + -> t + -> y + -> Sig.T y +curveStable expFunc op time y0 = + y0 : map (op y0) + (foldr + (\e xs -> + let k = expFunc e + in k : concatMapPair (\x -> (x, op x k)) xs) + unreachable (iterate double time)) + +unreachable :: a +unreachable = error "only reachable in infinity" + +double :: Additive.C t => t -> t +double t = t+t + +concatMapPair :: (a -> (b,b)) -> Sig.T a -> Sig.T b +concatMapPair f = flattenPairs . map f + +flattenPairs :: Sig.T (a,a) -> Sig.T a +flattenPairs = foldr (\(a,b) xs -> a:b:xs) [] + +subdivide :: (y -> y -> y) -> Sig.T y -> Sig.T y +subdivide f xs0@(x:xs1) = + x : flattenPairs (zipWith (\x0 x1 -> (f x0 x1, x1)) xs0 xs1) +subdivide _ [] = [] + + +concatMapPair' :: (a -> (b,b)) -> Sig.T a -> Sig.T b +concatMapPair' f = concatMap ((\(x,y) -> [x,y]) . f) + + +curveMultiscale :: (y -> y -> y) -> y -> y -> Sig.T y +curveMultiscale op d y0 = + y0 : map (op y0) (iterateAssoc op d) + + +curveMultiscaleNeutral :: (y -> y -> y) -> y -> y -> Sig.T y +curveMultiscaleNeutral op d neutral = + neutral : iterateAssoc op d 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,93 @@ +{-# OPTIONS -fno-implicit-prelude #-} +{- | +Copyright : (c) Henning Thielemann 2006 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes +-} +module Synthesizer.Plain.Cut ( + {- * dissection -} + takeUntilPause, + takeUntilInterval, + + {- * glueing -} + selectBool, + select, + arrange, + ) where + +import qualified Synthesizer.Plain.Signal as Sig + +import qualified Data.EventList.Relative.TimeBody as EventList + +import qualified MathObj.LaurentPolynomial as Laurent +import qualified Algebra.Real as Real +import qualified Algebra.Additive as Additive + +import Data.Array (Array, Ix, (!)) + +import qualified Number.NonNegative as NonNeg + +import NumericPrelude.List (zipWithMatch) + +import PreludeBase +import NumericPrelude + + + +{- | +Take signal until it falls short of a certain amplitude for a given time. +-} +takeUntilPause :: (Real.C a) => a -> Int -> Sig.T a -> Sig.T a +takeUntilPause y = + takeUntilInterval ((<=y) . abs) + +{- | +Take values until the predicate p holds for n successive values. +The list is truncated at the beginning of the interval of matching values. +-} +takeUntilInterval :: (a -> Bool) -> Int -> Sig.T a -> Sig.T a +takeUntilInterval p n xs = + map fst $ + takeWhile (( if p x then succ acc else 0) 0 xs + ++ repeat 0 + + + +selectBool :: (Sig.T a, Sig.T a) -> Sig.T Bool -> Sig.T a +selectBool = + zipWithMatch (\(xf,xt) c -> if c then xt else xf) . + uncurry (zipWithMatch (,)) + + +select :: Ix i => Array i (Sig.T a) -> Sig.T i -> Sig.T a +select arr = + zipWith (!) + (map (fmap head) $ iterate (fmap tail) arr) + + + +{- | +Given a list of signals with time stamps, +mix them into one signal as they occur in time. +Ideally for composing music. + +Cf. 'MathObj.LaurentPolynomial.series' +-} +arrange :: (Additive.C v) => + EventList.T NonNeg.Int (Sig.T v) + {-^ A list of pairs: (relative start time, signal part), + The start time is relative to the start time + of the previous event. -} + -> Sig.T v + {-^ The mixed signal. -} +arrange evs = + let xs = EventList.getBodies evs + in case map NonNeg.toNumber (EventList.getTimes evs) of + t:ts -> replicate t zero ++ Laurent.addShiftedMany ts xs + [] -> [] 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 @@ +{-# OPTIONS -fno-implicit-prelude #-} +{- | + +-} +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,122 @@ +module Synthesizer.Plain.Effect where + +import qualified Synthesizer.Plain.Noise as Noise +import qualified Synthesizer.Plain.Filter.Recursive as Filter +import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1 +-- import qualified Synthesizer.Plain.Filter.Recursive.Allpass as Allpass +-- import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilter +import qualified Synthesizer.Plain.Filter.Recursive.Moog as Moog +import qualified Synthesizer.Plain.Filter.Recursive.Comb as Comb +-- import qualified Synthesizer.Plain.Filter.Recursive.Integration as Integrate +import qualified Synthesizer.Plain.Filter.Recursive.Butterworth as Butter +import qualified Synthesizer.Plain.Filter.Recursive.Chebyshev as Cheby +import Synthesizer.Plain.Control(exponential2) +import Synthesizer.Plain.Instrument +import Synthesizer.Plain.Effect.Glass(glass) +import qualified Sox +import qualified Sox.File +import Filter.Example(guitarRaw, flangedSaw) +--import Interpolation(interpolate,interpolateConstant) +--import System.Random +import System.Exit(ExitCode) +import System.Cmd(rawSystem) + +main :: IO ExitCode +main = + let rate = 44100 + in do {- Sox.File.writeMono "test" rate + (take (round (3*rate)) (soundD rate)) -} + Sox.File.renderMono "test" rate soundE + rawSystem "sox" (Sox.sampleRateOption rate ++ ["test.sw", "test.aiff"]) + rawSystem "play" ["test.aiff"] + + +soundE, soundD, + soundC, soundB, soundA, + sound9, sound8, sound7, + sound6, sound5, sound4, + sound3, sound2, sound1, + sound0, soundm0 :: Double -> [Double] + +soundE = glass + +soundD = flangedSaw + +soundC _ = guitarRaw + +cFreq :: Double +cFreq = 521.3417849066773 + +soundB sampleRate = + let baseFreq = cFreq/2 + chord = zipWith3 (\x y z -> (x+y+z)/5) + (choir sampleRate (baseFreq*1/1)) + (choir sampleRate (baseFreq*5/4)) + (choir sampleRate (baseFreq*3/2)) + filterFreqs = map (3000/sampleRate*) + (map sin (iterate (pi/(6*sampleRate)+) 0)) + in Butter.lowpass 8 (0.3::Double) filterFreqs (chord::[Double]) + +soundA sampleRate = + choir sampleRate cFreq + +sound9 sampleRate = + map (*0.1) (accumulatedSaws sampleRate cFreq !! 20) + +sound8 sampleRate = + let filterFreqs = exponential2 (-0.5*sampleRate) (100/sampleRate) + -- Cheby.lowpassB + -- Cheby.highpassB + -- Cheby.lowpassA + -- Cheby.highpassA + in Cheby.lowpassB 8 (0.3::Double) filterFreqs (Noise.white::[Double]) + +sound7 sampleRate = + let filterFreqs = exponential2 (-0.5*sampleRate) (100/sampleRate) + -- butterworthHighpass + in Butter.lowpass 8 (0.3::Double) filterFreqs (Noise.white::[Double]) + +-- a moog filter which randomly changes the resonance frequency +sound6 sampleRate = + let order = 10 + {- unused + switchRates = repeat (8/sampleRate) + filterFreqs = map (\exp -> 100*2**exp/sampleRate) + ((randomRs (0,6) (mkStdGen 142857))::[Double]) + filterReso = 10 + -} + + control0 {-, control1, control2-} :: [Moog.Parameter Double] + -- constant control + control0 = repeat (Moog.parameter order (Filter.Pole 10 (400/sampleRate))) + -- apply moogFilterParam first then resample, fast + {- Need Additive and VectorSpace instances for MoogFilterParam + control1 = interpolateConstant 0 switchRates + (map (moogFilterParam order) + (map (Pole filterReso) filterFreqs)) + -- first resample then apply moogFilterParam, slow + control2 = map (moogFilterParam order) + (map (Pole filterReso) + (interpolateConstant 0 switchRates filterFreqs)) + -} + in Moog.lowpass order control0 + (map (0.5*) (fatSawChord sampleRate 220)) + +sound5 sampleRate = + Comb.runMulti + (map (\t -> round (t*sampleRate)) [0.08,0.13,0.21]) + (0.3::Double) (bell sampleRate 441) +sound4 sampleRate = + Comb.runProc + (round (0.3*sampleRate)) + (Filt1.lowpass + (repeat (Filt1.parameter (441/sampleRate::Double)))) + (bell sampleRate 441) + +sound3 sampleRate = allpassPlain sampleRate 0.3 1 441 +sound2 sampleRate = allpassDown sampleRate 10 0.5 1000 441 + +sound1 sampleRate = map (0.1*) (moogDown sampleRate 6 0.4 5000 441) +sound0 sampleRate = map (0.3*) (moogReso sampleRate 6 0.1 2000 441) + +soundm0 sampleRate = fatSawChordFilter sampleRate 110 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 @@ +{-# OPTIONS -fno-implicit-prelude #-} +module Synthesizer.Plain.Effect.Fly where + +import qualified Synthesizer.Plain.Oscillator as Osci +import qualified Synthesizer.Plain.Filter.NonRecursive as FiltNR +import qualified Synthesizer.Plain.Interpolation as Interpolation +import qualified Synthesizer.Plain.Miscellaneous as Syn + +import Sox.File +import System.Exit(ExitCode) + +import System.Random + +import qualified Algebra.NormedSpace.Euclidean as Euc + +import PreludeBase +import NumericPrelude + + +{- + ghc -O -fvia-C -fglasgow-exts -fallow-undecidable-instances --make Fly.hs && echo start && time a.out +-} + +main :: IO ExitCode +main = + Sox.File.writeStereo "Fly" sampleRate + (take (round (10*sampleRate)) fly) + +sampleRate :: Double +sampleRate = 44100 + +{-| stereo sound of a humming fly -} +fly :: [(Double,Double)] +fly = + let pinkNoise seed freq range = + Interpolation.multiRelativeZeroPadCubic (0::Double) + (repeat (freq/sampleRate)) + (randomRs (-range,range) (mkStdGen seed)) + {- the track of a fly is composed of a slow motion over a big range + and fast but small oscillations -} + flyCoord seed = zipWith (+) (pinkNoise seed 40 0.3) + (pinkNoise seed 1 10) + {- explicit signature required + because of multi-param type class NormedEuc -} + trajectory :: [(Double, Double, Double)] + trajectory = + zip3 (flyCoord 366210) + (flyCoord 234298) + (flyCoord 654891) + + channel ear = + let (phase,volumes) = Syn.receive3Dsound 1 0.1 ear trajectory + -- (*sampleRate) in 'speed' and + -- (/sampleRate) in 'freqs' neutralizes + speeds = map (\v -> 250/sampleRate+2*(Euc.norm v)) + (zipWith subtract (tail trajectory) trajectory) + freqs = zipWith (+) speeds (FiltNR.differentiate phase) + sound = Osci.freqModSaw 0 freqs + in zipWith (*) (map (10*) volumes) sound + + in zip (channel (-1,0,0)) (channel (1,0,0)) 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 @@ +{-# OPTIONS -fno-implicit-prelude #-} +module Synthesizer.Plain.Effect.Glass where + +import qualified Data.EventList.Relative.TimeBody as EventList +import qualified Number.NonNegative as NonNeg + +import qualified Synthesizer.Plain.Oscillator as Osci +import qualified Synthesizer.Basic.Wave as Wave +import qualified Synthesizer.Plain.Cut as Cut +import qualified Synthesizer.Plain.Control as Ctrl +import qualified Synthesizer.Plain.Noise as Noise +import qualified Synthesizer.Plain.Filter.NonRecursive as FiltNR + +import qualified Algebra.Transcendental as Trans +import qualified Algebra.RealField as RealField +import qualified Algebra.Additive as Additive +import qualified Algebra.Module as Module + +import System.Random(randomRs, mkStdGen) + +import PreludeBase +import NumericPrelude as NP + + +{- | We try to simulate the sound of broken glass + as a mixture of short percussive sounds with random pitch -} +glass :: Double -> [Double] +glass sampleRate = + Cut.arrange (particles sampleRate 1500) + +particles :: Double -> Double -> EventList.T NonNeg.Int [Double] +particles sampleRate freq = + let sampledDensity = + (2000/sampleRate) *> map densityHeavy [0, (1/sampleRate) ..] + pattern = take (round (0.8*sampleRate)) + (Noise.randomPeeks sampledDensity) + times = timeDiffs pattern + chirp = iterate (0.001+) 0 + pitches = map ((freq*) . (2**)) + (zipWith (+) chirp (randomRs (0,1) (mkStdGen 56))) + amps = map (0.4*) (map (2**) (randomRs (-2,0) (mkStdGen 721))) + in EventList.fromPairList $ zip times $ + zipWith (particle sampleRate) pitches amps + + +particle :: (RealField.C a, Trans.C a, Module.C a a) => a -> a -> a -> [a] +particle sampleRate freq amp = + let halfLife = 0.01 + in take (round (10*halfLife*sampleRate)) + (FiltNR.envelopeVector + (Osci.static Wave.square 0 (freq/sampleRate)) + (Ctrl.exponential2 (0.01*sampleRate) amp)) + +densitySmooth, densityHeavy :: Trans.C a => a -> a +densitySmooth x = x * exp(-10*x*x) +densityHeavy x = 0.4 * exp (-4*x) + +timeDiffsAlt :: [Bool] -> [NonNeg.Int] +timeDiffsAlt = + let diffs n (True : xs) = n : diffs 1 xs + diffs n (False : xs) = diffs (succ n) xs + diffs _ [] = [] + in diffs (NonNeg.fromNumber 0) + +timeDiffs :: [Bool] -> [NonNeg.Int] +timeDiffs = map (NonNeg.fromNumber . length) . segmentBefore id + +segmentBefore :: (a -> Bool) -> [a] -> [[a]] +segmentBefore p = + foldr (\ x ~(y:ys) -> (if p x then ([]:) else id) ((x:y):ys)) [[]] 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 @@ +{-# OPTIONS -fno-implicit-prelude #-} +module Synthesizer.Plain.Filter.Delay where + +import qualified Synthesizer.Plain.Filter.NonRecursive as FiltNR +import qualified Synthesizer.Plain.Displacement as Syn +import qualified Synthesizer.Plain.Control as Ctrl +import qualified Synthesizer.Plain.Noise as Noise +import System.Random (Random, randomRs, mkStdGen, ) + +import qualified Algebra.Module as Module +import qualified Algebra.RealField as RealField +import qualified Algebra.Additive as Additive + +import qualified Synthesizer.Plain.Interpolation as Interpolation + +import qualified Synthesizer.Plain.Filter.Delay.ST as DelayST +import qualified Synthesizer.Plain.Filter.Delay.List as DelayList +import qualified Synthesizer.Plain.Filter.Delay.Block as DelayBlock + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +phaser :: (Module.C a v, RealField.C a) => a -> [a] -> [v] -> [v] +phaser maxDelay ts xs = + FiltNR.amplifyVector (0.5 `asTypeOf` head ts) + (Syn.mix xs + (DelayBlock.modulated Interpolation.constant (ceiling maxDelay) ts xs)) + + +plane :: Double -> [Double] +plane sampleRate = + let maxDelay = 500 + in phaser + maxDelay + (map (maxDelay-) + (Ctrl.exponential2 (10*sampleRate) maxDelay)) + Noise.white + + +-- move to test suite *** +propSingle :: Interpolation.T Double Double -> [Bool] +propSingle ip = + let maxDelay = (5::Int) + xs = randomRs (-1,1) (mkStdGen 1037) + ts = take 20 (randomRs (0, fromIntegral maxDelay) (mkStdGen 2330)) + pm0 = DelayST.modulated ip maxDelay ts xs + pm1 = DelayList.modulatedRev ip maxDelay ts xs + pm2 = DelayList.modulated ip maxDelay ts xs + pm3 = DelayBlock.modulated ip maxDelay ts xs + approx x y = abs (x-y) < 1e-10 + -- equal as = and (zipWith (==) as (tail as)) + -- equal [pm0, pm1 {-, pm2-}] + in [pm0==pm1, pm2==pm3, and (zipWith approx pm1 pm2)] + +{- | +The test for constant interpolation will fail, +due to different point of views in forward and backward interpolation. +-} +propAll :: [[Bool]] +propAll = + map propSingle $ + Interpolation.constant : + Interpolation.linear : + Interpolation.cubic : + [] 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 @@ +{-# OPTIONS -fno-implicit-prelude #-} +{- | +Fast delay based on block lists. +Blocks are arrays. They are part of Haskell 98. +In contrast to ring buffers, +block lists allow infinite look ahead. +-} +module Synthesizer.Plain.Filter.Delay.Block where + +import qualified Synthesizer.Plain.Interpolation as Interpolation +import qualified Synthesizer.Plain.Signal as Sig + +import qualified Algebra.RealField as RealField +import qualified Algebra.Additive as Additive + +import Data.Array((!), Array, listArray, elems, bounds, indices, rangeSize) +import Data.List(tails) + +import Test.QuickCheck ((==>), Property) + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +modulatedCore :: (RealField.C a, Additive.C v) => + Interpolation.T a v -> Int -> Sig.T a -> Sig.T v -> Sig.T v +modulatedCore ip size ts = + zipWith + (\t (offset,bs) -> + let (ti,tf) = splitFraction (-t) + in Interpolation.func ip tf (dropBlocksToList (size+offset+ti) bs)) + ts . + suffixIndexes . + {- Using 'size' for the block size is a heuristics, + maybe it is not a good choice in many cases. -} + listToBlocks size + +modulated :: (RealField.C a, Additive.C v) => + Interpolation.T a v -> Int -> Sig.T a -> Sig.T v -> Sig.T v +modulated ip maxDelay ts xs = + let size = maxDelay + Interpolation.number ip + in modulatedCore ip + (size - Interpolation.offset ip) + ts + (replicate size zero ++ xs) + + +type BlockList a = [Array Int a] + + +listToBlocks :: Int -> Sig.T a -> BlockList a +listToBlocks blockSize = + map (listArray (0,blockSize-1)) . + takeWhile (not . null) . + iterate (drop blockSize) + + +dropBlocksToList :: Int -> BlockList a -> Sig.T a +dropBlocksToList number blocks = + let dropUntil remain (b:bs) = + if remain <= snd (bounds b) + then (remain, b, bs) + else dropUntil (remain - rangeSize (bounds b)) bs + dropUntil remain [] = (remain, listArray (0,-1) [], []) + (offset, lead, suffix) = dropUntil number blocks + in map (lead!) [offset .. (snd $ bounds lead)] ++ + concatMap elems suffix + +propDrop :: Int -> Int -> [Int] -> Property +propDrop size n xs = + let infXs = cycle xs + len = 1000 + in size>0 && n>=0 && not (null xs) ==> + take len (drop n infXs) == + take len (dropBlocksToList n (listToBlocks size infXs)) + +{- | +Drop elements from a blocked list. +The offset must lie in the leading block. +-} +dropSingleBlocksToList :: Int -> BlockList a -> Sig.T a +dropSingleBlocksToList number (arr:arrs) = + map (arr!) [number .. (snd $ bounds arr)] ++ + concatMap elems arrs +dropSingleBlocksToList _ [] = [] + + +suffixIndexes :: BlockList a -> [(Int, BlockList a)] +suffixIndexes xs = + do blockSuffix <- init $ tails xs + i <- indices $ head blockSuffix + return (i,blockSuffix) 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 @@ +{-# OPTIONS -fno-implicit-prelude #-} +module Synthesizer.Plain.Filter.Delay.List where + +import qualified Synthesizer.Plain.Interpolation as Interpolation + +import qualified Algebra.RealField as RealField +import qualified Algebra.Additive as Additive + +import Data.List(tails) + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +{- | +This function uses suffixes of the reversed signal. +This way small delays perform well +but the big drawback is that the garbage collector +can not deallocate old samples. +-} +modulatedRevCore :: (RealField.C a, Additive.C v) => + Interpolation.T a v -> Int -> [a] -> [v] -> [v] +modulatedRevCore ip size ts xs = + zipWith + (\t x -> + let (ti,tf) = splitFraction t + in Interpolation.func ip tf (drop ti x)) + ts (drop size (scanl (flip (:)) [] xs)) + +modulatedRev :: (RealField.C a, Additive.C v) => + Interpolation.T a v -> Int -> [a] -> [v] -> [v] +modulatedRev ip maxDelay ts xs = + let size = maxDelay + Interpolation.number ip + in modulatedRevCore ip + (size + 1 + Interpolation.offset ip) + ts + (replicate size zero ++ xs) + + + +modulatedCore :: (RealField.C a, Additive.C v) => + Interpolation.T a v -> Int -> [a] -> [v] -> [v] +modulatedCore ip size ts xs = + zipWith + (\t x -> + let (ti,tf) = splitFraction (-t) + in Interpolation.func ip tf (drop (size+ti) x)) + ts (tails xs) + +{- | +This is essentially different for constant interpolation, +because this function "looks forward" +whereas the other two variants "look backward". +For the symmetric interpolation functions +of linear and cubic interpolation, this does not really matter. +-} +modulated :: (RealField.C a, Additive.C v) => + Interpolation.T a v -> Int -> [a] -> [v] -> [v] +modulated ip maxDelay ts xs = + let size = maxDelay + Interpolation.number ip + in modulatedCore ip + (size - Interpolation.offset ip) + ts + (replicate size zero ++ xs) 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 @@ +{-# OPTIONS -fno-implicit-prelude #-} +{- | +An implementation of a Delay using a classical circular buffer +running in the State Thread monad. +-} +module Synthesizer.Plain.Filter.Delay.ST where + +import qualified Synthesizer.Plain.Interpolation as Interpolation + +import qualified Algebra.RealField as RealField +import qualified Algebra.Additive as Additive + +import Control.Monad.ST.Lazy(runST,strictToLazyST,ST) +import Data.Array.ST + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +{- +I had no success in hiding ST in the 'modulatedST' function. +The explicit type signature is crucial. +-} +modulatedAction :: (RealField.C a, Additive.C v) => + Interpolation.T a v -> Int -> [a] -> [v] -> ST s [v] +modulatedAction ip size ts xs = + let ipNum = Interpolation.number ip + ipFunc = Interpolation.func ip + in do arr <- strictToLazyST (newArray (0,2*size-1) zero) + :: Additive.C v => ST s (STArray s Int v) + mapM (\(n,t,x) -> strictToLazyST $ + do writeArray arr n x + writeArray arr (n+size) x + let (ti,tf) = splitFraction t + y <- mapM (readArray arr) (take ipNum [(n+ti) ..]) + return (if ti<0 + then error "negative delay" + else + if size < ti+ipNum + then error "too much delay" + else ipFunc tf y)) + (zip3 (cycle [(size-1),(size-2)..0]) ts xs) + +modulated :: (RealField.C a, Additive.C v) => + Interpolation.T a v -> Int -> [a] -> [v] -> [v] +modulated ip maxDelay ts xs = + let offset = Interpolation.offset ip + in drop offset + (runST + (modulatedAction + ip (maxDelay + Interpolation.number ip) + (replicate offset zero ++ ts) xs)) + + 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 NumericPrelude.List (takeMatch, dropMatch, ) +import qualified Data.List as List + +import NumericPrelude +import PreludeBase +import Prelude () + + +{- | +Determine optimal filter coefficients and residue by adaptive approximation. +The number of initial filter coefficients is used as filter order. +-} +approxCoefficients :: Field.C a => + a -> [a] -> [a] -> [(a,[a])] +approxCoefficients k mask0 xs = + let infixes = map (takeMatch mask0) (List.tails xs) + targets = dropMatch mask0 xs + in scanl + (\(_,mask) (infx,target) -> + let residue = target - scalarProduct mask infx + norm2 = scalarProduct infx infx + in (residue, + mask + map ((k*residue/norm2)*) infx)) + (zero,mask0) (zip infixes targets) +{- +mapM print $ take 20 $ drop 2000 $ approxCoefficients (1::Double) [0,0,0,0.1] (iterate (1+) 100) + + +mapM print $ take 20 $ drop 10000 $ approxCoefficients (0.2::Double) [0.1,0] (map sin (iterate (0.03+) 0)) + +must yield coefficients [-1, 2*cos(0.03::Double)] +-} 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 @@ +{-# OPTIONS -fno-implicit-prelude #-} +{- | +Copyright : (c) Henning Thielemann 2006 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes +-} +module Synthesizer.Plain.Filter.NonRecursive where + +import qualified Synthesizer.Plain.Control as Ctrl +import qualified Synthesizer.Plain.Signal as Sig + +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Module as Module +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Algebra.Module(linearComb, (*>)) + +import Synthesizer.Utility (nest, ) +import Data.List (tails) + +-- import Control.Monad.State (StateT) +-- import Control.Monad.Writer (WriterT) + +import PreludeBase +import NumericPrelude + + +{- * Envelope application -} + +amplify :: (Ring.C a) => a -> Sig.T a -> Sig.T a +amplify v = map (v*) + +amplifyVector :: (Module.C a v) => a -> Sig.T v -> Sig.T v +amplifyVector = (*>) + + +envelope :: (Ring.C a) => + Sig.T a {-^ the envelope -} + -> Sig.T a {-^ the signal to be enveloped -} + -> Sig.T a +envelope = zipWith (*) + +envelopeVector :: (Module.C a v) => + Sig.T a {-^ the envelope -} + -> Sig.T v {-^ the signal to be enveloped -} + -> Sig.T v +envelopeVector = zipWith (*>) + + + +fadeInOut :: (Field.C a) => Int -> Int -> Int -> Sig.T a -> Sig.T a +fadeInOut tIn tHold tOut xs = + let leadIn = take tIn $ Ctrl.linearMultiscale ( recip (fromIntegral tIn)) 0 + leadOut = take tOut $ Ctrl.linearMultiscale (- recip (fromIntegral tOut)) 1 + (partIn, partHoldOut) = splitAt tIn xs + (partHold, partOut) = splitAt tHold partHoldOut + in envelope leadIn partIn ++ + partHold ++ + envelope leadOut partOut + + +fadeInOutAlt :: (Field.C a) => Int -> Int -> Int -> Sig.T a -> Sig.T a +fadeInOutAlt tIn tHold tOut = + zipWith id + ((map (\x y -> y * fromIntegral x / fromIntegral tIn) [0..tIn-1]) ++ + (replicate tHold id) ++ + (map (\x y -> y * fromIntegral x / fromIntegral tOut) [tOut-1,tOut-2..0])) + + + +{- * Shift -} + +delay :: Additive.C y => Int -> Sig.T y -> Sig.T y +delay = delayPad zero + +delayPad :: y -> Int -> Sig.T y -> Sig.T y +delayPad z n = + if n<0 + then drop (negate n) + else (replicate n z ++) + + +{- * Smoothing -} + + +{-| Unmodulated non-recursive filter -} +generic :: Module.C a v => + Sig.T a -> Sig.T v -> Sig.T v +generic m x = + let mr = reverse m + xp = delay (pred (length m)) x + in map (linearComb mr) (init (tails xp)) + +{-| +Unmodulated non-recursive filter +Output has same length as the input. + +It is elegant but leaks memory. + -} +genericAlt :: Module.C a v => + Sig.T a -> Sig.T v -> Sig.T v +genericAlt m x = + map (linearComb m) + (tail (scanl (flip (:)) [] x)) + + +propGeneric :: (Module.C a v, Eq v) => + Sig.T a -> Sig.T v -> Bool +propGeneric m x = +-- generic m x == genericAlt m x + and $ zipWith (==) (generic m x) (genericAlt m x) + + + +{- | +@eps@ is the threshold relatively to the maximum. +That is, if the gaussian falls below @eps * gaussian 0@, +then the function truncated. +-} +gaussian :: (Trans.C a, RealField.C a, Module.C a v) => a -> a -> a -> Sig.T v -> Sig.T v +gaussian eps ratio freq = + let var = ratioFreqToVariance ratio freq + area = var * sqrt (2*pi) + gau t = exp (-(t/var)^2/2) / area + width = ceiling (var * sqrt (-2 * log eps)) -- inverse gau + gauSmp = map (gau . fromIntegral) [-width .. width] + in drop width . generic gauSmp + +{- +GNUPlot.plotList [] (take 1000 $ gaussian 0.001 0.5 0.04 (Filter.Test.chirp 5000) :: [Double]) + +The filtered chirp must have amplitude 0.5 at 400 (0.04*10000). +-} + +{- + We want to approximate a Gaussian by a binomial filter. + The latter one can be implemented by a convolutional power. + However we still require a number of operations per sample + which is proportional to the variance. +-} +binomial :: (Trans.C a, RealField.C a, Module.C a v) => a -> a -> Sig.T v -> Sig.T v +binomial ratio freq = + let width = ceiling (2 * ratioFreqToVariance ratio freq ^ 2) + in drop width . nest (2*width) ((asTypeOf 0.5 freq *>) . binomial1) + +{- +exp (-(t/var)^2/2) / area *> cis (2*pi*f*t) + == exp (-(t/var)^2/2 +: 2*pi*f*t) / area + == exp ((-t^2 +: 2*var^2*2*pi*f*t) / (2*var^2)) / area + == exp ((t^2 - i*2*var^2*2*pi*f*t) / (-2*var^2)) / area + == exp (((t^2 - i*var^2*2*pi*f)^2 + (var^2*2*pi*f)^2) / (-2*var^2)) / area + == exp (((t^2 - i*var^2*2*pi*f)^2 / (-2*var^2) - (var*2*pi*f)^2/2)) / area + +sumMap (\t -> exp (-(t/var)^2/2) / area *> cis (2*pi*f*t)) + [-infinity..infinity] + ~ sumMap (\t -> exp (-(t/var)^2/2)) [-infinity..infinity] + * exp (-(var*2*pi*f)^2/2) / area + = exp (-(var*2*pi*f)^2/2) +-} +{- | + Compute the variance of the Gaussian + such that its Fourier transform has value @ratio@ at frequency @freq@. +-} +ratioFreqToVariance :: (Trans.C a) => a -> a -> a +ratioFreqToVariance ratio freq = + sqrt (-2 * log ratio) / (2*pi*freq) + -- inverse of the fourier transformed gaussian + +binomial1 :: (Additive.C v) => Sig.T v -> Sig.T v +binomial1 xt@(x:xs) = x : (xs + xt) +binomial1 [] = [] + + + + + + +{- | +Moving (uniformly weighted) average in the most trivial form. +This is very slow and needs about @n * length x@ operations. +-} +sums :: (Additive.C v) => Int -> Sig.T v -> Sig.T v +sums n = map (sum . take n) . init . tails + + + +sumsDownsample2 :: (Additive.C v) => Sig.T v -> Sig.T v +sumsDownsample2 (x0:x1:xs) = (x0+x1) : sumsDownsample2 xs +sumsDownsample2 xs = xs + +downsample2 :: Sig.T a -> Sig.T a +downsample2 (x0:_:xs) = x0 : downsample2 xs +downsample2 xs = xs + + +{- | +Given a list of numbers +and a list of sums of (2*k) of successive summands, +compute a list of the sums of (2*k+1) or (2*k+2) summands. + +Eample for 2*k+1 + +@ + [0+1+2+3, 2+3+4+5, 4+5+6+7, ...] -> + [0+1+2+3+4, 1+2+3+4+5, 2+3+4+5+6, 3+4+5+6+7, 4+5+6+7+8, ...] +@ + +Example for 2*k+2 + +@ + [0+1+2+3, 2+3+4+5, 4+5+6+7, ...] -> + [0+1+2+3+4+5, 1+2+3+4+5+6, 2+3+4+5+6+7, 3+4+5+6+7+8, 4+5+6+7+8+9, ...] +@ +-} +sumsUpsampleOdd :: (Additive.C v) => Int -> Sig.T v -> Sig.T v -> Sig.T v +sumsUpsampleOdd n {- 2*k -} xs ss = + let xs2k = drop n xs + in (head ss + head xs2k) : + concat (zipWith3 (\s x0 x2k -> [x0+s, s+x2k]) + (tail ss) + (downsample2 (tail xs)) + (tail (downsample2 xs2k))) + +sumsUpsampleEven :: (Additive.C v) => Int -> Sig.T v -> Sig.T v -> Sig.T v +sumsUpsampleEven n {- 2*k -} xs ss = + sumsUpsampleOdd (n+1) xs (zipWith (+) ss (downsample2 (drop n xs))) + +sumsPyramid :: (Additive.C v) => Int -> Sig.T v -> Sig.T v +sumsPyramid = + let aux 1 ys = ys + aux 2 ys = ys + tail ys -- binomial1 + aux m ys = + let ysd = sumsDownsample2 ys + in if even m + then sumsUpsampleEven (m-2) ys (aux (div (m-2) 2) ysd) + else sumsUpsampleOdd (m-1) ys (aux (div (m-1) 2) ysd) + in aux + + +{- +*Synthesizer.Plain.Filter.NonRecursive> movingAverageModulated 10 (replicate 10 (3::Double) ++ [1.1,2.2,2.6,0.7,0.1,0.1]) (repeat (1::Double)) +[0.5,0.6666666666666666,0.8333333333333333,1.0,1.0,1.0,1.0,1.0,1.0,1.0,0.9999999999999999,1.0,0.9999999999999998,0.999999999999999,0.9999999999999942,0.9999999999999942] +-} + + +{- * Filter operators from calculus -} + +{- | +Forward difference quotient. +Shortens the signal by one. +Inverts 'Synthesizer.Plain.Filter.Recursive.Integration.run' in the sense that +@differentiate (zero : integrate x) == x@. +The signal is shifted by a half time unit. +-} +differentiate :: Additive.C v => Sig.T v -> Sig.T v +differentiate x = zipWith subtract x (tail x) + +{- | +Central difference quotient. +Shortens the signal by two elements, +and shifts the signal by one element. +(Which can be fixed by prepending an appropriate value.) +For linear functions this will yield +essentially the same result as 'differentiate'. +You obtain the result of 'differentiateCenter' +if you smooth the one of 'differentiate' +by averaging pairs of adjacent values. + +ToDo: Vector variant +-} +differentiateCenter :: Field.C v => Sig.T v -> Sig.T v +differentiateCenter x = + map ((1/2)*) $ + zipWith subtract x (tail (tail x)) + +{- | +Second derivative. +It is @differentiate2 == differentiate . differentiate@ +but 'differentiate2' should be faster. +-} +differentiate2 :: Additive.C v => Sig.T v -> Sig.T v +differentiate2 xs0 = + let xs1 = tail xs0 + xs2 = tail xs1 + in zipWith3 (\x0 x1 x2 -> x0+x2-(x1+x1)) xs0 xs1 xs2 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,54 @@ +{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes +-} +module Synthesizer.Plain.Filter.Recursive where + +import qualified Algebra.Module as Module +-- import qualified Algebra.Transcendental as Trans +-- import qualified Algebra.Field as Field +-- import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Algebra.Additive((+), (-), negate, ) +import Algebra.Module((*>)) + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +{- * Various Filters -} + + +{- ** Recursive filters with resonance -} + +{-| Description of a filter pole. -} +data Pole a = + Pole {poleResonance :: !a {- ^ Resonance, that is the amplification of the band center frequency. -} + , poleFrequency :: !a {- ^ Band center frequency. -} } + deriving (Eq, Show, Read) + +instance Additive.C v => Additive.C (Pole v) where + zero = Pole zero zero + (+) (Pole yr yf) (Pole xr xf) = Pole (yr + xr) (yf + xf) + (-) (Pole yr yf) (Pole xr xf) = Pole (yr - xr) (yf - xf) + negate (Pole xr xf) = Pole (negate xr) (negate xf) + +{- +An instance for Module.C of the Pole datatype +makes no sense in most cases, +but when it comes to interpolation +this is very handy. +-} +instance Module.C a v => Module.C a (Pole v) where + s *> (Pole xr xf) = Pole (s *> xr) (s *> xf) + + +data Passband = Lowpass | Highpass + deriving (Show, Eq, Enum) 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,162 @@ +{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes +-} +module Synthesizer.Plain.Filter.Recursive.Allpass where + +import qualified Synthesizer.Plain.Signal as Sig +import qualified Synthesizer.Plain.Modifier as Modifier + +import qualified Algebra.Module as Module +import qualified Algebra.RealTranscendental as RealTrans +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Algebra.Module((*>)) + +import Number.Complex ((+:)) +import qualified Number.Complex as Complex +import Synthesizer.Utility (nest, mapSnd, ) + +import Control.Monad.State (State(..), evalState, ) + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + + +newtype Parameter a = Parameter a {- ^ Feedback factor. -} + deriving Show + + +{-# INLINE parameter #-} +parameter :: Trans.C a => + Int {- ^ The number of equally designed 1st order allpasses. -} + -> a {- ^ The phase shift to be achieved for the given frequency. -} + -> a {- ^ The frequency we specified the phase shift for. -} + -> Parameter a +parameter order phase frequency = + let orderFloat = fromIntegral order + omega = frequency * 2 * pi + phi = phase / orderFloat + k = (cos phi - cos omega) / (1 - cos (phi - omega)) + in Parameter k + +{-# INLINE flangerParameter #-} +flangerParameter :: Trans.C a => Int -> a -> Parameter a +flangerParameter order frequency = + parameter order (-2*pi) frequency + +{-# INLINE firstOrderStep #-} +firstOrderStep :: (Ring.C a, Module.C a v) => + Parameter a -> v -> State (v,v) v +firstOrderStep (Parameter k) u0 = + State (\(u1,y1) -> let y0 = u1 + k *> (u0-y1) in (y0,(u0,y0))) + +{-# INLINE firstOrderModifier #-} +firstOrderModifier :: (Ring.C a, Module.C a v) => + Modifier.Simple (v,v) (Parameter a) v v +firstOrderModifier = + Modifier.Simple (zero,zero) firstOrderStep + +{-# INLINE firstOrder #-} +firstOrder :: (Ring.C a, Module.C a v) => + Sig.T (Parameter a) -> Sig.T v -> Sig.T v +firstOrder = Sig.modifyModulated firstOrderModifier + + +{-# INLINE makePhase #-} +makePhase :: RealTrans.C a => Parameter a -> a -> a +makePhase (Parameter k) frequency = + let omega = 2*pi * frequency + in 2 * Complex.phase ((k+cos omega)+:(- sin omega)) + omega + +{- +internal storage is not very efficient +because the second value of one pair is equal +to the first value of the subsequent value +-} +{-# INLINE cascadeStepStackPairs #-} +cascadeStepStackPairs :: (Ring.C a, Module.C a v) => + Parameter a -> v -> State [(v,v)] v +cascadeStepStackPairs k = + -- stackStatesR would work as well, but with reversed list of states + Modifier.stackStatesL (firstOrderStep k) + +{-# INLINE cascadeStepStack #-} +cascadeStepStack :: (Ring.C a, Module.C a v) => + Parameter a -> v -> State [v] v +cascadeStepStack k x = + State $ + mapSnd fromPairs . + runState (cascadeStepStackPairs k x) . + toPairs + +{-# INLINE fromPairs #-} +fromPairs :: [(a,a)] -> [a] +fromPairs xs@(x:_) = fst x : map snd xs +fromPairs [] = error "Allpass.fromPairs: empty list" + +{-# INLINE toPairs #-} +toPairs :: [a] -> [(a,a)] +toPairs xs = zip xs (tail xs) + +{-# INLINE cascadeStep #-} +{-# INLINE cascadeStepRec #-} +{-# INLINE cascadeStepRecAlt #-} +cascadeStep, cascadeStepRec, cascadeStepRecAlt :: + (Ring.C a, Module.C a v) => + Parameter a -> v -> State [v] v + +cascadeStep = cascadeStepRec + +cascadeStepRec (Parameter k) x = State $ \s -> + let crawl _ [] = error "Allpass.crawl needs at least one element in the list" + crawl u0 (_:[]) = u0:[] + crawl u0 (u1:y1:us) = + let y0 = u1 + k *> (u0-y1) + in u0 : crawl y0 (y1:us) + news = crawl x s + in (last news, news) + +cascadeStepRecAlt k x = State $ \s -> + let crawl _ [] = error "Allpass.crawl needs at least one element in the list" + crawl u0 (u1:u1s) = mapSnd (u0:) $ + case u1s of + [] -> (u0,[]) + (y1:_) -> + crawl (evalState (firstOrderStep k u0) (u1,y1)) u1s + in crawl x s + +{-# INLINE cascadeModifier #-} +cascadeModifier :: (Ring.C a, Module.C a v) => + Int -> Modifier.Simple [v] (Parameter a) v v +cascadeModifier order = + Modifier.Simple (replicate (succ order) zero) cascadeStep + + +{-# INLINE cascade #-} +{-# INLINE cascadeState #-} +{-# INLINE cascadeIterative #-} +cascade, cascadeState, cascadeIterative :: + (Ring.C a, Module.C a v) => + Int -> Sig.T (Parameter a) -> Sig.T v -> Sig.T v + +{-| Choose one of the implementations below -} +cascade = cascadeState + +{-| Simulate the Allpass cascade by a list of states of the partial allpasses -} +cascadeState order = + Sig.modifyModulated (cascadeModifier order) + +{-| Directly implement the allpass cascade as multiple application of allpasses of 1st order -} +cascadeIterative order c = + nest order (firstOrder c) 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,91 @@ +{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes +-} +module Synthesizer.Plain.Filter.Recursive.AllpassPoly where + +-- import qualified Synthesizer.Plain.Signal as Sig +-- import qualified Synthesizer.Plain.Modifier as Modifier + +import qualified Algebra.Module as Module +import qualified Algebra.RealTranscendental as RealTrans +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Algebra.Module((*>)) + +import Number.Complex (cis,(+:),real,imag) +import qualified Number.Complex as Complex +import Orthogonals(Scalar,one_ket_solution) + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + + +newtype Parameter a = Parameter [a] + deriving Show + +{- | Compute coefficients for an allpass that shifts low frequencies + by approximately the shift you want. + To achieve this we solve a linear least squares problem, + where low frequencies are more weighted than high ones. + The output is a list of coefficients for an arbitrary order allpass. -} +shiftParam :: (Scalar a, P.Fractional a, Trans.C a) => + Int -> a -> a -> Parameter a +shiftParam order weight phase = + let {- construct matrix for normal equations -} + normalVector = map negate + (map (scalarProdScrewExp weight order phase 0) [1..order]) + normalMatrix = map (\j -> + map (scalarProdScrewExp weight order phase j) [1..order]) [1..order] + in Parameter (one_ket_solution normalMatrix normalVector) + +{- + GNUPlot.plotFunc (GNUPlot.linearScale 500 (0,1)) ((fwrap (-pi,pi)).(makePhase (shiftParam 6 (-6) (-pi/2::Double)))) +-} +makePhase :: RealTrans.C a => Parameter a -> a -> a +makePhase (Parameter ks) frequency = + let omega = 2*pi * frequency + omegas = iterate (omega+) omega + denom = 1+sum (zipWith (\k w -> k*cos w +: k*sin w) ks omegas) + in 2 * Complex.phase denom - omega*(fromIntegral (length ks)) + +{- integrate (0,2*pi) (\omega -> exp (r*omega) * screwProd order phase k j omega) -} +scalarProdScrewExp :: Trans.C a => a -> Int -> a -> Int -> Int -> a +scalarProdScrewExp r order phase k j = + let (intCos,intSin) = integrateScrewExp r (k+j-order) + in 2 * (fst (integrateScrewExp r (k-j)) - + (cos phase * intCos + sin phase * intSin)) + +screwProd :: Trans.C a => Int -> a -> Int -> Int -> a -> a +screwProd order phase k j omega = + let z0 = cis (fromIntegral k * omega) - + cis phase * cis (fromIntegral (order-k) * omega) + z1 = cis (fromIntegral j * omega) - + cis phase * cis (fromIntegral (order-j) * omega) + in real z0 * real z1 + imag z0 * imag z1 + +{- integrate (0,2*pi) (\omega -> (exp (r*omega) +: 0) * cis (k*omega)) -} +integrateScrewExp :: Trans.C a => a -> Int -> (a,a) +integrateScrewExp r kInt = + let k = fromIntegral kInt + q = (exp (2*pi*r) - 1) / (r^2 + k^2) + in (r*q, -k*q) + +{- Should be moved to NumericPrelude -} +integrateNum :: (Field.C a, Module.C a v) => Int -> (a,a) -> (a->v) -> v +integrateNum n (lo,hi) f = + let xs = map (\k -> lo + (hi-lo) * fromIntegral k / fromIntegral n) + [1..(n-1)] + in ((hi-lo) / fromIntegral n) *> + (foldl (+) ((1/2 `asTypeOf` lo) *> (f lo + f hi)) + (map f xs)) 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,85 @@ +{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +Butterworth lowpass and highpass +-} +module Synthesizer.Plain.Filter.Recursive.Butterworth where + +import Synthesizer.Plain.Filter.Recursive (Passband(Lowpass,Highpass)) +import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2 +-- import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1 +import qualified Synthesizer.Plain.Signal as Sig +-- import qualified Synthesizer.Plain.Modifier as Modifier + +import qualified Algebra.Module as Module +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +-- import Control.Monad.State (State(..), evalState) + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + + +sineListSlow, sineListFast :: (Trans.C a) => a -> [a] +sineListSlow x = map sin (map (x*) (iterate (2+) 1)) + +sineListFast x = + let sinx = sin x + cos2x = 2 - 4*sinx*sinx + --cos2x = 2 * cos (2*x) + sines = (-sinx) : sinx : + zipWith (\y1 y0 -> cos2x * y0 - y1) sines (tail sines) + in tail sines + +parameterInstable, parameter :: (Trans.C a) => + a -> a -> a -> Filt2.Parameter a + +{- must handle infinite values when 'freq' approaches 0.5 -} +parameterInstable ratio sinw freq = + let wc = ratio * tan (pi*freq) + sinw2 = 2 * wc * sinw + wc2 = wc * wc + denom = wc2 + sinw2 + 1 + c0 = wc2 / denom + in Filt2.Parameter c0 (2*c0) c0 + (2*(1-wc2)/denom) ((-wc2+sinw2-1)/denom) + +-- using ratio disallows simplification by trigonometric Pythagoras' theorem +parameter ratio sinw freq = + let phi = pi*freq + sinsin = sin (2*phi) * sinw + sinphi2 = (sin phi)^2 + ratsin = 1 + (ratio^2-1) * sinphi2 + denom = ratsin + ratio*sinsin + c0 = ratio^2 * sinphi2 / denom + in Filt2.Parameter c0 (2*c0) c0 + (2*(1-(ratio^2+1)*sinphi2)/denom) ((ratio*sinsin-ratsin)/denom) + +run :: (Trans.C a, Module.C a v) => + Passband -> Int -> a -> Sig.T a -> Sig.T v -> Sig.T v +run kind order ratio freqs = + let orderFloat = fromIntegral (2*order) + sines = take (div order 2) (sineListFast (pi/orderFloat)) + -- the filter amplifies frequency 0 with factor 1 + -- and frequency 'freq' with factor 'ratio' + wcoef = (1/ratio^2-1)**(-1/orderFloat) + makePartialFilter s = + Filt2.run (map (Filt2.adjustPassband kind . parameter wcoef s) freqs) + in foldl (.) id (map makePartialFilter sines) + +lowpass, highpass :: (Trans.C a, Module.C a v) => + Int -> a -> Sig.T a -> Sig.T v -> Sig.T v +lowpass = run Lowpass +highpass order ratio freqs = + run Highpass order ratio (map (0.5-) freqs) 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,119 @@ +{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +Chebyshev lowpass and highpass +-} +module Synthesizer.Plain.Filter.Recursive.Chebyshev where + +import Synthesizer.Plain.Filter.Recursive (Passband(Lowpass,Highpass)) +import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2 +-- import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1 +import qualified Synthesizer.Plain.Signal as Sig +-- import qualified Synthesizer.Plain.Modifier as Modifier + +import qualified Algebra.VectorSpace as VectorSpace +import qualified Algebra.Module as Module +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Algebra.Module((*>)) + +import Number.Complex ((+:),real,imag) +import qualified Number.Complex as Complex + +-- import Control.Monad.State (State(..), evalState) + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + +-- compute the partial filter of the second order from the pole information +{- +It's worth to think it over whether this routine could be used for the Butterworth filter. +But whereas this function is specialized to the zeros of the denominator polynomial +for the Butterworth filter the quadratic factors of the polynomial can be determined +more efficiently than the zeros. +-} +parameterA, parameterB :: (Trans.C a) => + a -> Complex.T a -> a -> Filt2.Parameter a +parameterA vol z freq = + let re = real z + im = imag z + phi = pi*freq + sinphi = sin phi + cosphi = cos phi + cpims = cosphi + im*sinphi + cmims = cosphi - im*sinphi + resin2 = (re*sinphi)^2 + denom = - cmims^2 - resin2 + c0 = vol * sinphi^2 / denom + in Filt2.Parameter + c0 (2*c0) c0 + (-2*(cpims*cmims - resin2)/denom) ((cpims^2 + resin2)/denom) + +runA :: (Trans.C a, Module.C a v) => + Passband -> Int -> a -> Sig.T a -> Sig.T v -> Sig.T v +runA kind order ratio freqs = + let orderFloat = fromIntegral (2*order) + bn = asinh (ratio/sqrt(1-ratio^2)) / orderFloat + pikn = take order (map (pi/(2*orderFloat)*) (iterate (2+) 1)) + zeros = map (\angle -> cos angle * cosh bn +: (- sin angle * sinh bn)) pikn + {- if ratio == (sqrt 2) then the product of the normalization factors is + 2^(1-2*order) -} + makePartialFilter z = + Filt2.run + (map (Filt2.adjustPassband kind . + parameterA (sqrt + ((1-real z^2-imag z^2)^2 + 4*imag z^2)) z) + freqs) + in foldl (.) (ratio *>) (map makePartialFilter zeros) + + +parameterB a0 z freq = + let re = real z + im = imag z + phi = pi*freq + sinphi = sin phi + cosphi = cos phi + spimc = sinphi + im*cosphi + smimc = sinphi - im*cosphi + recos2 = (re*cosphi)^2 + denom = smimc^2 + recos2 + c0 = (sinphi^2 + a0^2*cosphi^2) / denom + c1 = (sinphi^2 - a0^2*cosphi^2) / denom + in Filt2.Parameter + c0 (2*c1) c0 + (-2*(spimc*smimc - recos2)/denom) (-(spimc^2 + recos2)/denom) + +runB :: (Trans.C a, Module.C a v) => + Passband -> Int -> a -> Sig.T a -> Sig.T v -> Sig.T v +runB kind order ratio freqs = + let orderFloat = fromIntegral (2*order) + bn = (asinh (sqrt(1-ratio^2)/ratio)) / orderFloat + pikn = take order (map (pi/(2*orderFloat)*) (iterate (2+) 1)) + zeros = map (\angle -> (cos angle * cosh bn +: (- sin angle * sinh bn))) pikn + a0s = map cos pikn + makePartialFilter a0 z = + Filt2.run + (map (Filt2.adjustPassband kind . + parameterB a0 z) freqs) + in foldl (.) id (zipWith makePartialFilter a0s zeros) + +lowpassA, highpassA, lowpassB, highpassB :: + (Trans.C a, VectorSpace.C a v) => + Int -> a -> Sig.T a -> Sig.T v -> Sig.T v +lowpassA = runA Lowpass +highpassA order ratio freqs = + runA Highpass order ratio (map (0.5-) freqs) + +lowpassB = runB Lowpass +highpassB order ratio freqs = + runB Highpass order ratio (map (0.5-) freqs) 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,67 @@ +{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +Comb filters, useful for emphasis of tones with harmonics +and for repeated echos. +-} +module Synthesizer.Plain.Filter.Recursive.Comb where + +import Synthesizer.Plain.Filter.NonRecursive (delay, ) +import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1 +import qualified Synthesizer.Plain.Signal as Sig +-- import qualified Synthesizer.Plain.Modifier as Modifier +import qualified Synthesizer.Plain.Control as Ctrl + +import qualified Algebra.Module as Module +-- import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Algebra.Module((*>)) + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +{- | +The most simple version of the Karplus-Strong algorithm +which is suitable to simulate a plucked string. +It is similar to the 'runProc' function. +-} +karplusStrong :: (Ring.C a, Module.C a v) => + Filt1.Parameter a -> Sig.T v -> Sig.T v +karplusStrong c wave = + let y = wave ++ Filt1.lowpass (Ctrl.constant c) y + in y + + +{- | +Infinitely many equi-delayed exponentially decaying echos. +The echos are clipped to the input length. +We think it is easier (and simpler to do efficiently) +to pad the input with zeros or whatever +instead of cutting the result according to the input length. +-} +run :: (Module.C a v) => Int -> a -> Sig.T v -> Sig.T v +run time gain x = + let y = zipWith (+) x (delay time (gain *> y)) + in y + +{- | Echos of different delays. -} +runMulti :: (Ring.C a, Module.C a v) => [Int] -> a -> Sig.T v -> Sig.T v +runMulti time gain x = + let y = foldl (zipWith (+)) x (map (flip delay (gain *> y)) time) + in y + +{- | Echos can be piped through an arbitrary signal processor. -} +runProc :: Additive.C v => Int -> (Sig.T v -> Sig.T v) -> Sig.T v -> Sig.T v +runProc time feedback x = + let y = zipWith (+) x (delay time (feedback y)) + in y 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,105 @@ +{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +First order low pass and high pass filter. +-} +module Synthesizer.Plain.Filter.Recursive.FirstOrder where + +import qualified Synthesizer.Plain.Signal as Sig +import qualified Synthesizer.Plain.Modifier as Modifier + +import qualified Algebra.Module as Module +import qualified Algebra.Transcendental as Trans +-- import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +-- import qualified Algebra.Additive as Additive + +import Algebra.Module((*>)) + +-- import qualified Number.Complex as Complex + +import Control.Monad.State (State(..), ) + +import PreludeBase +import NumericPrelude + + + +newtype Parameter a = Parameter a + deriving Show + +{-| Convert cut-off frequency to feedback factor. -} +{-# INLINE parameter #-} +parameter :: Trans.C a => a -> Parameter a +parameter freq = Parameter (exp (-2*pi*freq)) + + +{-# INLINE lowpassStep #-} +lowpassStep :: (Ring.C a, Module.C a v) => + Parameter a -> v -> State v v +lowpassStep (Parameter c) x = + State (\s -> let y = x + c *> (s-x) in (y,y)) + +{-# INLINE lowpassModifierInit #-} +lowpassModifierInit :: (Ring.C a, Module.C a v) => + Modifier.Initialized v v (Parameter a) v v +lowpassModifierInit = + Modifier.Initialized id lowpassStep + +{-# INLINE lowpassModifier #-} +lowpassModifier :: (Ring.C a, Module.C a v) => + Modifier.Simple v (Parameter a) v v +lowpassModifier = + Sig.modifierInitialize lowpassModifierInit zero + +{-# INLINE lowpassInit #-} +lowpassInit :: (Ring.C a, Module.C a v) => + v -> Sig.T (Parameter a) -> Sig.T v -> Sig.T v +lowpassInit = + Sig.modifyModulatedInit lowpassModifierInit + +{-# INLINE lowpass #-} +lowpass :: (Ring.C a, Module.C a v) => + Sig.T (Parameter a) -> Sig.T v -> Sig.T v +lowpass = lowpassInit zero + + +{-# INLINE highpassStep #-} +highpassStep :: (Ring.C a, Module.C a v) => + Parameter a -> v -> State v v +highpassStep c x = + fmap (x-) (lowpassStep c x) + +{-# INLINE highpassModifierInit #-} +highpassModifierInit :: (Ring.C a, Module.C a v) => + Modifier.Initialized v v (Parameter a) v v +highpassModifierInit = + Modifier.Initialized negate highpassStep + +{-# INLINE highpassModifier #-} +highpassModifier :: (Ring.C a, Module.C a v) => + Modifier.Simple v (Parameter a) v v +highpassModifier = + Sig.modifierInitialize highpassModifierInit zero + +{-# INLINE highpassInit #-} +highpassInit :: (Ring.C a, Module.C a v) => + v -> Sig.T (Parameter a) -> Sig.T v -> Sig.T v +highpassInit = + Sig.modifyModulatedInit highpassModifierInit + +highpassInitAlt :: (Ring.C a, Module.C a v) => + v -> Sig.T (Parameter a) -> Sig.T v -> Sig.T v +highpassInitAlt y0 control x = + x - lowpassInit (-y0) control x + +{-# INLINE highpass #-} +highpass :: (Ring.C a, Module.C a v) => + Sig.T (Parameter a) -> Sig.T v -> Sig.T v +highpass = highpassInit zero 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 @@ +{-# OPTIONS -fno-implicit-prelude #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +Filter operators from calculus +-} +module Synthesizer.Plain.Filter.Recursive.Integration where + +import qualified Synthesizer.Plain.Signal as Sig +-- import qualified Synthesizer.Plain.Modifier as Modifier + +-- import qualified Algebra.Field as Field +-- import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import PreludeBase +import NumericPrelude + + + +{- | +Integrate with initial value zero. +However the first emitted value is the value of the input signal. +It maintains the length of the signal. +-} +{-# INLINE run #-} +run :: Additive.C v => Sig.T v -> Sig.T v +run = scanl1 (+) + +{- | +Integrate with initial condition. +First emitted value is the initial condition. +The signal become one element longer. +-} +{-# INLINE runInit #-} +runInit :: Additive.C v => v -> Sig.T v -> Sig.T v +runInit = scanl (+) + +{- other quadrature methods may follow -} 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,106 @@ +{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +Moog cascade lowpass with resonance. +-} +module Synthesizer.Plain.Filter.Recursive.Moog where + +import Synthesizer.Plain.Filter.Recursive (Pole(..)) +import Synthesizer.Plain.Filter.NonRecursive (envelopeVector) +import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1 +import qualified Synthesizer.Plain.Signal as Sig +import qualified Synthesizer.Plain.Modifier as Modifier + +import qualified Algebra.Module as Module +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Algebra.Module((*>)) + +import Synthesizer.Utility (nest) + +import Control.Monad.State (State(..), evalState, gets) + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +data Parameter a = + Parameter + {feedback :: !a + {- ^ Feedback of the lowpass cascade -} + ,lowpassParam :: !(Filt1.Parameter a) + {- ^ Feedback of each of the lowpasses of 1st order -} } + deriving Show + +parameter :: Trans.C a => Int -> Pole a -> Parameter a +parameter order (Pole resonance frequency) = + let beta = frequency * 2 * pi + alpha = (pi-beta) / fromIntegral order + k = sin alpha / sin (alpha+beta) + + q = ((sin (alpha+beta) - sin alpha) / sin beta) ^ fromIntegral order + f = (resonance-1) / (resonance*q+1) + in Parameter f (Filt1.Parameter k) + +{- +Used for lowpassState, +list of internal values may be processed by Applicative.traverse. +-} +lowpassStepStack :: (Ring.C a, Module.C a v) => + Parameter a -> v -> State [v] v +lowpassStepStack (Parameter f k) x = + do y0 <- gets head + y1 <- Modifier.stackStatesR (Filt1.lowpassStep k) (x - f *> y0) + return ((1+f) *> y1) + +lowpassStepRev :: (Ring.C a, Module.C a v) => + Parameter a -> v -> State [v] v +lowpassStepRev (Parameter f k) x = State (\s -> + let news = + tail (scanl + (evalState . Filt1.lowpassStep k) + -- (\u0 y1 -> let Filt1.Parameter k0 = k in (1-k0) *> u0 + k0 *> y1) + (x - f *> last s) s) + in ((1+f) *> last news, news)) + + +lowpassModifier :: (Ring.C a, Module.C a v) => + Int -> Modifier.Simple [v] (Parameter a) v v +lowpassModifier order = + Modifier.Simple (replicate order zero) lowpassStepStack + + +lowpass, lowpassState, lowpassRecursive :: + (Ring.C a, Module.C a v) => + Int -> Sig.T (Parameter a) -> Sig.T v -> Sig.T v + +{-| Choose one of the implementations below -} +lowpass = lowpassRecursive + +{-| Simulate the Moog cascade by a list of states of the partial lowpasses -} +lowpassState order = + Sig.modifyModulated (lowpassModifier order) + +{-| The elegant way of implementing the Moog cascade by recursion -} +lowpassRecursive order c x = + let k = map lowpassParam c + f = map feedback c + z = zipWith subtract (envelopeVector f (zero:y)) x + y = nest order (Filt1.lowpass k) z + in zipWith (*>) (map (1+) f) y + +lowpassTest :: [Double] +lowpassTest = + lowpass 10 + (repeat (parameter 10 (Pole 10 (0.05::Double)))) + (1:repeat 0) 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 @@ +{-# OPTIONS -fno-implicit-prelude #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes +-} +module Synthesizer.Plain.Filter.Recursive.MovingAverage + (sumsStaticInt, + modulatedFrac, + ) where + +import qualified Synthesizer.Plain.Signal as Sig +-- import qualified Synthesizer.Plain.Modifier as Modifier +import qualified Synthesizer.Plain.Filter.Recursive.Integration as Integration + +import Synthesizer.Plain.Filter.NonRecursive (delay, ) + +import qualified Algebra.Module as Module +import qualified Algebra.RealField as RealField + +-- import qualified Algebra.Field as Field +-- import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Control.Monad.Fix (fix) +import Data.List (tails) + +import PreludeBase +import NumericPrelude + + + +{- | +Like 'Synthesizer.Plain.Filter.NonRecursive.sums' but in a recursive form. +This needs only linear time (independent of the window size) +but may accumulate rounding errors. + +@ +ys = xs * (1,0,0,0,-1) \/ (1,-1) +ys * (1,-1) = xs * (1,0,0,0,-1) +ys = xs * (1,0,0,0,-1) + ys * (0,1) +@ +-} +sumsStaticInt :: (Additive.C v) => Int -> Sig.T v -> Sig.T v +sumsStaticInt n xs = + fix (\ys -> let (xs0,xs1) = splitAt n xs + in (xs0 ++ (xs1-xs)) + (zero:ys)) + +{- +staticInt :: (Module.C a v, Additive.C v) => Int -> Sig.T v -> Sig.T v +staticInt n xs = +-} + + +{- +Sum of a part of a vector with negative sign for reverse order. +It adds from @from@ (inclusively) to @to@ (exclusively), +that is, it sums up @abs (to-from)@ values +-} +sumFromTo :: (Additive.C v) => Int -> Int -> Sig.T v -> v +sumFromTo from to = + if from <= to + then sum . take (to-from) . drop from + else negate . sum . take (from-to) . drop to + +{- +It would be a nice approach to interpolate not just linearly at the borders +but in a way that the cut-off frequency is perfectly suppressed. +However suppression depends on the phase shift of the wave. +Actually, we could use a complex factor, but does this help? +-} +sumFromToFrac :: (RealField.C a, Module.C a v) => a -> a -> Sig.T v -> v +sumFromToFrac from to xs = + let (fromInt, fromFrac) = splitFraction from + (toInt, toFrac) = splitFraction to + in case compare fromInt toInt of + EQ -> (to-from) *> (xs !! fromInt) + LT -> + sum $ + zipWith id + (((1-fromFrac) *>) : + replicate (toInt-fromInt-1) id ++ + (toFrac *>) : + []) $ + drop fromInt xs + GT -> + negate $ sum $ + zipWith id + (((1-toFrac) *>) : + replicate (fromInt-toInt-1) id ++ + (fromFrac *>) : + []) $ + drop toInt xs + + + +{- | +Sig.T a must contain only non-negative elements. +-} +sumDiffsModulated :: (RealField.C a, Module.C a v) => + a -> Sig.T a -> Sig.T v -> Sig.T v +sumDiffsModulated d ds = + -- prevent negative d's since 'drop' cannot restore past values + zipWith3 sumFromToFrac ((d+1) : ds) (map (1+) ds) . + init . init . tails . (zero:) +{- + zipWith3 sumFromToFrac (d : map (subtract 1) ds) ds . + init . tails +-} + +sumsModulated :: (RealField.C a, Module.C a v) => + Int -> Sig.T a -> Sig.T v -> Sig.T v +sumsModulated maxDInt ds xs = + let maxD = fromIntegral maxDInt + posXs = sumDiffsModulated 0 ds xs + negXs = sumDiffsModulated maxD (map (maxD-) ds) (delay maxDInt xs) + in Integration.run (posXs - negXs) + +{- | +Shift sampling points by a half sample period +in order to preserve signals for window widths below 1. +-} +sumsModulatedHalf :: (RealField.C a, Module.C a v) => + Int -> Sig.T a -> Sig.T v -> Sig.T v +sumsModulatedHalf maxDInt ds xs = + let maxD = fromIntegral maxDInt + d0 = maxD+0.5 + delXs = delay maxDInt xs + posXs = sumDiffsModulated d0 (map (d0+) ds) delXs + negXs = sumDiffsModulated d0 (map (d0-) ds) delXs + in Integration.run (posXs - negXs) + +modulatedFrac :: (RealField.C a, Module.C a v) => + Int -> Sig.T a -> Sig.T v -> Sig.T v +modulatedFrac maxDInt ds xs = + zipWith (\d y -> recip (2*d) *> y) ds $ + sumsModulatedHalf maxDInt ds xs + 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,85 @@ +{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +All recursive filters with real coefficients +can be decomposed into first order and second order filters with real coefficients. +This follows from the Fundamental theorem of algebra. +-} +module Synthesizer.Plain.Filter.Recursive.SecondOrder where + +import Synthesizer.Plain.Filter.Recursive (Passband(Lowpass,Highpass)) +import qualified Synthesizer.Plain.Signal as Sig +-- import qualified Synthesizer.Plain.Modifier as Modifier +-- import qualified Synthesizer.Plain.Control as Ctrl + +-- import qualified Algebra.VectorSpace as VectorSpace +import qualified Algebra.Module as Module +-- import qualified Algebra.Transcendental as Trans +-- import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Algebra.Module((*>)) + +import Data.List (zipWith6) + +import Control.Monad.State (State(..), ) + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +{- | Parameters for a general recursive filter of 2nd order. -} +data Parameter a = + Parameter {c0, c1, c2, d1, d2 :: !a} + deriving Show + +{- | Given the filter parameters of a lowpass filter, + turn them into highpass parameters, if requested filter type is Highpass -} +{-# INLINE adjustPassband #-} +adjustPassband :: (Ring.C a) => + Passband -> Parameter a -> Parameter a +adjustPassband kind p = + case kind of + Lowpass -> p + Highpass -> Parameter (c0 p) (- c1 p) (c2 p) (- d1 p) (d2 p) + +{-# INLINE step #-} +step :: (Ring.C a, Module.C a v) => + Parameter a -> v -> State ((v,v),(v,v)) v +step c u0 = State $ \((u1,u2),(y1,y2)) -> + let y0 = + c0 c *> u0 + + c1 c *> u1 + d1 c *> y1 + + c2 c *> u2 + d2 c *> y2 + in (y0, ((u0,u1),(y0,y1))) + + +{-# INLINE runInit #-} +runInit :: (Ring.C a, Module.C a v) => + ((v,v),(v,v)) -> Sig.T (Parameter a) -> Sig.T v -> Sig.T v +runInit ((u0init,u1init),(y0init,y1init)) control input = + let u0s = input + u1s = u0init:u0s + u2s = u1init:u1s + y1s = y0init:y0s + y2s = y1init:y1s + y0s = zipWith6 + (\c u0 u1 u2 y1 y2 -> + c0 c *> u0 + + c1 c *> u1 + d1 c *> y1 + + c2 c *> u2 + d2 c *> y2) + control u0s u1s u2s y1s y2s + in y0s + +{-# INLINE run #-} +run :: (Ring.C a, Module.C a v) => + Sig.T (Parameter a) -> Sig.T v -> Sig.T v +run = runInit zero 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,69 @@ +{-# OPTIONS -fno-implicit-prelude #-} +module Synthesizer.Plain.Filter.Recursive.Test where + +import qualified Synthesizer.Plain.Oscillator as Osci +import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2 +import qualified Synthesizer.Plain.Filter.Recursive.Butterworth as Butter +import qualified Synthesizer.Plain.Filter.Recursive.Chebyshev as Cheby +import Number.Complex((+:)) + +import qualified Algebra.Ring as Ring + +import PreludeBase +import NumericPrelude + + +sampleRate :: Ring.C a => a +--sampleRate = 44100 +sampleRate = 22050 +--sampleRate = 11025 + + +chirp :: Double -> [Double] +chirp len = Osci.freqModSine 0 (iterate (+0.5/len) 0) + + +filter2ndOrderTest :: [Double] +filter2ndOrderTest = + take 10 + (Filt2.run + (repeat (Filt2.Parameter 1 0 0 0 (1::Double))) + (1 : repeat 0)) + + +butterworthLowpassTest0 :: [Double] +butterworthLowpassTest0 = + take 30 (Butter.lowpass 2 0.2 (repeat (0.1::Double)) (repeat 1)) + +butterworthLowpassTest1 :: Double +butterworthLowpassTest1 = + maximum (take 300 (drop 500 + (Butter.lowpass 6 0.1 (repeat (0.05::Double)) + (map sin (iterate (+2*pi*0.05) 0))))) + +butterworthLowpassTest2 :: [Double] +butterworthLowpassTest2 = + let len = 1*sampleRate + in take (round len) (Butter.lowpass 20 0.1 (repeat (0.1::Double)) (chirp len)) + + +chebyshevALowpassTest0 :: Filt2.Parameter Double +chebyshevALowpassTest0 = + let beta = (asinh 1) / 4 + in Cheby.parameterA 1 (12/13 * cosh beta +: (-5/13 * sinh beta)) 0.1 + +chebyshevBLowpassTest0 :: Filt2.Parameter Double +chebyshevBLowpassTest0 = + let beta = (asinh 1) / 4 + in Cheby.parameterB (12/13) (12/13 * cosh beta +: (-5/13 * sinh beta)) 0.1 + +chebyshevLowpassTest1 :: [Double] +chebyshevLowpassTest1 = + let len = 1*sampleRate + in take (round len) (Filt2.run (repeat chebyshevALowpassTest0) (chirp len)) + +chebyshevLowpassTest2 :: [Double] +chebyshevLowpassTest2 = + let len = 1*sampleRate + in take (round len) (Cheby.lowpassA 10 0.25 (repeat (0.1::Double)) (chirp len)) + 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,107 @@ +{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +State variable filter. +One filter that generates lowpass, bandpass, highpass at once. + +ToDo: band limit filter as sum of input and band pass +-} +module Synthesizer.Plain.Filter.Recursive.Universal where + +import Synthesizer.Plain.Filter.Recursive (Pole(..)) +import qualified Synthesizer.Plain.Signal as Sig +import qualified Synthesizer.Plain.Modifier as Modifier + +import qualified Algebra.Module as Module +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Algebra.Module((*>)) + +import Control.Monad.State (State(..), ) + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +data Parameter a = + Parameter {k1, k2, ampIn, ampI1, ampI2 :: !a} + +data Result a = + Result {highpass, bandpass, lowpass :: !a} + +instance Additive.C v => Additive.C (Result v) where + {-# INLINE zero #-} + {-# INLINE (+) #-} + {-# INLINE (-) #-} + {-# INLINE negate #-} + zero = Result zero zero zero + (+) (Result xhp xbp xlp) (Result yhp ybp ylp) = Result (xhp + yhp) (xbp + ybp) (xlp + ylp) + (-) (Result xhp xbp xlp) (Result yhp ybp ylp) = Result (xhp - yhp) (xbp - ybp) (xlp - ylp) + negate (Result xhp xbp xlp) = Result (negate xhp) (negate xbp) (negate xlp) + + +instance Module.C a v => Module.C a (Result v) where + {-# INLINE (*>) #-} + s *> (Result hp bp lp) = Result (s *> hp) (s *> bp) (s *> lp) + + +{-| Universal filter: Computes high pass, band pass, low pass in one go -} +{-# INLINE parameter #-} +parameter :: Trans.C a => Pole a -> Parameter a +parameter (Pole resonance frequency) = + let zr = cos (2*pi*frequency) + zr1 = zr-1 + q2 = resonance^2 + sqrtQZ = sqrt (zr1*(-8*q2+zr1-4*q2*zr1)) + pk1 = (-zr1+sqrtQZ) / (2*q2-zr1+sqrtQZ) + q21zr = 4*q2*zr + a = 2 * (zr1*zr1-q21zr*zr) / (zr1+q21zr+(1+2*zr1)*sqrtQZ) + pk2 = a+2-pk1 + volHP = (4-2*pk1-pk2) / 4 + volLP = pk2 + volBP = sqrt (volHP*volLP) + in Parameter + (pk1*volHP/volBP) (pk2*volHP/volLP) + volHP (volBP/volHP) (volLP/volBP) + +{-# INLINE step #-} +step :: (Ring.C a, Module.C a v) => + Parameter a -> v -> State (v,v) (Result v) +step p u = + State $ \(i1,i2) -> + let newsum = ampIn p *> u + k1 p *> i1 - k2 p *> i2 + newi1 = i1 - ampI1 p *> newsum + newi2 = i2 - ampI2 p *> newi1 + out = Result newsum newi1 newi2 + in (out, (newi1, newi2)) + +{-# INLINE modifierInit #-} +modifierInit :: (Ring.C a, Module.C a v) => + Modifier.Initialized (v,v) (v,v) (Parameter a) v (Result v) +modifierInit = + Modifier.Initialized id step + +{-# INLINE modifier #-} +modifier :: (Ring.C a, Module.C a v) => + Modifier.Simple (v,v) (Parameter a) v (Result v) +modifier = Sig.modifierInitialize modifierInit (zero, zero) + +{-# INLINE runInit #-} +runInit :: (Ring.C a, Module.C a v) => + (v,v) -> Sig.T (Parameter a) -> Sig.T v -> Sig.T (Result v) +runInit = Sig.modifyModulatedInit modifierInit + +{-# INLINE run #-} +run :: (Ring.C a, Module.C a v) => + Sig.T (Parameter a) -> Sig.T v -> Sig.T (Result v) +run = runInit (zero, zero) 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,302 @@ +{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-} +module Synthesizer.Plain.Instrument where + +import Synthesizer.Plain.Displacement (mixMulti, ) +import Synthesizer.Plain.Control (exponential2) +import qualified Synthesizer.Plain.Oscillator as Osci +import qualified Synthesizer.Basic.Wave as Wave +import qualified Synthesizer.Plain.Noise as Noise +import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1 +import qualified Synthesizer.Plain.Filter.Recursive.Allpass as Allpass +import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilter +import qualified Synthesizer.Plain.Filter.Recursive.Moog as Moog +import qualified Synthesizer.Plain.Filter.Recursive.Comb as Comb +import qualified Synthesizer.Plain.Filter.Recursive as FiltR +import qualified Synthesizer.Plain.Filter.NonRecursive as FiltNR +import qualified Synthesizer.Plain.Interpolation as Interpolation +import Data.List(zipWith4) + +import System.Random + +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Module as Module +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring + +import PreludeBase +import NumericPrelude + + + +{-| Create a sound of a slightly changed frequency + just as needed for a simple stereo sound. -} +stereoPhaser :: Ring.C a => + (a -> [b]) {- ^ A function mapping a frequency to a signal. -} + -> a {- ^ The factor to the frequency, should be close to 1. -} + -> a {- ^ The base (undeviated) frequency of the sound. -} + -> [b] +stereoPhaser sound dif freq = sound (freq*dif) + + + +allpassPlain :: (RealField.C a, Trans.C a, Module.C a a) => + a -> a -> a -> a -> [a] +allpassPlain sampleRate halfLife k freq = + Allpass.cascade 10 + (map Allpass.Parameter (exponential2 (halfLife*sampleRate) k)) + (simpleSaw sampleRate freq) + +allpassDown :: (RealField.C a, Trans.C a, Module.C a a) => + a -> Int -> a -> a -> a -> [a] +allpassDown sampleRate order halfLife filterfreq freq = + let x = simpleSaw sampleRate freq + in map (0.3*) (zipWith (+) x + (Allpass.cascade order + (map (Allpass.flangerParameter order) + (exponential2 (halfLife*sampleRate) (filterfreq/sampleRate))) + x)) + + +moogDown, moogReso :: + (RealField.C a, Trans.C a, Module.C a a) => + a -> Int -> a -> a -> a -> [a] +moogDown sampleRate order halfLife filterfreq freq = + Moog.lowpass order + (map (Moog.parameter order) (map (FiltR.Pole 10) + (exponential2 (halfLife*sampleRate) (filterfreq/sampleRate)))) + (simpleSaw sampleRate freq) + +moogReso sampleRate order halfLife filterfreq freq = + Moog.lowpass order + (map (Moog.parameter order) (zipWith FiltR.Pole + (exponential2 (halfLife*sampleRate) 100) + (repeat (filterfreq/sampleRate)))) + (simpleSaw sampleRate freq) + +bell :: (Trans.C a, RealField.C a) => a -> a -> [a] +bell sampleRate freq = + let halfLife = 0.5 + in zipWith3 (\x y z -> (x+y+z)/3) + (bellHarmonic sampleRate 1 halfLife freq) + (bellHarmonic sampleRate 4 halfLife freq) + (bellHarmonic sampleRate 7 halfLife freq) + +bellHarmonic :: (Trans.C a, RealField.C a) => a -> a -> a -> a -> [a] +bellHarmonic sampleRate n halfLife freq = + zipWith (*) (Osci.freqModSine 0 (map (\modu -> freq/sampleRate*n*(1+0.005*modu)) + (Osci.staticSine 0 (5.0/sampleRate)))) + (exponential2 (halfLife/n*sampleRate) 1) + + +fastBell, squareBell, moogGuitar, moogGuitarSoft, simpleSaw, fatSaw :: + (RealField.C a, Trans.C a, Module.C a a) => a -> a -> [a] + +fastBell sampleRate freq = + zipWith (*) (Osci.staticSine 0 (freq/sampleRate)) + (exponential2 (0.2*sampleRate) 1) + +filterSaw :: (Module.C a a, Trans.C a, RealField.C a) => + a -> a -> a -> [a] +filterSaw sampleRate filterFreq freq = + map (\r -> UniFilter.lowpass r * 0.1) + (UniFilter.run (map (UniFilter.parameter . FiltR.Pole 10) + (exponential2 (0.1*sampleRate) (filterFreq/sampleRate))) + (Osci.staticSaw 0 (freq/sampleRate))) + +squareBell sampleRate freq = Filt1.lowpass + (map Filt1.parameter + (exponential2 (sampleRate/10) (4000/sampleRate))) +-- (Osci.freqModSample Interpolation.cubic [0, 0.7, -0.3, 0.7, 0, -0.7, 0.3, -0.7] 0 + (Osci.freqModSample Interpolation.linear [0, 0.5, 0.6, 0.8, 0, -0.5, -0.6, -0.8] 0 + (map (\modu -> freq/sampleRate*(1+modu/100)) + (Osci.staticSine 0 (5.0/sampleRate)))) + +fmBell :: (RealField.C a, Trans.C a) => a -> a -> a -> a -> [a] +fmBell sampleRate depth freqRatio freq = + let modul = FiltNR.envelope (exponential2 (0.2*sampleRate) depth) + (Osci.staticSine 0 (freqRatio*freq/sampleRate)) + env = exponential2 (0.5*sampleRate) 1 + in FiltNR.envelope env (Osci.phaseModSine (freq/sampleRate) modul) + +moogGuitar sampleRate freq = + let moogOrder = 4 + filterControl = + map (Moog.parameter moogOrder) + (map (FiltR.Pole 10) (exponential2 + (0.5*sampleRate) + (4000/sampleRate))) + tone = Osci.freqModSaw 0 (map (\modu -> freq/sampleRate*(1+0.005*modu)) + (Osci.staticSine 0 (5.0/sampleRate))) + in Moog.lowpass moogOrder filterControl tone + +moogGuitarSoft sampleRate freq = + FiltNR.envelope (map (1-) (exponential2 (0.003*sampleRate) 1)) + (moogGuitar sampleRate freq) + + + +{-| low pass with resonance -} +filterSweep :: (Field.C v, Module.C a v, Trans.C a, RealField.C a) => + a -> a -> [v] -> [v] +filterSweep sampleRate phase = + map (\r -> UniFilter.lowpass r / 2) . + UniFilter.run + (map (\freq -> + UniFilter.parameter (FiltR.Pole 10 ((1800/sampleRate)*2**freq))) + (Osci.staticSine phase (1/16/sampleRate)) + ) + + +fatSawChordFilter, fatSawChord :: + (RealField.C a, Trans.C a, Module.C a a) => a -> a -> [a] + +fatSawChordFilter sampleRate freq = + map (\r -> UniFilter.lowpass r / 2) + (UniFilter.run (filterDown sampleRate) + (fatSawChord sampleRate freq)) + +fatSawChord sampleRate freq = + zipWith3 (\x y z -> (x+y+z)/3) + (fatSaw sampleRate (1 *freq)) + (fatSaw sampleRate (5/4*freq)) + (fatSaw sampleRate (3/2*freq)) + +filterDown :: (RealField.C a, Trans.C a) => a -> [UniFilter.Parameter a] + +filterDown sampleRate = + map UniFilter.parameter $ + map (FiltR.Pole 10) $ + exponential2 (sampleRate/3) (4000/sampleRate) + +simpleSaw sampleRate freq = + Osci.staticSaw 0 (freq/sampleRate) + +{-| accumulate multiple similar saw sounds and observe the increase of volume + The oscillator @osc@ must accept relative frequencies. -} +modulatedWave :: (Trans.C a, RealField.C a) => + a -> (a -> [a] -> [a]) -> a -> a -> a -> a -> a -> [a] +modulatedWave sampleRate osc freq start depth phase speed = + osc start (map (\x -> freq/sampleRate*(1+x*depth)) + (Osci.staticSine phase (speed/sampleRate))) + +accumulatedSaws :: (Random a, Trans.C a, RealField.C a) => a -> a -> [[a]] +accumulatedSaws sampleRate freq = + let starts = randomRs (0,1) (mkStdGen 48251) + depths = randomRs (0,0.02) (mkStdGen 12354) + phases = randomRs (0,1) (mkStdGen 74389) + speeds = randomRs (0.1,0.3) (mkStdGen 03445) + saws = zipWith4 (modulatedWave sampleRate Osci.freqModSaw freq) + starts depths phases speeds + in scanl1 (zipWith (+)) saws + +choirWave :: Field.C a => [a] +choirWave = + [0.702727421560071, 0.7378359559947721, 0.7826845805704197, 0.6755514176072053, + 0.4513448069764686, 0.3272995923197175, 0.3404887595570093, 0.41416011004660863, + 0.44593673999775735, 0.4803528740412951, 0.48761174828621334, 0.44076701468836754, + 0.39642906530439503, 0.35467843549395706, 0.38054627445988315, 0.3888748481589558, + 0.35303993804564215, 0.3725196582177455, 0.44980257249714667, 0.5421204370443772, + 0.627630436752643, 0.6589491426946169, 0.619819155051891, 0.5821754728547365, + 0.5495877076869761, 0.5324446834830168, 0.47242861142812065, 0.3686685958119909, + 0.2781440436733245, 0.2582500464201269, 0.1955614176372372, 0.038373557320540604, + -0.13132155046556182, -0.21867394831598339, -0.24302145520904606, -0.3096437514614372, + -0.44774961666697943, -0.5889830267579028, -0.7168993833444837, -0.816723038671071, + -0.8330283834679535, -0.8384077057999397, -0.8834813451725689, -0.9159391171556484, + -0.9189751669797644, -0.8932026446626791, -0.8909164153221475, -0.9716732300637536, + -1, -0.9253833606736654, -0.8568630538844477, -0.863932337623625, + -0.857811827480001, -0.8131204084064676, -0.7839286071242304, -0.7036632045472225, + -0.5824648346845637, -0.46123726085299827, -0.41391985851146285, -0.45323938111069567, + -0.5336689022602625, -0.5831307769323063, -0.5693896103843189, -0.48596981886424745, + -0.35791155598992863, -0.2661471984133689, -0.24158092840946802, -0.23965213828744264, + -0.23421368394531547, -0.25130667896294306, -0.3116359503337366, -0.31263345635966144, + -0.1879031874103659, -0.00020936838180399674, 0.18567090309156153, 0.2713525359068149, + 0.2979908042971701, 0.2957704726566382, 0.28820375086489286, 0.364513508557745, + 0.4520234711163569, 0.43210542988077005, 0.4064955825278379, 0.4416784798648095, + 0.5240917981530765, 0.6496469543088884, 0.7658103369723797, 0.8012776441058732, + 0.7824042138292476, 0.752678361663059, 0.760211176708886, 0.7308266231622353] + + +choir :: (Random a, Trans.C a, RealField.C a) => a -> a -> [a] +choir sampleRate freq = + let starts = randomRs (0,1) (mkStdGen 48251) + depths = randomRs (0,0.02) (mkStdGen 12354) + phases = randomRs (0,1) (mkStdGen 74389) + speeds = randomRs (0.1,0.3) (mkStdGen 03445) + voices = zipWith4 (modulatedWave sampleRate + (Osci.freqModSample Interpolation.constant choirWave) freq) + starts depths phases speeds + in map (*0.2) ((scanl1 (zipWith (+)) voices) !! 10) + + +fatSaw sampleRate freq = + {- a simplified version of modulatedWave -} + let partial depth modPhase modFreq = + osciDoubleSaw sampleRate + (map (\x -> freq*(1+x*depth)) + (Osci.staticSine modPhase (modFreq/sampleRate))) + in zipWith3 (((((/3).).(+)).).(+)) + (partial 0.00311 0.0 20) + (partial 0.00532 0.3 17) + (partial 0.00981 0.9 6) + +osciDoubleSaw :: (RealField.C a, Module.C a a) => a -> [a] -> [a] +osciDoubleSaw sampleRate = + Osci.freqModSample Interpolation.linear [-1, -0.2, 0.5, -0.5, 0.2, 1.0] 0 + . map (/sampleRate) + + +{-| A tone with a waveform with roughly the dependency x -> x**p, + where the waveform is normalized to constant quadratic norm -} +osciSharp :: (RealField.C a, Trans.C a) => a -> a -> [a] +osciSharp sampleRate freq = + let --control = iterate (+ (-1/sampleRate)) 4 + control = exponential2 (0.01*sampleRate) 10 + in Osci.shapeMod Wave.powerNormed 0 (freq/sampleRate) control + +{-| Build a saw sound from its harmonics and modulate it. + Different to normal modulation + I modulate each harmonic with the same depth rather than a proportional one. -} +osciAbsModSaw :: (RealField.C a, Trans.C a) => a -> a -> [a] +osciAbsModSaw sampleRate freq = + let ratios = map fromIntegral [(1::Int)..20] + harmonic n = FiltNR.amplify (0.25/n) + (Osci.freqModSine 0 (map (\x -> (n+0.03*x)*freq/sampleRate) + (Osci.staticSine 0 (1/sampleRate)))) + in mixMulti (map harmonic ratios) + +{-| Short pulsed Noise.white, + i.e. Noise.white amplified with pulses of varying H\/L ratio. -} +pulsedNoise :: (Ring.C a, Random a, RealField.C a, Trans.C a) => + a + -> a {-^ frequency of the pulses, interesting ones are around 100 Hz and below -} + -> [a] +pulsedNoise sampleRate freq = + zipWith3 (\thr0 thr1 x -> if thr0+1 < (thr1+1)*0.2 then x else 0) + (Osci.staticSine 0 (freq/sampleRate)) (Osci.staticSine 0 (0.1/sampleRate)) Noise.white + +noiseBass :: (Ring.C a, Random a, RealField.C a, Trans.C a, Module.C a a) => + a + -> a + -> [a] +noiseBass sampleRate freq = + let y = FiltNR.envelope (exponential2 (0.1*sampleRate) 1) Noise.white + ks = Comb.runProc (round (sampleRate/freq)) + (Filt1.lowpass + (repeat (Filt1.parameter (2000/sampleRate)))) y + in ks + +{-| Drum sound using the Karplus-Strong-Algorithm + This is a Noise.white enveloped by an exponential2 + which is piped through the Karplus-Strong machine + for generating some frequency. + The whole thing is then frequency modulated + to give a falling frequency. -} +electroTom :: (Ring.C a, Random a, RealField.C a, Trans.C a, Module.C a a) => + a -> [a] +electroTom sampleRate = + let y = FiltNR.envelope (exponential2 (0.1*sampleRate) 1) Noise.white + ks = Comb.runProc (round (sampleRate/30)) + (Filt1.lowpass + (repeat $ Filt1.parameter (1000/sampleRate))) y + in Interpolation.multiRelativeZeroPadLinear 0 (exponential2 (0.3*sampleRate) 1) ks 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,313 @@ +{-# OPTIONS -fno-implicit-prelude #-} +{- | +ToDo: +use AffineSpace instead of Module for the particular interpolation types, +since affine combinations assert reconstruction of constant functions. +They are more natural for interpolation of internal control parameters. +However, how can cubic interpolation expressed by affine combinations +without divisions? +-} +module Synthesizer.Plain.Interpolation where + +import qualified Synthesizer.Plain.Control as Ctrl +import qualified Synthesizer.Plain.Signal as Sig +import qualified Synthesizer.Plain.Filter.NonRecursive as FiltNR + +import qualified Algebra.Module as Module +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Algebra.Additive(zero) +import Algebra.Module((*>)) +import Data.Maybe (fromMaybe) +import Synthesizer.Utility (viewListL, viewListR, affineComb, ) +import Synthesizer.ApplicativeUtility (liftA4, ) + +import Control.Monad.State (StateT(StateT), evalStateT, replicateM_, ap, guard, ) +import Control.Applicative (Applicative(pure, (<*>)), (<$>), liftA2, ) + +import PreludeBase +import NumericPrelude + + +{- | interpolation as needed for resampling -} +data T t y = + Cons { + number :: Int, -- interpolation requires a total number of 'number' + offset :: Int, -- interpolation requires 'offset' values before the current + func :: t -> Sig.T y -> y + } + + +{-* Interpolation with various padding methods -} + +zeroPad :: (RealField.C t) => + (T t y -> t -> Sig.T y -> a) -> + y -> T t y -> t -> Sig.T y -> a +zeroPad interpolate z ip phase x = + let (phInt, phFrac) = splitFraction phase + in interpolate ip phFrac + (FiltNR.delayPad z (offset ip - phInt) (x ++ repeat z)) + +constantPad :: (RealField.C t) => + (T t y -> t -> Sig.T y -> a) -> + T t y -> t -> Sig.T y -> a +constantPad interpolate ip phase x = + let (phInt, phFrac) = splitFraction phase + xPad = + do (xFirst,_) <- viewListL x + (xBody,xLast) <- viewListR x + return (FiltNR.delayPad xFirst (offset ip - phInt) (xBody ++ repeat xLast)) + in interpolate ip phFrac + (fromMaybe [] xPad) + + +{- | +Only for finite input signals. +-} +cyclicPad :: (RealField.C t) => + (T t y -> t -> Sig.T y -> a) -> + T t y -> t -> Sig.T y -> a +cyclicPad interpolate ip phase x = + let (phInt, phFrac) = splitFraction phase + in interpolate ip phFrac + (drop (mod (phInt - offset ip) (length x)) (cycle x)) + +{- | +The extrapolation may miss some of the first and some of the last points +-} +extrapolationPad :: (RealField.C t) => + (T t y -> t -> Sig.T y -> a) -> + T t y -> t -> Sig.T y -> a +extrapolationPad interpolate ip phase = + interpolate ip (phase - fromIntegral (offset ip)) +{- + This example shows pikes, although there shouldn't be any: + plotList (take 100 $ interpolate (Zero (0::Double)) ipCubic (-0.9::Double) (repeat 0.03) [1,0,1,0.8]) +-} + + +{-* Interpolation of multiple values with various padding methods -} + +skip :: (RealField.C t) => + T t y -> (t, Sig.T y) -> (t, Sig.T y) +skip ip (phase0, x0) = + let (n, frac) = splitFraction phase0 + (m, x1) = Sig.dropMarginRem (number ip) n x0 + in (fromIntegral m + frac, x1) + +single :: (RealField.C t) => + T t y -> t -> Sig.T y -> y +single ip phase0 x0 = + uncurry (func ip) $ skip ip (phase0, x0) +-- curry (uncurry (func ip) . skip ip) +{- +GNUPlot.plotFunc [] (GNUPlot.linearScale 1000 (0,2)) (\t -> single linear (t::Double) [0,4,1::Double]) +-} + +-- | alternative implementation of 'single' +singleRec :: (Ord t, Ring.C t) => + T t y -> t -> Sig.T y -> y +singleRec ip phase x = + -- check if we are leaving the current interval + maybe + (func ip phase x) + (singleRec ip (phase - 1)) + (do (_,xs) <- viewListL x + guard (phase >= 1 && minLength (number ip) xs) + return xs) + + +{-* Interpolation of multiple values with various padding methods -} + +{- | All values of frequency control must be non-negative. -} +multiRelative :: (RealField.C t) => + T t y -> t -> Sig.T y -> Sig.T t -> Sig.T y +multiRelative ip phase0 x0 = + map (uncurry (func ip)) . + scanl + (\(phase,x) freq -> skip ip (phase + freq, x)) + (skip ip (phase0,x0)) + + +multiRelativeZeroPad :: (RealField.C t) => + y -> T t y -> t -> Sig.T t -> Sig.T y -> Sig.T y +multiRelativeZeroPad z ip phase fs x = + zeroPad multiRelative z ip phase x fs + +multiRelativeConstantPad :: (RealField.C t) => + T t y -> t -> Sig.T t -> Sig.T y -> Sig.T y +multiRelativeConstantPad ip phase fs x = + constantPad multiRelative ip phase x fs + +multiRelativeCyclicPad :: (RealField.C t) => + T t y -> t -> Sig.T t -> Sig.T y -> Sig.T y +multiRelativeCyclicPad ip phase fs x = + cyclicPad multiRelative ip phase x fs + +{- | +The extrapolation may miss some of the first and some of the last points +-} +multiRelativeExtrapolationPad :: (RealField.C t) => + T t y -> t -> Sig.T t -> Sig.T y -> Sig.T y +multiRelativeExtrapolationPad ip phase fs x = + extrapolationPad multiRelative ip phase x fs +{- + This example shows pikes, although there shouldn't be any: + plotList (take 100 $ interpolate (Zero (0::Double)) ipCubic (-0.9::Double) (repeat 0.03) [1,0,1,0.8]) +-} + +{-* All-in-one interpolation functions -} + +multiRelativeZeroPadConstant :: + (RealField.C t, Additive.C y) => t -> Sig.T t -> Sig.T y -> Sig.T y +multiRelativeZeroPadConstant = multiRelativeZeroPad zero constant + +multiRelativeZeroPadLinear :: + (RealField.C t, Module.C t y) => t -> Sig.T t -> Sig.T y -> Sig.T y +multiRelativeZeroPadLinear = multiRelativeZeroPad zero linear + +multiRelativeZeroPadCubic :: + (RealField.C t, Module.C t y) => t -> Sig.T t -> Sig.T y -> Sig.T y +multiRelativeZeroPadCubic = multiRelativeZeroPad zero cubic + + +{-* Different kinds of interpolation -} + +{-** Hard-wired interpolations -} + +data PrefixReader y a = + PrefixReader Int (StateT (Sig.T y) Maybe a) + +instance Functor (PrefixReader y) where + fmap f (PrefixReader count parser) = + PrefixReader count (fmap f parser) + +-- this is a MonadWriter with Sum monoid +instance Applicative (PrefixReader y) where + pure = PrefixReader 0 . return + (PrefixReader count0 parser0) <*> (PrefixReader count1 parser1) = + PrefixReader (count0+count1) (parser0 `ap` parser1) + +getNode :: PrefixReader y y +getNode = PrefixReader 1 (StateT viewListL) + +fromPrefixReader :: String -> Int -> PrefixReader y (t -> y) -> T t y +fromPrefixReader name off (PrefixReader count parser) = + Cons count off + (\t xs -> + maybe + (error (name ++ " interpolation: not enough nodes")) + ($t) + (evalStateT parser xs)) + +{-| Consider the signal to be piecewise constant. -} +constant :: T t y +constant = + fromPrefixReader "constant" 0 (const <$> getNode) + +{-| Consider the signal to be piecewise linear. -} +linear :: (Module.C t y) => T t y +linear = + fromPrefixReader "linear" 0 + (liftA2 + (\x0 x1 phase -> affineComb phase (x0,x1)) + getNode getNode) + +{-| Consider the signal to be piecewise cubic, + with smooth connections at the nodes. + It uses a cubic curve which has node values + x0 at 0 and x1 at 1 and derivatives + (x1-xm1)/2 and (x2-x0)/2, respectively. + You can see how it works + if you evaluate the expression for t=0 and t=1 + as well as the derivative at these points. -} +cubic :: (Field.C t, Module.C t y) => T t y +cubic = + fromPrefixReader "cubic" 1 + (liftA4 + (\xm1 x0 x1 x2 t -> + let lipm12 = affineComb t (xm1,x2) + lip01 = affineComb t (x0, x1) + three = 3 `asTypeOf` t + in lip01 + (t*(t-1)/2) *> + (lipm12 + (x0+x1) - three *> lip01)) + getNode getNode getNode getNode) + +cubicAlt :: (Field.C t, Module.C t y) => T t y +cubicAlt = + fromPrefixReader "cubicAlt" 1 + (liftA4 + (\xm1 x0 x1 x2 t -> + let half = 1/2 `asTypeOf` t + in cubicHalf t x0 (half *> (x1-xm1)) + + cubicHalf (1-t) x1 (half *> (x0-x2))) + getNode getNode getNode getNode) + + +{- \t -> cubicHalf t x x' has a double zero at 1 and + at 0 it has value x and steepness x' -} +cubicHalf :: (Module.C t y) => t -> y -> y -> y +cubicHalf t x x' = + (t-1)^2 *> ((1+2*t)*>x + t*>x') + + + +{-** Interpolation based on piecewise defined functions -} + +piecewise :: (Module.C t y) => + Int -> [t -> t] -> T t y +piecewise center ps = + Cons (length ps) (center-1) + (\t -> Module.linearComb (reverse (map ($t) ps))) + +piecewiseConstant :: (Module.C t y) => T t y +piecewiseConstant = + piecewise 1 [const 1] + +piecewiseLinear :: (Module.C t y) => T t y +piecewiseLinear = + piecewise 1 [id, (1-)] + +piecewiseCubic :: (Field.C t, Module.C t y) => T t y +piecewiseCubic = + piecewise 2 $ + Ctrl.cubicFunc (0,(0,0)) (1,(0,1/2)) : + Ctrl.cubicFunc (0,(0,1/2)) (1,(1,0)) : + Ctrl.cubicFunc (0,(1,0)) (1,(0,-1/2)) : + Ctrl.cubicFunc (0,(0,-1/2)) (1,(0,0)) : + [] + +{- +GNUPlot.plotList [] $ take 100 $ interpolate (Zero 0) piecewiseCubic (-2.3 :: Double) (repeat 0.1) [2,1,2::Double] +-} + + +{-** Interpolation based on arbitrary functions -} + +{- | with this wrapper you can use the collection of interpolating functions from Donadio's DSP library -} +function :: (Module.C t y) => + (Int,Int) {- ^ @(left extent, right extent)@, e.g. @(1,1)@ for linear hat -} + -> (t -> t) + -> T t y +function (left,right) f = + let len = left+right + in Cons len left + (\t -> Module.linearComb (reverse + (map (\x -> f (t + fromIntegral x)) (take len [(-left)..])))) +{- +GNUPlot.plotList [] $ take 300 $ interpolate (Zero 0) (function (1,1) (\x -> exp (-6*x*x))) (-2.3 :: Double) (repeat 0.03) [2,1,2::Double] +-} + + + +{-* Helper functions -} + + +{-| Test if a list has at least @n@ elements + make sure that @n@ is non-negative -} +minLength :: Int -> Sig.T y -> Bool +minLength n xs = + maybe False (const True) (evalStateT (replicateM_ n (StateT viewListL)) xs) 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 @@ +{-# OPTIONS_GHC -fno-implicit-prelude #-} +module Synthesizer.Plain.LorenzAttractor where + +import qualified Algebra.Module as Module +import qualified Algebra.Ring as Ring + +import PreludeBase +import NumericPrelude + + +computeDerivatives :: (Ring.C y) => + (y, y, y) -> (y, y, y) -> (y, y, y) +computeDerivatives (a,b,c) (x,y,z) = + let x' = a*(y-x) + y' = x*(b-z) - y + z' = x*y -c*z + in (x',y',z') + +explicitEuler :: (Module.C a v) => + a -> (v -> v) -> v -> [v] +explicitEuler h phi s = + let ys = s : map (\y -> y + h *> phi y) ys + in ys + + +equilibrium :: (Double, Double, Double) +equilibrium = (sqrt 72, sqrt 72, 27.001) + +example0 :: [(Double, Double, Double)] +example0 = + explicitEuler (0.01::Double) + (computeDerivatives (10, 28, 8/3)) equilibrium + +example :: [(Double, Double, Double)] +example = + explicitEuler (0.01::Double) + (computeDerivatives (10, 28, 8/3)) (8.5, 8.6, 27) 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 @@ +{-# OPTIONS -fno-implicit-prelude #-} +module Synthesizer.Plain.Miscellaneous where + +import qualified Algebra.NormedSpace.Euclidean as Euc +import qualified Algebra.Field as Field +-- import qualified Algebra.Ring as Ring +-- import qualified Algebra.Additive as Additive + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +{- * Spatial effects -} + +{-| simulate an moving sounding object + convert the way of the object through 3D space + into a delay and attenuation information, + sonicDelay is the reciprocal of the sonic velocity -} +receive3Dsound :: (Field.C a, Euc.C a v) => a -> a -> v -> [v] -> ([a],[a]) +receive3Dsound att sonicDelay ear way = + let dists = map (Euc.norm) (map (subtract ear) way) + phase = map (sonicDelay*) dists + volumes = map (\x -> 1/(att+x)^2) dists + in (phase, volumes) 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,80 @@ +{- | +Support for stateful modifiers like controlled filters. +-} +module Synthesizer.Plain.Modifier where + +import Control.Monad.State (State(..), zipWithM, evalState) + +import qualified Data.List as List + +import Prelude hiding (init) + + +-- Signal.T, re-defined here in order to avoid module cycle +type T a = [a] + + +data Simple s ctrl a b = + Simple { + init :: s, + step :: ctrl -> a -> State s b + } + +{-| +modif is a process controlled by values of type c +with an internal state of type s, +it converts an input value of type a into an output value of type b +while turning into a new state + +ToDo: +Shall finite signals be padded with zeros? +-} +static :: + Simple s ctrl a b -> ctrl -> T a -> T b +static modif control x = + evalState (mapM (step modif control) x) (init modif) + +{-| Here the control may vary over the time. -} +modulated :: + Simple s ctrl a b -> T ctrl -> T a -> T b +modulated modif control x = + evalState (zipWithM (step modif) control x) (init modif) + + +data Initialized s init ctrl a b = + Initialized { + initInit :: init -> s, + initStep :: ctrl -> a -> State s b + } + + +initialize :: + Initialized s init ctrl a b -> init -> Simple s ctrl a b +initialize modif stateInit = + Simple (initInit modif stateInit) (initStep modif) + +staticInit :: + Initialized s init ctrl a b -> init -> ctrl -> T a -> T b +staticInit modif state = + static (initialize modif state) + +{-| Here the control may vary over the time. -} +modulatedInit :: + Initialized s init ctrl a b -> init -> T ctrl -> T a -> T b +modulatedInit modif state = + modulated (initialize modif state) + + + +{- | +The number of stacked state monads +depends on the size of the list of state values. +This is like a dynamically nested StateT. +-} +stackStatesR :: (a -> State s a) -> (a -> State [s] a) +stackStatesR m = + State . List.mapAccumR (runState . m) + +stackStatesL :: (a -> State s a) -> (a -> State [s] a) +stackStatesL m = + State . List.mapAccumL (runState . m) 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 @@ +{-# OPTIONS -fno-implicit-prelude #-} +{- | Noise and random processes. -} +module Synthesizer.Plain.Noise where + +import qualified Synthesizer.Plain.Signal as Sig + +import qualified Algebra.Real as Real +import qualified Algebra.Ring as Ring + +import System.Random (Random, RandomGen, randomRs, mkStdGen, ) + +import NumericPrelude.List (sliceVert) + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +{-| +Deterministic white noise, uniformly distributed between -1 and 1. +That is, variance is 1\/3. +-} +white :: (Ring.C y, Random y) => + Sig.T y +white = whiteGen (mkStdGen 12354) + +whiteGen :: (Ring.C y, Random y, RandomGen g) => + g -> Sig.T y +whiteGen = randomRs (-1,1) + +{- | +Approximates normal distribution with variance 1 +by a quadratic B-spline distribution. +-} +whiteQuadraticBSplineGen :: (Ring.C y, Random y, RandomGen g) => + g -> Sig.T y +whiteQuadraticBSplineGen = + map sum . sliceVert 3 . randomRs (-1,1) + + +randomPeeks :: (Real.C y, Random y) => + Sig.T y {- ^ momentary densities, @p@ means that there is about one peak + in the time range of @1\/p@ samples -} + -> Sig.T Bool {- ^ Every occurence of 'True' represents a peak. -} +randomPeeks = + randomPeeksGen (mkStdGen 876) + +randomPeeksGen :: (Real.C y, Random y, RandomGen g) => + g + -> Sig.T y + -> Sig.T Bool +randomPeeksGen = + zipWith (<) . randomRs (0,1) 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,200 @@ +{-# OPTIONS -fno-implicit-prelude #-} +{- | +Copyright : (c) Henning Thielemann 2006 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +Tone generators + +Frequencies are always specified in ratios of the sample rate, +e.g. the frequency 0.01 for the sample rate 44100 Hz +means a physical frequency of 441 Hz. +-} +module Synthesizer.Plain.Oscillator where + +import qualified Synthesizer.Plain.ToneModulation as ToneMod +import qualified Synthesizer.Basic.Wave as Wave +import qualified Synthesizer.Basic.Phase as Phase +import qualified Synthesizer.Plain.Interpolation as Interpolation +import qualified Synthesizer.Plain.Signal as Sig + +import Synthesizer.Plain.ToneModulation (freqToPhase, ) + +{- +import qualified Algebra.RealTranscendental as RealTrans +import qualified Algebra.Module as Module +import qualified Algebra.VectorSpace as VectorSpace + +import Algebra.Module((*>)) +-} +import qualified Algebra.Transcendental as Trans +import qualified Algebra.RealField as RealField +-- import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +-- import qualified Number.NonNegative as NonNeg + +import NumericPrelude + +-- import qualified Prelude as P +import PreludeBase + + +type Phase a = a + + +{- * Oscillators with arbitrary but constant waveforms -} + +{- | oscillator with constant frequency -} +static :: (RealField.C a) => Wave.T a b -> (Phase a -> a -> Sig.T b) +static wave phase freq = + map (Wave.apply wave) + (iterate (Phase.increment freq) (Phase.fromRepresentative phase)) + +{- | oscillator with modulated frequency -} +freqMod :: (RealField.C a) => Wave.T a b -> Phase a -> Sig.T a -> Sig.T b +freqMod wave phase freqs = + map (Wave.apply wave) + (freqToPhase (Phase.fromRepresentative phase) freqs) + +{- | oscillator with modulated phase -} +phaseMod :: (RealField.C a) => Wave.T a b -> a -> Sig.T (Phase a) -> Sig.T b +phaseMod wave freq phases = + map (Wave.apply wave) $ + zipWith Phase.increment phases (iterate (Phase.increment freq) zero) + +{- | oscillator with modulated shape -} +shapeMod :: (RealField.C a) => (c -> Wave.T a b) -> (Phase a) -> a -> Sig.T c -> Sig.T b +shapeMod wave phase freq parameters = + zipWith (Wave.apply . wave) parameters $ + iterate (Phase.increment freq) (Phase.fromRepresentative phase) + +{- | oscillator with both phase and frequency modulation -} +phaseFreqMod :: (RealField.C a) => Wave.T a b -> Sig.T (Phase a) -> Sig.T a -> Sig.T b +phaseFreqMod wave phases freqs = + map (Wave.apply wave) + (zipWith Phase.increment phases (freqToPhase zero freqs)) + +{- | oscillator with both shape and frequency modulation -} +shapeFreqMod :: (RealField.C a) => (c -> Wave.T a b) -> Phase a -> Sig.T c -> Sig.T a -> Sig.T b +shapeFreqMod wave phase parameters freqs = + zipWith (Wave.apply . wave) parameters $ + freqToPhase (Phase.fromRepresentative phase) freqs + + +{- | oscillator with a sampled waveform with constant frequency + This is essentially an interpolation with cyclic padding. -} +staticSample :: RealField.C a => Interpolation.T a b -> [b] -> Phase a -> a -> Sig.T b +staticSample ip wave phase freq = + freqModSample ip wave phase (repeat freq) + +{- | oscillator with a sampled waveform with modulated frequency + Should behave homogenously for different types of interpolation. -} +freqModSample :: RealField.C a => Interpolation.T a b -> [b] -> Phase a -> Sig.T a -> Sig.T b +freqModSample ip wave phase freqs = + let len = fromIntegral (length wave) + in Interpolation.multiRelativeCyclicPad + ip (phase*len) (map (len*) freqs) wave + +{- | +Shape control is a list of relative changes, +each of which must be non-negative in order to allow lazy processing. +'1' advances by one wave. +Frequency control can be negative. +If you want to use sampled waveforms as well +then use 'Wave.sample' in the list of waveforms. +With sampled waves this function is identical to HunkTranspose in Assampler. + +Example: interpolate different versions +of 'Wave.oddCosine' and 'Wave.oddTriangle'. + +You could also chop a tone into single waves +and use the waves as input for this function +but you certainly want to use +'Wave.sampledTone' or 'shapeFreqModFromSampledTone' instead, +because in the wave information for 'shapeFreqModSample' +shape and phase are strictly separated. +-} +shapeFreqModSample :: (RealField.C c, RealField.C b) => + Interpolation.T c (Wave.T b a) -> [Wave.T b a] -> c -> Phase b -> Sig.T c -> Sig.T b -> Sig.T a +shapeFreqModSample ip waves shape0 phase shapes freqs = + zipWith Wave.apply + (Interpolation.multiRelativeConstantPad ip shape0 shapes waves) + (freqToPhase (Phase.fromRepresentative phase) freqs) +{- +GNUPlot.plotList [] $ take 500 $ shapeFreqModSample Interpolation.cubic (map Wave.truncOddCosine [0..3]) (0.1::Double) (0::Double) (repeat 0.005) (repeat 0.02) +-} + +{- | +Time stretching and frequency modulation of a pure tone. + +We consider a tone as the result of a shape modulated oscillator, +and virtually reconstruct the waveform function +(a function of time and phase) by interpolation and resample it. +This way we can alter frequency and time progress of the tone independently. + +This function is identical to using 'shapeFreqMod' +with a wave function constructed by 'Wave.sampledTone' +but it consumes the sampled source tone lazily +and thus allows only relative shape control with non-negative control steps. + +The function is similar to 'shapeFreqModSample' but respects +that in a sampled tone, phase and shape control advance synchronously. +Actually we could re-use 'shapeFreqModSample' with modified phase values. +But we would have to cope with negative shape control jumps, +and waves would be padded locally cyclically. +The latter one is not wanted +since we want padding according to the adjacencies in the source tone. + +Although the shape difference values must be non-negative +I hesitate to give them the type @Number.NonNegative.T t@ +because then you cannot call this function with other types +of non-negative numbers like 'Number.NonNegativeChunky.T'. + +The prototype tone signal is reproduced if +@freqs == repeat (1\/period)@ and @shapes == repeat 1@. +-} +shapeFreqModFromSampledTone :: (RealField.C t) => + Interpolation.T t y -> + Interpolation.T t y -> + t -> Sig.T y -> t -> t -> Sig.T t -> Sig.T t -> Sig.T y +shapeFreqModFromSampledTone + ipLeap ipStep period sampledTone + shape0 phase shapes freqs = + map + (uncurry (ToneMod.interpolateCell ipLeap ipStep)) + (ToneMod.oscillatorCells + ipLeap ipStep period sampledTone + (shape0, shapes) (Phase.fromRepresentative phase, freqs)) +{- +GNUPlot.plotList [] $ take 1000 $ shapeFreqModFromSampledTone Interpolation.linear Interpolation.linear (1/0.07::Double) (staticSine (0::Double) 0.07) 0 0 (repeat 0.1) (repeat 0.01) +GNUPlot.plotList [] $ take 1000 $ shapeFreqModFromSampledTone Interpolation.linear Interpolation.linear (1/0.07::Double) (staticSine (0::Double) 0.07) 0 0 (repeat 0.1) (iterate (*(1-2e-3)) 0.01) +GNUPlot.plotList [] $ take 101 $ shapeFreqModFromSampledTone Interpolation.linear Interpolation.linear (1/0.07::Double) (iterate (1+) (0::Double)) 0 0 (repeat 1) (repeat 0.7) +-} + + +{- * Oscillators with specific waveforms -} + +{- | sine oscillator with static frequency -} +staticSine :: (Trans.C a, RealField.C a) => a -> a -> Sig.T a +staticSine = static Wave.sine + +{- | sine oscillator with modulated frequency -} +freqModSine :: (Trans.C a, RealField.C a) => a -> Sig.T a -> Sig.T a +freqModSine = freqMod Wave.sine + +{- | sine oscillator with modulated phase, useful for FM synthesis -} +phaseModSine :: (Trans.C a, RealField.C a) => a -> Sig.T a -> Sig.T a +phaseModSine = phaseMod Wave.sine + +{- | saw tooth oscillator with modulated frequency -} +staticSaw :: RealField.C a => a -> a -> Sig.T a +staticSaw = static Wave.saw + +{- | saw tooth oscillator with modulated frequency -} +freqModSaw :: RealField.C a => a -> Sig.T a -> Sig.T a +freqModSaw = freqMod Wave.saw 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,209 @@ +{-# OPTIONS_GHC -O -fglasgow-exts #-} +{- glasgow-exts are for the rules -} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : portable +-} +module Synthesizer.Plain.Signal where + +import qualified Synthesizer.Generic.Signal as SigG +import qualified Sound.Signal as Signal + +import qualified Algebra.Additive as Additive + +import qualified Synthesizer.Plain.Modifier as Modifier +import Synthesizer.Utility (viewListL, viewListR, ) + +import qualified NumericPrelude.List as NPList +import qualified Data.List as List + + +type T a = [a] + + +{- * Generic routines that are useful for filters -} + +type Modifier s ctrl a b = Modifier.Simple s ctrl a b + +{-| +modif is a process controlled by values of type c +with an internal state of type s, +it converts an input value of type a into an output value of type b +while turning into a new state + +ToDo: +Shall finite signals be padded with zeros? +-} +modifyStatic :: + Modifier s ctrl a b -> ctrl -> T a -> T b +modifyStatic = Modifier.static + +{-| Here the control may vary over the time. -} +modifyModulated :: + Modifier s ctrl a b -> T ctrl -> T a -> T b +modifyModulated = Modifier.modulated + + +type ModifierInit s init ctrl a b = Modifier.Initialized s init ctrl a b + + +modifierInitialize :: + ModifierInit s init ctrl a b -> init -> Modifier s ctrl a b +modifierInitialize = Modifier.initialize + +modifyStaticInit :: + ModifierInit s init ctrl a b -> init -> ctrl -> T a -> T b +modifyStaticInit = Modifier.staticInit + +{-| Here the control may vary over the time. -} +modifyModulatedInit :: + ModifierInit s init ctrl a b -> init -> T ctrl -> T a -> T b +modifyModulatedInit = Modifier.modulatedInit + + + +instance Signal.C [] where + singleton = (:[]) + unfoldR = unfoldR + reduceL = reduceL + mapAccumL = mapAccumL + (++) = (List.++) + zipWith = List.zipWith + +unfoldR :: (acc -> Maybe (y, acc)) -> acc -> (acc, T y) +unfoldR f = + let recurse acc0 = + maybe + (acc0,[]) + (\(y,acc1) -> + let (accEnd, signal) = recurse acc1 + in (accEnd, y : signal)) + (f acc0) + in recurse + +reduceL :: (x -> acc -> Maybe acc) -> acc -> T x -> acc +reduceL f = + let recurse a xt = + case xt of + [] -> a + (x:xs) -> + maybe a + (\ a' -> seq a' (recurse a' xs)) + (f x a) + in recurse + +mapAccumL :: (x -> acc -> Maybe (y, acc)) -> acc -> T x -> (acc, T y) +mapAccumL f = + let recurse acc0 xt = + case xt of + [] -> (acc0,[]) + (x:xs) -> + maybe + (acc0,[]) + (\(y,acc1) -> + let (accEnd, signal) = recurse acc1 xs + in (accEnd, y : signal)) + (f x acc0) + in recurse + +crochetL :: (x -> acc -> Maybe (y, acc)) -> acc -> T x -> T y +crochetL f a = snd . mapAccumL f a + + +{- | +Feed back signal into signal processor, +and apply a delay by one value. +'fix1' is a kind of 'Signal.generate'. +-} +fix1 :: y -> (T y -> T y) -> T y +fix1 pad f = + let y = f (pad:y) + in y + +{-# RULES + "fix1/crochetL" forall f a b. + fix1 a (Signal.crochetL f b) = + Signal.generate (\(a0,b0) -> + do yb1@(y0,_) <- f a0 b0 + return (y0, yb1)) (a,b) ; + #-} + + +instance SigG.C [] where + empty = [] + null = List.null + cons = (:) + fromList = id + toList = id + repeat = List.repeat + cycle = List.cycle + replicate = List.replicate + iterate = List.iterate + iterateAssoc = NPList.iterateAssoc + unfoldR = List.unfoldr + map = List.map + mix = (Additive.+) + zipWith = List.zipWith + scanL = List.scanl + viewL = viewListL + viewR = viewListR + foldL = List.foldl + length = List.length + take = List.take + drop = List.drop + splitAt = List.splitAt + dropMarginRem = dropMarginRem + takeWhile = List.takeWhile + dropWhile = List.dropWhile + span = List.span + append = (List.++) + concat = List.concat + reverse = List.reverse +{- + mapAccumL = List.mapAccumL + mapAccumR = List.mapAccumR +-} + crochetL = crochetL + +{- +instance SigG.Data [] y where + +instance SigG.C [] where + add = (Additive.+) + map = List.map + zipWith = List.zipWith +-} + + +{- | +@dropMarginRem n m xs@ +drops at most the first @m@ elements of @xs@ +and ensures that @xs@ still contains @n@ elements. +Additionally returns the number of elements that could not be dropped +due to the margin constraint. +That is @dropMarginRem n m xs == (k,ys)@ implies @length xs - m == length ys - k@. +Requires @length xs >= n@. +-} +dropMarginRem :: Int -> Int -> T a -> (Int, T a) +dropMarginRem n m = + head . + dropMargin n m . + zipWithTails (,) (iterate pred m) + +dropMargin :: Int -> Int -> T a -> T a +dropMargin n m xs = + NPList.dropMatch (take m (drop n xs)) xs + +{- | +Can be implemented more efficiently +than just by 'zipWith' and 'List.tails' +for other data structures. +-} +zipWithTails :: + (y0 -> T y1 -> y2) -> T y0 -> T y1 -> T y2 +zipWithTails f xs = + zipWith f xs . init . List.tails 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,459 @@ +{-# OPTIONS -O2 -fno-implicit-prelude #-} +{- | +Copyright : (c) Henning Thielemann 2006 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + + +Avoid importing this module. +Better use functions from +"Synthesizer.Plain.Oscillator" and +"Synthesizer.Basic.Wave" + +Input data is interpreted as samples of data on a cylinder +in the following form: + +> |* | +> | * | +> | * | +> | * | +> | * | +> | * | +> | * | +> | *| +> | * | +> | * | +> | * | + + +> ----------- +> * +> * +> * +> * +> * +> * +> * +> * +> * +> * +> * +> ----------- + +We have to interpolate in the parallelograms. + +-} +module Synthesizer.Plain.ToneModulation where + +import qualified Synthesizer.Basic.Phase as Phase + +import qualified Synthesizer.Plain.Interpolation as Interpolation +-- import qualified Data.Array as Array +import Data.Array (Array, (!), listArray, ) + +-- import qualified Algebra.Transcendental as Trans +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +-- import qualified Algebra.Real as Real +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import qualified Number.NonNegative as NonNeg +import qualified Number.NonNegativeChunky as Chunky + +import Synthesizer.Utility (viewListL, viewListR, clip, mapPair, ) +import Control.Monad (guard) + +import qualified Data.List as List + +import NumericPrelude.List (replicateMatch, takeMatch, ) +import NumericPrelude + +-- import qualified Prelude as P +import PreludeBase + + + +-- * general helpers + +interpolateCell :: + Interpolation.T a y -> + Interpolation.T b y -> + (a, b) -> + [[y]] -> y +interpolateCell ipLeap ipStep (qLeap,qStep) = + Interpolation.func ipStep qStep . + map (Interpolation.func ipLeap qLeap) + + +{- | +Convert from the (shape,phase) parameter pair +to the index within a wave (step) and the index of a wave (leap) +in the sampled prototype tone. +-} +untangleShapePhase :: (Field.C a) => + Int -> a -> (a, a) -> (a, a) +untangleShapePhase periodInt period (shape,phase) = + let leap = shape/period - phase + step = shape - leap * fromIntegral periodInt + in (leap, step) + +untangleShapePhaseAnalytic :: (Field.C a) => + Int -> a -> (a, a) -> (a, a) +untangleShapePhaseAnalytic periodInt period (shape,phase) = + let periodRound = fromIntegral periodInt + vLeap = (periodRound, periodRound-period) + vStep = (1,1) + in solveSLE2 (vLeap,vStep) (shape,period*phase) + +{- +Cramer's rule + +see HTam/Numerics/ZeroFinder/Root, however the matrix is transposed +-} +solveSLE2 :: Field.C a => ((a,a), (a,a)) -> (a,a) -> (a,a) +solveSLE2 a@(a0,a1) b = + let det = det2 a + in (det2 (b, a1) / det, + det2 (a0, b) / det) + +det2 :: Ring.C a => ((a,a), (a,a)) -> a +det2 ((a00,a10),(a01,a11)) = + a00*a11 - a10*a01 + +{- +transpose :: ((a,a), (a,a)) -> ((a,a), (a,a)) +transpose ((a00,a10),(a01,a11)) = ((a00,a01),(a10,a11)) +-} + + +flattenShapePhase :: RealField.C a => + Int + -> a + -> (a, Phase.T a) + -> (Int, (a, a)) +flattenShapePhase periodInt period (shape,phase) = + let (xShape,xWave) = + untangleShapePhase periodInt period (shape, Phase.toRepresentative phase) + (nLeap,qLeap) = splitFraction xShape + (nStep,qStep) = splitFraction xWave + {- reverse solveSLE2 for the shape parameter + with respect to the rounded (wave,shape) coordinates -} + n = nStep + nLeap * periodInt + in (n,(qLeap,qStep)) + +shapeLimits :: Ring.C t => + Interpolation.T a v + -> Interpolation.T a v + -> Int + -> t + -> (t, t) +shapeLimits ipLeap ipStep periodInt len = + let minShape = + fromIntegral $ + interpolationOffset ipLeap ipStep periodInt + + periodInt + maxShape = + minShape + len - + fromIntegral + (Interpolation.number ipStep + + Interpolation.number ipLeap * periodInt) + in (minShape, maxShape) + + +interpolationOffset :: + Interpolation.T a v + -> Interpolation.T a v + -> Int + -> Int +interpolationOffset ipLeap ipStep periodInt = + Interpolation.offset ipStep + + Interpolation.offset ipLeap * periodInt + + + + +-- * array based shape variable wave + +data Prototype a v = + Prototype { + protoIpLeap, + protoIpStep :: Interpolation.T a v, + protoIpOffset :: Int, + protoPeriod :: a, + protoPeriodInt :: Int, + protoShapeLimits :: (a,a), + protoArray :: Array Int v + } + + +makePrototype :: (RealField.C a) => + Interpolation.T a v -> + Interpolation.T a v -> + a -> [v] -> Prototype a v +makePrototype ipLeap ipStep period tone = + let periodInt = round period + ipOffset = + interpolationOffset ipLeap ipStep periodInt + len = length tone + (lower,upper) = + shapeLimits ipLeap ipStep periodInt len + limits = + if lower > upper + then error "min>max" + else + (fromIntegral lower, fromIntegral upper) + + arr = listArray (0, pred len) tone + + in Prototype { + protoIpLeap = ipLeap, + protoIpStep = ipStep, + protoIpOffset = ipOffset, + protoPeriod = period, + protoPeriodInt = periodInt, + protoShapeLimits = limits, + protoArray = arr + } + +sampledToneCell :: (RealField.C a) => + Prototype a v -> a -> Phase.T a -> ((a,a),[[v]]) +sampledToneCell p shape phase = + let (n, q) = + flattenShapePhase (protoPeriodInt p) (protoPeriod p) + (uncurry clip (protoShapeLimits p) shape, phase) + in (q, + map (map (protoArray p ! ) . iterate (protoPeriodInt p +)) $ + enumFrom (n - protoIpOffset p)) + +sampledToneAltCell :: (RealField.C a) => + Prototype a v -> a -> Phase.T a -> ((a,a),[[v]]) +sampledToneAltCell p shape phase = + let (n, q) = + flattenShapePhase (protoPeriodInt p) (protoPeriod p) + (uncurry clip (protoShapeLimits p) shape, phase) + in (q, + iterate (drop (protoPeriodInt p)) $ + map (protoArray p ! ) (enumFrom (n - protoIpOffset p))) + + +{- + M = ((1,1)^T, (periodRound, period-periodRound)^T) + + equation for the line + 0 = (nStep - offset ipStep) + + (nLeap - offset ipLeap) * periodInt + + <(1,periodInt), (offset ipStep, offset ipLeap)> + = <(1,periodInt), (nStep,nLeap)> + d = + = + = <(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) => + Interpolation.T t y -> + Interpolation.T t y -> + t -> [y] -> (t,[t]) -> (Phase.T t,[t]) -> [((t,t),[[y]])] +oscillatorCells + ipLeap ipStep period sampledTone shapes freqs = + let periodInt = round period + ptrs = + List.transpose $ + takeWhile (not . null) $ + iterate (drop periodInt) sampledTone + ipOffset = + interpolationOffset ipLeap ipStep periodInt + (skip:skips,coords) = + unzip $ + oscillatorCoords periodInt period + (limitRelativeShapes ipLeap ipStep periodInt sampledTone shapes) + freqs + in zipWith + -- n will be zero within the data, it's only needed for extrapolation + (\(k,q) (n,ptr) -> + if n>0 + then error "ToneModulation.oscillatorCells: limit of shape parameter is buggy" + else + (q, drop (periodInt+k) ptr)) + coords $ + tail $ + scanl + {- since we clip the coordinates before calling oscillatorCells + we do not need 'dropRem', since 'drop' would never go beyond the list end -} + (\ (n,ptr0) d0 -> dropRem (n+d0) ptr0) + (0,ptrs) + ((skip - ipOffset - periodInt) : skips) + +dropFrac :: RealField.C i => i -> [a] -> (Int, i, [a]) +dropFrac = + let recurse acc n xt = + if n>=1 + then + case xt of + _:xs -> recurse (succ acc) (n-1) xs + [] -> (acc, n, []) + else (acc,n,xt) + in recurse 0 + +dropFrac' :: RealField.C i => i -> [a] -> (Int, i, [a]) +dropFrac' = + let recurse acc n xt = + maybe + (acc,n,xt) + (recurse (succ acc) (n-1) . snd) + (guard (n>=1) >> viewListL xt) + in recurse 0 + +propDropFrac :: (RealField.C i, Eq a) => i -> [a] -> Bool +propDropFrac n xs = + dropFrac n xs == dropFrac' n xs + + + +dropRem :: Int -> [a] -> (Int, [a]) +dropRem = + let recurse n xt = + if n>0 + then + case xt of + _:xs -> recurse (pred n) xs + [] -> (n, []) + else (n,xt) + in recurse + +dropRem' :: Int -> [a] -> (Int, [a]) +dropRem' = + let recurse n xt = + maybe + (n,xt) + (recurse (pred n) . snd) + (guard (n>0) >> viewListL xt) + in recurse + +propDropRem :: (Eq a) => Int -> [a] -> Bool +propDropRem n xs = + dropRem n xs == dropRem' n xs + +{- +*Synthesizer.Plain.ToneModulation> Test.QuickCheck.quickCheck (\n xs -> propDropRem n (xs::[Int])) +OK, passed 100 tests. +*Synthesizer.Plain.ToneModulation> Test.QuickCheck.quickCheck (\n xs -> propDropFrac (n::Rational) (xs::[Int])) +OK, passed 100 tests. +-} + + +oscillatorCoords :: (RealField.C t) => + Int -> t -> (t,[t]) -> (Phase.T t, [t]) -> [(Int,(Int,(t,t)))] +oscillatorCoords periodInt period + (shape0, shapes) (phase, freqs) = + let shapeOffsets = + scanl + (\(_,s) c -> splitFraction (s+c)) + (splitFraction shape0) shapes + phases = + let (s:ss) = map (\(n,_) -> fromIntegral n / period) shapeOffsets + in freqToPhase + (Phase.increment (-s) phase) -- phase - s + (zipWith (-) freqs ss) + in zipWith +-- (\(d,s) p -> (d, (s,p))) + (\(d,s) p -> (d, flattenShapePhase periodInt period (s,p))) + shapeOffsets + phases +{- +mapM print $ take 30 $ let period = 1/0.07::Double in oscillatorCoords (round period) period 0 0 (repeat 0.1) (repeat 0.01) + +*Synthesizer.Plain.Oscillator> mapM print $ take 30 $ let period = 1/0.07::Rational in oscillatorCoords (round period) period 0 0 (repeat 1) (repeat 0.07) + +*Synthesizer.Plain.Oscillator> mapM print $ take 30 $ let period = 1/0.07::Rational in oscillatorCoords (round period) period 0 0 (repeat 0.25) (repeat 0.0175) +-} + + +-- this function fits better in the Oscillator module +{- | +Convert a list of phase steps into a list of momentum phases +phase is a number in the interval [0,1) +freq contains the phase steps +-} +freqToPhase :: RealField.C a => Phase.T a -> [a] -> [Phase.T a] +freqToPhase phase freq = scanl (flip Phase.increment) phase freq + + + +limitRelativeShapes :: (RealField.C t) => + Interpolation.T t y -> + Interpolation.T t y -> + Int -> [y] -> (t,[t]) -> (t,[t]) +limitRelativeShapes ipLeap ipStep periodInt sampledTone = + let -- len = List.genericLength sampledTone + len = Chunky.fromChunks (replicateMatch sampledTone one) + (minShape, maxShape) = shapeLimits ipLeap ipStep periodInt len + fromChunky = NonNeg.toNumber . Chunky.toNumber + toChunky = Chunky.fromNumber . NonNeg.fromNumber + in mapPair (fromChunky, map fromChunky) . + uncurry (limitMaxRelativeValuesNonNeg maxShape) . + mapPair (toChunky, map toChunky) . + uncurry (limitMinRelativeValues (fromChunky minShape)) +{- +*Synthesizer.Plain.Oscillator> let ip = Interpolation.linear in limitRelativeShapes ip ip 13 (take 100 $ iterate (1+) (0::Double)) (0::Double, cycle [0.5,1.5]) +(13.0,[0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,1.0,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5,1.5,0.5*** Exception: Numeric.NonNegative.Chunky.-: negative number +-} + + +limitMinRelativeValues :: (Additive.C a, Ord a) => + a -> a -> [a] -> (a, [a]) +limitMinRelativeValues xMin x0 xs = + let (ys,zs) = + span (( (x0,xs) + (_:yr) -> (xMin, replicateMatch yr zero ++ + case zs of + [] -> [] + (z:zr) -> fst z : map snd zr) + +limitMaxRelativeValues :: (Additive.C a, Ord a) => + a -> a -> [a] -> (a, [a]) +limitMaxRelativeValues xMax x0 xs = + let (ys,zs) = + span (>zero) (scanl (-) (xMax-x0) xs) + in maybe + (xMax, replicateMatch xs zero) + (\ ~(yl,yr) -> (x0, takeMatch yl xs ++ takeMatch zs (yr : repeat zero))) + (viewListR ys) + +{- | +Avoids negative numbers and thus can be used with Chunky numbers. +-} +limitMaxRelativeValuesNonNeg :: (Additive.C a, Ord a) => + a -> a -> [a] -> (a, [a]) +limitMaxRelativeValuesNonNeg xMax x0 xs = + let (ys,zs) = + span fst (scanl (\(_,acc) d -> safeSub acc d) (safeSub xMax x0) xs) + in maybe + (xMax, replicateMatch xs zero) + (\ ~(yl, ~(_,yr)) -> (x0, takeMatch yl xs ++ takeMatch zs (yr : repeat zero))) + (viewListR ys) +{- +*Synthesizer.Plain.Oscillator> limitMaxRelativeValuesNonNeg (let inf = 1+inf in inf) (0::Chunky.T NonNeg.Rational) (repeat 2.5) +-} + +safeSub :: (Additive.C a, Ord a) => a -> a -> (Bool, a) +safeSub a b = (a>=b, a-b) 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/SampleRateContext/Control.hs b/src/Synthesizer/SampleRateContext/Control.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/SampleRateContext/Control.hs @@ -0,0 +1,202 @@ +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + + +Control curves which can be used +as envelopes, for controlling filter parameters and so on. +-} +module Synthesizer.SampleRateContext.Control + ({- * Primitives -} + constant, constantVector, linear, line, exponential, exponential2, + {- * Piecewise -} + piecewise, piecewiseVolume, Control(..), ControlPiece(..), + (-|#), ( #|-), (=|#), ( #|=), (|#), ( #|), -- spaces before # for Haddock + {- * Preparation -} + mapLinear, mapExponential, ) + where + +import Synthesizer.Plain.Control + (Control(..), ControlPiece(..), (-|#), ( #|-), (=|#), ( #|=), (|#), ( #|)) + +import qualified Synthesizer.Amplitude.Control as CtrlV +import qualified Synthesizer.Plain.Control as Ctrl + +import qualified Synthesizer.SampleRateContext.Signal as SigC +import qualified Synthesizer.SampleRateContext.Rate as Rate +import Synthesizer.SampleRateContext.Signal + (toTimeScalar, toAmplitudeScalar, toGradientScalar) + +import qualified Algebra.OccasionallyScalar as OccScalar +import qualified Algebra.Module as Module +import qualified Algebra.Transcendental as Trans +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Real as Real +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import NumericPrelude +import PreludeBase as P +import Prelude () + + +constant :: (Field.C y', Real.C y', OccScalar.C y y') => + y' {-^ value -} + -> Rate.T t t' -> SigC.T y y' y +constant y = Rate.pure $ CtrlV.constant y + +{- | +The amplitude must be positive! +This is not checked. +-} +constantVector :: -- (Field.C y', Real.C y', OccScalar.C y y') => + y' {-^ amplitude -} + -> yv {-^ value -} + -> Rate.T t t' -> SigC.T y y' yv +constantVector y yv = Rate.pure $ CtrlV.constantVector y yv + +{- Using the 'Ctrl.linear' instead of 'Ctrl.linearStable' + the type class constraints would be weaker. +linear :: (Additive.C y, Field.C y', Real.C y', OccScalar.C y y') => +-} + +{- | +Caution: This control curve can contain samples +with an absolute value greater than 1. + +Linear curves starting with zero are impossible. +Maybe you prefer using 'line'. +-} +linear :: + (Additive.C q, Field.C q', + Real.C q', OccScalar.C q q') => + q' {-^ slope of the curve -} + -> q' {-^ initial value -} + -> Rate.T q q' -> SigC.T q q' q +linear slope y0 sr = + let amp = abs y0 + steep = toGradientScalar amp sr slope + in SigC.Cons amp + (Ctrl.linearMultiscale steep (OccScalar.toScalar (signum y0))) + +{- | +Generates a finite ramp. +-} +line :: + (RealField.C q, Field.C q', + Real.C q', OccScalar.C q q') => + q' {-^ duration of the ramp -} + -> (q',q') {-^ initial and final value -} + -> Rate.T q q' -> SigC.T q q' q +line dur' (y0',y1') sr = + let amp = max (abs y0') (abs y1') + dur = toTimeScalar sr dur' + y0 = toAmplitudeScalar z y0' + y1 = toAmplitudeScalar z y1' + z = SigC.Cons amp + (take (floor dur) + (Ctrl.linearMultiscale ((y1-y0)/dur) y0)) + in z + +exponential :: (Trans.C q, Ring.C q', Real.C q', OccScalar.C q q') => + q' {-^ time where the function reaches 1\/e of the initial value -} + -> q' {-^ initial value -} + -> Rate.T q q' -> SigC.T q q' q +exponential time y0 sr = + SigC.Cons (abs y0) + (Ctrl.exponentialMultiscale + (toTimeScalar sr time) (OccScalar.toScalar (signum y0))) + +{- + take 1000 $ show (run (fixSampleRate 100 (exponential 0.1 1)) :: SigDouble) +-} + +exponential2 :: (Trans.C q, Ring.C q', Real.C q', OccScalar.C q q') => + q' {-^ half life, time where the function reaches 1\/2 of the initial value -} + -> q' {-^ initial value -} + -> Rate.T q q' -> SigC.T q q' q +exponential2 time y0 sr = + SigC.Cons (abs y0) + (Ctrl.exponential2Multiscale + (toTimeScalar sr time) (OccScalar.toScalar (signum y0))) + + + +{- | +Since this function looks for the maximum node value, +and since the signal parameter inference phase must be completed before signal processing, +infinite descriptions cannot be used here. +-} +piecewise :: (Trans.C q, RealField.C q, + Real.C q', Field.C q', OccScalar.C q q') => + [ControlPiece q'] + -> Rate.T q q' -> SigC.T q q' q +piecewise cs = + let amplitude = maximum + (map (\c -> max (abs (Ctrl.pieceY0 c)) + (abs (Ctrl.pieceY1 c))) cs) + in piecewiseVolume cs amplitude + + +piecewiseVolume :: + (Trans.C q, RealField.C q, + Real.C q', Field.C q', OccScalar.C q q') => + [ControlPiece q'] + -> q' + -> Rate.T q q' -> SigC.T q q' q +piecewiseVolume cs amplitude sr = + let ps = map (\(Ctrl.ControlPiece typ y0 y1 d) -> + Ctrl.ControlPiece + {- We cannot provide an default case like "_ -> typ", + because the returned constructors + have different parameter type. -} + (case typ of + CtrlStep -> CtrlStep + CtrlLin -> CtrlLin + -- this may exceed value range (-1,1) + CtrlCubic d0 d1 -> + CtrlCubic + (toGradientScalar amplitude sr d0) + (toGradientScalar amplitude sr d1) + CtrlExp sat -> + CtrlExp + (toAmplitudeScalar z sat) + CtrlCos -> CtrlCos) + (toAmplitudeScalar z y0) + (toAmplitudeScalar z y1) + (toTimeScalar sr d)) cs + z = SigC.Cons amplitude (Ctrl.piecewise ps) + in z + + + +{- | +Map a control curve without amplitude unit +by a linear (affine) function with a unit. +-} +mapLinear :: (Ring.C y, Field.C y', Real.C y', OccScalar.C y y') => + y' {- ^ range: one is mapped to @center+range@ -} + -> y' {- ^ center: zero is mapped to @center@ -} + -> Rate.T t t' + -> SigC.T y y' y + -> SigC.T y y' y +mapLinear range center = + Rate.pure $ CtrlV.mapLinear range center + +{- | +Map a control curve without amplitude unit +exponentially to one with a unit. +-} +mapExponential :: (Field.C y', Trans.C y, Module.C y y') => + y {- ^ range: one is mapped to @center*range@, must be positive -} + -> y' {- ^ center: zero is mapped to @center@ -} + -> Rate.T t t' + -> SigC.T y y y + -> SigC.T y y' y +mapExponential range center = + Rate.pure $ CtrlV.mapExponential range center diff --git a/src/Synthesizer/SampleRateContext/Cut.hs b/src/Synthesizer/SampleRateContext/Cut.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/SampleRateContext/Cut.hs @@ -0,0 +1,214 @@ +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes +-} +module Synthesizer.SampleRateContext.Cut ( + {- * dissection -} + splitAt, + take, + drop, + takeUntilPause, + unzip, + unzip3, + + {- * glueing -} + concat, concatVolume, + append, appendVolume, + zip, zipVolume, + zip3, zip3Volume, + arrange, arrangeVolume, + ) where + +import qualified Synthesizer.Amplitude.Cut as CutV +import qualified Synthesizer.Plain.Cut as CutS + +import qualified Synthesizer.SampleRateContext.Signal as SigC +import qualified Synthesizer.SampleRateContext.Rate as Rate +-- import Synthesizer.SampleRateContext.Rate (($#)) +import Synthesizer.SampleRateContext.Signal + (toTimeScalar, toAmplitudeScalar) + +import qualified Data.EventList.Relative.TimeBody as EventList +import qualified Numeric.NonNegative.Class as NonNeg + +import qualified Algebra.NormedSpace.Maximum as NormedMax +import qualified Algebra.OccasionallyScalar as OccScalar +import qualified Algebra.Module as Module +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring + +import qualified Data.List as List + +import PreludeBase ((.), ($), Ord, (<=), map, fst, snd) +-- import NumericPrelude +import Prelude (RealFrac) + + +{- * dissection -} + +splitAt :: (RealField.C t, Ring.C t', OccScalar.C t t') => + t' -> Rate.T t t' -> SigC.T y y' yv -> (SigC.T y y' yv, SigC.T y y' yv) +splitAt t' sr x = + let (ss0,ss1) = List.splitAt (RealField.round (toTimeScalar sr t')) (SigC.samples x) + in (SigC.replaceSamples ss0 x, + SigC.replaceSamples ss1 x) + +take :: (RealField.C t, Ring.C t', OccScalar.C t t') => + t' -> Rate.T t t' -> SigC.T y y' yv -> SigC.T y y' yv +take t sr = fst . splitAt t sr + +drop :: (RealField.C t, Ring.C t', OccScalar.C t t') => + t' -> Rate.T t t' -> SigC.T y y' yv -> SigC.T y y' yv +drop t sr = snd . splitAt t sr + +takeUntilPause :: + (RealField.C t, Ring.C t', OccScalar.C t t', + Field.C y', NormedMax.C y yv, OccScalar.C y y') => + y' -> t' -> Rate.T t t' -> SigC.T y y' yv -> SigC.T y y' yv +takeUntilPause y' t' sr x = + let t = toTimeScalar sr t' + y = toAmplitudeScalar x y' + in SigC.replaceSamples + (CutS.takeUntilInterval ((<=y) . NormedMax.norm) + (RealField.ceiling t) (SigC.samples x)) x + + +unzip :: + Rate.T t t' -> + SigC.T y y' (yv0, yv1) -> + (SigC.T y y' yv0, SigC.T y y' yv1) +unzip = Rate.pure CutV.unzip + +unzip3 :: + Rate.T t t' -> + SigC.T y y' (yv0, yv1, yv2) -> + (SigC.T y y' yv0, SigC.T y y' yv1, SigC.T y y' yv2) +unzip3 = Rate.pure CutV.unzip3 + + + +{- * glueing -} + +{- | +Similar to @foldr1 append@ but more efficient and accurate, +because it reduces the number of amplifications. +Does not work for infinite lists, +because no maximum amplitude can be computed. +-} +concat :: + (Ord y', Field.C y', OccScalar.C y y', + Module.C y yv) => + Rate.T t t' -> [SigC.T y y' yv] -> SigC.T y y' yv +concat = Rate.pure $ CutV.concat + +{- | +Give the output volume explicitly. +Does also work for infinite lists. +-} +concatVolume :: + (Field.C y', OccScalar.C y y', + Module.C y yv) => + y' -> Rate.T t t' -> [SigC.T y y' yv] -> SigC.T y y' yv +concatVolume amp = Rate.pure $ CutV.concatVolume amp + + +append :: + (Ord y', Field.C y', OccScalar.C y y', + Module.C y yv) => + Rate.T t t' -> SigC.T y y' yv -> SigC.T y y' yv -> SigC.T y y' yv +append = Rate.pure $ CutV.append + +appendVolume :: + (Field.C y', OccScalar.C y y', + Module.C y yv) => + y' -> + Rate.T t t' -> SigC.T y y' yv -> SigC.T y y' yv -> SigC.T y y' yv +appendVolume amp = Rate.pure $ CutV.appendVolume amp + + +zip :: + (Ord y', Field.C y', OccScalar.C y y', + Module.C y yv0, Module.C y yv1) => + Rate.T t t' -> SigC.T y y' yv0 -> SigC.T y y' yv1 -> SigC.T y y' (yv0,yv1) +zip = Rate.pure $ CutV.zip + +zipVolume :: + (Field.C y', OccScalar.C y y', + Module.C y yv0, Module.C y yv1) => + y' -> + Rate.T t t' -> SigC.T y y' yv0 -> SigC.T y y' yv1 -> SigC.T y y' (yv0,yv1) +zipVolume amp = Rate.pure $ CutV.zipVolume amp + + + +zip3 :: + (Ord y', Field.C y', OccScalar.C y y', + Module.C y yv0, Module.C y yv1, Module.C y yv2) => + Rate.T t t' -> SigC.T y y' yv0 -> SigC.T y y' yv1 -> SigC.T y y' yv2 -> + SigC.T y y' (yv0,yv1,yv2) +zip3 = Rate.pure $ CutV.zip3 + +zip3Volume :: + (Field.C y', OccScalar.C y y', + Module.C y yv0, Module.C y yv1, Module.C y yv2) => + y' -> + Rate.T t t' -> SigC.T y y' yv0 -> SigC.T y y' yv1 -> SigC.T y y' yv2 -> + SigC.T y y' (yv0,yv1,yv2) +zip3Volume amp = Rate.pure $ CutV.zip3Volume amp + + +{- | +Uses maximum input volume as output volume. +-} +arrange :: + (Ring.C t', OccScalar.C t t', + RealFrac t, NonNeg.C t, + Ord y', Field.C y', OccScalar.C y y', + Module.C y yv) => + t' {-^ Unit of the time values in the time ordered list. -} + -> Rate.T t t' + -> EventList.T t (SigC.T y y' yv) + {- ^ A list of pairs: (relative start time, signal part), + The start time is relative + to the start time of the previous event. -} + -> SigC.T y y' yv + {- ^ The mixed signal. -} +arrange unit' sr sched = + let amp = List.maximum (map SigC.amplitude (EventList.getBodies sched)) + in arrangeVolume amp unit' sr sched + + +{- | +Given a list of signals with time stamps, +mix them into one signal as they occur in time. +Ideally for composing music. +Infinite schedules are not supported. +Does not work for infinite lists, +because no maximum amplitude can be computed. +-} +arrangeVolume :: + (Ring.C t', OccScalar.C t t', + RealFrac t, NonNeg.C t, + Field.C y', OccScalar.C y y', + Module.C y yv) => + y' {-^ Output volume. -} + -> t' {-^ Unit of the time values in the time ordered list. -} + -> Rate.T t t' + -> EventList.T t (SigC.T y y' yv) + {- ^ A list of pairs: (relative start time, signal part), + The start time is relative + to the start time of the previous event. -} + -> SigC.T y y' yv + {- ^ The mixed signal. -} +arrangeVolume amp unit' sr sched' = + let unit = toTimeScalar sr unit' + sched = + EventList.mapBody (SigC.vectorSamples (toAmplitudeScalar z)) sched' + z = SigC.Cons amp + (CutS.arrange (EventList.resample unit sched)) + in z diff --git a/src/Synthesizer/SampleRateContext/Displacement.hs b/src/Synthesizer/SampleRateContext/Displacement.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/SampleRateContext/Displacement.hs @@ -0,0 +1,83 @@ +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes +-} +module Synthesizer.SampleRateContext.Displacement ( + mix, mixVolume, + mixMulti, mixMultiVolume, + raise, + ) where + +import qualified Synthesizer.Amplitude.Displacement as MiscV + +import qualified Synthesizer.SampleRateContext.Signal as SigC +import qualified Synthesizer.SampleRateContext.Rate as Rate + +-- import Synthesizer.SampleRateContext.Signal (toAmplitudeScalar) + +-- import qualified Synthesizer + +import qualified Algebra.OccasionallyScalar as OccScalar +import qualified Algebra.Module as Module +-- import qualified Algebra.Transcendental as Trans +import qualified Algebra.Field as Field +import qualified Algebra.Real as Real +-- import qualified Algebra.Ring as Ring +-- import qualified Algebra.Additive as Additive + +-- import Algebra.Module ((*>)) + +import PreludeBase +-- import NumericPrelude +import Prelude () + + +{- * Mixing -} + +{-| Mix two signals. + In opposition to 'zipWith' the result has the length of the longer signal. -} +mix :: (Real.C y', Field.C y', Module.C y yv, OccScalar.C y y') => + Rate.T t t' + -> SigC.T y y' yv + -> SigC.T y y' yv + -> SigC.T y y' yv +mix = Rate.pure MiscV.mix + +mixVolume :: + (Real.C y', Field.C y', Module.C y yv, OccScalar.C y y') => + y' + -> Rate.T t t' + -> SigC.T y y' yv + -> SigC.T y y' yv + -> SigC.T y y' yv +mixVolume v = Rate.pure $ MiscV.mixVolume v + +{-| Mix one or more signals. -} +mixMulti :: + (Real.C y', Field.C y', Module.C y yv, OccScalar.C y y') => + Rate.T t t' + -> [SigC.T y y' yv] + -> SigC.T y y' yv +mixMulti = Rate.pure MiscV.mixMulti + +mixMultiVolume :: + (Real.C y', Field.C y', Module.C y yv, OccScalar.C y y') => + y' + -> Rate.T t t' + -> [SigC.T y y' yv] + -> SigC.T y y' yv +mixMultiVolume v = Rate.pure $ MiscV.mixMultiVolume v + +{-| Add a number to all of the signal values. + This is useful for adjusting the center of a modulation. -} +raise :: (Field.C y', Module.C y yv, OccScalar.C y y') => + y' + -> yv + -> Rate.T t t' + -> SigC.T y y' yv + -> SigC.T y y' yv +raise y' yv = Rate.pure $ MiscV.raise y' yv diff --git a/src/Synthesizer/SampleRateContext/Filter.hs b/src/Synthesizer/SampleRateContext/Filter.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/SampleRateContext/Filter.hs @@ -0,0 +1,345 @@ +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes +-} +module Synthesizer.SampleRateContext.Filter ( + {- * Non-recursive -} + + {- ** Amplification -} + amplify, + negate, + envelope, + {- ** Filter operators from calculus -} + differentiate, + +{- + {- ** Smooth -} + mean, + + {- ** Delay -} + delay, + phaseModulation, + phaser, + phaserStereo, + + + {- * Recursive -} + + {- ** Without resonance -} + firstOrderLowpass, + firstOrderHighpass, + butterworthLowpass, + butterworthHighpass, + chebyshevALowpass, + chebyshevAHighpass, + chebyshevBLowpass, + chebyshevBHighpass, + {- ** With resonance -} + universal, + moogLowpass, + {- ** Allpass -} + allpassCascade, +-} + {- ** Reverb -} + comb, + + {- ** Filter operators from calculus -} + integrate, +) where + + +import qualified Synthesizer.Amplitude.Filter as FiltV +import qualified Synthesizer.SampleRateContext.Signal as SigC +import qualified Synthesizer.SampleRateContext.Rate as Rate + +import Synthesizer.SampleRateContext.Signal + (toTimeScalar, {- toFrequencyScalar, -} ) + +-- import qualified Synthesizer.Plain.Displacement as Syn +-- import qualified Synthesizer.Plain.Filter.Recursive as FiltR +import qualified Synthesizer.Plain.Filter.Recursive.Comb as Comb +import qualified Synthesizer.Plain.Filter.Recursive.Integration as Integrate +import qualified Synthesizer.Plain.Filter.NonRecursive as FiltNR +{- +import qualified Synthesizer.Plain.Interpolation as Interpolation +import qualified Synthesizer.Plain.Filter.Delay.Block as Delay + +import Synthesizer.Utility(clip) +-} + +import qualified Algebra.OccasionallyScalar as OccScalar +-- import qualified Algebra.Transcendental as Trans +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +-- import qualified Algebra.Real as Real +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive +import qualified Algebra.Module as Module +-- import qualified Algebra.VectorSpace as VectorSpace + +-- import Control.Monad(liftM2) + +import NumericPrelude hiding (negate) +import PreludeBase as P +import Prelude () + + +{- | The amplification factor must be positive. -} +amplify :: (Ring.C y') => + y' + -> Rate.T t t' + -> SigC.T y y' yv + -> SigC.T y y' yv +amplify volume = Rate.pure $ FiltV.amplify volume + +negate :: (Additive.C yv) => + Rate.T t t' + -> SigC.T y y' yv + -> SigC.T y y' yv +negate = Rate.pure FiltV.negate + +envelope :: (Module.C y0 yv, Ring.C y') => + Rate.T t t' + -> SigC.T y y' y0 {- the envelope -} + -> SigC.T y y' yv {- the signal to be enveloped -} + -> SigC.T y y' yv +envelope = Rate.pure FiltV.envelope + + + +differentiate :: (Additive.C v, Ring.C q') => + Rate.T t q' + -> SigC.T y q' v + -> SigC.T y q' v +differentiate sr x = + SigC.Cons + (SigC.amplitude x * Rate.toNumber sr) + (FiltNR.differentiate (SigC.samples x)) + + +{- +{- | needs a good handling of boundaries, yet -} +mean :: (Additive.C yv, Field.C y', RealField.C a, + Module.C a v, OccScalar.C a q) => + q {- ^ time length of the window -} + -> SigC.T y y' yv + -> Rate.T t t' -> (SigC.T y y' yv) +mean time x = + do t <- toTimeScalar x (Expr.constant time) + let tInt = round ((t-1)/2) + let width = tInt*2+1 + returnModified [] + ((SigP.asTypeOfAmplitude (recip (fromIntegral width)) x *> ) . + Filt.sums width . FiltNR.delay tInt) x + + +delay :: (Additive.C yv, Field.C y', RealField.C a, OccScalar.C a q) => + q + -> SigC.T y y' yv + -> Rate.T t t' -> (SigC.T y y' yv) +delay time x = + do t <- toTimeScalar x (Expr.constant time) + returnModified [] (FiltNR.delay (round t)) x + + +phaseModulation :: + (Additive.C yv, Field.C y', RealField.C a, OccScalar.C a q) => + Interpolation.T a v + -> q {- ^ minDelay, minimal delay, may be negative -} + -> q {- ^ maxDelay, maximal delay, it must be @minDelay <= maxDelay@ + and the modulation must always be + in the range [minDelay,maxDelay]. -} + -> SigI.T a q a + {- ^ delay control, positive numbers mean delay, + negative numbers mean prefetch -} + -> SigC.T y y' yv + -> Rate.T t t' -> (SigC.T y y' yv) +phaseModulation ip minDelay maxDelay delays x = + do t0 <- toTimeScalar x (Expr.constant minDelay) + t1 <- toTimeScalar x (Expr.constant maxDelay) + let tInt0 = floor t0 + let tInt1 = ceiling t1 + let tInt0Neg = Additive.negate tInt0 + ds <- SigI.scalarSamples (toTimeScalar delays) delays + returnModified [SigP.sampleRate delays] + (FiltNR.delay tInt0 . + Delay.modulated ip (tInt1-tInt0+1) + (FiltNR.delay tInt0Neg + (Syn.raise (fromIntegral tInt0Neg) + (map (clip t0 t1) ds)))) x + + +{- | symmetric phaser -} +phaser :: (Additive.C yv, Field.C y', RealField.C a, + Module.C a v, OccScalar.C a q) => + Interpolation.T a v + -> q {- ^ maxDelay, must be positive -} + -> SigI.T a q a + {- ^ delay control -} + -> SigC.T y y' yv + -> Rate.T t t' -> (SigC.T y y' yv) +phaser ip maxDelay delays x = + amplify (asTypeOf 0.5 maxDelay) =<< + uncurry SynI.mix =<< phaserCore ip maxDelay delays x + +phaserStereo :: (Additive.C yv, Field.C y', Real.C q, RealField.C a, + Module.C a v, OccScalar.C a q) => + Interpolation.T a v + -> q {- ^ maxDelay, must be positive -} + -> SigI.T a q a + {- ^ delay control -} + -> SigC.T y y' yv + -> SigI.Process a q (v,v) +phaserStereo ip maxDelay delays x = + uncurry CutI.zip =<< phaserCore ip maxDelay delays x + +phaserCore :: (Additive.C yv, Field.C y', RealField.C a, + Module.C a v, OccScalar.C a q) => + Interpolation.T a v + -> q {- ^ maxDelay, must be positive -} + -> SigI.T a q a + {- ^ delay control -} + -> SigC.T y y' yv + -> Process.T q (SigC.T y y' yv, SigC.T y y' yv) +phaserCore ip maxDelay delays x = + do let minDelay = Additive.negate maxDelay + negDelays <- Inference.Signal.Filter.negate delays + liftM2 (,) + (phaseModulation ip minDelay maxDelay delays x) + (phaseModulation ip minDelay maxDelay negDelays x) + + + +firstOrderLowpass, firstOrderHighpass :: + (Trans.C a, Trans.C q, Module.C a v, OccScalar.C a q) => + SigI.T a q a {- ^ Control signal for the cut-off frequency. -} + -> SigC.T y y' yv {- ^ Input signal -} + -> Rate.T t t' -> (SigC.T y y' yv) +firstOrderLowpass = firstOrderGen Filt1.lowpass +firstOrderHighpass = firstOrderGen Filt1.highpass + +firstOrderGen :: (Trans.C a, Trans.C q, Module.C a v, OccScalar.C a q) => + ([a] -> [v] -> [v]) + -> SigI.T a q a + -> SigC.T y y' yv + -> Rate.T t t' -> (SigC.T y y' yv) +firstOrderGen filt freq x = + do freqs <- SigI.scalarSamples (toFrequencyScalar x) freq + returnModified [SigP.sampleRate freq] + (filt (map Filt1.parameter freqs)) x + + +butterworthLowpass, butterworthHighpass, + chebyshevALowpass, chebyshevAHighpass, + chebyshevBLowpass, chebyshevBHighpass :: + (Field.C y', Trans.C a, VectorSpace.C a v, OccScalar.C a q) => + Int {- ^ Order of the filter, must be even, + the higher the order, the sharper is the separation of frequencies. -} + -> a {- ^ The attenuation at the cut-off frequency. + Should be between 0 and 1. -} + -> SigI.T a q a {- ^ Control signal for the cut-off frequency. -} + -> SigC.T y y' yv {- ^ Input signal -} + -> Rate.T t t' -> (SigC.T y y' yv) + +butterworthLowpass = higherOrderNoResoGen Butter.lowpass +butterworthHighpass = higherOrderNoResoGen FiltR.butterworthHighpass +chebyshevALowpass = higherOrderNoResoGen FiltR.chebyshevALowpass +chebyshevAHighpass = higherOrderNoResoGen FiltR.chebyshevAHighpass +chebyshevBLowpass = higherOrderNoResoGen FiltR.chebyshevBLowpass +chebyshevBHighpass = higherOrderNoResoGen FiltR.chebyshevBHighpass + +higherOrderNoResoGen :: + (Field.C y', Ring.C a, OccScalar.C a q) => + (Int -> a -> [a] -> [v] -> [v]) + -> Int + -> a + -> SigI.T a q a + -> SigC.T y y' yv + -> Rate.T t t' -> (SigC.T y y' yv) +higherOrderNoResoGen filt order ratio freq x = + do freqs <- SigI.scalarSamples (toFrequencyScalar x) freq + returnModified [SigP.sampleRate freq] + (filt order ratio freqs) x + + + +universal :: (Trans.C a, Module.C a v, Field.C y', OccScalar.C a q) => + SigI.T a q a {- ^ signal for resonance, + i.e. factor of amplification at the resonance frequency + relatively to the transition band. -} + -> SigI.T a q a {- ^ signal for cut off and band center frequency -} + -> SigC.T y y' yv {- ^ input signal -} + -> SigI.Process a q (v,v,v) {- ^ highpass, bandpass, lowpass filter -} +universal reso freq x = + do resos <- SigI.scalarSamples (Process.exprToScalar) reso + freqs <- SigI.scalarSamples (toFrequencyScalar x) freq + let params = + map FiltR.uniFilterParam + (zipWith FiltR.Pole resos freqs) + returnModified [SigP.sampleRate reso, SigP.sampleRate freq] + (FiltR.uniFilter params) x + +moogLowpass :: (Trans.C a, Module.C a v, Field.C y', OccScalar.C a q) => + Int + -> SigI.T a q a {- ^ signal for resonance, + i.e. factor of amplification at the resonance frequency + relatively to the transition band. -} + -> SigI.T a q a {- ^ signal for cut off and band center frequency -} + -> SigC.T y y' yv + -> Rate.T t t' -> (SigC.T y y' yv) +moogLowpass order reso freq x = + do resos <- SigI.scalarSamples (Process.exprToScalar) reso + freqs <- SigI.scalarSamples (toFrequencyScalar x) freq + let params = + map (Moog.parameter order) + (zipWith FiltR.Pole resos freqs) + returnModified [SigP.sampleRate reso, SigP.sampleRate freq] + (Moog.lowpass order params) x + +allpassCascade :: (Trans.C a, Module.C a v, Field.C y', OccScalar.C a q) => + Int {- ^ order, number of filters in the cascade -} + -> a {- ^ the phase shift to be achieved for the given frequency -} + -> SigI.T a q a {- ^ lowest comb frequency -} + -> SigC.T y y' yv + -> Rate.T t t' -> (SigC.T y y' yv) +allpassCascade order phase freq x = + do freqs <- SigI.scalarSamples (toFrequencyScalar x) freq + let params = map (FiltR.allpassCascadeParam order phase) freqs + returnModified [SigP.sampleRate freq] + (FiltR.allpassCascade order params) x +-} + + + +{- | Infinitely many equi-delayed exponentially decaying echos. -} +comb :: (RealField.C t, Ring.C t', OccScalar.C t t', Module.C y yv) => + t' -> y -> Rate.T t t' -> SigC.T y y' yv -> SigC.T y y' yv +comb time gain sr x = + SigC.Cons (SigC.amplitude x) + (Comb.run (round (toTimeScalar sr time)) gain (SigC.samples x)) + + +integrate :: (Additive.C v, Field.C q') => + Rate.T t q' + -> SigC.T y q' v + -> SigC.T y q' v +integrate sr x = + SigC.Cons + (SigC.amplitude x / Rate.toNumber sr) + (Integrate.run (SigC.samples x)) + + +{- +returnModified :: (Eq q) => + [Process.Value q] -> ([v] -> [w]) -> SigC.T y y' yv -> SigI.Process a q w +returnModified sampleRates proc x = + do let sampleRate = SigP.sampleRate x + mapM_ (Process.equalValue sampleRate) sampleRates + SigI.returnCons + sampleRate (SigP.amplitude x) + (proc (SigP.samples x)) +-} diff --git a/src/Synthesizer/SampleRateContext/Noise.hs b/src/Synthesizer/SampleRateContext/Noise.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/SampleRateContext/Noise.hs @@ -0,0 +1,137 @@ +{-# OPTIONS -fno-implicit-prelude #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +-} +module Synthesizer.SampleRateContext.Noise + (white, whiteBandEnergy, randomPeeks, + whiteGen, whiteBandEnergyGen, randomPeeksGen, + ) where + + +import qualified Synthesizer.Plain.Noise as Noise + +import qualified Synthesizer.SampleRateContext.Signal as SigC +import qualified Synthesizer.SampleRateContext.Rate as Rate + +import qualified Algebra.OccasionallyScalar as OccScalar +import qualified Algebra.Algebraic as Algebraic +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring + +import System.Random (Random, RandomGen, randomRs, mkStdGen) + +import NumericPrelude +import PreludeBase as P + + + +{- | +Uniformly distributed white noise. +The volume is given by two values: +The width of a frequency band and the volume caused by it. +The width of a frequency band must be given +in order to achieve independence from sample rate. + +See 'whiteBandEnergy'. +-} +white :: (Ring.C yv, Random yv, Algebraic.C q') => + q' {-^ width of the frequency band -} + -> q' {-^ volume caused by the given frequency band -} + -> Rate.T t q' -> SigC.T y q' yv + {-^ noise -} +white = whiteGen (mkStdGen 6746) + +whiteGen :: (Ring.C yv, Random yv, RandomGen g, Algebraic.C q') => + g {-^ random generator, can be used to choose a seed -} + -> q' {-^ width of the frequency band -} + -> q' {-^ volume caused by the given frequency band -} + -> Rate.T t q' -> SigC.T y q' yv + {-^ noise -} +whiteGen gen bandWidth volume sr = + SigC.Cons + (sqrt (3 * bandWidth / Rate.toNumber sr) * volume) + (Noise.whiteGen gen) + + +{-| +Uniformly distributed white noise. +Instead of an amplitude you must specify a value +that is like an energy per frequency band. +It makes no sense to specify an amplitude +because if you keep the same signal amplitude +while increasing the sample rate by a factor of four +the amplitude of the frequency spectrum halves. +Thus deep frequencies would be damped +when higher frequencies enter. + +Example: +If your signal is a function from time to voltage, +the amplitude must have the unit @volt^2*second@, +which can be also viewed as @volt^2\/hertz@. + +Note that the energy is proportional to the square of the signal amplitude. +In order to double the noise amplitude, +you must increase the energy by a factor of four. + +Using this notion of amplitude +the behaviour amongst several frequency filters +is quite consistent but a problem remains: +When the noise is quantised +then noise at low sample rates and noise at high sample rates +behave considerably different. +This indicates that quantisation should not just pick values, +but it should average over the hold periods. +-} +whiteBandEnergy :: (Ring.C yv, Random yv, Algebraic.C q') => + q' {-^ energy per frequency band -} + -> Rate.T t q' -> SigC.T y q' yv + {-^ noise -} +whiteBandEnergy = whiteBandEnergyGen (mkStdGen 6746) + +whiteBandEnergyGen :: (Ring.C yv, Random yv, RandomGen g, Algebraic.C q') => + g {-^ random generator, can be used to choose a seed -} + -> q' {-^ energy per frequency band -} + -> Rate.T t q' -> SigC.T y q' yv + {-^ noise -} +whiteBandEnergyGen gen energy sr = + SigC.Cons (sqrt (3 * Rate.toNumber sr * energy)) (Noise.whiteGen gen) + + +{- +The Field.C q constraint could be lifted to Ring.C +if we would use direct division instead of toFrequencyScalar. +-} +randomPeeks :: + (Field.C q, Random q, Ord q, + Field.C q', OccScalar.C q q') => + Rate.T q q' + -> SigC.T q q' q {- ^ momentary densities (frequency), + @p@ means that there is about one peak + in the time range of @1\/p@. -} + -> [Bool] + {- ^ Every occurence of 'True' represents a peak. -} +randomPeeks = + randomPeeksGen (mkStdGen 876) + +randomPeeksGen :: + (Field.C q, Random q, Ord q, + Field.C q', OccScalar.C q q', + RandomGen g) => + g {-^ random generator, can be used to choose a seed -} + -> Rate.T q q' + -> SigC.T q q' q {- ^ momentary densities (frequency), + @p@ means that there is about one peak + in the time range of @1\/p@. -} + -> [Bool] + {- ^ Every occurence of 'True' represents a peak. -} +randomPeeksGen g sr dens = + let amp = SigC.toFrequencyScalar sr (SigC.amplitude dens) + in zipWith (<) + (randomRs (0, recip amp) g) + (SigC.samples dens) diff --git a/src/Synthesizer/SampleRateContext/Oscillator.hs b/src/Synthesizer/SampleRateContext/Oscillator.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/SampleRateContext/Oscillator.hs @@ -0,0 +1,89 @@ +{-# OPTIONS -fno-implicit-prelude #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +-} +module Synthesizer.SampleRateContext.Oscillator ( + {- * Oscillators with constant waveforms -} + static, + freqMod, + phaseMod, + phaseFreqMod, +) where + +import qualified Synthesizer.Plain.Oscillator as Osci +import qualified Synthesizer.Basic.Wave as Wave +-- import qualified Synthesizer.Basic.Phase as Phase + +import qualified Synthesizer.SampleRateContext.Signal as SigC +import qualified Synthesizer.SampleRateContext.Rate as Rate +import Synthesizer.SampleRateContext.Signal (toFrequencyScalar) + +import qualified Algebra.OccasionallyScalar as OccScalar +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field + +-- import NumericPrelude +import PreludeBase as P + + +{- * Oscillators with constant waveforms -} + +{- | oscillator with a functional waveform with constant frequency -} +static :: (RealField.C t, Field.C t', OccScalar.C t t') => + Wave.T t yv {- ^ waveform -} + -> y' {- ^ amplitude -} + -> t {- ^ start phase from the range [0,1] -} + -> t' {- ^ frequency -} + -> Rate.T t t' + -> SigC.T y y' yv +static wave amplitude phase freq' sr = + let freq = toFrequencyScalar sr freq' + in SigC.Cons amplitude (Osci.static wave phase freq) + +{- | oscillator with a functional waveform with modulated frequency -} +freqMod :: (RealField.C t, Field.C t', OccScalar.C t t') => + Wave.T t yv {- ^ waveform -} + -> y' {- ^ amplitude -} + -> t {- ^ start phase from the range [0,1] -} + -> Rate.T t t' + -> SigC.T t t' t {- ^ frequency control -} + -> SigC.T y y' yv +freqMod wave amplitude phase sr xs = + let freqs = SigC.scalarSamples (toFrequencyScalar sr) xs + in SigC.Cons amplitude + (Osci.freqMod wave phase freqs) + +{- | oscillator with modulated phase -} +phaseMod :: (RealField.C t, Field.C t', OccScalar.C t t') => + Wave.T t yv {- ^ waveform -} + -> y' {- ^ amplitude -} + -> t' {- ^ frequency control -} + -> Rate.T t t' + -> SigC.T t t t {- ^ phase modulation, phases must have no unit and + are from range [0,1] -} + -> SigC.T y y' yv +phaseMod wave amplitude freq' sr xs = + let freq = toFrequencyScalar sr freq' + phases = SigC.scalarSamples id xs + in SigC.Cons amplitude + (Osci.phaseMod wave freq phases) + +{- | oscillator with a functional waveform with modulated phase and frequency -} +phaseFreqMod :: (RealField.C t, Field.C t', OccScalar.C t t') => + Wave.T t yv {- ^ waveform -} + -> y' {- ^ amplitude -} + -> Rate.T t t' + -> SigC.T t t t {- ^ phase control -} + -> SigC.T t t' t {- ^ frequency control -} + -> SigC.T y y' yv +phaseFreqMod wave amplitude sr xs ys = + let phases = SigC.scalarSamples id xs + freqs = SigC.scalarSamples (toFrequencyScalar sr) ys + in SigC.Cons amplitude + (Osci.phaseFreqMod wave phases freqs) diff --git a/src/Synthesizer/SampleRateContext/Play.hs b/src/Synthesizer/SampleRateContext/Play.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/SampleRateContext/Play.hs @@ -0,0 +1,22 @@ +module Synthesizer.SampleRateContext.Play where + +import qualified BinarySample as BinSmp + +import qualified Synthesizer.SampleRateContext.Signal as SigC +import qualified Synthesizer.SampleRateContext.Rate as Rate +import qualified Synthesizer.Physical.Signal as SigP +import qualified Synthesizer.Physical.Play as PlayP + +import qualified Algebra.OccasionallyScalar as OccScalar +import qualified Algebra.VectorSpace as VectorSpace +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field + + +auto :: (RealField.C t, BinSmp.C yv, + Field.C t', OccScalar.C t t', + Field.C y', OccScalar.C y y', + VectorSpace.C y yv) => + t' -> y' -> t' -> (Rate.T t t' -> SigC.T y y' yv) -> IO () +auto freqUnit amp sampleRate proc = + PlayP.auto freqUnit amp (SigP.runPlain sampleRate proc) diff --git a/src/Synthesizer/SampleRateContext/Rate.hs b/src/Synthesizer/SampleRateContext/Rate.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/SampleRateContext/Rate.hs @@ -0,0 +1,68 @@ +{- | + +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes (OccasionallyScalar) + + + +Light-weight sample parameter inference which will fit most needs. +We only do \"poor man's inference\", only for sample rates. +The sample rate will be provided as an argument of a special type 'T'. +This argument will almost never be passed explicitly +but handled operators analogous to '($)' and '(.)'. + +In contrast to the run-time inference approach, +we have the static guarantee that the sample rate is fixed +before passing a signal to the outside world. +-} +module Synthesizer.SampleRateContext.Rate ( + T(..), + fromNumber, toNumber, + loop, pure, + ($:), ($::), ($^), ($#), + (.:), (.^), + liftP, liftP2, liftP3, liftP4, + ) where + +import Synthesizer.ApplicativeUtility + +{- +import NumericPrelude +import PreludeBase as P +-} + + +{- | +This wraps a function which computes a sample rate dependent result. +Sample rate tells how many values per unit are stored +for representation of a signal. +-} +newtype T t t' = Cons {decons :: t'} + deriving (Eq, Ord, Show) + + +fromNumber :: t' -> T t t' +fromNumber = Cons + +toNumber :: T t t' -> t' +toNumber = decons + + +pure :: a -> T t t' -> a +pure = const + + +{- +{- | +The first argument will be a function like 'Synthesizer.SampleRateContext.Signal.toTimeScalar'. +If you use this function instead of 'Synthesizer.SampleRateContext.Signal.toTimeScalar' directly, +the type @t@ can be automatically infered. +-} +convertTimeParam :: (t' -> t' -> t) -> t' -> (t -> a) -> T t t' -> a +convertTimeParam convert t' f = Cons $ \sr -> + f (convert sr t') +-} diff --git a/src/Synthesizer/SampleRateContext/Signal.hs b/src/Synthesizer/SampleRateContext/Signal.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/SampleRateContext/Signal.hs @@ -0,0 +1,72 @@ +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes (OccasionallyScalar) + +For a description see "Synthesizer.SampleRateContext.Rate". +-} +module Synthesizer.SampleRateContext.Signal ( + T(..), + toTimeScalar, + toFrequencyScalar, + toAmplitudeScalar, + toGradientScalar, + scalarSamples, + vectorSamples, + replaceAmplitude, + replaceSamples, + ($-), + ) where + +import Synthesizer.SampleRateContext.Rate (($:)) +import qualified Synthesizer.SampleRateContext.Rate as Rate + +import Synthesizer.Amplitude.Signal +import qualified Synthesizer.Amplitude.Control as CtrlV + +import qualified Algebra.OccasionallyScalar as OccScalar +-- import qualified Algebra.Module as Module +import qualified Algebra.Field as Field +import qualified Algebra.Real as Real +import qualified Algebra.Ring as Ring + +import Algebra.OccasionallyScalar (toScalar) + +import NumericPrelude +-- import PreludeBase as P +import Prelude () + + +{- +returnCons :: + y' -> [yv] -> Rate t t' (T y y' yv) +returnCons amp sig = Proc.pure (Cons amp sig) +-} + + +toTimeScalar :: (Ring.C t', OccScalar.C t t') => + Rate.T t t' -> t' -> t +toTimeScalar sampleRate t = + toScalar (t * Rate.toNumber sampleRate) + +toFrequencyScalar :: (Field.C t', OccScalar.C t t') => + Rate.T t t' -> t' -> t +toFrequencyScalar sampleRate f = + toScalar (f / Rate.toNumber sampleRate) + +toGradientScalar :: (Field.C q', OccScalar.C q q') => + q' -> Rate.T q q' -> q' -> q +toGradientScalar amp sampleRate steepness = + toFrequencyScalar sampleRate (steepness / amp) + + +{- | +Take a scalar argument where a process expects a signal. +Only possible for non-negative values so far. +-} +($-) :: (Field.C y', Real.C y', OccScalar.C y y') => + (Rate.T t t' -> T y y' y -> a) -> y' -> (Rate.T t t' -> a) +($-) f x = f $: Rate.pure (CtrlV.constant x) 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,362 @@ +{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-} +module Synthesizer.State.Analysis where + +import qualified Synthesizer.State.Control as Ctrl +import qualified Synthesizer.State.Signal as Sig + +-- import qualified Algebra.Module as Module +-- import qualified Algebra.Transcendental as Trans +import qualified Algebra.Algebraic as Algebraic +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Real as Real +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import qualified Algebra.NormedSpace.Maximum as NormedMax +import qualified Algebra.NormedSpace.Euclidean as NormedEuc +import qualified Algebra.NormedSpace.Sum as NormedSum + +import qualified Data.Array as Array + +import qualified Data.IntMap as IntMap + +-- import Algebra.Module((*>)) + +import Data.Array (accumArray) +-- import Data.List (foldl', ) + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +{- * Notions of volume -} + +{- | +Volume based on Manhattan norm. +-} +{-# INLINE volumeMaximum #-} +volumeMaximum :: (Real.C y) => Sig.T y -> y +volumeMaximum = + Sig.foldL max zero . rectify +-- maximum . rectify + +{- | +Volume based on Energy norm. +-} +{-# INLINE volumeEuclidean #-} +volumeEuclidean :: (Algebraic.C y) => Sig.T y -> y +volumeEuclidean = + Algebraic.sqrt . volumeEuclideanSqr + +{-# INLINE volumeEuclideanSqr #-} +volumeEuclideanSqr :: (Field.C y) => Sig.T y -> y +volumeEuclideanSqr = + average . Sig.map sqr + +{- | +Volume based on Sum norm. +-} +{-# INLINE volumeSum #-} +volumeSum :: (Field.C y, Real.C y) => Sig.T y -> y +volumeSum = average . rectify + + + +{- | +Volume based on Manhattan norm. +-} +{-# INLINE volumeVectorMaximum #-} +volumeVectorMaximum :: (NormedMax.C y yv, Ord y) => Sig.T yv -> y +volumeVectorMaximum = + Sig.foldL max zero . Sig.map NormedMax.norm +-- NormedMax.norm +-- maximum . Sig.map NormedMax.norm + +{- | +Volume based on Energy norm. +-} +{-# INLINE volumeVectorEuclidean #-} +volumeVectorEuclidean :: (Algebraic.C y, NormedEuc.C y yv) => Sig.T yv -> y +volumeVectorEuclidean = + Algebraic.sqrt . volumeVectorEuclideanSqr + +{-# INLINE volumeVectorEuclideanSqr #-} +volumeVectorEuclideanSqr :: (Field.C y, NormedEuc.Sqr y yv) => Sig.T yv -> y +volumeVectorEuclideanSqr = + average . Sig.map NormedEuc.normSqr + +{- | +Volume based on Sum norm. +-} +{-# INLINE volumeVectorSum #-} +volumeVectorSum :: (NormedSum.C y yv, Field.C y) => Sig.T yv -> y +volumeVectorSum = + average . Sig.map NormedSum.norm + + + + +{- | +Compute minimum and maximum value of the stream the efficient way. +Input list must be non-empty and finite. +-} +{-# INLINE bounds #-} +bounds :: (Ord y) => Sig.T y -> (y,y) +bounds = + maybe + (error "Analysis.bounds: List must contain at least one element.") + (\(x,xs) -> + Sig.foldL (\(minX,maxX) y -> (min y minX, max y maxX)) (x,x) xs) + . Sig.viewL + + + + +{- * Miscellaneous -} + +{- +histogram: + length x = sum (histogramDiscrete x) + + units: + 1) histogram (amplify k x) = timestretch k (amplify (1/k) (histogram x)) + 2) histogram (timestretch k x) = amplify k (histogram x) + timestretch: k -> (s -> V) -> (k*s -> V) + amplify: k -> (s -> V) -> (s -> k*V) + histogram: (a -> b) -> (a^ia*b^ib -> a^ja*b^jb) + x: (s -> V) + 1) => (s^ia*(k*V)^ib -> s^ja*(k*V)^jb) + = (s^ia*V^ib*k -> s^ja*V^jb/k) + => ib=1, jb=-1 + 2) => ((k*s)^ia*V^ib -> (k*s)^ja*V^jb) + = (s^ia*V^ib -> s^ja*V^jb*k) + => ia=0, ja=1 + histogram: (s -> V) -> (V -> s/V) +histogram': + integral (histogram' x) = integral x + histogram' (amplify k x) = timestretch k (histogram' x) + histogram' (timestretch k x) = amplify k (histogram' x) + -> this does only apply if we slice the area horizontally + and sum the slice up at each level, + we must also restrict to the positive values, + this is not quite the usual histogram +-} + +{- | +Input list must be finite. +List is scanned twice, but counting may be faster. +-} +{-# INLINE histogramDiscreteArray #-} +histogramDiscreteArray :: Sig.T Int -> (Int, Sig.T Int) +histogramDiscreteArray = + withAtLeast1 "histogramDiscreteArray" $ \ x -> + let hist = + accumArray (+) zero + (bounds x) (attachOne x) + in (fst (Array.bounds hist), Sig.fromList (Array.elems hist)) + + +{- | +Input list must be finite. +If the input signal is empty, the offset is @undefined@. +List is scanned twice, but counting may be faster. +The sum of all histogram values is one less than the length of the signal. +-} +{-# INLINE histogramLinearArray #-} +histogramLinearArray :: RealField.C y => Sig.T y -> (Int, Sig.T y) +histogramLinearArray = + withAtLeast2 "histogramLinearArray" $ \ x -> + let (xMin,xMax) = bounds x + hist = + accumArray (+) zero + (floor xMin, floor xMax) + (meanValues x) + in (fst (Array.bounds hist), Sig.fromList (Array.elems hist)) + +{- | +Input list must be finite. +If the input signal is empty, the offset is @undefined@. +List is scanned once, counting may be slower. +-} +{-# INLINE histogramDiscreteIntMap #-} +histogramDiscreteIntMap :: Sig.T Int -> (Int, Sig.T Int) +histogramDiscreteIntMap = + withAtLeast1 "histogramDiscreteIntMap" $ \ x -> + let hist = IntMap.fromListWith (+) (attachOne x) + in case IntMap.toAscList hist of + [] -> error "histogramDiscreteIntMap: the list was non-empty before processing ..." + fAll@((fIndex,fHead):fs) -> (fIndex, + Sig.fromList $ + fHead : + concat (zipWith + (\(i0,_) (i1,f1) -> replicate (i1-i0-1) zero ++ [f1]) + fAll fs)) + +{-# INLINE histogramLinearIntMap #-} +histogramLinearIntMap :: RealField.C y => Sig.T y -> (Int, Sig.T y) +histogramLinearIntMap = + withAtLeast2 "histogramLinearIntMap" $ \ x -> + let hist = IntMap.fromListWith (+) (meanValues x) + -- we can rely on the fact that the keys are contiguous + (startKey:_, elems) = unzip (IntMap.toAscList hist) + in (startKey, Sig.fromList elems) + -- This doesn't work, due to a bug in IntMap of GHC-6.4.1 + -- in (head (IntMap.keys hist), IntMap.elems hist) + +{-# INLINE withAtLeast1 #-} +withAtLeast1 :: + String -> + (Sig.T y -> (Int, Sig.T y)) -> + Sig.T y -> + (Int, Sig.T y) +withAtLeast1 name f x = + maybe + (error (name ++ ": no bounds found"), Sig.empty) + (const (f x)) $ + Sig.viewL x + +{-# INLINE withAtLeast2 #-} +withAtLeast2 :: (RealField.C y) => + String -> + (Sig.T y -> (Int, Sig.T y)) -> + Sig.T y -> + (Int, Sig.T y) +withAtLeast2 name f x = + maybe + (error (name ++ ": no bounds found"), Sig.empty) + (\(y,ys) -> + if Sig.null ys + then (floor y, Sig.empty) + else f x) $ + Sig.viewL x + +{- +The bug in IntMap GHC-6.4.1 is: + +*Synthesizer.Plain.Analysis> IntMap.keys $ IntMap.fromList $ [(0,0),(-1,-1::Int)] +[0,-1] +*Synthesizer.Plain.Analysis> IntMap.elems $ IntMap.fromList $ [(0,0),(-1,-1::Int)] +[0,-1] +*Synthesizer.Plain.Analysis> IntMap.assocs $ IntMap.fromList $ [(0,0),(-1,-1::Int)] +[(0,0),(-1,-1)] + +The bug has gone in IntMap as shipped with GHC-6.6. +-} + +{-# INLINE histogramIntMap #-} +histogramIntMap :: (RealField.C y) => y -> Sig.T y -> (Int, Sig.T Int) +histogramIntMap binsPerUnit = + histogramDiscreteIntMap . quantize binsPerUnit + +{-# INLINE quantize #-} +quantize :: (RealField.C y) => y -> Sig.T y -> Sig.T Int +quantize binsPerUnit = Sig.map (floor . (binsPerUnit*)) + +{-# INLINE attachOne #-} +attachOne :: Sig.T i -> [(i,Int)] +attachOne = Sig.toList . Sig.map (\i -> (i,one)) + +{-# INLINE meanValues #-} +meanValues :: RealField.C y => Sig.T y -> [(Int,y)] +meanValues x = concatMap spread (Sig.toList (Sig.zapWith (,) x)) + +{-# INLINE spread #-} +spread :: RealField.C y => (y,y) -> [(Int,y)] +spread (l0,r0) = + let (l,r) = if l0<=r0 then (l0,r0) else (r0,l0) + (li,lf) = splitFraction l + (ri,rf) = splitFraction r + k = recip (r-l) + nodes = + (li,k*(1-lf)) : + zip [li+1 ..] (replicate (ri-li-1) k) ++ + (ri, k*rf) : + [] + in if li==ri + then [(li,one)] + else nodes + +{- | +Requires finite length. +This is identical to the arithmetic mean. +-} +{-# INLINE directCurrentOffset #-} +directCurrentOffset :: Field.C y => Sig.T y -> y +directCurrentOffset = average + + +{-# INLINE scalarProduct #-} +scalarProduct :: Ring.C y => Sig.T y -> Sig.T y -> y +scalarProduct xs ys = + Sig.sum (Sig.zipWith (*) xs ys) + +{- | +'directCurrentOffset' must be non-zero. +-} +{-# INLINE centroid #-} +centroid :: Field.C y => Sig.T y -> y +centroid xs = + scalarProduct (Sig.iterate (one+) zero) xs / Sig.sum xs + +{- +centroidAlt :: Field.C y => Sig.T y -> y +centroidAlt xs = + Sig.sum (scanr (+) zero (tail xs)) / sum xs +-} + + +{-# INLINE average #-} +average :: Field.C y => Sig.T y -> y +average x = + Sig.sum x / fromIntegral (Sig.length x) + +{-# INLINE rectify #-} +rectify :: Real.C y => Sig.T y -> Sig.T y +rectify = Sig.map abs + +{- | +Detects zeros (sign changes) in a signal. +This can be used as a simple measure of the portion +of high frequencies or noise in the signal. +It ca be used as voiced\/unvoiced detector in a vocoder. + +@zeros x !! n@ is @True@ if and only if +@(x !! n >= 0) \/= (x !! (n+1) >= 0)@. +The result will be one value shorter than the input. +-} +{-# INLINE zeros #-} +zeros :: (Ord y, Additive.C y) => Sig.T y -> Sig.T Bool +zeros = + Sig.zapWith (/=) . Sig.map (>=zero) + + + +{- | +Detect thresholds with a hysteresis. +-} +{-# INLINE flipFlopHysteresis #-} +flipFlopHysteresis :: (Ord y) => + (y,y) -> Bool -> Sig.T y -> Sig.T Bool +flipFlopHysteresis (lower,upper) = + Sig.scanL + (\state x -> + if state + then not(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,250 @@ +{-# OPTIONS_GHC -O2 -fglasgow-exts -fno-implicit-prelude #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes +-} +module Synthesizer.State.Control where + +import qualified Synthesizer.Plain.Control as Ctrl +import qualified Synthesizer.Piecewise as Piecewise +import Synthesizer.State.Displacement (raise) + +import qualified Synthesizer.State.Signal as Sig + +import qualified Algebra.Module as Module +import qualified Algebra.Transcendental as Trans +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Algebra.Module((*>)) + +-- import Number.Complex (cis,real) +-- import qualified Number.Complex as Complex +-- import Data.List (zipWith4, tails) +-- import NumericPrelude.List (iterateAssoc) + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +{- * Control curve generation -} + +{-# INLINE constant #-} +constant :: a -> Sig.T a +constant = Sig.repeat + +{-# INLINE linear #-} +linear :: Additive.C a => + a {-^ steepness -} + -> a {-^ initial value -} + -> Sig.T a + {-^ linear progression -} +linear d y0 = Sig.iterate (d+) y0 + +{- | +As stable as the addition of time values. +-} +{-# INLINE linearMultiscale #-} +linearMultiscale :: Additive.C y => + y + -> y + -> Sig.T y +linearMultiscale = curveMultiscale (+) + +{- | +Linear curve starting at zero. +-} +{-# INLINE linearMultiscaleNeutral #-} +linearMultiscaleNeutral :: Additive.C y => + y + -> Sig.T y +linearMultiscaleNeutral slope = + curveMultiscaleNeutral (+) slope zero + +{-# INLINE exponential #-} +{-# INLINE exponentialMultiscale #-} +exponential, exponentialMultiscale :: Trans.C a => + a {-^ time where the function reaches 1\/e of the initial value -} + -> a {-^ initial value -} + -> Sig.T a + {-^ exponential decay -} +exponential time = + Sig.iterate (exp (- recip time) *) + +exponentialMultiscale time = curveMultiscale (*) (exp (- recip time)) + +{-# INLINE exponentialMultiscaleNeutral #-} +exponentialMultiscaleNeutral :: Trans.C y => + y {-^ time where the function reaches 1\/e of the initial value -} + -> Sig.T y {-^ exponential decay -} +exponentialMultiscaleNeutral time = + curveMultiscaleNeutral (*) (exp (- recip time)) one + + +{-# INLINE exponential2 #-} +{-# INLINE exponential2Multiscale #-} +exponential2, exponential2Multiscale :: Trans.C a => + a {-^ half life -} + -> a {-^ initial value -} + -> Sig.T a + {-^ exponential decay -} +exponential2 halfLife = + Sig.iterate (((Ring.one+Ring.one) ** (- recip halfLife)) *) +-- Sig.iterate (((Ring.one/(Ring.one+Ring.one)) ** recip halfLife) *) + +exponential2Multiscale halfLife = curveMultiscale (*) (0.5 ** recip halfLife) + +{- the 0.5 constant seems to block fusion + Sig.iterate ((0.5 ** recip halfLife) *) +-} +{- dito fromInteger + Sig.iterate ((fromInteger 2 ** (- recip halfLife)) *) +-} + +{-# INLINE exponential2MultiscaleNeutral #-} +exponential2MultiscaleNeutral :: Trans.C y => + y {-^ half life -} + -> Sig.T y {-^ exponential decay -} +exponential2MultiscaleNeutral halfLife = + curveMultiscaleNeutral (*) (0.5 ** recip halfLife) one + + +{-# INLINE exponentialFromTo #-} +{-# INLINE exponentialFromToMultiscale #-} +exponentialFromTo, exponentialFromToMultiscale :: Trans.C y => + y {-^ time where the function reaches 1\/e of the initial value -} + -> y {-^ initial value -} + -> y {-^ value after given time -} + -> Sig.T y {-^ exponential decay -} +exponentialFromTo time y0 y1 = + Sig.iterate (* (y1/y0) ** recip time) y0 +exponentialFromToMultiscale time y0 y1 = + curveMultiscale (*) ((y1/y0) ** recip time) y0 + + + + +{-| This is an extension of 'exponential' to vectors + which is straight-forward but requires more explicit signatures. + But since it is needed rarely I setup a separate function. -} +{-# INLINE vectorExponential #-} +vectorExponential :: (Trans.C a, Module.C a v) => + a {-^ time where the function reaches 1\/e of the initial value -} + -> v {-^ initial value -} + -> Sig.T v + {-^ exponential decay -} +vectorExponential time y0 = + Sig.iterate (exp (-1/time) *>) y0 + +{-# INLINE vectorExponential2 #-} +vectorExponential2 :: (Trans.C a, Module.C a v) => + a {-^ half life -} + -> v {-^ initial value -} + -> Sig.T v + {-^ exponential decay -} +vectorExponential2 halfLife y0 = + Sig.iterate (0.5**(1/halfLife) *>) y0 + + + +{-# INLINE cosine #-} +cosine :: Trans.C a => + a {-^ time t0 where 1 is approached -} + -> a {-^ time t1 where -1 is approached -} + -> Sig.T a + {-^ a cosine wave where one half wave is between t0 and t1 -} +cosine = Ctrl.cosineWithSlope $ + \d x -> Sig.map cos (linear d x) + + + +{-# INLINE cubicHermite #-} +cubicHermite :: Field.C a => (a, (a,a)) -> (a, (a,a)) -> Sig.T a +cubicHermite node0 node1 = + Sig.map (Ctrl.cubicFunc node0 node1) (linear 1 0) + + + +-- * piecewise curves + + +splitDurations :: (RealField.C t) => + [t] -> [(Int, t)] +splitDurations ts0 = + let (ds,ts) = + unzip $ scanl + (\(_,fr) d -> splitFraction (fr+d)) + (0,1) ts0 + in zip (tail ds) (map (subtract 1) ts) + +{-# INLINE piecewise #-} +piecewise :: (RealField.C a) => + Piecewise.T a a (a -> Sig.T a) -> Sig.T a +piecewise xs = + Sig.concat $ zipWith + (\(n, t) (Piecewise.PieceData c yi0 yi1 d) -> + Sig.take n $ Piecewise.computePiece c yi0 yi1 d t) + (splitDurations $ map Piecewise.pieceDur xs) + xs + + +type Piece a = + Piecewise.Piece a a + (a {- fractional start time -} -> Sig.T a) + + +{-# INLINE stepPiece #-} +stepPiece :: Piece a +stepPiece = + Piecewise.pieceFromFunction $ \ y0 _y1 _d _t0 -> + constant y0 + +{-# INLINE linearPiece #-} +linearPiece :: (Field.C a) => Piece a +linearPiece = + Piecewise.pieceFromFunction $ \ y0 y1 d t0 -> + let s = (y1-y0)/d in linear s (y0-t0*s) + +{-# INLINE exponentialPiece #-} +exponentialPiece :: (Trans.C a) => a -> Piece a +exponentialPiece saturation = + Piecewise.pieceFromFunction $ \ y0 y1 d t0 -> + let y0' = y0-saturation + y1' = y1-saturation + yd = y0'/y1' + in raise saturation + (exponential (d / log yd) (y0' * yd**(t0/d))) + +{-# INLINE cosinePiece #-} +cosinePiece :: (Trans.C a) => Piece a +cosinePiece = + Piecewise.pieceFromFunction $ \ y0 y1 d t0 -> + Sig.map + (\y -> (1+y)*(y0/2)+(1-y)*(y1/2)) + (cosine t0 (t0+d)) + +{-# INLINE cubicPiece #-} +cubicPiece :: (Field.C a) => a -> a -> Piece a +cubicPiece yd0 yd1 = + Piecewise.pieceFromFunction $ \ y0 y1 d t0 -> + cubicHermite (t0,(y0,yd0)) (t0+d,(y1,yd1)) + + +-- * auxiliary functions + +{-# INLINE curveMultiscale #-} +curveMultiscale :: (y -> y -> y) -> y -> y -> Sig.T y +curveMultiscale op d y0 = + Sig.cons y0 (Sig.map (op y0) (Sig.iterateAssoc op d)) + +{-# INLINE curveMultiscaleNeutral #-} +curveMultiscaleNeutral :: (y -> y -> y) -> y -> y -> Sig.T y +curveMultiscaleNeutral op d neutral = + Sig.cons neutral (Sig.iterateAssoc op d) 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 @@ +{-# OPTIONS -fno-implicit-prelude #-} +{- | +Copyright : (c) Henning Thielemann 2006 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes +-} +module Synthesizer.State.Cut ( + {- * dissection -} + takeUntilPause, + takeUntilInterval, + + {- * glueing -} + selectBool, + select, + arrange, + arrangeList, + ) where + +import qualified Synthesizer.State.Signal as Sig + +import qualified Data.EventList.Relative.TimeBody as EventList + +import qualified MathObj.LaurentPolynomial as Laurent +import qualified Algebra.Real as Real +import qualified Algebra.Additive as Additive + +import qualified Data.Array as Array +import Data.Array (Array, Ix, (!), elems, ) +import Control.Applicative (Applicative, ) +import Data.Traversable (sequenceA, ) + +import Synthesizer.Utility (mapSnd, ) + +import qualified Number.NonNegative as NonNeg + +import PreludeBase +import NumericPrelude + + + +{- | +Take signal until it falls short of a certain amplitude for a given time. +-} +{-# INLINE takeUntilPause #-} +takeUntilPause :: (Real.C a) => a -> Int -> Sig.T a -> Sig.T a +takeUntilPause y = + takeUntilInterval ((<=y) . abs) + +{- | +Take values until the predicate p holds for n successive values. +The list is truncated at the beginning of the interval of matching values. +-} +{-# INLINE takeUntilInterval #-} +takeUntilInterval :: (a -> Bool) -> Int -> Sig.T a -> Sig.T a +takeUntilInterval p n xs = + Sig.map fst $ + Sig.takeWhile (( if p x then succ acc else 0) 0 xs) $ + Sig.repeat 0 + + + +{-# INLINE selectBool #-} +selectBool :: (Sig.T a, Sig.T a) -> Sig.T Bool -> Sig.T a +selectBool = + Sig.zipWith (\(xf,xt) c -> if c then xt else xf) . + uncurry Sig.zip + + +{-# INLINE select #-} +select :: Ix i => Array i (Sig.T a) -> Sig.T i -> Sig.T a +select = + Sig.crochetL + (\xi arr -> + do arr0 <- sequenceArray (fmap Sig.viewL arr) + return (fst (arr0!xi), fmap snd arr0)) + +{-# INLINE sequenceArray #-} +sequenceArray :: + (Applicative f, Ix i) => + Array i (f a) -> f (Array i a) +sequenceArray arr = + fmap (Array.listArray (Array.bounds arr)) $ + sequenceA (Array.elems arr) + + +{- | +Given a list of signals with time stamps, +mix them into one signal as they occur in time. +Ideally for composing music. + +Cf. 'MathObj.LaurentPolynomial.series' +-} +{-# INLINE arrangeList #-} +arrangeList :: (Additive.C v) => + EventList.T NonNeg.Int (Sig.T v) + {-^ A list of pairs: (relative start time, signal part), + The start time is relative to the start time + of the previous event. -} + -> Sig.T v + {-^ The mixed signal. -} +arrangeList evs = + let xs = map Sig.toList (EventList.getBodies evs) + in case map NonNeg.toNumber (EventList.getTimes evs) of + t:ts -> Sig.replicate t zero `Sig.append` + Sig.fromList (Laurent.addShiftedMany ts xs) + [] -> Sig.empty + + + + +{-# INLINE arrange #-} +arrange :: (Additive.C v) => + EventList.T NonNeg.Int (Sig.T v) + {-^ A list of pairs: (relative start time, signal part), + The start time is relative to the start time + of the previous event. -} + -> Sig.T v + {-^ The mixed signal. -} +arrange evs = + let xs = EventList.getBodies evs + in case map NonNeg.toNumber (EventList.getTimes evs) of + t:ts -> Sig.replicate t zero `Sig.append` + addShiftedMany ts xs + [] -> Sig.empty + + +{-# INLINE addShiftedMany #-} +addShiftedMany :: (Additive.C a) => [Int] -> [Sig.T a] -> Sig.T a +addShiftedMany ds xss = + foldr (uncurry addShifted) Sig.empty (zip (ds++[zero]) xss) + + + +{-# INLINE addShifted #-} +addShifted :: Additive.C a => Int -> Sig.T a -> Sig.T a -> Sig.T a +addShifted del xs ys = + if del < 0 + then error "State.Signal.addShifted: negative shift" + else + Sig.unfoldR + (\((d,ys0),xs0) -> + -- d<0 cannot happen + if d==zero + then + fmap + (mapSnd (\(xs1,ys1) -> ((zero,ys1),xs1))) + (Sig.mixStep (xs0, ys0)) + else + Just $ mapSnd ((,) (pred d, ys0)) $ + Sig.switchL (zero, xs0) (,) xs0) + ((del,ys),xs) 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 @@ +{-# OPTIONS -fno-implicit-prelude #-} +module Synthesizer.State.Displacement where + +import qualified Synthesizer.State.Signal as Sig + +-- import qualified Algebra.Module as Module +-- import qualified Algebra.Transcendental as Trans +-- import qualified Algebra.Field as Field +-- import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +{- * Mixing -} + +{-| +Mix two signals. +In opposition to 'zipWith' the result has the length of the longer signal. +-} +{-# INLINE mix #-} +mix :: (Additive.C v) => Sig.T v -> Sig.T v -> Sig.T v +mix = Sig.mix + +{-| Mix an arbitrary number of signals. -} +{-# INLINE mixMulti #-} +mixMulti :: (Additive.C v) => [Sig.T v] -> Sig.T v +mixMulti = foldl mix Sig.empty + + +{-| +Add a number to all of the signal values. +This is useful for adjusting the center of a modulation. +-} +{-# INLINE raise #-} +raise :: (Additive.C v) => v -> Sig.T v -> Sig.T v +raise x = Sig.map ((+) x) + + +{- * Distortion -} +{-| +In "Synthesizer.Basic.Distortion" you find a collection +of appropriate distortion functions. +-} +{-# INLINE distort #-} +distort :: (c -> a -> a) -> Sig.T c -> Sig.T a -> Sig.T a +distort = Sig.zipWith 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,67 @@ +{-# OPTIONS -fno-implicit-prelude #-} +module Synthesizer.State.Filter.Delay where + +import qualified Synthesizer.State.Interpolation as Interpolation +import qualified Synthesizer.State.Signal as Sig + +import qualified Algebra.RealField as RealField +import qualified Algebra.Additive as Additive + +-- import qualified Prelude as P +-- import PreludeBase +import NumericPrelude + + + +{- * Shift -} + +{-# INLINE static #-} +static :: Additive.C y => Int -> Sig.T y -> Sig.T y +static = staticPad zero + +{-# INLINE staticPad #-} +staticPad :: y -> Int -> Sig.T y -> Sig.T y +staticPad = Interpolation.delayPad + +{-# INLINE staticPos #-} +staticPos :: Additive.C y => Int -> Sig.T y -> Sig.T y +staticPos n = Sig.append (Sig.replicate n zero) + +{-# INLINE staticNeg #-} +staticNeg :: Int -> Sig.T y -> Sig.T y +staticNeg = Sig.drop + + + +{-# INLINE modulatedCore #-} +modulatedCore :: (RealField.C a, Additive.C v) => + Interpolation.T a v -> Int -> Sig.T a -> Sig.T v -> Sig.T v +modulatedCore ip size = + Sig.zipWithTails + (\t -> Interpolation.single ip (fromIntegral size + t)) + +{- +modulatedCoreSlow :: (RealField.C a, Additive.C v) => + Interpolation.T a v -> Int -> Sig.T a -> Sig.T v -> Sig.T v +modulatedCoreSlow ip size ts xs = + Sig.fromList $ zipWith + (\t -> Interpolation.single ip (fromIntegral size - t)) + (Sig.toList ts) (Sig.tails xs) +-} + +{- | +This is essentially different for constant interpolation, +because this function "looks forward" +whereas the other two variants "look backward". +For the symmetric interpolation functions +of linear and cubic interpolation, this does not really matter. +-} +{-# INLINE modulated #-} +modulated :: (RealField.C a, Additive.C v) => + Interpolation.T a v -> Int -> Sig.T a -> Sig.T v -> Sig.T v +modulated ip minDev ts xs = + let size = Interpolation.number ip - minDev + in modulatedCore ip + (size - Interpolation.offset ip) + ts + (staticPos size xs) 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,290 @@ +{-# OPTIONS -fno-implicit-prelude #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes +-} +module Synthesizer.State.Filter.NonRecursive where + +import qualified Synthesizer.State.Signal as Sig + +import qualified Synthesizer.State.Filter.Delay as Delay +import qualified Synthesizer.State.Control as Ctrl + +import qualified Algebra.Transcendental as Trans +import qualified Algebra.Module as Module +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Algebra.Module( {- linearComb, -} (*>)) + +import Synthesizer.Utility (nest) + +import PreludeBase +import NumericPrelude + + + +{- * Envelope application -} + +{-# INLINE amplify #-} +amplify :: (Ring.C a) => a -> Sig.T a -> Sig.T a +amplify v = Sig.map (v*) + +{-# INLINE amplifyVector #-} +amplifyVector :: (Module.C a v) => a -> Sig.T v -> Sig.T v +amplifyVector v = Sig.map (v*>) + + +{-# INLINE envelope #-} +envelope :: (Ring.C a) => + Sig.T a {-^ the envelope -} + -> Sig.T a {-^ the signal to be enveloped -} + -> Sig.T a +envelope = Sig.zipWith (*) + +{-# INLINE envelopeVector #-} +envelopeVector :: (Module.C a v) => + Sig.T a {-^ the envelope -} + -> Sig.T v {-^ the signal to be enveloped -} + -> Sig.T v +envelopeVector = Sig.zipWith (*>) + + + +{-# INLINE fadeInOut #-} +fadeInOut :: (Field.C a) => + Int -> Int -> Int -> Sig.T a -> Sig.T a +fadeInOut tIn tHold tOut = + let leadIn = Sig.take tIn $ Ctrl.linear ( recip (fromIntegral tIn)) zero + leadOut = Sig.take tOut $ Ctrl.linear (- recip (fromIntegral tOut)) one + hold = Sig.replicate tHold one + in envelope (leadIn `Sig.append` hold `Sig.append` leadOut) + + +{- * Smoothing -} + + +{-| Unmodulated non-recursive filter -} +{-# INLINE generic #-} +generic :: (Module.C a v) => + Sig.T a -> Sig.T v -> Sig.T v +generic m x = + let mr = Sig.reverse m + xp = Delay.staticPos (pred (Sig.length m)) x + in Sig.mapTails (Sig.linearComb mr) xp + +{- +genericSlow :: Module.C a v => + Sig.T a -> Sig.T v -> Sig.T v +genericSlow m x = + let mr = Sig.reverse m + xp = delay (pred (Sig.length m)) x + in Sig.fromList (map (Sig.linearComb mr) (init (Sig.tails xp))) +-} + +{- +{- | +@eps@ is the threshold relatively to the maximum. +That is, if the gaussian falls below @eps * gaussian 0@, +then the function truncated. +-} +gaussian :: + (Trans.C a, RealField.C a, Module.C a v) => + a -> a -> a -> Sig.T v -> Sig.T v +gaussian eps ratio freq = + let var = ratioFreqToVariance ratio freq + area = var * sqrt (2*pi) + gau t = exp (-(t/var)^2/2) / area + width = ceiling (var * sqrt (-2 * log eps)) -- inverse gau + gauSmp = map (gau . fromIntegral) [-width .. width] + in drop width . generic gauSmp +-} + +{- +GNUPlot.plotList [] (take 1000 $ gaussian 0.001 0.5 0.04 (Filter.Test.chirp 5000) :: [Double]) + +The filtered chirp must have amplitude 0.5 at 400 (0.04*10000). +-} + +{- + We want to approximate a Gaussian by a binomial filter. + The latter one can be implemented by a convolutional power. + However we still require a number of operations per sample + which is proportional to the variance. +-} +{-# INLINE binomial #-} +binomial :: + (Trans.C a, RealField.C a, Module.C a v) => + a -> a -> Sig.T v -> Sig.T v +binomial ratio freq = + let width = ceiling (2 * ratioFreqToVariance ratio freq ^ 2) + in Sig.drop width . nest (2*width) ((asTypeOf 0.5 freq *>) . binomial1) + +{- +exp (-(t/var)^2/2) / area *> cis (2*pi*f*t) + == exp (-(t/var)^2/2 +: 2*pi*f*t) / area + == exp ((-t^2 +: 2*var^2*2*pi*f*t) / (2*var^2)) / area + == exp ((t^2 - i*2*var^2*2*pi*f*t) / (-2*var^2)) / area + == exp (((t^2 - i*var^2*2*pi*f)^2 + (var^2*2*pi*f)^2) / (-2*var^2)) / area + == exp (((t^2 - i*var^2*2*pi*f)^2 / (-2*var^2) - (var*2*pi*f)^2/2)) / area + +sumMap (\t -> exp (-(t/var)^2/2) / area *> cis (2*pi*f*t)) + [-infinity..infinity] + ~ sumMap (\t -> exp (-(t/var)^2/2)) [-infinity..infinity] + * exp (-(var*2*pi*f)^2/2) / area + = exp (-(var*2*pi*f)^2/2) +-} +{- | + Compute the variance of the Gaussian + such that its Fourier transform has value @ratio@ at frequency @freq@. +-} +{-# INLINE ratioFreqToVariance #-} +ratioFreqToVariance :: (Trans.C a) => a -> a -> a +ratioFreqToVariance ratio freq = + sqrt (-2 * log ratio) / (2*pi*freq) + -- inverse of the fourier transformed gaussian + +{-# INLINE binomial1 #-} +binomial1 :: (Additive.C v) => Sig.T v -> Sig.T v +binomial1 = Sig.zapWith (+) + + + + + +{- | +Moving (uniformly weighted) average in the most trivial form. +This is very slow and needs about @n * length x@ operations. +-} +{-# INLINE sums #-} +sums :: (Additive.C v) => Int -> Sig.T v -> Sig.T v +sums n = Sig.mapTails (Sig.sum . Sig.take n) + + +{- +sumsDownsample2 :: (Additive.C v) => Sig.T v -> Sig.T v +sumsDownsample2 (x0:x1:xs) = (x0+x1) : sumsDownsample2 xs +sumsDownsample2 xs = xs + +downsample2 :: Sig.T a -> Sig.T a +downsample2 (x0:_:xs) = x0 : downsample2 xs +downsample2 xs = xs + + +{- | +Given a list of numbers +and a list of sums of (2*k) of successive summands, +compute a list of the sums of (2*k+1) or (2*k+2) summands. + +Eample for 2*k+1 + +@ + [0+1+2+3, 2+3+4+5, 4+5+6+7, ...] -> + [0+1+2+3+4, 1+2+3+4+5, 2+3+4+5+6, 3+4+5+6+7, 4+5+6+7+8, ...] +@ + +Example for 2*k+2 + +@ + [0+1+2+3, 2+3+4+5, 4+5+6+7, ...] -> + [0+1+2+3+4+5, 1+2+3+4+5+6, 2+3+4+5+6+7, 3+4+5+6+7+8, 4+5+6+7+8+9, ...] +@ +-} +sumsUpsampleOdd :: (Additive.C v) => Int -> Sig.T v -> Sig.T v -> Sig.T v +sumsUpsampleOdd n {- 2*k -} xs ss = + let xs2k = drop n xs + in (head ss + head xs2k) : + concat (zipWith3 (\s x0 x2k -> [x0+s, s+x2k]) + (tail ss) + (downsample2 (tail xs)) + (tail (downsample2 xs2k))) + +sumsUpsampleEven :: (Additive.C v) => Int -> Sig.T v -> Sig.T v -> Sig.T v +sumsUpsampleEven n {- 2*k -} xs ss = + sumsUpsampleOdd (n+1) xs (zipWith (+) ss (downsample2 (drop n xs))) + +sumsPyramid :: (Additive.C v) => Int -> Sig.T v -> Sig.T v +sumsPyramid n xs = + let aux 1 ys = ys + aux 2 ys = ys + tail ys + aux m ys = + let ysd = sumsDownsample2 ys + in if even m + then sumsUpsampleEven (m-2) ys (aux (div (m-2) 2) ysd) + else sumsUpsampleOdd (m-1) ys (aux (div (m-1) 2) ysd) + in aux n xs + + +propSums :: Bool +propSums = + let n = 1000 + xs = [0::Double ..] + naive = sums n xs + rec = drop (n-1) $ sumsRec n xs + pyramid = sumsPyramid n xs + in and $ take 1000 $ + zipWith3 (\x y z -> x==y && y==z) naive rec pyramid + +-} + + + +{- * Filter operators from calculus -} + +{- | +Forward difference quotient. +Shortens the signal by one. +Inverts 'Synthesizer.State.Filter.Recursive.Integration.run' in the sense that +@differentiate (zero : integrate x) == x@. +The signal is shifted by a half time unit. +-} +{-# INLINE differentiate #-} +differentiate :: Additive.C v => Sig.T v -> Sig.T v +differentiate x = Sig.zapWith subtract x + +{- | +Central difference quotient. +Shortens the signal by two elements, +and shifts the signal by one element. +(Which can be fixed by prepending an appropriate value.) +For linear functions this will yield +essentially the same result as 'differentiate'. +You obtain the result of 'differentiateCenter' +if you smooth the one of 'differentiate' +by averaging pairs of adjacent values. + +ToDo: Vector variant +-} +{-# INLINE differentiateCenter #-} +differentiateCenter :: Field.C v => Sig.T v -> Sig.T v +differentiateCenter = + Sig.zapWith (\(x0,_) (_,x1) -> (x1 - x0) * (1/2)) . + Sig.zapWith (,) +{- +differentiateCenter :: Field.C v => Sig.T v -> Sig.T v +differentiateCenter x = + Sig.map ((1/2)*) $ + Sig.zipWith subtract x (Sig.tail (Sig.tail x)) +-} + +{- | +Second derivative. +It is @differentiate2 == differentiate . differentiate@ +but 'differentiate2' should be faster. +-} +{-# INLINE differentiate2 #-} +differentiate2 :: Additive.C v => Sig.T v -> Sig.T v +differentiate2 = differentiate . differentiate +{- +differentiate2 :: Additive.C v => Sig.T v -> Sig.T v +differentiate2 xs0 = + let xs1 = Sig.tail xs0 + xs2 = Sig.tail xs1 + in Sig.zipWith3 (\x0 x1 x2 -> x0+x2-(x1+x1)) xs0 xs1 xs2 +-} 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,68 @@ +{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +Comb filters, useful for emphasis of tones with harmonics +and for repeated echos. +-} +module Synthesizer.State.Filter.Recursive.Comb where + +import qualified Synthesizer.State.Signal as Sig +import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1 + +import qualified Synthesizer.State.Filter.Delay as Delay + +import qualified Algebra.Module as Module +-- import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Algebra.Module((*>)) + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +{- | +The most simple version of the Karplus-Strong algorithm +which is suitable to simulate a plucked string. +It is similar to the 'runProc' function. +-} +{-# INLINE karplusStrong #-} +karplusStrong :: (Ring.C a, Module.C a v) => + Filt1.Parameter a -> Sig.T v -> Sig.T v +karplusStrong c wave = + Sig.delayLoop (Sig.modifyStatic Filt1.lowpassModifier c) wave + + +{- | +Infinitely many equi-delayed exponentially decaying echos. +The echos are clipped to the input length. +We think it is easier (and simpler to do efficiently) +to pad the input with zeros or whatever +instead of cutting the result according to the input length. +-} +{-# INLINE run #-} +run :: (Module.C a v) => Int -> a -> Sig.T v -> Sig.T v +run time gain = Sig.delayLoopOverlap time (gain *>) + +{- | Echos of different delays. -} +{-# INLINE runMulti #-} +runMulti :: (Ring.C a, Module.C a v) => [Int] -> a -> Sig.T v -> Sig.T v +runMulti times gain x = + let y = Sig.fromList $ Sig.toList $ + foldl + (Sig.zipWith (+)) x + (map (flip Delay.staticPos (gain *> y)) times) + in y + +{- | Echos can be piped through an arbitrary signal processor. -} +{-# INLINE runProc #-} +runProc :: Additive.C v => Int -> (Sig.T v -> Sig.T v) -> Sig.T v -> Sig.T v +runProc = Sig.delayLoopOverlap 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,45 @@ +{-# OPTIONS -fno-implicit-prelude #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +Filter operators from calculus +-} +module Synthesizer.State.Filter.Recursive.Integration where + +import qualified Synthesizer.State.Signal as Sig + +-- import qualified Algebra.Field as Field +-- import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import PreludeBase +import NumericPrelude + + + +{- | +Integrate with initial value zero. +However the first emitted value is the value of the input signal. +It maintains the length of the signal. +-} +{-# INLINE run #-} +run :: Additive.C v => Sig.T v -> Sig.T v +run = + Sig.crochetL (\x acc -> let y = x+acc in Just (y,y)) zero + -- scanl1 (+) + +{- | +Integrate with initial condition. +First emitted value is the initial condition. +The signal become one element longer. +-} +{-# INLINE runInit #-} +runInit :: Additive.C v => v -> Sig.T v -> Sig.T v +runInit = Sig.scanL (+) + +{- other quadrature methods may follow -} 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 @@ +{-# OPTIONS -fno-implicit-prelude #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +-} +module Synthesizer.State.Filter.Recursive.MovingAverage + (sumsStaticInt, + modulatedFrac, + ) where + +import qualified Synthesizer.State.Signal as Sig +import qualified Synthesizer.State.Filter.Recursive.Integration as Integration + +import qualified Synthesizer.State.Filter.Delay as Delay + +import qualified Algebra.Module as Module +import qualified Algebra.RealField as RealField + +-- import qualified Algebra.Field as Field +-- import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import PreludeBase +import NumericPrelude + + + +{- | +Like 'Synthesizer.State.Filter.NonRecursive.sums' but in a recursive form. +This needs only linear time (independent of the window size) +but may accumulate rounding errors. + +@ +ys = xs * (1,0,0,0,-1) \/ (1,-1) +ys * (1,-1) = xs * (1,0,0,0,-1) +ys = xs * (1,0,0,0,-1) + ys * (0,1) +@ +-} +{-# INLINE sumsStaticInt #-} +sumsStaticInt :: (Additive.C v) => Int -> Sig.T v -> Sig.T v +sumsStaticInt n xs = + Integration.run (xs - Delay.staticPos n xs) + +{- +staticInt :: (Module.C a v, Additive.C v) => Int -> Sig.T v -> Sig.T v +staticInt n xs = +-} + + +{- +Sum of a part of a vector with negative sign for reverse order. +It adds from @from@ (inclusively) to @to@ (exclusively), +that is, it sums up @abs (to-from)@ values + +sumFromTo :: (Additive.C v) => Int -> Int -> Sig.T v -> v +sumFromTo from to = + if from <= to + then Sig.sum . Sig.take (to-from) . Sig.drop from + else negate . Sig.sum . Sig.take (from-to) . Sig.drop to +-} + +{-# INLINE sumFromToFrac #-} +sumFromToFrac :: (RealField.C a, Module.C a v) => a -> a -> Sig.T v -> v +sumFromToFrac from to xs = + let (fromInt, fromFrac) = splitFraction from + (toInt, toFrac) = splitFraction to + in case compare fromInt toInt of + EQ -> (to-from) *> Sig.index fromInt xs + LT -> + Sig.sum $ + Sig.zipWith id + (((1-fromFrac) *>) `Sig.cons` + Sig.replicate (toInt-fromInt-1) id `Sig.append` + Sig.singleton (toFrac *>)) $ + Sig.drop fromInt xs + GT -> + negate $ Sig.sum $ + Sig.zipWith id + (((1-toFrac) *>) `Sig.cons` + Sig.replicate (fromInt-toInt-1) id `Sig.append` + Sig.singleton (fromFrac *>)) $ + Sig.drop toInt xs + + +{- + run $ + addNextWeighted (1-toFrac) >> + replicateM_ (fromInt-toInt-1) addNext >> + addNextWeighted (fromFrac) + +type Accumulator v a = + WriterT (Dual (Endo v)) (StateT (Sig.T v) Maybe a) + +getNext :: Accumulator v a +getNext = + lift $ StateT $ viewListL + +addAccum :: Additive.C v => v -> Accumulator v () +addAccum x = tell ((x+) $!) + +addNext :: Additive.C v => Accumulator v () +addNext w = + addAccum =<< getNext + +addNextWeighted :: Module.C a v => a -> Accumulator v () +addNextWeighted w = + addAccum . (w *>) =<< getNext +-} + +{- +newtype Accumulator v = + Accumulator ((v, Sig.T v) -> v -> (Sig.T v, v)) + +addNext :: Additive.C v => Accumulator v +addNext = + Accumulator $ \(x,xs) s -> (xs, x+s) + +addNextWeighted :: Module.C a v => a -> Accumulator v +addNextWeighted a = + Accumulator $ \(x,xs) s -> (xs, a*>x + s) + +bindAccum :: Accumulator v -> Accumulator v -> Accumulator v +bindAccum (Accumulator f) (Accumulator g) = + Accumulator $ \x s0 -> + let (ys,s1) = f x s0 + in maybe s1 () (viewListL ys) +-} + + +{- | +Sig.T a must contain only non-negative elements. +-} +{-# INLINE sumDiffsModulated #-} +sumDiffsModulated :: (RealField.C a, Module.C a v) => + a -> Sig.T a -> Sig.T v -> Sig.T v +sumDiffsModulated d ds = + Sig.init . + -- prevent negative d's since 'drop' cannot restore past values + Sig.zipWithTails (uncurry sumFromToFrac) + (Sig.zip (Sig.cons (d+1) ds) (Sig.map (1+) ds)) . + Sig.cons zero +{- + Sig.zipWithTails (uncurry sumFromToFrac) + (Sig.zip (Sig.cons d (Sig.map (subtract 1) ds)) ds) +-} + +{- +sumsModulated :: (RealField.C a, Module.C a v) => + Int -> Sig.T a -> Sig.T v -> Sig.T v +sumsModulated maxDInt ds xs = + let maxD = fromIntegral maxDInt + posXs = sumDiffsModulated 0 ds xs + negXs = sumDiffsModulated maxD (Sig.map (maxD-) ds) (Delay.static maxDInt xs) + in Integration.run (posXs - negXs) +-} + +{- | +Shift sampling points by a half sample period +in order to preserve signals for window widths below 1. +-} +{-# INLINE sumsModulatedHalf #-} +sumsModulatedHalf :: (RealField.C a, Module.C a v) => + Int -> Sig.T a -> Sig.T v -> Sig.T v +sumsModulatedHalf maxDInt ds xs = + let maxD = fromIntegral maxDInt + d0 = maxD+0.5 + delXs = Delay.staticPos maxDInt xs + posXs = sumDiffsModulated d0 (Sig.map (d0+) ds) delXs + negXs = sumDiffsModulated d0 (Sig.map (d0-) ds) delXs + in Integration.run (posXs - negXs) + +{-# INLINE modulatedFrac #-} +modulatedFrac :: (RealField.C a, Module.C a v) => + Int -> Sig.T a -> Sig.T v -> Sig.T v +modulatedFrac maxDInt ds xs = + Sig.zipWith (\d y -> recip (2*d) *> y) ds $ + sumsModulatedHalf maxDInt ds xs + 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,282 @@ +{-# OPTIONS -fno-implicit-prelude #-} +{- | +ToDo: +use AffineSpace instead of Module for the particular interpolation types, +since affine combinations assert reconstruction of constant functions. +They are more natural for interpolation of internal control parameters. +However, how can cubic interpolation expressed by affine combinations +without divisions? +-} +module Synthesizer.State.Interpolation where + +import qualified Synthesizer.State.Signal as Sig +import qualified Synthesizer.Plain.Control as Ctrl + +import qualified Synthesizer.Generic.Interpolation as InterpolationG +import qualified Synthesizer.Generic.Signal as SigG +import qualified Synthesizer.Generic.SampledValue as Sample + +import qualified Algebra.Module as Module +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Algebra.Module((*>)) +import Data.Maybe (fromMaybe) + +import Control.Monad.State (StateT(StateT), evalStateT, ap, ) +import Control.Applicative (Applicative(pure, (<*>)), (<$>), liftA2, ) +import Synthesizer.ApplicativeUtility (liftA4, ) +import Synthesizer.Utility (affineComb, ) + +import PreludeBase +import NumericPrelude + + + + +{- | interpolation as needed for resampling -} +data T t y = + Cons { + number :: Int, -- interpolation requires a total number of 'number' + offset :: Int, -- interpolation requires 'offset' values before the current + func :: t -> Sig.T y -> y + } + + +{-# INLINE toGeneric #-} +toGeneric :: + (Sample.C y, SigG.C sig) => + T t y -> InterpolationG.T sig t y +toGeneric ip = + InterpolationG.Cons { + InterpolationG.number = number ip, + InterpolationG.offset = offset ip, + InterpolationG.func = \ t x -> func ip t (Sig.fromGenericSignal x) + } + + + +{-* Interpolation with various padding methods -} + +{-# INLINE zeroPad #-} +zeroPad :: (RealField.C t) => + (T t y -> t -> Sig.T y -> a) -> + y -> T t y -> t -> Sig.T y -> a +zeroPad interpolate z ip phase x = + let (phInt, phFrac) = splitFraction phase + in interpolate ip phFrac + (delayPad z (offset ip - phInt) (Sig.append x (Sig.repeat z))) + +{-# INLINE constantPad #-} +constantPad :: (RealField.C t) => + (T t y -> t -> Sig.T y -> a) -> + T t y -> t -> Sig.T y -> a +constantPad interpolate ip phase x = + let (phInt, phFrac) = splitFraction phase + xPad = + do (xFirst,_) <- Sig.viewL x + return (delayPad xFirst (offset ip - phInt) (Sig.extendConstant x)) + in interpolate ip phFrac + (fromMaybe Sig.empty xPad) + + +{- | +Only for finite input signals. +-} +{-# INLINE cyclicPad #-} +cyclicPad :: (RealField.C t) => + (T t y -> t -> Sig.T y -> a) -> + T t y -> t -> Sig.T y -> a +cyclicPad interpolate ip phase x = + let (phInt, phFrac) = splitFraction phase + in interpolate ip phFrac + (Sig.drop (mod (phInt - offset ip) (Sig.length x)) (Sig.cycle x)) + +{- | +The extrapolation may miss some of the first and some of the last points +-} +{-# INLINE extrapolationPad #-} +extrapolationPad :: (RealField.C t) => + (T t y -> t -> Sig.T y -> a) -> + T t y -> t -> Sig.T y -> a +extrapolationPad interpolate ip phase = + interpolate ip (phase - fromIntegral (offset ip)) +{- + This example shows pikes, although there shouldn't be any: + plotList (take 100 $ interpolate (Zero (0::Double)) ipCubic (-0.9::Double) (repeat 0.03) [1,0,1,0.8]) +-} + + +{-* Helper methods for interpolation of multiple nodes -} + +{-# INLINE skip #-} +skip :: (RealField.C t) => + T t y -> (t, Sig.T y) -> (t, Sig.T y) +skip ip (phase0, x0) = + let (n, frac) = splitFraction phase0 + (m, x1) = Sig.dropMarginRem (number ip) n x0 + in (fromIntegral m + frac, x1) + +{-# INLINE single #-} +single :: (RealField.C t) => + T t y -> t -> Sig.T y -> y +single ip phase0 x0 = + uncurry (func ip) $ skip ip (phase0, x0) +-- curry (uncurry (func ip) . skip ip) +{- +GNUPlot.plotFunc [] (GNUPlot.linearScale 1000 (0,2)) (\t -> single linear (t::Double) [0,4,1::Double]) +-} + + + +{-* Different kinds of interpolation -} + +{-** Hard-wired interpolations -} + +data PrefixReader y a = + PrefixReader Int (StateT (Sig.T y) Maybe a) + +instance Functor (PrefixReader y) where + fmap f (PrefixReader count parser) = + PrefixReader count (fmap f parser) + +instance Applicative (PrefixReader y) where + pure = PrefixReader 0 . return + (PrefixReader count0 parser0) <*> (PrefixReader count1 parser1) = + PrefixReader (count0+count1) (parser0 `ap` parser1) + +{-# INLINE getNode #-} +getNode :: PrefixReader y y +getNode = PrefixReader 1 (StateT Sig.viewL) + +{-# INLINE fromPrefixReader #-} +fromPrefixReader :: String -> Int -> PrefixReader y (t -> y) -> T t y +fromPrefixReader name off (PrefixReader count parser) = + Cons count off + (\t xs -> + maybe + (error (name ++ " interpolation: not enough nodes")) + ($t) + (evalStateT parser xs)) + +{-| Consider the signal to be piecewise constant. -} +{-# INLINE constant #-} +constant :: T t y +constant = + fromPrefixReader "constant" 0 (const <$> getNode) + +{-| Consider the signal to be piecewise linear. -} +{-# INLINE linear #-} +linear :: (Module.C t y) => T t y +linear = + fromPrefixReader "linear" 0 + (liftA2 + (\x0 x1 phase -> affineComb phase (x0,x1)) + getNode getNode) + +{-| Consider the signal to be piecewise cubic, + with smooth connections at the nodes. + It uses a cubic curve which has node values + x0 at 0 and x1 at 1 and derivatives + (x1-xm1)/2 and (x2-x0)/2, respectively. + You can see how it works + if you evaluate the expression for t=0 and t=1 + as well as the derivative at these points. -} +{-# INLINE cubic #-} +cubic :: (Field.C t, Module.C t y) => T t y +cubic = + fromPrefixReader "cubic" 1 + (liftA4 + (\xm1 x0 x1 x2 t -> + let lipm12 = affineComb t (xm1,x2) + lip01 = affineComb t (x0, x1) + three = 3 `asTypeOf` t + in lip01 + (t*(t-1)/2) *> + (lipm12 + (x0+x1) - three *> lip01)) + getNode getNode getNode getNode) + +{-# INLINE cubicAlt #-} +cubicAlt :: (Field.C t, Module.C t y) => T t y +cubicAlt = + fromPrefixReader "cubicAlt" 1 + (liftA4 + (\xm1 x0 x1 x2 t -> + let half = 1/2 `asTypeOf` t + in cubicHalf t x0 (half *> (x1-xm1)) + + cubicHalf (1-t) x1 (half *> (x0-x2))) + getNode getNode getNode getNode) + + +{- \t -> cubicHalf t x x' has a double zero at 1 and + at 0 it has value x and steepness x' -} +{-# INLINE cubicHalf #-} +cubicHalf :: (Module.C t y) => t -> y -> y -> y +cubicHalf t x x' = + (t-1)^2 *> ((1+2*t)*>x + t*>x') + + + +{-** Interpolation based on piecewise defined functions -} + +{-# INLINE piecewise #-} +piecewise :: (Module.C t y) => + Int -> [t -> t] -> T t y +piecewise center ps = + Cons (length ps) (center-1) + (\t -> Sig.linearComb (Sig.fromList (map ($t) (reverse ps)))) + +{-# INLINE piecewiseConstant #-} +piecewiseConstant :: (Module.C t y) => T t y +piecewiseConstant = + piecewise 1 [const 1] + +{-# INLINE piecewiseLinear #-} +piecewiseLinear :: (Module.C t y) => T t y +piecewiseLinear = + piecewise 1 [id, (1-)] + +{-# INLINE piecewiseCubic #-} +piecewiseCubic :: (Field.C t, Module.C t y) => T t y +piecewiseCubic = + piecewise 2 $ + Ctrl.cubicFunc (0,(0,0)) (1,(0,1/2)) : + Ctrl.cubicFunc (0,(0,1/2)) (1,(1,0)) : + Ctrl.cubicFunc (0,(1,0)) (1,(0,-1/2)) : + Ctrl.cubicFunc (0,(0,-1/2)) (1,(0,0)) : + [] + +{- +GNUPlot.plotList [] $ take 100 $ interpolate (Zero 0) piecewiseCubic (-2.3 :: Double) (repeat 0.1) [2,1,2::Double] +-} + + +{-** Interpolation based on arbitrary functions -} + +{- | with this wrapper you can use the collection of interpolating functions from Donadio's DSP library -} +{-# INLINE function #-} +function :: (Module.C t y) => + (Int,Int) {- ^ @(left extent, right extent)@, e.g. @(1,1)@ for linear hat -} + -> (t -> t) + -> T t y +function (left,right) f = + let len = left+right + ps = Sig.take len $ Sig.iterate pred (pred right) + -- ps = Sig.reverse $ Sig.take len $ Sig.iterate succ (-left) + in Cons len left + (\t -> Sig.linearComb $ + Sig.map (\x -> f (t + fromIntegral x)) ps) +{- +GNUPlot.plotList [] $ take 300 $ interpolate (Zero 0) (function (1,1) (\x -> exp (-6*x*x))) (-2.3 :: Double) (repeat 0.03) [2,1,2::Double] +-} + + +{-* Helper functions -} + +{-# INLINE delayPad #-} +delayPad :: y -> Int -> Sig.T y -> Sig.T y +delayPad z n = + if n<0 + then Sig.drop (negate n) + else Sig.append (Sig.replicate n z) 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 @@ +{-# OPTIONS -fno-implicit-prelude #-} +module Synthesizer.State.Miscellaneous where + +import qualified Synthesizer.State.Signal as Signal + +import qualified Algebra.NormedSpace.Euclidean as Euc +-- import qualified Algebra.Module as Module +-- import qualified Algebra.Transcendental as Trans +import qualified Algebra.Field as Field +-- import qualified Algebra.Ring as Ring +-- import qualified Algebra.Additive as Additive + +-- import qualified Prelude as P +-- import PreludeBase +import NumericPrelude + +{- * Spatial effects -} + +{-| simulate an moving sounding object + convert the way of the object through 3D space + into a delay and attenuation information, + sonicDelay is the reciprocal of the sonic velocity -} +{-# INLINE receive3Dsound #-} +receive3Dsound :: (Field.C a, Euc.C a v) => + a -> a -> v -> Signal.T v -> (Signal.T a,Signal.T a) +receive3Dsound att sonicDelay ear way = + let dists = Signal.map Euc.norm (Signal.map (subtract ear) way) + phase = Signal.map (sonicDelay*) dists + volumes = Signal.map (\x -> 1/(att+x)^2) dists + in (phase, volumes) 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 @@ +{-# OPTIONS -fno-implicit-prelude #-} +{- | Noise and random processes. -} +module Synthesizer.State.Noise where + +import qualified Synthesizer.State.Signal as Sig + +import qualified Algebra.Real as Real +import qualified Algebra.Ring as Ring + +import System.Random (Random, RandomGen, randomR, mkStdGen, ) +import qualified System.Random as Rnd + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +{-| +Deterministic white noise, uniformly distributed between -1 and 1. +That is, variance is 1\/3. +-} +{-# INLINE white #-} +white :: (Ring.C y, Random y) => + Sig.T y +white = whiteGen (mkStdGen 12354) + +{-# INLINE whiteGen #-} +whiteGen :: + (Ring.C y, Random y, RandomGen g) => + g -> Sig.T y +whiteGen = randomRs (-1,1) + + +{- | +Approximates normal distribution with variance 1 +by a quadratic B-spline distribution. +-} +{-# INLINE whiteQuadraticBSplineGen #-} +whiteQuadraticBSplineGen :: + (Ring.C y, Random y, RandomGen g) => + g -> Sig.T y +whiteQuadraticBSplineGen g = + let (g0,gr) = Rnd.split g + (g1,g2) = Rnd.split gr + in whiteGen g0 `Sig.mix` + whiteGen g1 `Sig.mix` + whiteGen g2 + + +{-# INLINE randomPeeks #-} +randomPeeks :: (Real.C y, Random y) => + Sig.T y {- ^ momentary densities, @p@ means that there is about one peak + in the time range of @1\/p@ samples -} + -> Sig.T Bool {- ^ Every occurence of 'True' represents a peak. -} +randomPeeks = + randomPeeksGen (mkStdGen 876) + +{-# INLINE randomPeeksGen #-} +randomPeeksGen :: (Real.C y, Random y, RandomGen g) => + g + -> Sig.T y + -> Sig.T Bool +randomPeeksGen = + Sig.zipWith (<) . randomRs (0,1) + + + +{-# INLINE randomRs #-} +randomRs :: + (Ring.C y, Random y, RandomGen g) => + (y,y) -> g -> Sig.T y +randomRs bnd = Sig.unfoldR (Just . randomR bnd) 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 @@ +{-# OPTIONS -fno-implicit-prelude #-} +{- | +Noise and random processes. +This uses a fast reimplementation of 'System.Random.randomR' +since the standard function seems not to be inlined (at least in GHC-6.8.2). +-} +module Synthesizer.State.NoiseCustom where + +import qualified Synthesizer.State.Signal as Sig + +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field + +import qualified Synthesizer.RandomKnuth as Knuth + +import System.Random (Random, RandomGen, ) +import qualified System.Random as Rnd + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +{-| +Deterministic white noise, uniformly distributed between -1 and 1. +That is, variance is 1\/3. +-} +{-# INLINE white #-} +white :: (Field.C y, Random y) => + Sig.T y +white = whiteGen (Knuth.cons 12354) + +{-# INLINE whiteGen #-} +whiteGen :: + (Field.C y, Random y, RandomGen g) => + g -> Sig.T y +whiteGen = randomRs (-1,1) + + +{- | +Approximates normal distribution with variance 1 +by a quadratic B-spline distribution. +-} +{-# INLINE whiteQuadraticBSplineGen #-} +whiteQuadraticBSplineGen :: + (Field.C y, Random y, RandomGen g) => + g -> Sig.T y +whiteQuadraticBSplineGen g = + let (g0,gr) = Rnd.split g + (g1,g2) = Rnd.split gr + in whiteGen g0 `Sig.mix` + whiteGen g1 `Sig.mix` + whiteGen g2 + + +{-# INLINE randomPeeks #-} +randomPeeks :: (RealField.C y, Random y) => + Sig.T y {- ^ momentary densities, @p@ means that there is about one peak + in the time range of @1\/p@ samples -} + -> Sig.T Bool {- ^ Every occurence of 'True' represents a peak. -} +randomPeeks = + randomPeeksGen (Knuth.cons 876) + +{-# INLINE randomPeeksGen #-} +randomPeeksGen :: (RealField.C y, Random y, RandomGen g) => + g + -> Sig.T y + -> Sig.T Bool +randomPeeksGen = + Sig.zipWith (<) . randomRs (0,1) + + +{-# INLINE randomRs #-} +randomRs :: + (Field.C y, Random y, RandomGen g) => + (y,y) -> g -> Sig.T y +randomRs bnd = Sig.unfoldR (Just . randomR bnd) + +{-# INLINE randomR #-} +randomR :: + (RandomGen g, Field.C y) => + (y, y) -> g -> (y, g) +randomR (lower,upper) g0 = + let (n,g1) = Rnd.next g0 + (l,u) = Rnd.genRange g0 + nd = fromIntegral n + ld = fromIntegral l + ud = fromIntegral u + x01 = (nd-ld)/(ud-ld) + in ((1-x01)*lower + x01*upper, g1) 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,139 @@ +{-# OPTIONS_GHC -O2 -fno-implicit-prelude #-} +{- | +Copyright : (c) Henning Thielemann 2006 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +Tone generators +-} +module Synthesizer.State.Oscillator where + +import qualified Synthesizer.Causal.Oscillator as Osci +import qualified Synthesizer.Basic.WaveSmoothed as WaveSmooth +import qualified Synthesizer.Basic.Wave as Wave +import qualified Synthesizer.Basic.Phase as Phase + +import qualified Synthesizer.Causal.Process as Causal +import qualified Synthesizer.State.Signal as Sig + +import qualified Synthesizer.State.Interpolation as Interpolation + + +import qualified Algebra.Transcendental as Trans +import qualified Algebra.RealField as RealField + +-- import qualified Prelude as P +-- import NumericPrelude +-- import PreludeBase + + + +{- * Oscillators with arbitrary but constant waveforms -} + +{-# INLINE static #-} +{- | +Oscillator with constant frequency. +It causes aliasing effects for sharp waveforms and high frequencies. +-} +static :: (RealField.C a) => Wave.T a b -> (Phase.T a -> a -> Sig.T b) +static wave phase freq = + Sig.map (Wave.apply wave) (Osci.freqToPhases phase freq) + +{-# INLINE staticAntiAlias #-} +{- | +Oscillator with constant frequency +that suppresses aliasing effects using waveforms with controllable smoothness. +-} +staticAntiAlias :: (RealField.C a) => + WaveSmooth.T a b -> (Phase.T a -> a -> Sig.T b) +staticAntiAlias wave phase freq = + Sig.map (WaveSmooth.apply wave freq) (Osci.freqToPhases phase freq) + +{-# INLINE phaseMod #-} +{- | oscillator with modulated phase -} +phaseMod :: (RealField.C a) => Wave.T a b -> a -> Sig.T a -> Sig.T b +phaseMod wave freq = + Causal.apply (Osci.phaseMod wave freq) + +{-# INLINE shapeMod #-} +{- | oscillator with modulated shape -} +shapeMod :: (RealField.C a) => + (c -> Wave.T a b) -> Phase.T a -> a -> Sig.T c -> Sig.T b +shapeMod wave phase freq = + Causal.apply (Osci.shapeMod wave phase freq) + +{-# INLINE freqMod #-} +{- | oscillator with modulated frequency -} +freqMod :: (RealField.C a) => Wave.T a b -> Phase.T a -> Sig.T a -> Sig.T b +freqMod wave phase = + Causal.apply (Osci.freqMod wave phase) + +{-# INLINE freqModAntiAlias #-} +{- | oscillator with modulated frequency -} +freqModAntiAlias :: (RealField.C a) => + WaveSmooth.T a b -> Phase.T a -> Sig.T a -> Sig.T b +freqModAntiAlias wave phase = + Causal.apply (Osci.freqModAntiAlias wave phase) + +{-# INLINE phaseFreqMod #-} +{- | oscillator with both phase and frequency modulation -} +phaseFreqMod :: (RealField.C a) => + Wave.T a b -> Sig.T a -> Sig.T a -> Sig.T b +phaseFreqMod wave = + Causal.apply2 (Osci.phaseFreqMod wave) + +{-# INLINE shapeFreqMod #-} +{- | oscillator with both shape and frequency modulation -} +shapeFreqMod :: (RealField.C a) => + (c -> Wave.T a b) -> Phase.T a -> Sig.T c -> Sig.T a -> Sig.T b +shapeFreqMod wave phase = + Causal.apply2 (Osci.shapeFreqMod wave phase) + + +{- | oscillator with a sampled waveform with constant frequency + This essentially an interpolation with cyclic padding. -} +{-# INLINE staticSample #-} +staticSample :: RealField.C a => + Interpolation.T a b -> Sig.T b -> Phase.T a -> a -> Sig.T b +staticSample ip wave phase freq = + Causal.apply (Osci.freqModSample ip wave phase) (Sig.repeat freq) + +{- | oscillator with a sampled waveform with modulated frequency + Should behave homogenously for different types of interpolation. -} +{-# INLINE freqModSample #-} +freqModSample :: RealField.C a => + Interpolation.T a b -> Sig.T b -> Phase.T a -> Sig.T a -> Sig.T b +freqModSample ip wave phase = + Causal.apply (Osci.freqModSample ip wave phase) + + + +{- * Oscillators with specific waveforms -} + +{-# INLINE staticSine #-} +{- | sine oscillator with static frequency -} +staticSine :: (Trans.C a, RealField.C a) => Phase.T a -> a -> Sig.T a +staticSine = static Wave.sine + +{-# INLINE freqModSine #-} +{- | sine oscillator with modulated frequency -} +freqModSine :: (Trans.C a, RealField.C a) => Phase.T a -> Sig.T a -> Sig.T a +freqModSine = freqMod Wave.sine + +{-# INLINE phaseModSine #-} +{- | sine oscillator with modulated phase, useful for FM synthesis -} +phaseModSine :: (Trans.C a, RealField.C a) => a -> Sig.T a -> Sig.T a +phaseModSine = phaseMod Wave.sine + +{-# INLINE staticSaw #-} +{- | saw tooth oscillator with modulated frequency -} +staticSaw :: RealField.C a => Phase.T a -> a -> Sig.T a +staticSaw = static Wave.saw + +{-# INLINE freqModSaw #-} +{- | saw tooth oscillator with modulated frequency -} +freqModSaw :: RealField.C a => Phase.T a -> Sig.T a -> Sig.T a +freqModSaw = freqMod Wave.saw 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,712 @@ +{-# OPTIONS_GHC -O -fglasgow-exts -fno-implicit-prelude #-} +{- glasgow-exts are for higher rank types -} +module Synthesizer.State.Signal where + +import qualified Synthesizer.Generic.Signal as SigG +import qualified Synthesizer.Generic.SampledValue as Sample + +-- import qualified Synthesizer.Plain.Signal as Sig +import qualified Synthesizer.Plain.Modifier as Modifier +import qualified Data.List as List + +import qualified Algebra.Module as Module +import qualified Algebra.Additive as Additive +import Algebra.Additive (zero) + +import Algebra.Module ((*>)) + +import qualified Synthesizer.Format as Format + +import Control.Monad.State + (State, runState, StateT(StateT), runStateT, liftM2, ) +import Control.Monad (Monad, mplus, msum, + (>>), (>>=), fail, return, (=<<), + Functor, fmap, ) + +import qualified Synthesizer.Storable.Signal as SigSt +import Foreign.Storable (Storable) + +import Synthesizer.Utility + (viewListL, mapFst, mapSnd, mapPair, fst3, snd3, thd3, nest, ) + +import NumericPrelude.Condition (toMaybe) +import NumericPrelude (fromInteger, ) + +import Text.Show (Show(showsPrec), showParen, showString, ) +import Data.Maybe (Maybe(Just, Nothing), maybe, fromMaybe, ) +import Prelude + ((.), ($), ($!), id, const, flip, curry, uncurry, fst, snd, error, + (>), (>=), max, Ord, + succ, pred, Bool(True,False), not, Int, +-- fromInteger, + ) + + +-- | Cf. StreamFusion Data.Stream +data T a = + forall s. -- Seq s => + Cons !(StateT s Maybe a) -- compute next value + !s -- initial state + + +instance (Show y) => Show (T y) where + showsPrec p x = + showParen (p >= 10) + (showString "StateSignal.fromList " . showsPrec 11 (toList x)) + +instance Format.C T where + format = showsPrec + +instance Functor T where + fmap = map + + +instance SigG.C T where + empty = empty + null = null + cons = cons + fromList = fromList + toList = toList + repeat = repeat + cycle = cycle + replicate = replicate + iterate = iterate + iterateAssoc op x = iterate (op x) x -- should be optimized + unfoldR = generate + map = map + mix = mix + zipWith = zipWith + scanL = scanL + viewL = viewL + viewR = viewR + foldL = foldL + length = length + take = take + drop = drop + splitAt = splitAt + dropMarginRem = dropMarginRem + takeWhile = takeWhile + dropWhile = dropWhile + span = span + append = append + concat = concat + reverse = reverse +{- + mapAccumL = mapAccumL + mapAccumR = mapAccumR +-} + crochetL = crochetL + + + + +{-# INLINE generate #-} +generate :: (acc -> Maybe (y, acc)) -> acc -> T y +generate f = Cons (StateT f) + +{-# INLINE unfoldR #-} +unfoldR :: (acc -> Maybe (y, acc)) -> acc -> T y +unfoldR = generate + +{-# INLINE generateInfinite #-} +generateInfinite :: (acc -> (y, acc)) -> acc -> T y +generateInfinite f = generate (Just . f) + +{-# INLINE fromList #-} +fromList :: [y] -> T y +fromList = generate viewListL + +{-# INLINE toList #-} +toList :: T y -> [y] +toList (Cons f x0) = + List.unfoldr (runStateT f) x0 + + +{-# INLINE fromGenericSignal #-} +fromGenericSignal :: + (Sample.C a, SigG.C sig) => + sig a -> T a +fromGenericSignal = + generate SigG.viewL + +{-# INLINE toGenericSignal #-} +toGenericSignal :: + (Sample.C a, SigG.C sig) => + T a -> sig a +toGenericSignal (Cons f a) = + SigG.unfoldR (runStateT f) a + + +{-# INLINE fromStorableSignal #-} +fromStorableSignal :: + (Storable a) => + SigSt.T a -> T a +fromStorableSignal = + generate SigSt.viewL + +{-# INLINE toStorableSignal #-} +toStorableSignal :: + (Storable a) => + SigSt.ChunkSize -> T a -> SigSt.T a +toStorableSignal size (Cons f a) = + SigSt.unfoldr size (runStateT f) a + + + +{-# INLINE iterate #-} +iterate :: (a -> a) -> a -> T a +iterate f = generateInfinite (\x -> (x, f x)) + +{-# INLINE iterateAssoc #-} +iterateAssoc :: (a -> a -> a) -> a -> T a +iterateAssoc op x = iterate (op x) x -- should be optimized + +{-# INLINE repeat #-} +repeat :: a -> T a +repeat = iterate id + + + + +{-# INLINE crochetL #-} +crochetL :: (x -> acc -> Maybe (y, acc)) -> acc -> T x -> T y +crochetL g b (Cons f a) = + Cons + (StateT (\(a0,b0) -> + do (x0,a1) <- runStateT f a0 + (y0,b1) <- g x0 b0 + Just (y0, (a1,b1)))) + (a,b) + + +{-# INLINE scanL #-} +scanL :: (acc -> x -> acc) -> acc -> T x -> T acc +scanL f start = + cons start . + crochetL (\x acc -> let y = f acc x in Just (y, y)) start + + +{-# INLINE scanLClip #-} +-- | input and output have equal length, that's better for fusion +scanLClip :: (acc -> x -> acc) -> acc -> T x -> T acc +scanLClip f start = + crochetL (\x acc -> Just (acc, f acc x)) start + +{-# INLINE map #-} +map :: (a -> b) -> (T a -> T b) +map f = crochetL (\x _ -> Just (f x, ())) () + + +{-# INLINE unzip #-} +unzip :: T (a,b) -> (T a, T b) +unzip x = (map fst x, map snd x) + +{-# INLINE unzip3 #-} +unzip3 :: T (a,b,c) -> (T a, T b, T c) +unzip3 xs = (map fst3 xs, map snd3 xs, map thd3 xs) + + +{-# INLINE delay1 #-} +{- | +This is a fusion friendly implementation of delay. +However, in order to be a 'crochetL' +the output has the same length as the input, +that is, the last element is removed - at least for finite input. +-} +delay1 :: a -> T a -> T a +delay1 = crochetL (flip (curry Just)) + +{-# INLINE delay #-} +delay :: y -> Int -> T y -> T y +delay z n = append (replicate n z) + +{-# INLINE take #-} +take :: Int -> T a -> T a +take = crochetL (\x n -> toMaybe (n>zero) (x, pred n)) + +{-# INLINE takeWhile #-} +takeWhile :: (a -> Bool) -> T a -> T a +takeWhile p = crochetL (\x _ -> toMaybe (p x) (x, ())) () + +{-# INLINE replicate #-} +replicate :: Int -> a -> T a +replicate n = take n . repeat + + +{- * functions consuming multiple lists -} + +{-# INLINE zipWith #-} +zipWith :: (a -> b -> c) -> (T a -> T b -> T c) +zipWith h (Cons f a) = + crochetL + (\x0 a0 -> + do (y0,a1) <- runStateT f a0 + Just (h y0 x0, a1)) + a + +{-# INLINE zipWith3 #-} +zipWith3 :: (a -> b -> c -> d) -> (T a -> T b -> T c -> T d) +zipWith3 f s0 s1 = + zipWith (uncurry f) (zip s0 s1) + +{-# INLINE zipWith4 #-} +zipWith4 :: (a -> b -> c -> d -> e) -> (T a -> T b -> T c -> T d -> T e) +zipWith4 f s0 s1 = + zipWith3 (uncurry f) (zip s0 s1) + + +{-# INLINE zip #-} +zip :: T a -> T b -> T (a,b) +zip = zipWith (,) + +{-# INLINE zip3 #-} +zip3 :: T a -> T b -> T c -> T (a,b,c) +zip3 = zipWith3 (,,) + +{-# INLINE zip4 #-} +zip4 :: T a -> T b -> T c -> T d -> T (a,b,c,d) +zip4 = zipWith4 (,,,) + + +{- * functions based on 'foldL' -} + +{-# INLINE foldL' #-} +foldL' :: (x -> acc -> acc) -> acc -> T x -> acc +foldL' g b = + switchL b (\ x xs -> foldL' g (g x $! b) xs) + +{-# INLINE foldL #-} +foldL :: (acc -> x -> acc) -> acc -> T x -> acc +foldL f = foldL' (flip f) + +{-# INLINE length #-} +length :: T a -> Int +length = foldL' (const succ) zero + + +{- * functions based on 'foldR' -} + +foldR :: (x -> acc -> acc) -> acc -> T x -> acc +foldR g b = + switchL b (\ x xs -> g x (foldR g b xs)) + + +{- * Other functions -} + +{-# INLINE null #-} +null :: T a -> Bool +null = + switchL True (const (const False)) + -- foldR (const (const False)) True + +{-# INLINE empty #-} +empty :: T a +empty = generate (const Nothing) () + +{-# INLINE singleton #-} +singleton :: a -> T a +singleton = + generate (fmap (\x -> (x, Nothing))) . Just + +{-# INLINE cons #-} +{- | +This is expensive and should not be used to construct lists iteratively! +-} +cons :: a -> T a -> T a +cons x xs = + generate + (\(mx0,xs0) -> + fmap (mapSnd ((,) Nothing)) $ + maybe + (viewL xs0) + (\x0 -> Just (x0, xs0)) + mx0) $ + (Just x, xs) + +{-# INLINE viewL #-} +viewL :: T a -> Maybe (a, T a) +viewL (Cons f a0) = + fmap + (mapSnd (Cons f)) + (runStateT f a0) + +{- iterated 'cons' is very inefficient +viewR :: T a -> Maybe (T a, a) +viewR = + foldR (\x mxs -> Just (maybe (empty,x) (mapFst (cons x)) mxs)) Nothing +-} + +{-# INLINE viewR #-} +viewR :: Storable a => T a -> Maybe (T a, a) +viewR = viewRSize SigSt.defaultChunkSize + +{-# INLINE viewRSize #-} +viewRSize :: Storable a => SigSt.ChunkSize -> T a -> Maybe (T a, a) +viewRSize size = + fmap (mapFst fromStorableSignal) . + SigSt.viewR . + toStorableSignal size + + +{-# INLINE switchL #-} +switchL :: b -> (a -> T a -> b) -> T a -> b +switchL n j = + maybe n (uncurry j) . viewL + +{-# INLINE switchR #-} +switchR :: Storable a => b -> (T a -> a -> b) -> T a -> b +switchR n j = + maybe n (uncurry j) . viewR + + +{- | +This implementation requires +that the input generator has to check repeatedly whether it is finished. +-} +{-# INLINE extendConstant #-} +extendConstant :: T a -> T a +extendConstant xt0 = + switchL + empty + (\ x0 _ -> + generate + (\xt1@(x1,xs1) -> + Just $ switchL + (x1,xt1) + (\x xs -> (x, (x,xs))) + xs1) + (x0,xt0)) $ + xt0 + + +{- +{-# INLINE tail #-} +tail :: T a -> T a +tail = Cons . List.tail . decons + +{-# INLINE head #-} +head :: T a -> a +head = List.head . decons +-} + +{-# INLINE drop #-} +drop :: Int -> T a -> T a +drop n = + fromMaybe empty . + nest n (fmap snd . viewL =<<) . + Just + +{-# INLINE dropMarginRem #-} +{- | +This implementation expects that looking ahead is cheap. +-} +dropMarginRem :: Int -> Int -> T a -> (Int, T a) +dropMarginRem n m = + switchL (error "StateSignal.dropMaringRem: length xs < n") const . + dropMargin n m . + zipWithTails (,) (iterate pred m) + +{-# INLINE dropMargin #-} +dropMargin :: Int -> Int -> T a -> T a +dropMargin n m xs = + dropMatch (take m (drop n xs)) xs + + +dropMatch :: T b -> T a -> T a +dropMatch xs ys = + fromMaybe ys $ + liftM2 dropMatch + (fmap snd $ viewL xs) + (fmap snd $ viewL ys) + + +index :: Int -> T a -> a +index n = + switchL (error "State.Signal: index too large") const . drop n + + +{- +splitAt :: Int -> T a -> (T a, T a) +splitAt n = mapPair (Cons, Cons) . List.splitAt n . decons +-} + +{-# INLINE splitAt #-} +splitAt :: Storable a => + Int -> T a -> (T a, T a) +splitAt = splitAtSize SigSt.defaultChunkSize + +{-# INLINE splitAtSize #-} +splitAtSize :: Storable a => + SigSt.ChunkSize -> Int -> T a -> (T a, T a) +splitAtSize size n = + mapPair (fromStorableSignal, fromStorableSignal) . + SigSt.splitAt n . + toStorableSignal size + + +{-# INLINE dropWhile #-} +dropWhile :: (a -> Bool) -> T a -> T a +dropWhile p xt = + switchL empty (\ x xs -> if p x then dropWhile p xs else xt) xt + +{- +span :: (a -> Bool) -> T a -> (T a, T a) +span p = mapPair (Cons, Cons) . List.span p . decons +-} + +{-# INLINE span #-} +span :: Storable a => + (a -> Bool) -> T a -> (T a, T a) +span = spanSize SigSt.defaultChunkSize + +{-# INLINE spanSize #-} +spanSize :: Storable a => + SigSt.ChunkSize -> (a -> Bool) -> T a -> (T a, T a) +spanSize size p = + mapPair (fromStorableSignal, fromStorableSignal) . + SigSt.span p . + toStorableSignal size + + +{-# INLINE cycle #-} +cycle :: T a -> T a +cycle xs = + switchL + (error "StateSignal.cycle: empty input") + (curry $ \yt -> generate (Just . fromMaybe yt . viewL) xs) + xs + +{-# INLINE mix #-} +mix :: Additive.C a => T a -> T a -> T a +mix = + curry (unfoldR mixStep) + + +mixStep :: (Additive.C a) => + (T a, T a) -> Maybe (a, (T a, T a)) +mixStep (xt,yt) = + case (viewL xt, viewL yt) of + (Just (x,xs), Just (y,ys)) -> Just (x Additive.+ y, (xs,ys)) + (Nothing, Just (y,ys)) -> Just (y, (xt,ys)) + (Just (x,xs), Nothing) -> Just (x, (xs,yt)) + (Nothing, Nothing) -> Nothing + + +{-# INLINE sub #-} +sub :: Additive.C a => T a -> T a -> T a +sub xs ys = mix xs (neg ys) + +{-# INLINE neg #-} +neg :: Additive.C a => T a -> T a +neg = map Additive.negate + +instance Additive.C y => Additive.C (T y) where + zero = empty + (+) = mix + (-) = sub + negate = neg + +instance Module.C y yv => Module.C y (T yv) where + (*>) x y = map (x*>) y + + +infixr 5 `append` + +{-# INLINE append #-} +append :: T a -> T a -> T a +append xs ys = + generate + (\(b,xs0) -> + mplus + (fmap (mapSnd ((,) b)) $ viewL xs0) + (if b + then Nothing + else fmap (mapSnd ((,) True)) $ viewL ys)) + (False,xs) + +{-# INLINE appendStored #-} +appendStored :: Storable a => + T a -> T a -> T a +appendStored = appendStoredSize SigSt.defaultChunkSize + +{-# INLINE appendStoredSize #-} +appendStoredSize :: Storable a => + SigSt.ChunkSize -> T a -> T a -> T a +appendStoredSize size xs ys = + fromStorableSignal $ + SigSt.append + (toStorableSignal size xs) + (toStorableSignal size ys) + +{-# INLINE concat #-} +-- | certainly inefficient because of frequent list deconstruction +concat :: [T a] -> T a +concat = + generate + (msum . + List.map + (\ x -> viewListL x >>= + \(y,ys) -> viewL y >>= + \(z,zs) -> Just (z,zs:ys)) . + List.init . List.tails) + + +{-# INLINE concatStored #-} +concatStored :: Storable a => + [T a] -> T a +concatStored = concatStoredSize SigSt.defaultChunkSize + +{-# INLINE concatStoredSize #-} +concatStoredSize :: Storable a => + SigSt.ChunkSize -> [T a] -> T a +concatStoredSize size = + fromStorableSignal . + SigSt.concat . + List.map (toStorableSignal size) + +{-# INLINE reverse #-} +reverse :: + T a -> T a +reverse = + fromList . List.reverse . toList + +{-# INLINE reverseStored #-} +reverseStored :: Storable a => + T a -> T a +reverseStored = reverseStoredSize SigSt.defaultChunkSize + +{-# INLINE reverseStoredSize #-} +reverseStoredSize :: Storable a => + SigSt.ChunkSize -> T a -> T a +reverseStoredSize size = + fromStorableSignal . + SigSt.reverse . + toStorableSignal size + + +{-# INLINE sum #-} +sum :: (Additive.C a) => T a -> a +sum = foldL' (Additive.+) Additive.zero + +{-# INLINE maximum #-} +maximum :: (Ord a) => T a -> a +maximum = + switchL + (error "FusionList.maximum: empty list") + (foldL' max) + +{- +{-# INLINE tails #-} +tails :: T y -> [T y] +tails = List.map Cons . List.tails . decons +-} + +{-# INLINE init #-} +init :: T y -> T y +init = + switchL + (error "FusionList.init: empty list") + (crochetL (\x acc -> Just (acc,x))) + +{-# INLINE sliceVert #-} +-- inefficient since it computes some things twice +sliceVert :: Int -> T y -> [T y] +sliceVert n = +-- map fromList . Sig.sliceVert n . toList + List.map (take n) . List.takeWhile (not . null) . List.iterate (drop n) + +{-# INLINE zapWith #-} +zapWith :: (a -> a -> b) -> T a -> T b +zapWith f = + switchL empty + (crochetL (\y x -> Just (f x y, y))) + +zapWithAlt :: (a -> a -> b) -> T a -> T b +zapWithAlt f xs = + zipWith f xs (switchL empty (curry snd) xs) + +{-# INLINE modifyStatic #-} +modifyStatic :: Modifier.Simple s ctrl a b -> ctrl -> T a -> T b +modifyStatic modif control x = + crochetL + (\a acc -> + Just (runState (Modifier.step modif control a) acc)) + (Modifier.init modif) x + +{-| Here the control may vary over the time. -} +{-# INLINE modifyModulated #-} +modifyModulated :: Modifier.Simple s ctrl a b -> T ctrl -> T a -> T b +modifyModulated modif control x = + crochetL + (\ca acc -> + Just (runState (uncurry (Modifier.step modif) ca) acc)) + (Modifier.init modif) + (zip control x) + + +-- cf. Module.linearComb +{-# INLINE linearComb #-} +linearComb :: + (Module.C t y) => + T t -> T y -> y +linearComb ts ys = + sum $ zipWith (*>) ts ys + + +-- comonadic 'bind' +-- only non-empty suffixes are processed +{-# INLINE mapTails #-} +mapTails :: + (T y0 -> y1) -> T y0 -> T y1 +mapTails f = + generate (\xs -> + do (_,ys) <- viewL xs + return (f xs, ys)) + +-- only non-empty suffixes are processed +{-# INLINE zipWithTails #-} +zipWithTails :: + (y0 -> T y1 -> y2) -> T y0 -> T y1 -> T y2 +zipWithTails f = + curry $ generate (\(xs0,ys0) -> + do (x,xs) <- viewL xs0 + (_,ys) <- viewL ys0 + return (f x ys0, (xs,ys))) + +delayLoop :: + (T y -> T y) + -- ^ processor that shall be run in a feedback loop + -> T y -- ^ prefix of the output, its length determines the delay + -> T y +delayLoop proc prefix = + -- the temporary list is need for sharing the output + let ys = fromList (toList prefix List.++ toList (proc ys)) + in ys + +delayLoopOverlap :: + (Additive.C y) => + Int + -> (T y -> T y) + -- ^ processor that shall be run in a feedback loop + -> T y -- ^ input + -> T y -- ^ output has the same length as the input +delayLoopOverlap time proc xs = + -- the temporary list is need for sharing the output + let ys = zipWith (Additive.+) xs (delay zero time (proc (fromList (toList ys)))) + in ys + + +{- +A traversable instance is hardly useful, +because 'cons' is so expensive. + +instance Traversable T where +-} +{-# INLINE sequence_ #-} +sequence_ :: Monad m => T (m a) -> m () +sequence_ = + switchL (return ()) (\x xs -> x >> sequence_ xs) + +{-# INLINE mapM_ #-} +mapM_ :: Monad m => (a -> m ()) -> T a -> m () +mapM_ f = sequence_ . map f 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,74 @@ +module Synthesizer.Storable.Cut where + +import qualified Synthesizer.Storable.Signal as Sig + +import qualified Data.EventList.Relative.TimeBody as EventList +import Control.Monad.State (runState, modify, gets, put, ) +import Synthesizer.Utility (mapSnd, ) + +-- import qualified Algebra.Real as Real +import qualified Algebra.Additive as Additive +import qualified Number.NonNegative as NonNeg + +import Foreign.Storable (Storable) + +import PreludeBase +import NumericPrelude + + +{-# INLINE arrange #-} +arrange :: (Storable v, Additive.C v) => + Sig.ChunkSize + -> EventList.T NonNeg.Int (Sig.T v) + {-^ A list of pairs: (relative start time, signal part), + The start time is relative to the start time + of the previous event. -} + -> Sig.T v + {-^ The mixed signal. -} +arrange size = + uncurry Sig.append . + flip runState Sig.empty . + fmap (Sig.concat . EventList.getTimes) . + EventList.mapM + (\timeNN -> + let time = NonNeg.toNumber timeNN + in do (prefix,suffix) <- gets (Sig.splitAtPad size time) + put suffix + return prefix) + (\body -> + modify (Sig.mix body)) + + +arrangeList :: (Storable v, Additive.C v) => + Sig.ChunkSize + -> EventList.T NonNeg.Int (Sig.T v) + {-^ A list of pairs: (relative start time, signal part), + The start time is relative to the start time + of the previous event. -} + -> Sig.T v + {-^ The mixed signal. -} +arrangeList size evs = + let xs = EventList.getBodies evs + in case EventList.getTimes evs of + t:ts -> Sig.replicate size (NonNeg.toNumber t) zero `Sig.append` + addShiftedMany size ts xs + [] -> Sig.empty + + +addShiftedMany :: (Storable a, Additive.C a) => + Sig.ChunkSize -> [NonNeg.Int] -> [Sig.T a] -> Sig.T a +addShiftedMany size ds xss = + foldr (uncurry (addShifted size)) Sig.empty (zip (ds++[0]) xss) + + +{- +It is crucial that 'mix' uses the chunk size structure of the second operand. +This way we avoid unnecessary and even infinite look-ahead. +-} +addShifted :: (Storable a, Additive.C a) => + Sig.ChunkSize -> NonNeg.Int -> Sig.T a -> Sig.T a -> Sig.T a +addShifted size delNN px py = + let del = NonNeg.toNumber delNN + in uncurry Sig.append $ + mapSnd (flip Sig.mix py) $ + Sig.splitAtPad size del px diff --git a/src/Synthesizer/Storable/Filter/Recursive/Comb.hs b/src/Synthesizer/Storable/Filter/Recursive/Comb.hs new file mode 100644 --- /dev/null +++ b/src/Synthesizer/Storable/Filter/Recursive/Comb.hs @@ -0,0 +1,90 @@ +{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-} +{- | +Copyright : (c) Henning Thielemann 2008 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +Comb filters, useful for emphasis of tones with harmonics +and for repeated echos. + +We cannot generalize this to "Synthesizer.Generic.Signal" +since we need control over the chunk size. +-} +module Synthesizer.Storable.Filter.Recursive.Comb where + +import qualified Synthesizer.Storable.Signal as Sig +import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1 + +import qualified Synthesizer.Generic.Signal as SigG +import qualified Synthesizer.Generic.SampledValue as Sample + +-- import qualified Synthesizer.Storable.Filter.Delay as Delay + +import Foreign.Storable (Storable) + +import qualified Algebra.Module as Module +-- import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import Algebra.Module((*>)) + +import qualified Prelude as P +import PreludeBase +import NumericPrelude + + +{- | +The most simple version of the Karplus-Strong algorithm +which is suitable to simulate a plucked string. +It is similar to the 'runProc' function. +-} +{-# INLINE karplusStrong #-} +karplusStrong :: + (Ring.C a, Module.C a v, Sample.C v) => + Filt1.Parameter a -> Sig.T v -> Sig.T v +karplusStrong c wave = + Sig.delayLoop (SigG.modifyStatic Filt1.lowpassModifier c) wave + + +{- | +Infinitely many equi-delayed exponentially decaying echos. +The echos are clipped to the input length. +We think it is easier (and simpler to do efficiently) +to pad the input with zeros or whatever +instead of cutting the result according to the input length. +-} +{-# INLINE run #-} +run :: (Module.C a v, Storable v) => + Int -> a -> Sig.T v -> Sig.T v +run time gain = + Sig.delayLoopOverlap time (amplify gain) + +{- | +Echos of different delays. +Chunk size must be smaller than all of the delay times. +-} +{-# INLINE runMulti #-} +runMulti :: (Ring.C a, Module.C a v, Storable v) => + [Int] -> a -> Sig.T v -> Sig.T v +runMulti times gain x = + let y = foldl + (Sig.zipWith (+)) x + (map (flip (Sig.delay Sig.defaultChunkSize zero) (amplify gain y)) times) +-- (map (flip Delay.staticPos (gain *> y)) times) + in y + +{- | Echos can be piped through an arbitrary signal processor. -} +{-# INLINE runProc #-} +runProc :: (Additive.C v, Storable v) => + Int -> (Sig.T v -> Sig.T v) -> Sig.T v -> Sig.T v +runProc = Sig.delayLoopOverlap + + +{-# INLINE amplify #-} +amplify :: (Storable v, Module.C a v) => + a -> Sig.T v -> Sig.T v +amplify gain = Sig.map (gain *>) 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 @@ +{-# OPTIONS_GHC -O2 -fno-implicit-prelude #-} +{- | +Copyright : (c) Henning Thielemann 2006 +License : GPL + +Maintainer : synthesizer@henning-thielemann.de +Stability : provisional +Portability : requires multi-parameter type classes + +Tone generators +-} +module Synthesizer.Storable.Oscillator where + +import qualified Synthesizer.Basic.Wave as Wave +import qualified Synthesizer.Basic.Phase as Phase + +import qualified Synthesizer.Storable.Signal as Signal +import Synthesizer.Storable.Signal (ChunkSize) +import Foreign.Storable (Storable) + +-- import qualified Synthesizer.Plain.Interpolation as Interpolation + +{- +import qualified Algebra.RealTranscendental as RealTrans +import qualified Algebra.Module as Module +import qualified Algebra.VectorSpace as VectorSpace + +import Algebra.Module((*>)) +-} +import qualified Algebra.Transcendental as Trans +import qualified Algebra.RealField as RealField +-- import qualified Algebra.Field as Field +-- import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + +import NumericPrelude + +import qualified Prelude as P +import PreludeBase + + + +{- * Oscillators with arbitrary but constant waveforms -} + +{-# INLINE freqToPhase #-} +{- | Convert a list of phase steps into a list of momentum phases + phase is a number in the interval [0,1) + freq contains the phase steps -} +freqToPhase :: (RealField.C a, Storable a) => + Phase.T a -> Signal.T a -> Signal.T (Phase.T a) +freqToPhase phase freq = Signal.scanL (flip Phase.increment) phase freq + + +{-# INLINE static #-} +{-# SPECULATE static :: Storable b => ChunkSize -> (Double -> b) -> (Double -> Double -> Signal.T b) #-} +{- | oscillator with constant frequency -} +static :: (RealField.C a, Storable a, Storable b) => + ChunkSize -> Wave.T a b -> (Phase.T a -> a -> Signal.T b) +static size wave phase freq = + Signal.map (Wave.apply wave) (Signal.iterate size (Phase.increment freq) phase) + +{- | oscillator with modulated phase -} +phaseMod :: (RealField.C a, Storable a, Storable b) => + ChunkSize -> Wave.T a b -> a -> Signal.T a -> Signal.T b +phaseMod size wave = shapeMod size (Wave.phaseOffset wave) zero + +{-# ONLINE shapeMod #-} +{- | oscillator with modulated shape -} +shapeMod :: (RealField.C a, Storable a, Storable b, Storable c) => + ChunkSize -> (c -> Wave.T a b) -> Phase.T a -> a -> Signal.T c -> Signal.T b +shapeMod size wave phase freq parameters = + Signal.zipWith (Wave.apply . wave) parameters + (Signal.iterate size (Phase.increment freq) phase) + +{- | oscillator with modulated frequency -} +freqMod :: (RealField.C a, Storable a, Storable b) => + ChunkSize -> Wave.T a b -> Phase.T a -> Signal.T a -> Signal.T b +freqMod _size wave phase freqs = + Signal.map (Wave.apply wave) (freqToPhase phase freqs) + +{- | oscillator with both phase and frequency modulation -} +phaseFreqMod :: (RealField.C a, Storable a, Storable b) => + ChunkSize -> Wave.T a b -> Signal.T a -> Signal.T a -> Signal.T b +phaseFreqMod size wave = + shapeFreqMod size (Wave.phaseOffset wave) zero + +{- | oscillator with both shape and frequency modulation -} +shapeFreqMod :: (RealField.C a, Storable a, Storable b, Storable c) => + ChunkSize -> (c -> Wave.T a b) -> + Phase.T a -> Signal.T c -> Signal.T a -> Signal.T b +shapeFreqMod _size wave phase parameters freqs = + Signal.zipWith (Wave.apply . wave) parameters (freqToPhase phase freqs) + + +{- +{- | oscillator with a sampled waveform with constant frequency + This essentially an interpolation with cyclic padding. -} +staticSample :: RealField.C a => Interpolation.T a b -> Signal.T b -> a -> a -> Signal.T b +staticSample ip wave phase freq = + freqModSample ip wave phase (repeat freq) + +{- | oscillator with a sampled waveform with modulated frequency + Should behave homogenously for different types of interpolation. -} +freqModSample :: RealField.C a => Interpolation.T a b -> Signal.T b -> a -> Signal.T a -> Signal.T b +freqModSample ip wave phase freqs = + let len = fromIntegral (length wave) + in Interpolation.multiRelativeCyclicPad + ip (phase*len) (Signal.map (*len) freqs) wave +-} + + + +{- * Oscillators with specific waveforms -} + +{-# INLINE staticSine #-} +{-# SPECULATE staticSine :: ChunkSize -> Double -> Double -> Signal.T Double #-} +{- | sine oscillator with static frequency -} +staticSine :: (Trans.C a, RealField.C a, Storable a) => + ChunkSize -> Phase.T a -> a -> Signal.T a +staticSine size = static size Wave.sine + +{-# INLINE freqModSine #-} +{-# SPECULATE freqModSine :: ChunkSize -> Double -> Signal.T Double -> Signal.T Double #-} +{- | sine oscillator with modulated frequency -} +freqModSine :: (Trans.C a, RealField.C a, Storable a) => + ChunkSize -> Phase.T a -> Signal.T a -> Signal.T a +freqModSine size = freqMod size Wave.sine + +{-# INLINE phaseModSine #-} +{-# SPECULATE phaseModSine :: ChunkSize -> Double -> Signal.T Double -> Signal.T Double #-} +{- | sine oscillator with modulated phase, useful for FM synthesis -} +phaseModSine :: (Trans.C a, RealField.C a, Storable a) => + ChunkSize -> a -> Signal.T a -> Signal.T a +phaseModSine size = phaseMod size Wave.sine + +{-# INLINE staticSaw #-} +{-# SPECULATE staticSaw :: ChunkSize -> Double -> Double -> Signal.T Double #-} +{- | saw tooth oscillator with modulated frequency -} +staticSaw :: (RealField.C a, Storable a) => + ChunkSize -> Phase.T a -> a -> Signal.T a +staticSaw size = static size Wave.saw + +{-# INLINE freqModSaw #-} +{-# SPECULATE freqModSaw :: ChunkSize -> Double -> Signal.T Double -> Signal.T Double #-} +{- | saw tooth oscillator with modulated frequency -} +freqModSaw :: (RealField.C a, Storable a) => + ChunkSize -> Phase.T a -> Signal.T a -> Signal.T a +freqModSaw size = freqMod size Wave.saw + + +{- Test whether Fusion takes place. +For the following code the simplifier can't resist! + +testLength :: (Storable a, Enum a) => a -> Int +testLength x = + Signal.length (Signal.map succ (Signal.fromList (Signal.ChunkSize 100) [x,x,x])) +-} 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,1318 @@ +{- OPTIONS_GHC -O2 -fglasgow-exts -} +{- glasgow-exts are for the rules -} +{- | +Chunky signal stream build on StorableVector. + +Hints for fusion: + - Higher order functions should always be inlined in the end + in order to turn them into machine loops + instead of calling a function in an inner loop. +-} +module Synthesizer.Storable.Signal ( + T, + Vector.hPut, + ChunkSize, Vector.chunkSize, defaultChunkSize, + -- for Storable.Oscillator + scanL, + Vector.map, + Vector.iterate, + Vector.zipWith, + -- for State.Signal + Vector.span, + Vector.append, + Vector.concat, + Vector.span, + Vector.splitAt, + Vector.viewL, + Vector.viewR, + Vector.switchL, + Vector.unfoldr, + Vector.reverse, + -- for Dimensional.File + Vector.writeFile, + -- for Storable.Cut + splitAtPad, + -- for Storable.Filter.Comb + delay, + delayLoop, + delayLoopOverlap, + -- for FusionTest + mix, mixSize, + Vector.empty, + Vector.replicate, + Vector.repeat, + Vector.drop, + Vector.take, + takeCrochet, + fromList, + appendFromFusionList, + appendFusionList, + ) where + +-- import qualified Sound.Signal as Signal + +import qualified Synthesizer.Generic.Signal as SigG +import qualified Synthesizer.FusionList.Signal as FList + +import qualified Data.List as List +import qualified Data.StorableVector.Lazy as Vector +import qualified Data.StorableVector as V +import Data.StorableVector.Lazy (ChunkSize(..)) + +import Data.Maybe (Maybe(Just,Nothing), maybe, fromMaybe) +-- import qualified Data.Char as Char +-- import Data.Int (Int8) + +import Data.StorableVector(Vector) +import Foreign.Storable (Storable) +import Foreign.Ptr (minusPtr) +import Foreign.ForeignPtr (withForeignPtr) +import Foreign.Marshal (advancePtr) +import StorableInstance () + +-- import qualified Synthesizer.Format as Format + +-- import Control.Arrow ((***)) +import Control.Monad (liftM, liftM2, {- guard, -} ) + +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive +import qualified Algebra.ToInteger as ToInteger + +import qualified Number.NonNegativeChunky as Chunky +import qualified Number.NonNegative as NonNeg + +import NumericPrelude.Condition (toMaybe) +import NumericPrelude.List (sliceVert, dropWhileRev, ) + +import Synthesizer.Utility (viewListL, viewListR, nest, mapFst, mapSnd, mapPair) + +-- import qualified Algebra.Additive as Additive + + +import System.IO (openBinaryFile, hClose, hPutBuf, IOMode(WriteMode), Handle) +import Control.Exception (bracket) + + +import NumericPrelude + (sum, (+), (-), divMod, fromIntegral, fromInteger, toInteger, isZero, zero, ) + +{- +import Prelude hiding + (length, (++), iterate, foldl, map, repeat, replicate, null, + zip, zipWith, zipWith3, drop, take, splitAt, takeWhile, reverse) +-} + +import qualified Prelude as P +import Prelude + (IO, ($), (.), fst, snd, id, + Int, Double, Float, + Char, Num, Show, showsPrec, FilePath, + Bool(True,False), not, + flip, curry, uncurry, + Ord, (<), (>), (<=), {- (>=), (==), -} min, max, + mapM_, fmap, (=<<), return, + Enum, succ, pred, ) + + +-- this form is needed for Storable signal embed in amplitude signal +type T = Vector.Vector +-- type T a = Vector.Vector a + +instance (Show a, Storable a) => Show (Vector.Vector a) where + showsPrec p = showsPrec p . Vector.unpack + +{- +instance (Storable a) => Format.C T where + format = showsPrec +-} + + +defaultChunkSize :: ChunkSize +defaultChunkSize = ChunkSize 1024 + +instance SigG.C Vector.Vector where + {-# INLINE empty #-} + empty = Vector.empty + {-# INLINE null #-} + null = Vector.null + {-# INLINE cons #-} + cons = Vector.cons + {-# INLINE fromList #-} + fromList = Vector.pack defaultChunkSize + {-# INLINE toList #-} + toList = Vector.unpack + {-# INLINE repeat #-} + repeat = Vector.repeat defaultChunkSize + {-# INLINE cycle #-} + cycle = Vector.cycle + {-# INLINE replicate #-} + replicate = Vector.replicate defaultChunkSize + {-# INLINE iterate #-} + iterate = Vector.iterate defaultChunkSize + {-# INLINE iterateAssoc #-} + iterateAssoc op x = Vector.iterate defaultChunkSize (op x) x -- should be optimized + {-# INLINE unfoldR #-} + unfoldR = Vector.unfoldr defaultChunkSize + {-# INLINE map #-} + map = Vector.map + {-# INLINE mix #-} + mix = mix + {-# INLINE zipWith #-} + zipWith = Vector.zipWith + {-# INLINE scanL #-} + scanL = Vector.scanl + {-# INLINE viewL #-} + viewL = Vector.viewL + {-# INLINE viewR #-} + viewR = Vector.viewR + {-# INLINE foldL #-} + foldL = Vector.foldl + {-# INLINE length #-} + length = Vector.length + {-# INLINE take #-} + take = Vector.take + {-# INLINE drop #-} + drop = Vector.drop + {-# INLINE splitAt #-} + splitAt = Vector.splitAt + {-# INLINE dropMarginRem #-} + dropMarginRem = Vector.dropMarginRem -- can occur in an inner loop in Interpolation + {-# INLINE takeWhile #-} + takeWhile = Vector.takeWhile + {-# INLINE dropWhile #-} + dropWhile = Vector.dropWhile + {-# INLINE span #-} + span = Vector.span + {-# INLINE append #-} + append = Vector.append + {-# INLINE concat #-} + concat = Vector.concat + {-# INLINE reverse #-} + reverse = Vector.reverse +{- + {-# INLINE mapAccumL #-} + mapAccumL = Vector.mapAccumL + {-# INLINE mapAccumR #-} + mapAccumR = Vector.mapAccumR +-} + {-# INLINE crochetL #-} + crochetL = Vector.crochetL + + +{- +{- * Helper functions for StorableVector -} + +cancelNullVector :: (Vector a, b) -> Maybe (Vector a, b) +cancelNullVector y = + toMaybe (not (Vector.null (fst y))) y + +viewLVector :: Storable a => + Vector a -> Maybe (a, Vector a) +viewLVector = Vector.viewL +{- + toMaybe + (not (Vector.null x)) + (Vector.head x, Vector.tail x) +-} + +crochetLVector :: (Storable x, Storable y) => + (x -> acc -> Maybe (y, acc)) + -> acc + -> Vector x + -> (Vector y, Maybe acc) +crochetLVector f acc0 x0 = + mapSnd (fmap fst) $ + Vector.unfoldrN + (Vector.length x0) + (\(acc,xt) -> + do (x,xs) <- viewLVector xt + (y,acc') <- f x acc + return (y, (acc',xs))) + (acc0, x0) + +reduceLVector :: Storable x => + (x -> acc -> Maybe acc) -> acc -> Vector x -> (acc, Bool) +reduceLVector f acc0 x = + let recurse i acc = + if i < Vector.length x + then (acc, True) + else + maybe + (acc, False) + (recurse (succ i)) + (f (Vector.index x i) acc) + in recurse 0 acc0 + + + + +{- * Fundamental functions -} + +{- | +Sophisticated implementation where chunks always have size bigger than 0. +-} +{-# INLINE [0] unfoldr #-} +unfoldr :: (Storable b) => + ChunkSize + -> (a -> Maybe (b,a)) + -> a + -> T b +unfoldr (ChunkSize size) f = + Cons . + List.unfoldr + (cancelNullVector . Vector.unfoldrN size f =<<) . + Just + +{- | +Simple implementation where chunks can have size 0 in the first run. +Then they are filtered out. +This separation might reduce laziness. +-} +unfoldr0 :: (Storable b) => + ChunkSize + -> (a -> Maybe (b,a)) + -> a + -> T b +unfoldr0 (ChunkSize size) f = + Cons . + List.filter (not . Vector.null) . + List.unfoldr (fmap (Vector.unfoldrN size f)) . + Just + + +unfoldr1 :: (Storable b) => + ChunkSize + -> (a -> (b, Maybe a)) + -> Maybe a + -> T b +unfoldr1 size f = unfoldr size (liftM f) + +{-# INLINE [0] crochetL #-} +crochetL :: (Storable x, Storable y) => + (x -> acc -> Maybe (y, acc)) + -> acc + -> T x + -> T y +crochetL f acc0 = + Cons . List.unfoldr (\(xt,acc) -> + do (x,xs) <- viewListL xt + acc' <- acc + return $ mapSnd ((,) xs) $ crochetLVector f acc' x) . + flip (,) (Just acc0) . + decons + +{- +Usage of 'unfoldr' seems to be clumsy but that covers all cases, +like different block sizes in source and destination list. +-} +crochetLSize :: (Storable x, Storable y) => + ChunkSize + -> (x -> acc -> Maybe (y, acc)) + -> acc + -> T x + -> T y +crochetLSize size f = + curry (unfoldr size (\(acc,xt) -> + do (x,xs) <- viewL xt + (y,acc') <- f x acc + return (y, (acc',xs)))) + +viewL :: Storable a => T a -> Maybe (a, T a) +viewL (Cons xs0) = + -- dropWhile would be unnecessary if we require that all chunks are non-empty + do (x,xs) <- viewListL (List.dropWhile Vector.null xs0) + (y,ys) <- viewLVector x + return (y, append (fromChunk ys) (Cons xs)) + +viewR :: Storable a => T a -> Maybe (T a, a) +viewR (Cons xs0) = + -- dropWhile would be unnecessary if we require that all chunks are non-empty + do (xs,x) <- viewListR (dropWhileRev Vector.null xs0) + (ys,y) <- Vector.viewR x + return (append (Cons xs) (fromChunk ys), y) + +crochetListL :: (Storable y) => + ChunkSize + -> (x -> acc -> Maybe (y, acc)) + -> acc + -> [x] + -> T y +crochetListL size f = + curry (unfoldr size (\(acc,xt) -> + do (x,xs) <- viewListL xt + (y,acc') <- f x acc + return (y, (acc',xs)))) +-} + + +{-# INLINE fromList #-} +fromList :: (Storable a) => ChunkSize -> [a] -> T a +fromList = Vector.pack + + +{- +-- should start fusion +fromListCrochetL :: (Storable a) => ChunkSize -> [a] -> T a +fromListCrochetL size = + crochetListL size (\x _ -> Just (x, ())) () + +fromListUnfoldr :: (Storable a) => ChunkSize -> [a] -> T a +fromListUnfoldr size = unfoldr size viewListL + +fromListPack :: (Storable a) => ChunkSize -> [a] -> T a +fromListPack (ChunkSize size) = + Cons . + List.map Vector.pack . + sliceVert size + +toList :: (Storable a) => T a -> [a] +toList = List.concatMap Vector.unpack . decons + +-- if the chunk has length zero, an empty sequence is generated +fromChunk :: (Storable a) => Vector a -> T a +fromChunk x = + if Vector.null x + then empty + else Cons [x] + + + + +{-# NOINLINE [0] crochetFusionListL #-} +crochetFusionListL :: (Storable y) => + ChunkSize + -> (x -> acc -> Maybe (y, acc)) + -> acc + -> FList.T x + -> T y +crochetFusionListL size f = + curry (unfoldr size (\(acc,xt) -> + do (x,xs) <- FList.viewL xt + (y,acc') <- f x acc + return (y, (acc',xs)))) +-} + +{-# NOINLINE [0] fromFusionList #-} +fromFusionList :: (Storable a) => ChunkSize -> FList.T a -> T a +fromFusionList size = fromList size . FList.toList + -- fromFusionListCrochetL + +{- +{-# INLINE fromFusionListCrochetL #-} +fromFusionListCrochetL :: (Storable a) => ChunkSize -> FList.T a -> T a +fromFusionListCrochetL size = + crochetFusionListL size (\x _ -> Just (x, ())) () + +fromFusionListUnfoldr :: (Storable a) => ChunkSize -> FList.T a -> T a +fromFusionListUnfoldr size = + unfoldr size FList.viewL + + +{-# NOINLINE [0] toFusionList #-} +toFusionList :: (Storable a) => T a -> FList.T a +toFusionList = FList.Cons . List.concatMap Vector.unpack . decons + + +{- | +Converts from and to 'FList.T' +in order to speedup computation, +especially because it tells the optimizer about the 'Storable' constraint +and thus allows for more fusion, +where fusion would break otherwise. +-} +{-# INLINE chop #-} +chop :: (Storable a) => ChunkSize -> FList.T a -> FList.T a +chop size = toFusionList . fromFusionList size + + + +{-# INLINE [0] reduceL #-} +reduceL :: Storable x => + (x -> acc -> Maybe acc) -> acc -> T x -> acc +reduceL f acc0 = + let recurse acc xt = + case xt of + [] -> acc + (x:xs) -> + let (acc',continue) = reduceLVector f acc x + in if continue + then recurse acc' xs + else acc' + in recurse acc0 . decons + + + +{- * Basic functions -} + +empty :: Storable a => T a +empty = Cons [] + +null :: Storable a => T a -> Bool +null = List.null . decons + + +{-# NOINLINE [0] cons #-} +cons :: Storable a => a -> T a -> T a +cons x = Cons . (Vector.singleton x :) . decons + + +length :: T a -> Int +length = sum . List.map Vector.length . decons + + +reverse :: Storable a => T a -> T a +reverse = + Cons . List.reverse . List.map Vector.reverse . decons + + +{-# INLINE [0] foldl #-} +foldl :: Storable b => (a -> b -> a) -> a -> T b -> a +foldl f x0 = List.foldl (Vector.foldl f) x0 . decons + + +{-# INLINE [0] map #-} +map :: (Storable x, Storable y) => + (x -> y) + -> T x + -> T y +map f = mapInline f -- Cons . List.map (Vector.map f) . decons + +{-# INLINE mapInline #-} +mapInline :: (Storable x, Storable y) => + (x -> y) + -> T x + -> T y +mapInline f = + let mapVec = Vector.map f + in Cons . List.map mapVec . decons + + + +{-# NOINLINE [0] drop #-} +drop :: (Storable a) => Int -> T a -> T a +drop _ (Cons []) = empty +drop n (Cons (x:xs)) = + let m = Vector.length x + in if m<=n + then drop (n-m) (Cons xs) + else Cons (Vector.drop n x : xs) + +{-# NOINLINE [0] take #-} +take :: (Storable a) => Int -> T a -> T a +take _ (Cons []) = empty +take 0 _ = empty +take n (Cons (x:xs)) = + let m = Vector.length x + in if m<=n + then Cons $ (x:) $ decons $ take (n-m) $ Cons xs + else fromChunk (Vector.take n x) + + + +{-# NOINLINE [0] splitAt #-} +splitAt :: (Storable a) => Int -> T a -> (T a, T a) +splitAt n0 = + let recurse _ [] = ([], []) + recurse 0 xs = ([], xs) + recurse n (x:xs) = + let m = Vector.length x + in if m<=n + then mapFst (x:) $ recurse (n-m) xs + else mapPair ((:[]), (:xs)) $ Vector.splitAt n x + in mapPair (Cons, Cons) . recurse n0 . decons + + +dropMarginRem :: (Storable a) => Int -> Int -> T a -> (Int, T a) +dropMarginRem n m xs = + List.foldl' + (\(mi,xsi) k -> (mi-k, drop k xsi)) + (m,xs) + (List.map Vector.length $ decons $ take m $ drop n xs) + +{- +This implementation does only walk once through the dropped prefix. +It is maximally lazy and minimally space consuming. +-} +dropMargin :: (Storable a) => Int -> Int -> T a -> T a +dropMargin n m xs = + List.foldl' (flip drop) xs + (List.map Vector.length $ decons $ take m $ drop n xs) + + +{-# NOINLINE [0] dropWhile #-} +dropWhile :: (Storable a) => (a -> Bool) -> T a -> T a +dropWhile _ (Cons []) = empty +dropWhile p (Cons (x:xs)) = + let y = Vector.dropWhile p x + in if Vector.null y + then dropWhile p (Cons xs) + else Cons (y:xs) + +{-# NOINLINE [0] takeWhile #-} +takeWhile :: (Storable a) => (a -> Bool) -> T a -> T a +takeWhile _ (Cons []) = empty +takeWhile p (Cons (x:xs)) = + let y = Vector.takeWhile p x + in if Vector.length y < Vector.length x + then fromChunk y + else Cons (x : decons (takeWhile p (Cons xs))) + + +{-# NOINLINE [0] span #-} +span :: (Storable a) => (a -> Bool) -> T a -> (T a, T a) +span p = + let recurse [] = ([],[]) + recurse (x:xs) = + let (y,z) = Vector.span p x + in if Vector.null z + then mapFst (x:) (recurse xs) + else (decons $ fromChunk y, (z:xs)) + in mapPair (Cons, Cons) . recurse . decons +{- +span _ (Cons []) = (empty, empty) +span p (Cons (x:xs)) = + let (y,z) = Vector.span p x + in if Vector.length y == 0 + then mapFst (Cons . (x:) . decons) (span p (Cons xs)) + else (Cons [y], Cons (z:xs)) +-} + +concat :: (Storable a) => [T a] -> T a +concat = Cons . List.concat . List.map decons + + +{- | +Ensure a minimal length of the list by appending pad values. +-} +{-# NOINLINE [0] pad #-} +pad :: (Storable a) => ChunkSize -> a -> Int -> T a -> T a +pad size y n0 = + let recurse n xt = + if n<=0 + then xt + else + case xt of + [] -> decons $ replicate size n y + x:xs -> x : recurse (n - Vector.length x) xs + in Cons . recurse n0 . decons + +padAlt :: (Storable a) => ChunkSize -> a -> Int -> T a -> T a +padAlt size x n xs = + append xs + (let m = length xs + in if n>m + then replicate size (n-m) x + else empty) + + +infixr 5 `append` + +{-# NOINLINE [0] append #-} +append :: T a -> T a -> T a +append (Cons xs) (Cons ys) = Cons (xs List.++ ys) +-} + +{-# INLINE appendFromFusionList #-} +appendFromFusionList :: Storable a => + ChunkSize -> FList.T a -> FList.T a -> T a +appendFromFusionList size xs ys = + Vector.append (FList.toStorableSignal size xs) (FList.toStorableSignal size ys) + +{- | +Like 'appendFromFusionList' but returns a 'FList.T' +for more flexible following processing. +-} +{-# INLINE appendFusionList #-} +appendFusionList :: Storable a => + ChunkSize -> FList.T a -> FList.T a -> FList.T a +appendFusionList size xs ys = + FList.fromStorableSignal (appendFromFusionList size xs ys) + + +{- +{-# INLINE iterate #-} +iterate :: Storable a => ChunkSize -> (a -> a) -> a -> T a +iterate size f = unfoldr size (\x -> Just (x, f x)) + +repeat :: Storable a => ChunkSize -> a -> T a +repeat (ChunkSize size) = + Cons . List.repeat . Vector.replicate size + +cycle :: Storable a => T a -> T a +cycle = + Cons . List.cycle . decons + +replicate :: Storable a => ChunkSize -> Int -> a -> T a +replicate (ChunkSize size) n x = + let (numChunks, rest) = divMod n size + in append + (Cons (List.replicate numChunks (Vector.replicate size x))) + (fromChunk (Vector.replicate rest x)) +-} + +{-# INLINE scanL #-} +scanL :: (Storable a, Storable b) => + (a -> b -> a) -> a -> T b -> T a +scanL = Vector.scanl + + +{- +{-# INLINE [0] mapAccumL #-} +mapAccumL :: (Storable a, Storable b) => + (acc -> a -> (acc, b)) -> acc -> T a -> (acc, T b) +mapAccumL f start = + mapSnd Cons . + List.mapAccumL (Vector.mapAccumL f) start . + decons + +{-# INLINE [0] mapAccumR #-} +mapAccumR :: (Storable a, Storable b) => + (acc -> a -> (acc, b)) -> acc -> T a -> (acc, T b) +mapAccumR f start = + mapSnd Cons . + List.mapAccumR (Vector.mapAccumR f) start . + decons + +{-# RULEZ + "Storable.append/repeat/repeat" forall size x. + append (repeat size x) (repeat size x) = repeat size x ; + + "Storable.append/repeat/replicate" forall size n x. + append (repeat size x) (replicate size n x) = repeat size x ; + + "Storable.append/replicate/repeat" forall size n x. + append (replicate size n x) (repeat size x) = repeat size x ; + + "Storable.append/replicate/replicate" forall size n m x. + append (replicate size n x) (replicate size m x) = + replicate size (n+m) x ; + + "Storable.mix/repeat/repeat" forall size x y. + mix (repeat size x) (repeat size y) = repeat size (x+y) ; + + #-} + +{-# RULES + "Storable.length/cons" forall x xs. + length (cons x xs) = 1 + length xs ; + + "Storable.length/map" forall f xs. + length (map f xs) = length xs ; + + "Storable.map/cons" forall f x xs. + map f (cons x xs) = cons (f x) (map f xs) ; + + "Storable.map/repeat" forall size f x. + map f (repeat size x) = repeat size (f x) ; + + "Storable.map/replicate" forall size f x n. + map f (replicate size n x) = replicate size n (f x) ; + + "Storable.map/repeat" forall size f x. + map f (repeat size x) = repeat size (f x) ; + + {- + This can make things worse, if 'map' is applied to replicate, + since this can use of sharing. + It can also destroy the more important map/unfoldr fusion in + take n . map f . unfoldr g + + "Storable.take/map" forall n f x. + take n (map f x) = map f (take n x) ; + -} + + "Storable.take/repeat" forall size n x. + take n (repeat size x) = replicate size n x ; + + "Storable.take/take" forall n m xs. + take n (take m xs) = take (min n m) xs ; + + "Storable.drop/drop" forall n m xs. + drop n (drop m xs) = drop (n+m) xs ; + + "Storable.drop/take" forall n m xs. + drop n (take m xs) = take (max 0 (m-n)) (drop n xs) ; + + "Storable.map/mapAccumL/snd" forall g f acc0 xs. + map g (snd (mapAccumL f acc0 xs)) = + snd (mapAccumL (\acc a -> mapSnd g (f acc a)) acc0 xs) ; + + #-} + +{- GHC says this is an orphaned rule + "Storable.map/mapAccumL/mapSnd" forall g f acc0 xs. + mapSnd (map g) (mapAccumL f acc0 xs) = + mapAccumL (\acc a -> mapSnd g (f acc a)) acc0 xs ; +-} +-} + +{-# SPECULATE mix :: T Double -> T Double -> T Double #-} +{-# SPECULATE mix :: T Float -> T Float -> T Float #-} +{-# SPECULATE mix :: T (Double,Double) -> T (Double,Double) -> T (Double,Double) #-} +{-# SPECULATE mix :: T (Float,Float) -> T (Float,Float) -> T (Float,Float) #-} +{-# INLINE mix #-} +{- +'mix' is more efficient +since it appends the rest of the longer signal without copying. +It also preserves the chunk structure of the second signal, +which is essential if you want to limit look-ahead. +-} +mix :: (Additive.C x, Storable x) => + T x + -> T x + -> T x +mix xs ys = + let len = min (lazyLength xs) (lazyLength ys) :: Chunky.T NonNeg.Int + (prefixX,suffixX) = genericSplitAt len xs + (prefixY,suffixY) = genericSplitAt len ys + in Vector.append + (Vector.crochetL + (\y xs0 -> + fmap (mapFst (y+)) (Vector.viewL xs0)) + prefixX prefixY) + (if Vector.null suffixX + then suffixY + else suffixX) +{- +List.map V.unpack $ Vector.chunks $ mix (fromList defaultChunkSize [1,2,3,4,5::P.Double]) (fromList defaultChunkSize [1,2,3,4]) +-} + + +{- +We should move that to StorableVector package, +but we cannot, since that's Haskell 98. +-} +genericSplitAt :: + (Additive.C i, Ord i, ToInteger.C i, Storable x) => + i -> T x -> (T x, T x) +genericSplitAt n0 = + let recurse n xs0 = + maybe + ([], []) + (\(x,xs) -> + if isZero n + then ([], xs0) + else + let m = fromIntegral $ V.length x + in if m<=n + then mapFst (x:) $ recurse (n-m) xs + else mapPair ((:[]), (:xs)) $ + V.splitAt (fromInteger $ toInteger n) x) + $ viewListL xs0 + in mapPair (Vector.SV, Vector.SV) . recurse n0 . Vector.chunks + + +lazyLength :: (Ring.C i) => + T x -> i +lazyLength = + List.foldr (+) zero . List.map (fromIntegral . V.length) . Vector.chunks + +genericLength :: (Ring.C i) => + T x -> i +genericLength = + sum . List.map (fromIntegral . V.length) . Vector.chunks + + +splitAtPad :: + (Additive.C x, Storable x) => + ChunkSize -> Int -> T x -> (T x, T x) +splitAtPad size n = + mapFst (Vector.pad size Additive.zero n) . Vector.splitAt n + + +{-# SPECULATE mixSize :: ChunkSize -> T Double -> T Double -> T Double #-} +{-# SPECULATE mixSize :: ChunkSize -> T Float -> T Float -> T Float #-} +{-# SPECULATE mixSize :: ChunkSize -> T (Double,Double) -> T (Double,Double) -> T (Double,Double) #-} +{-# SPECULATE mixSize :: ChunkSize -> T (Float,Float) -> T (Float,Float) -> T (Float,Float) #-} +{-# INLINE mixSize #-} +mixSize :: (Additive.C x, Storable x) => + ChunkSize + -> T x + -> T x + -> T x +mixSize size = + curry (Vector.unfoldr size mixStep) + + +{-# INLINE mixStep #-} +mixStep :: (Additive.C x, Storable x) => + (T x, T x) -> + Maybe (x, (T x, T x)) +mixStep (xt,yt) = + case (Vector.viewL xt, Vector.viewL yt) of + (Just (x,xs), Just (y,ys)) -> Just (x+y, (xs,ys)) + (Nothing, Just (y,ys)) -> Just (y, (xt,ys)) + (Just (x,xs), Nothing) -> Just (x, (xs,yt)) + (Nothing, Nothing) -> Nothing + + + +{-# INLINE delay #-} +delay :: (Storable y) => + ChunkSize -> y -> Int -> T y -> T y +delay size z n = Vector.append (Vector.replicate size n z) + +{-# INLINE delayLoop #-} +delayLoop :: + (Storable y) => + (T y -> T y) + -- ^ processor that shall be run in a feedback loop + -> T y -- ^ prefix of the output, its length determines the delay + -> T y +delayLoop proc prefix = + let ys = Vector.append prefix (proc ys) + in ys + + +{-# INLINE delayLoopOverlap #-} +delayLoopOverlap :: + (Additive.C y, Storable y) => + Int + -> (T y -> T y) + {- ^ Processor that shall be run in a feedback loop. + It's absolutely necessary that this function preserves the chunk structure + and that it does not look a chunk ahead. + That's guaranteed for processes that do not look ahead at all, + like 'Vector.map', 'Vector.crochetL' and the like. -} + -> T y -- ^ input + -> T y -- ^ output has the same length as the input +delayLoopOverlap time proc xs = + let ys = Vector.zipWith (Additive.+) xs + (delay (Vector.chunkSize time) Additive.zero time (proc ys)) + in ys + + + +{- +{-# INLINE zip #-} +zip :: (Storable a, Storable b) => + ChunkSize -> (T a -> T b -> T (a,b)) +zip size = zipWith size (,) + +{-# INLINE zipWith3 #-} +zipWith3 :: (Storable a, Storable b, Storable c, Storable d) => + ChunkSize -> (a -> b -> c -> d) -> (T a -> T b -> T c -> T d) +zipWith3 size f s0 s1 = + zipWith size (uncurry f) (zip size s0 s1) + +{-# INLINE zipWith4 #-} +zipWith4 :: (Storable a, Storable b, Storable c, Storable d, Storable e) => + ChunkSize -> (a -> b -> c -> d -> e) -> (T a -> T b -> T c -> T d -> T e) +zipWith4 size f s0 s1 = + zipWith3 size (uncurry f) (zip size s0 s1) + + +{- * Fusable functions -} + +{-# INLINE [0] zipWith #-} +zipWith :: (Storable x, Storable y, Storable z) => + ChunkSize + -> (x -> y -> z) + -> T x + -> T y + -> T z +zipWith size f = + curry (unfoldr size (\(xt,yt) -> + liftM2 + (\(x,xs) (y,ys) -> (f x y, (xs,ys))) + (viewL xt) + (viewL yt))) + + + +scanLCrochet :: (Storable a, Storable b) => + (a -> b -> a) -> a -> T b -> T a +scanLCrochet f start = + cons start . + crochetL (\x acc -> let y = f acc x in Just (y, y)) start + +{-# INLINE mapCrochet #-} +mapCrochet :: (Storable a, Storable b) => (a -> b) -> (T a -> T b) +mapCrochet f = crochetL (\x _ -> Just (f x, ())) () +-} + +{-# INLINE takeCrochet #-} +takeCrochet :: Storable a => Int -> T a -> T a +takeCrochet = Vector.crochetL (\x n -> toMaybe (n>0) (x, pred n)) + +{- +{-# INLINE repeatUnfoldr #-} +repeatUnfoldr :: Storable a => ChunkSize -> a -> T a +repeatUnfoldr size = iterate size id + +{-# INLINE replicateCrochet #-} +replicateCrochet :: Storable a => ChunkSize -> Int -> a -> T a +replicateCrochet size n = takeCrochet n . repeat size + + + +{- +crochetFusionListLGenerate size g b f a = + unfoldr size (\(a0,b0) -> + do (y0,a1) <- f a0 + (z0,b1) <- g y0 b0 + Just (z0, (a1,b1))) (a,b) ; + +-} + + +{-# RULES + "Storable.crochetFusionListL/crochetL" forall size f g a b x. + crochetFusionListL size g b (FList.crochetL f a x) = + crochetFusionListL size (\x0 (a0,b0) -> + do (y0,a1) <- f x0 a0 + (z0,b1) <- g y0 b0 + Just (z0, (a1,b1))) (a,b) x ; + + "Storable.crochetFusionListL/generate" forall size f g a b. + crochetFusionListL size g b (FList.generate f a) = + unfoldr size (\(a0,b0) -> + do (y0,a1) <- f a0 + (z0,b1) <- g y0 b0 + Just (z0, (a1,b1))) (a,b) ; + +{- + "Storable.fromFusionList/crochetL" + forall size f a (x :: Storable a => FList.T a) . + fromFusionList size (FList.crochetL f a x) = + crochetL f a (fromFusionList size x) ; +-} + + "Storable.fromFusionList/generate" forall size f a. + fromFusionList size (FList.generate f a) = + unfoldr size f a ; + + "Storable.fromFusionList/cons" forall size x xs. + fromFusionList size (FList.cons x xs) = + cons x (fromFusionList size xs) ; + + "Storable.fromFusionList/empty" forall size. + fromFusionList size (FList.empty) = + empty ; + + "Storable.fromFusionList/append" forall size xs ys. + fromFusionList size (FList.append xs ys) = + append (fromFusionList size xs) (fromFusionList size ys) ; + + "Storable.fromFusionList/maybe" forall size f x y. + fromFusionList size (maybe x f y) = + maybe (fromFusionList size x) + (fromFusionList size . f) y ; + + "Storable.fromFusionList/fromMaybe" forall size x y. + fromFusionList size (fromMaybe x y) = + maybe (fromFusionList size x) (fromFusionList size) y ; + #-} + + +{- +The "fromList/drop" rule is not quite accurate +because the chunk borders are moved. +Maybe 'ChunkSize' better is a list of chunks sizes. +-} + +{-# RULEZ + "fromList/zipWith" + forall size f (as :: Storable a => [a]) (bs :: Storable a => [a]). + fromList size (List.zipWith f as bs) = + zipWith size f (fromList size as) (fromList size bs) ; + + "fromList/drop" forall as n size. + fromList size (List.drop n as) = + drop n (fromList size as) ; + #-} + + + +{- * Fused functions -} + +type Unfoldr s a = (s -> Maybe (a,s), s) + +{-# INLINE zipWithUnfoldr2 #-} +zipWithUnfoldr2 :: Storable z => + ChunkSize + -> (x -> y -> z) + -> Unfoldr a x + -> Unfoldr b y + -> T z +zipWithUnfoldr2 size h (f,a) (g,b) = + unfoldr size + (\(a0,b0) -> liftM2 (\(x,a1) (y,b1) -> (h x y, (a1,b1))) (f a0) (g b0)) +-- (uncurry (liftM2 (\(x,a1) (y,b1) -> (h x y, (a1,b1)))) . (f *** g)) + (a,b) + +{- done by takeCrochet +{-# INLINE mapUnfoldr #-} +mapUnfoldr :: (Storable x, Storable y) => + ChunkSize + -> (x -> y) + -> Unfoldr a x + -> T y +mapUnfoldr size g (f,a) = + unfoldr size (fmap (mapFst g) . f) a +-} + +{-# INLINE dropUnfoldr #-} +dropUnfoldr :: Storable x => + ChunkSize + -> Int + -> Unfoldr a x + -> T x +dropUnfoldr size n (f,a0) = + maybe + empty + (unfoldr size f) + (nest n (\a -> fmap snd . f =<< a) (Just a0)) + + +{- done by takeCrochet +{-# INLINE takeUnfoldr #-} +takeUnfoldr :: Storable x => + ChunkSize + -> Int + -> Unfoldr a x + -> T x +takeUnfoldr size n0 (f,a0) = + unfoldr size + (\(a,n) -> + do guard (n>0) + (x,a') <- f a + return (x, (a', pred n))) + (a0,n0) +-} + + +lengthUnfoldr :: Storable x => + Unfoldr a x + -> Int +lengthUnfoldr (f,a0) = + let recurse n a = + maybe n (recurse (succ n) . snd) (f a) + in recurse 0 a0 + + +{-# INLINE zipWithUnfoldr #-} +zipWithUnfoldr :: + (Storable b, Storable c) => + (acc -> Maybe (a, acc)) + -> (a -> b -> c) + -> acc + -> T b -> T c +zipWithUnfoldr f h a y = + crochetL (\y0 a0 -> + do (x0,a1) <- f a0 + Just (h x0 y0, a1)) a y + +{-# INLINE zipWithCrochetL #-} +zipWithCrochetL :: + (Storable x, Storable b, Storable c) => + ChunkSize + -> (x -> acc -> Maybe (a, acc)) + -> (a -> b -> c) + -> acc + -> T x -> T b -> T c +zipWithCrochetL size f h a x y = + crochetL (\(x0,y0) a0 -> + do (z0,a1) <- f x0 a0 + Just (h z0 y0, a1)) + a (zip size x y) + + +{-# INLINE crochetLCons #-} +crochetLCons :: + (Storable a, Storable b) => + (a -> acc -> Maybe (b, acc)) + -> acc + -> a -> T a -> T b +crochetLCons f a0 x xs = + maybe + empty + (\(y,a1) -> cons y (crochetL f a1 xs)) + (f x a0) + +{-# INLINE reduceLCons #-} +reduceLCons :: + (Storable a) => + (a -> acc -> Maybe acc) + -> acc + -> a -> T a -> acc +reduceLCons f a0 x xs = + maybe a0 (flip (reduceL f) xs) (f x a0) + + + + + +{-# RULES + "Storable.zipWith/share" forall size (h :: a->a->b) (x :: T a). + zipWith size h x x = map (\xi -> h xi xi) x ; + +-- "Storable.map/zipWith" forall size (f::c->d) (g::a->b->c) (x::T a) (y::T b). + "Storable.map/zipWith" forall size f g x y. + map f (zipWith size g x y) = + zipWith size (\xi yi -> f (g xi yi)) x y ; + + -- this rule lets map run on a different block structure + "Storable.zipWith/map,*" forall size f g x y. + zipWith size g (map f x) y = + zipWith size (\xi yi -> g (f xi) yi) x y ; + + "Storable.zipWith/*,map" forall size f g x y. + zipWith size g x (map f y) = + zipWith size (\xi yi -> g xi (f yi)) x y ; + + + "Storable.drop/unfoldr" forall size f a n. + drop n (unfoldr size f a) = + dropUnfoldr size n (f,a) ; + + "Storable.take/unfoldr" forall size f a n. + take n (unfoldr size f a) = +-- takeUnfoldr size n (f,a) ; + takeCrochet n (unfoldr size f a) ; + + "Storable.length/unfoldr" forall size f a. + length (unfoldr size f a) = lengthUnfoldr (f,a) ; + + "Storable.map/unfoldr" forall size g f a. + map g (unfoldr size f a) = +-- mapUnfoldr size g (f,a) ; + mapCrochet g (unfoldr size f a) ; + + "Storable.map/iterate" forall size g f a. + map g (iterate size f a) = + mapCrochet g (iterate size f a) ; + +{- + "Storable.zipWith/unfoldr,unfoldr" forall sizeA sizeB f g h a b n. + zipWith n h (unfoldr sizeA f a) (unfoldr sizeB g b) = + zipWithUnfoldr2 n h (f,a) (g,b) ; +-} + + -- block boundaries are changed here, so it changes lazy behaviour + "Storable.zipWith/unfoldr,*" forall sizeA sizeB f h a y. + zipWith sizeA h (unfoldr sizeB f a) y = + zipWithUnfoldr f h a y ; + + -- block boundaries are changed here, so it changes lazy behaviour + "Storable.zipWith/*,unfoldr" forall sizeA sizeB f h a y. + zipWith sizeA h y (unfoldr sizeB f a) = + zipWithUnfoldr f (flip h) a y ; + + "Storable.crochetL/unfoldr" forall size f g a b. + crochetL g b (unfoldr size f a) = + unfoldr size (\(a0,b0) -> + do (y0,a1) <- f a0 + (z0,b1) <- g y0 b0 + Just (z0, (a1,b1))) (a,b) ; + + "Storable.reduceL/unfoldr" forall size f g a b. + reduceL g b (unfoldr size f a) = + snd + (FList.recurse (\(a0,b0) -> + do (y,a1) <- f a0 + b1 <- g y b0 + Just (a1, b1)) (a,b)) ; + + "Storable.crochetL/cons" forall g b x xs. + crochetL g b (cons x xs) = + crochetLCons g b x xs ; + + "Storable.reduceL/cons" forall g b x xs. + reduceL g b (cons x xs) = + reduceLCons g b x xs ; + + + + + "Storable.take/crochetL" forall f a x n. + take n (crochetL f a x) = + takeCrochet n (crochetL f a x) ; + + "Storable.length/crochetL" forall f a x. + length (crochetL f a x) = length x ; + + "Storable.map/crochetL" forall g f a x. + map g (crochetL f a x) = + mapCrochet g (crochetL f a x) ; + + "Storable.zipWith/crochetL,*" forall size f h a x y. + zipWith size h (crochetL f a x) y = + zipWithCrochetL size f h a x y ; + + "Storable.zipWith/*,crochetL" forall size f h a x y. + zipWith size h y (crochetL f a x) = + zipWithCrochetL size f (flip h) a x y ; + + "Storable.crochetL/crochetL" forall f g a b x. + crochetL g b (crochetL f a x) = + crochetL (\x0 (a0,b0) -> + do (y0,a1) <- f x0 a0 + (z0,b1) <- g y0 b0 + Just (z0, (a1,b1))) (a,b) x ; + + "Storable.reduceL/crochetL" forall f g a b x. + reduceL g b (crochetL f a x) = + snd + (reduceL (\x0 (a0,b0) -> + do (y,a1) <- f x0 a0 + b1 <- g y b0 + Just (a1, b1)) (a,b) x) ; + #-} + + + +{- * Fusion tests -} + + +fromMapList :: (Storable y) => ChunkSize -> (x -> y) -> [x] -> T y +fromMapList size f = + unfoldr size (fmap (mapFst f) . viewListL) + +{-# RULES + "Storable.fromList/map" forall size f xs. + fromList size (List.map f xs) = fromMapList size f xs ; + #-} + + +fromMapFusionList :: (Storable y) => + ChunkSize -> (x -> y) -> FList.T x -> T y +fromMapFusionList size f = + unfoldr size (fmap (mapFst f) . FList.viewL) + +{-# RULES + "Storable.fromFusionList/map" forall size f xs. + fromFusionList size (FList.map f xs) = fromMapFusionList size f xs ; + + "Storable.fromFusionList/replicate" forall size n x. + fromFusionList size (FList.replicate n x) = replicate size n x ; + #-} + + + + +testLength :: (Storable a, Enum a) => a -> Int +testLength x = length (map succ (fromList (ChunkSize 100) [x,x,x])) + +testMapZip :: (Storable a, Enum a, Num a) => + ChunkSize -> T a -> T a -> T a +-- testMapZip size x y = map snd (zipWith size (,) x y) +testMapZip size x y = map succ (zipWith size (P.+) x y) + +testMapCons :: (Storable a, Enum a) => + a -> T a -> T a +testMapCons x xs = map succ (cons x xs) + +{-# INLINE testMapIterate #-} +{-# SPECIALISE testMapIterate :: + ChunkSize -> Char -> T Char #-} +testMapIterate :: (Storable a, Enum a) => + ChunkSize -> a -> T a +testMapIterate size y = map pred $ iterate size succ y + +testMapIterateInt :: + ChunkSize -> Int -> T Int +testMapIterateInt = testMapIterate + +-} 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,129 @@ +module Synthesizer.Utility where + +import qualified Algebra.Module as Module +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field + +import System.Random (Random, RandomGen, randomRs, ) + +import Prelude () +import PreludeBase +import NumericPrelude + + +{-# INLINE viewListL #-} +viewListL :: [a] -> Maybe (a, [a]) +viewListL [] = Nothing +viewListL (x:xs) = Just (x,xs) + +-- for constant padding +{-# INLINE viewListR #-} +viewListR :: [a] -> Maybe ([a], a) +viewListR = + foldr (\x -> Just . maybe ([],x) (mapFst (x:))) Nothing + +{-| +Apply the function @f@ n times to the start value. + +You can express that function using + +> nest n f x = (iterate f x) !! n +> nest n f = foldl (.) id (replicate n f) + +but this is not as elegant as calling @nest@. +Simon Thompson calls it @iter@. +-} +{-# INLINE nest #-} +nest :: Int -> (a -> a) -> a -> a +nest 0 _ x = x +nest n f x = f (nest (n-1) f x) + + +-- see event-list package +-- | Control.Arrow.*** +{-# INLINE mapPair #-} +mapPair :: (a -> c, b -> d) -> (a,b) -> (c,d) +mapPair ~(f,g) ~(x,y) = (f x, g y) + +-- | Control.Arrow.first +{-# INLINE mapFst #-} +mapFst :: (a -> c) -> (a,b) -> (c,b) +mapFst f ~(x,y) = (f x, y) + +-- | Control.Arrow.second +{-# INLINE mapSnd #-} +mapSnd :: (b -> d) -> (a,b) -> (a,d) +mapSnd g ~(x,y) = (x, g y) + + +{-# INLINE fst3 #-} +fst3 :: (a,b,c) -> a +fst3 (a,_,_) = a + +{-# INLINE snd3 #-} +snd3 :: (a,b,c) -> b +snd3 (_,b,_) = b + +{-# INLINE thd3 #-} +thd3 :: (a,b,c) -> c +thd3 (_,_,c) = c + + +{-# INLINE swap #-} +swap :: (a,b) -> (b,a) +swap (x,y) = (y,x) + + +{-| +If two values are equal, then return one of them, +otherwise raise an error. +-} +{-# INLINE common #-} +common :: (Eq a) => String -> a -> a -> a +common errorMsg x y = + if x == y + then x + else error errorMsg + + +-- * arithmetic + + +{-# INLINE fwrap #-} +fwrap :: RealField.C a => (a,a) -> a -> a +fwrap (lo,hi) x = lo + fmod (x-lo) (hi-lo) + +{-# INLINE fmod #-} +fmod :: RealField.C a => a -> a -> a +fmod x y = fraction (x/y) * y + +{-# INLINE fmodAlt #-} +fmodAlt :: RealField.C a => a -> a -> a +fmodAlt x y = x - fromInteger (floor (x/y)) * y + +propFMod :: RealField.C a => a -> a -> Bool +propFMod x y = +-- y /= 0 ==> + fmod x y == fmodAlt x y + +{-# INLINE affineComb #-} +affineComb :: (Module.C t y) => t -> (y,y) -> y +affineComb phase (x0,x1) = x0 + phase *> (x1-x0) + +{-# INLINE balanceLevel #-} +balanceLevel :: (Field.C y) => + y -> [y] -> [y] +balanceLevel center xs = + let d = center - sum xs / fromIntegral (length xs) + in map (d+) xs + +{-# INLINE randomRsBalanced #-} +randomRsBalanced :: (RandomGen g, Random y, Field.C y) => + g -> Int -> y -> y -> [y] +randomRsBalanced g n center width = + balanceLevel center (take n $ randomRs (zero,width) g) + + +{-# INLINE clip #-} +clip :: Ord a => a -> a -> a -> a +clip lower upper = max lower . min upper 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,26 @@ +module Main where + +import qualified Test.Sound.Synthesizer.Plain.Analysis as Analysis +import qualified Test.Sound.Synthesizer.Plain.Control as Control +import qualified Test.Sound.Synthesizer.Plain.Filter as Filter +import qualified Test.Sound.Synthesizer.Plain.Interpolation as Interpolation +import qualified Test.Sound.Synthesizer.Plain.Oscillator as Oscillator +import qualified Test.Sound.Synthesizer.Plain.ToneModulation as ToneModulation +import qualified Test.Sound.Synthesizer.Plain.Wave as Wave + +prefix :: String -> [(String, IO ())] -> [(String, IO ())] +prefix msg = + map (\(str,test) -> (msg ++ "." ++ str, test)) + +main :: IO () +main = + mapM_ (\(msg,io) -> putStr (msg++": ") >> io) $ + concat $ + prefix "Plain.Analysis" Analysis.tests : + prefix "Plain.Control" Control.tests : + prefix "Plain.Filter" Filter.tests : + prefix "Plain.Interpolation" Interpolation.tests : + prefix "Plain.Oscillator" Oscillator.tests : + prefix "Plain.ToneModulation" ToneModulation.tests : + prefix "Plain.Wave" Wave.tests : + [] 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,87 @@ +module Test.Sound.Synthesizer.Plain.Interpolation + (T, ip, + LinePreserving, lpIp, + tests) where + +import qualified Synthesizer.Plain.Interpolation as Interpolation + +import Test.QuickCheck (test, Arbitrary(..), elements, {- Property, (==>), -} ) +-- import Test.Utility + +import qualified Algebra.VectorSpace as VectorSpace +import qualified Algebra.Module as Module +-- import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +-- import qualified Algebra.Ring as Ring +-- import qualified Algebra.Additive as Additive + +import Test.Utility (equalList) + + +import NumericPrelude +import PreludeBase +import Prelude () + + + + +data T a v = Cons {name :: String, ip :: Interpolation.T a v} + +instance Show (T a v) where + show x = name x + +instance (Field.C a, Module.C a v) => Arbitrary (T a v) where + arbitrary = elements $ + Cons "constant" Interpolation.constant : + Cons "linear" Interpolation.linear : + Cons "cubic" Interpolation.cubic : + [] + coarbitrary = undefined + + + +data LinePreserving a v = + LPCons {lpName :: String, lpIp :: Interpolation.T a v} + +instance Show (LinePreserving a v) where + show x = lpName x + +instance (Field.C a, Module.C a v) => Arbitrary (LinePreserving a v) where + arbitrary = elements $ + LPCons "linear" Interpolation.linear : + LPCons "cubic" Interpolation.cubic : + [] + coarbitrary = undefined + + + +constant :: (Module.C a v, Eq v) => a -> v -> [v] -> Bool +constant t x0 xs = + equalList $ map ($(x0:xs)) $ map ($t) $ + Interpolation.func Interpolation.constant : + Interpolation.func Interpolation.piecewiseConstant : + [] + +linear :: (Module.C a v, Eq v) => a -> v -> v -> [v] -> Bool +linear t x0 x1 xs = + equalList $ map ($(x0:x1:xs)) $ map ($t) $ + Interpolation.func Interpolation.linear : + Interpolation.func Interpolation.piecewiseLinear : + [] + +cubic :: (VectorSpace.C a v, Eq v) => a -> v -> v -> v -> v -> [v] -> Bool +cubic t x0 x1 x2 x3 xs = + equalList $ map ($(x0:x1:x2:x3:xs)) $ map ($t) $ + Interpolation.func Interpolation.cubic : + Interpolation.func Interpolation.cubicAlt : + Interpolation.func Interpolation.piecewiseCubic : + [] + + + +tests :: [(String, IO ())] +tests = + ("constant", test (\t x -> constant (t::Rational) (x::Rational))) : + ("linear", test (\t x -> linear (t::Rational) (x::Rational))) : + ("cubic", test (\t x -> cubic (t::Rational) (x::Rational))) : + [] 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,490 @@ +module Test.Sound.Synthesizer.Plain.ToneModulation (tests) where + +import qualified Synthesizer.Plain.Oscillator as Osci +import qualified Synthesizer.Basic.Wave as Wave +import qualified Synthesizer.Basic.Phase as Phase +import qualified Synthesizer.Plain.Interpolation as Interpolation +import qualified Synthesizer.Plain.ToneModulation as ToneMod + +import qualified Test.Sound.Synthesizer.Plain.Interpolation as InterpolationTest + +import Test.QuickCheck (test, Property, (==>), Testable, ) +-- import Test.Utility + +import qualified Number.NonNegative as NonNeg +import qualified Number.NonNegativeChunky as Chunky + +import qualified Algebra.RealTranscendental as RealTrans +import qualified Algebra.Module as Module +import qualified Algebra.RealField as RealField +import qualified Algebra.Field as Field +import qualified Algebra.Ring as Ring +import qualified Algebra.Additive as Additive + + +import Synthesizer.Utility (clip, mapPair, ) +import qualified Data.List as List + + +import NumericPrelude +import PreludeBase +import Prelude () + + + +untangleShapePhase :: (Field.C a, Eq a) => + Int -> a -> (a, a) -> Property +untangleShapePhase periodInt period c = + period /= zero ==> + ToneMod.untangleShapePhase periodInt period c == + ToneMod.untangleShapePhaseAnalytic periodInt period c + + +absolutize :: (Additive.C a) => a -> [a] -> [a] +absolutize = scanl (+) + +limitMinRelativeValues :: + Int -> Int -> [NonNeg.Int] -> Bool +limitMinRelativeValues xMin x0 xsnn = + let xs = map NonNeg.toNumber xsnn + in map (max xMin) (absolutize x0 xs) == + uncurry absolutize (ToneMod.limitMinRelativeValues xMin x0 xs) + +limitMaxRelativeValues :: + Int -> Int -> [NonNeg.Int] -> Bool +limitMaxRelativeValues xMax x0 xsnn = + let xs = map NonNeg.toNumber xsnn + in map (min xMax) (absolutize x0 xs) == + uncurry absolutize (ToneMod.limitMaxRelativeValues xMax x0 xs) + +limitMaxRelativeValuesNonNeg :: + Int -> Int -> [NonNeg.Int] -> Bool +limitMaxRelativeValuesNonNeg xMax x0 xsnn = + let xs = map NonNeg.toNumber xsnn + in map (min xMax) (absolutize x0 xs) == + uncurry absolutize (ToneMod.limitMaxRelativeValuesNonNeg xMax x0 xs) + +-- chunky type is not necessary here but testing it a little is not wrong +limitMinRelativeValuesIdentity :: + Chunky.T NonNeg.Int -> [Chunky.T NonNeg.Int] -> Bool +limitMinRelativeValuesIdentity x0 xs = + (x0,xs) == ToneMod.limitMinRelativeValues 0 x0 xs + +limitMaxRelativeValuesIdentity :: + Chunky.T NonNeg.Int -> [Chunky.T NonNeg.Int] -> Bool +limitMaxRelativeValuesIdentity x0 xs = + let inf = 1 + inf + in (x0,xs) == ToneMod.limitMaxRelativeValues inf x0 xs + +limitMaxRelativeValuesNonNegIdentity :: + Chunky.T NonNeg.Int -> [Chunky.T NonNeg.Int] -> Bool +limitMaxRelativeValuesNonNegIdentity x0 xs = + let inf = 1 + inf + in (x0,xs) == ToneMod.limitMaxRelativeValuesNonNeg inf x0 xs + +limitMaxRelativeValuesInfinity :: + Chunky.T NonNeg.Int -> (Chunky.T NonNeg.Int, [Chunky.T NonNeg.Int]) -> Bool +limitMaxRelativeValuesInfinity x0 (x,xs) = + let inf = 1 + inf + ys = cycle (x:xs) + (z0,zs) = ToneMod.limitMaxRelativeValues inf x0 ys + in (x0, take 100 ys) == (z0, take 100 zs) + +limitMaxRelativeValuesNonNegInfinity :: + Chunky.T NonNeg.Int -> (Chunky.T NonNeg.Int, [Chunky.T NonNeg.Int]) -> Bool +limitMaxRelativeValuesNonNegInfinity x0 (x,xs) = + let inf = 1 + inf + ys = cycle (x:xs) + (z0,zs) = ToneMod.limitMaxRelativeValuesNonNeg inf x0 ys + in (x0, take 100 ys) == (z0, take 100 zs) + + +dropRem :: Eq a => Int -> [a] -> Bool +dropRem n xs = + let n1 = abs n + in map (flip ToneMod.dropRem xs) [0 .. n1 + length xs] == + map ((,) 0) (List.tails xs) ++ map (flip (,) []) [1..n1] + + +withInterpolation :: + (Interpolation.T a v -> x) -> + (InterpolationTest.T a v -> x) +withInterpolation f ipt = + f (InterpolationTest.ip ipt) + +withLPInterpolation :: + (Interpolation.T a v -> x) -> + (InterpolationTest.LinePreserving a v -> x) +withLPInterpolation f ipt = + f (InterpolationTest.lpIp ipt) + +withInterpolation2 :: + (Interpolation.T a v -> + Interpolation.T a v -> x) -> + (InterpolationTest.T a v -> + InterpolationTest.T a v -> x) +withInterpolation2 f = + withInterpolation $ \ ipLeap -> + withInterpolation $ \ ipStep -> + f ipLeap ipStep + +minLength :: + Interpolation.T a v -> + Interpolation.T a v -> + Int -> NonNeg.Int -> Int +minLength ipLeap ipStep periodInt ext = + Interpolation.number ipStep + + Interpolation.number ipLeap * periodInt + + NonNeg.toNumber ext + +sampledTone :: (RealField.C a, Eq v) => + InterpolationTest.T a v -> + InterpolationTest.T a v -> + NonNeg.T a -> NonNeg.Int -> (v,[v]) -> a -> Phase.T a -> Property +sampledTone = + withInterpolation2 $ \ ipLeap ipStep + periodNN ext (x,xs) shape phase -> + let period = NonNeg.toNumber periodNN + len = minLength ipLeap ipStep (ceiling period) ext + tone = take len (List.cycle (x:xs)) + in period /= zero ==> + Wave.sampledToneAlt ipLeap ipStep period tone shape `Wave.apply` phase == + Wave.sampledTone ipLeap ipStep period tone shape `Wave.apply` phase + + +sampledToneSine :: (RealTrans.C a, Module.C a a) => + NonNeg.T a -> NonNeg.Int -> a -> a -> a -> Bool +sampledToneSine periodNN ext phase0 shape phase = + let ipLeap = Interpolation.cubic + ipStep = Interpolation.cubic + ten = fromInteger 10 + period = ten + NonNeg.toNumber periodNN + len = minLength ipLeap ipStep (ceiling period) ext + tone = take len (Osci.staticSine phase0 (recip period)) + in abs (Wave.sampledTone ipLeap ipStep period tone shape `Wave.apply` (Phase.fromRepresentative phase) - + head (Osci.staticSine (phase0+phase) zero)) < ten ^- (-2) + + +sampledToneSineList :: (RealTrans.C a, Module.C a a) => + NonNeg.T a -> NonNeg.Int -> a -> a -> [a] -> [a] -> Bool +sampledToneSineList periodNN ext origPhase phase shapes freqs = + let ipLeap = Interpolation.cubic + ipStep = Interpolation.cubic + ten = fromInteger 10 + period = ten + NonNeg.toNumber periodNN + len = minLength ipLeap ipStep (ceiling period) ext + tone = take len (Osci.staticSine origPhase (recip period)) + in all ((< ten ^- (-2)) . abs) $ + zipWith (-) + (Osci.shapeFreqMod (Wave.sampledTone ipLeap ipStep period tone) + phase shapes freqs) + (Osci.freqModSine (origPhase+phase) freqs) + + +sampledToneLinear :: (RealField.C a, Module.C a v, Eq v) => + InterpolationTest.LinePreserving a v -> + InterpolationTest.LinePreserving a v -> + NonNeg.T a -> NonNeg.Int -> (v,v) -> a -> Phase.T a -> Property +sampledToneLinear = + withLPInterpolation $ \ ipLeap -> + withLPInterpolation $ \ ipStep -> + \ periodNN ext (i,d) shape phase -> + let period = NonNeg.toNumber periodNN + len = minLength ipLeap ipStep (ceiling period) ext + ramp = take len (List.iterate (d+) i) + limits = + mapPair (fromIntegral, fromIntegral) $ + ToneMod.shapeLimits ipLeap ipStep (round period) len + in period /= zero ==> + -- should be (fraction phase), right? + Wave.sampledTone ipLeap ipStep period ramp shape `Wave.apply` phase == + i + uncurry clip limits shape *> d +{- +let len=100; period=1/0.06::Double; ip = Interpolation.linear in GNUPlot.plotFuncs [] (GNUPlot.linearScale 1000 (0,fromIntegral len)) [\s -> Wave.sampledTone ip ip period (take len $ iterate (1+) (0::Double)) s 0, uncurry clip (mapPair (fromIntegral, fromIntegral) $ Wave.shapeLimits ip ip (round period::Int) len)] +-} + +sampledToneStair :: (RealField.C a, Module.C a v, Eq v) => + InterpolationTest.LinePreserving a v -> + NonNeg.Int -> NonNeg.Int -> (v,v) -> a -> Property +sampledToneStair = + withLPInterpolation $ \ ipLeap + periodIntNN ext (i,d) shape -> + let ipStep = Interpolation.constant + periodInt = NonNeg.toNumber periodIntNN + period = fromIntegral periodInt + len0 = minLength ipLeap ipStep periodInt ext + (rep,rm) = divMod (negate len0) periodInt + len = len0 + rm + stair = + concatMap (replicate periodInt) $ + take (negate rep) (List.iterate (period*>d+) i) + limits = + mapPair (fromIntegral, fromIntegral) $ + ToneMod.shapeLimits ipLeap ipStep periodInt len + in periodInt /= zero ==> + Wave.sampledTone ipLeap ipStep period stair shape `Wave.apply` zero == + i + uncurry clip limits shape *> d +{- +let len=periodInt*rep; rep=10; periodInt = 14::Int; period=fromIntegral periodInt; ipl = Interpolation.linear; ipc = Interpolation.constant in GNUPlot.plotFuncs [] (GNUPlot.linearScale 1000 (-10,10+fromIntegral len)) [\s -> Wave.sampledTone ipl ipc period (concatMap (replicate periodInt) $ take rep $ iterate (period+) (0::Double)) s 0, uncurry clip (mapPair (fromIntegral, fromIntegral) $ Wave.shapeLimits ipl ipc periodInt len)] +-} + +{- +sampledToneSaw :: (RealField.C a, Module.C a v, Eq v) => + InterpolationTest.LinePreserving a v -> + InterpolationTest.T a v -> + NonNeg.Int -> NonNeg.Int -> (v,v) -> a -> a -> Property +sampledToneSaw iptLeap iptStep periodIntNN ext (i,d) shape phase = + let ipLeap = InterpolationTest.lpIp iptLeap + ipStep = InterpolationTest.ip iptStep + periodInt = NonNeg.toNumber periodIntNN + period = fromIntegral periodInt + len0 = minLength ipLeap ipStep periodInt ext + rep = negate $ div (negate len0) periodInt + saw = + concat $ replicate rep $ + take periodInt $ List.iterate (d+) i + in periodInt /= zero ==> + Wave.sampledTone ipLeap ipStep period saw shape phase == + i + fraction phase *> d +-} + +sampledToneStatic :: (RealField.C a, Eq v) => + InterpolationTest.T a v -> + InterpolationTest.T a v -> + NonNeg.Int -> (v,[v]) -> a -> a -> Property +sampledToneStatic = + withInterpolation2 $ \ ipLeap ipStep + ext (x,xs) shape phase -> + let wave = x:xs + periodInt = length wave + period = fromIntegral periodInt + len = minLength ipLeap ipStep periodInt ext + rep = negate $ div (negate len) periodInt + tone = concat $ replicate rep wave + in period /= zero ==> + Wave.sampledTone ipLeap ipStep period tone shape `Wave.apply` (Phase.fromRepresentative phase) == + Interpolation.cyclicPad Interpolation.single ipStep (phase*period) wave +{- +let wave = [1,-1,0.5,-0.5::Double]; period = fromIntegral (length wave) :: Double; ip = Interpolation.linear in GNUPlot.plotFuncs [] (GNUPlot.linearScale 1000 (-1,3)) [Wave.sampledTone ip ip period (concat $ replicate 3 wave) 0.3, \phase -> Interpolation.cyclicPad Interpolation.single Interpolation.linear (phase*period) wave] +-} + + + +-- candidate for Utility +zapWith :: (a -> a -> b) -> [a] -> [b] +zapWith f xs = zipWith f xs (tail xs) + +-- candidate for Utility +monotoniclyIncreasing :: Ord a => [a] -> Bool +monotoniclyIncreasing [] = True +monotoniclyIncreasing xs = and $ zapWith (<=) xs + + +shapeFreqModFromSampledToneLimitIdentity :: (RealField.C t) => + InterpolationTest.T t y -> + InterpolationTest.T t y -> + NonNeg.Int -> (y,[y]) -> (t, [NonNeg.T t]) -> Bool +shapeFreqModFromSampledToneLimitIdentity = + withInterpolation2 $ \ ipLeap ipStep + periodIntNN (x,xs) (shape0,shapesNN) -> + let periodInt = NonNeg.toNumber periodIntNN + shapes = map NonNeg.toNumber shapesNN + a = + snd (ToneMod.limitRelativeShapes + ipLeap ipStep periodInt (List.cycle (x:xs)) + (shape0, cycle (zero:shapes))) !! 100 + in a == a + + +oscillatorCoords :: (RealField.C t) => + NonNeg.Int -> NonNeg.T t -> t -> Phase.T t -> [NonNeg.T t] -> [t] -> Property +oscillatorCoords + periodIntNN periodNN shape0 phase shapesNN freqs = + let shapes = map NonNeg.toNumber shapesNN + period = NonNeg.toNumber periodNN + periodInt = NonNeg.toNumber periodIntNN + periodRound = fromIntegral periodInt + coords = + ToneMod.oscillatorCoords + periodInt period + (shape0, shapes) (phase, freqs) + in period /= zero && periodInt /= zero ==> + all + (\(skip,(k,(qShape,qWave))) -> + skip >= zero && + monotoniclyIncreasing [negate periodInt, k, zero] && + monotoniclyIncreasing [zero, qShape, one] && + monotoniclyIncreasing [zero, qWave, periodRound]) + (tail coords) + + +shapeFreqModFromSampledToneCoordsIdentity :: (RealField.C t) => + NonNeg.Int -> NonNeg.T t -> (t, [NonNeg.T t]) -> Property +shapeFreqModFromSampledToneCoordsIdentity + periodIntNN periodNN (shape0,shapesNN) = + let period = NonNeg.toNumber periodNN + periodInt = NonNeg.toNumber periodIntNN + shapes = map NonNeg.toNumber shapesNN + phase = Phase.fromRepresentative $ shape0 / period + freqs = map (/period) shapes + in period /= zero ==> + all + (isZero . fst . snd . snd) + (ToneMod.oscillatorCoords + periodInt period (shape0, shapes) (phase, freqs)) + + +shapeFreqModFromSampledTone :: (RealField.C t, Eq v) => + InterpolationTest.T t v -> + InterpolationTest.T t v -> + NonNeg.T t -> + NonNeg.Int -> (v,[v]) -> + t -> t -> [NonNeg.T t] -> [t] -> + Property +shapeFreqModFromSampledTone = + withInterpolation2 $ \ ipLeap ipStep + periodNN ext (x,xs) shape0 phase shapesNN freqs -> + let shapes = map NonNeg.toNumber shapesNN + period = NonNeg.toNumber periodNN + len = minLength ipLeap ipStep (ceiling period) ext + tone = take len (List.cycle (x:xs)) + resampledToneA = + Osci.shapeFreqModFromSampledTone ipLeap ipStep period tone + shape0 phase shapes freqs + resampledToneB = + Osci.shapeFreqMod + (Wave.sampledTone ipLeap ipStep period tone) + phase (scanl (+) shape0 shapes) freqs + in period /= zero ==> + resampledToneA == resampledToneB +{- +let len=100; period=1/0.06::Double; ip = Interpolation.linear; tone = take len $ iterate (1+) (0::Double); shape0=0; shapes = replicate 100 1; in GNUPlot.plotLists [] [Osci.shapeFreqMod (Wave.sampledTone ip ip period tone) 0 (scanl (+) shape0 shapes) (repeat 0), Osci.shapeFreqModFromSampledTone ip ip period tone shape0 0 shapes (repeat 0)] +*Test.Sound.Synthesizer.Plain.Oscillator> let len=100; period=1/0.06::Double; ip = Interpolation.linear; tone = take len $ iterate (1+) (0::Double); shape0=0; shapes = concat $ replicate 50 [1.5,0.5]; in GNUPlot.plotLists [] [Osci.shapeFreqMod (Wave.sampledTone ip ip period tone) 0 (scanl (+) shape0 shapes) (repeat 0), Osci.shapeFreqModFromSampledTone ip ip period tone shape0 0 shapes (repeat 0)] +*Test.Sound.Synthesizer.Plain.Oscillator> let len=100; period=1/0.06::Rational; ipLeap = Interpolation.linear; ipStep = Interpolation.constant; tone = take len $ iterate (1+) (0::Rational); shape0=0; shapes = concat $ replicate 50 [1.5,0.5]; in GNUPlot.plotLists [] (map (map (\x -> fromRational' x :: Double)) [Osci.shapeFreqMod (Wave.sampledTone ipLeap ipStep period tone) 0 (scanl (+) shape0 shapes) (repeat 0), Osci.shapeFreqModFromSampledTone ipLeap ipStep period tone shape0 0 shapes (repeat 0)]) +-} + +oscillatorCells :: (RealField.C t, Eq v) => + InterpolationTest.T t v -> + InterpolationTest.T t v -> + NonNeg.T t -> + NonNeg.Int -> (v,[v]) -> + t -> t -> [NonNeg.T t] -> [t] -> + Property +oscillatorCells = + withInterpolation2 $ \ ipLeap ipStep + periodNN ext (x,xs) shape0 phase shapesNN freqs -> + let shapes = map NonNeg.toNumber shapesNN + period = NonNeg.toNumber periodNN + len = minLength ipLeap ipStep (ceiling period) ext + tone = take len (List.cycle (x:xs)) + crop = cropCell ipLeap ipStep + resampledToneA = + ToneMod.oscillatorCells ipLeap ipStep period tone + (shape0, shapes) (Phase.fromRepresentative phase, freqs) + resampledToneB = + Osci.shapeFreqMod + (Wave.Cons . ToneMod.sampledToneCell + (ToneMod.makePrototype ipLeap ipStep period tone)) + phase (scanl (+) shape0 shapes) freqs + in period /= zero ==> + map crop resampledToneA == map crop resampledToneB + +cropCell :: + Interpolation.T t v -> + Interpolation.T t v -> + ((t,t),[[v]]) -> ((t,t),[[v]]) +cropCell ipLeap ipStep (q,cell) = + (q, + take (Interpolation.number ipStep) $ + map (take (Interpolation.number ipLeap)) $ + cell) + + +shapeFreqModFromSampledToneIdentity :: (RealField.C t, Eq v) => + InterpolationTest.T t v -> + InterpolationTest.T t v -> + NonNeg.T t -> + NonNeg.Int -> (v,[v]) -> + Property +shapeFreqModFromSampledToneIdentity = + withInterpolation2 $ \ ipLeap ipStep + periodNN ext (x,xs) -> + let period = NonNeg.toNumber periodNN + len = minLength ipLeap ipStep (ceiling period) ext + tone = take len (List.cycle (x:xs)) + shape0 = zero + shapes = repeat one + phase = zero + freqs = repeat (recip period) + (n0,n1) = + ToneMod.shapeLimits ipLeap ipStep (round period) len + + resampledTone = + Osci.shapeFreqModFromSampledTone ipLeap ipStep period tone + shape0 phase shapes freqs + in period /= zero ==> + and (drop n0 (take (succ n1) (zipWith (==) resampledTone tone))) + + +testRationalLineIp :: Testable test => + (InterpolationTest.LinePreserving Rational Rational -> test) -> IO () +testRationalLineIp f = test f + +testRationalIp :: Testable test => + (InterpolationTest.T Rational Rational -> test) -> IO () +testRationalIp f = test f + + +tests :: [(String, IO ())] +tests = + ("untangleShapePhase", + test (\periodInt period -> + untangleShapePhase periodInt (period :: Rational))) : + ("limitMinRelativeValues", test limitMinRelativeValues) : + ("limitMaxRelativeValues", test limitMaxRelativeValues) : + ("limitMaxRelativeValuesNonNeg", + test limitMaxRelativeValuesNonNeg) : + ("limitMinRelativeValuesIdentity", + test limitMinRelativeValuesIdentity) : + ("limitMaxRelativeValuesIdentity", + test limitMaxRelativeValuesIdentity) : + ("limitMaxRelativeValuesNonNegIdentity", + test limitMaxRelativeValuesNonNegIdentity) : + ("limitMaxRelativeValuesInfinity", + test limitMaxRelativeValuesInfinity) : + ("limitMaxRelativeValuesNonNegInfinity", + test limitMaxRelativeValuesNonNegInfinity) : + ("dropRem", test (dropRem :: Int -> [Double] -> Bool)) : + ("sampledTone", + testRationalIp sampledTone) : + ("sampledToneSine", + test (\period -> sampledToneSine (period :: NonNeg.Double))) : + ("sampledToneSineList", + test (\period -> sampledToneSineList (period :: NonNeg.Double))) : + ("sampledToneLinear", + testRationalLineIp sampledToneLinear) : + ("sampledToneStair", + testRationalLineIp sampledToneStair) : +{- + ("sampledToneSaw", + testRationalLineIp sampledToneSaw) : +-} + ("sampledToneStatic", + testRationalIp sampledToneStatic) : + ("shapeFreqModFromSampledToneLimitIdentity", + testRationalIp shapeFreqModFromSampledToneLimitIdentity) : + ("oscillatorCoords", + test (\periodInt period -> + oscillatorCoords + periodInt (period :: NonNeg.Rational))) : + ("shapeFreqModFromSampledToneCoordsIdentity", + test (\periodInt period -> + shapeFreqModFromSampledToneCoordsIdentity + periodInt (period :: NonNeg.Rational))) : + ("shapeFreqModFromSampledTone", + testRationalIp shapeFreqModFromSampledTone) : + ("oscillatorCells", + testRationalIp oscillatorCells) : + ("shapeFreqModFromSampledToneIdentity", + testRationalIp shapeFreqModFromSampledToneIdentity) : + [] 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,33 @@ +{-# OPTIONS -fno-implicit-prelude #-} +module Test.Utility where + +-- import Test.QuickCheck (Arbitrary(..)) + +import qualified Algebra.Real as Real +import qualified Algebra.Ring as Ring + +import PreludeBase +import NumericPrelude + + +equalList :: Eq a => [a] -> Bool +equalList xs = + -- 'drop 1' instead of 'take' for suppression of error + and (zipWith (==) xs (drop 1 xs)) + + +approxEqual :: (Real.C a) => a -> a -> a -> Bool +approxEqual eps x y = + 2 * abs (x-y) <= eps * (abs x + abs y) + +approxEqualListRel :: (Real.C a) => a -> [a] -> Bool +approxEqualListRel eps xs = + let n = fromIntegral $ length xs + in approxEqualListAbs (eps * n * sum (map abs xs)) xs + +approxEqualListAbs :: (Real.C a) => a -> [a] -> Bool +approxEqualListAbs eps xs = + let n = fromIntegral $ length xs + s = sum xs + in sum (map (\x -> abs (n*x-s)) xs) <= eps + diff --git a/synthesizer.cabal b/synthesizer.cabal new file mode 100644 --- /dev/null +++ b/synthesizer.cabal @@ -0,0 +1,309 @@ +Name: synthesizer +Version: 0.0.3 +License: GPL +License-File: LICENSE +Author: Henning Thielemann +Maintainer: Henning Thielemann +Homepage: http://www.haskell.org/haskellwiki/Synthesizer +Package-URL: http://darcs.haskell.org/synthesizer/ +Category: Sound +Synopsis: Audio signal processing coded in Haskell +Description: + Audio signal processing + featuring both low-level functions + and high-level functions which use physical units, + abstract from the sample rate and are really fast + due to StorableVector, Stream-like list type and aggressive inlining. + For an interface to Haskore see . + For an introduction see @doc/Prologue.txt@. +Stability: Experimental +Tested-With: GHC==6.4.1, GHC==6.8.2 +Cabal-Version: >=1.2 +Build-Type: Simple + +Extra-Source-Files: + Makefile + src/OsciDiffEq.hs + doc/Prologue.txt + +Flag splitBase + description: Choose the new smaller, split-up base package. + +Flag buildExamples + description: Build example executables + default: False + +Flag buildProfilers + description: Build executables for investigating efficiency of code + default: False + +Flag buildTests + description: Build test suite + default: False + + +Library + Build-Depends: + mtl >=1.1 && <1.2, + event-list >=0.0.6 && <0.1, + non-negative >=0.0.1 && <0.1, + numeric-prelude >=0.0.4 && <0.1, + -- numeric-quest/Orthogonals is only needed by Filter.Graph + numeric-quest, + -- bytestring and binary are only needed by SpeedTest + bytestring >= 0.9 && <0.10, + binary >=0.1 && <1, + storablevector >=0.1.3, + -- QuickCheck is needed for Filter.Delay.Block + QuickCheck >=1 && <2 + + If flag(splitBase) + Build-Depends: + base >= 3, array >=0.1 && <0.2, containers >=0.1 && <0.2, random >=1.0 && <1.1, process >=1.0 && <1.1, unix >=2.3 && <2.4 + Else + Build-Depends: + base >= 1.0 && < 2, special-functors + + GHC-Options: -Wall + Hs-source-dirs: src + Exposed-modules: + Sound.Signal + Sound.Signal.Block + Sound.Signal.StrictBlock + -- further implementations of Signal class are in the Synthesizer.*.Signal modules + StorableInstance + BinarySample + Filter.Basic + Filter.Composition + Filter.Example + Filter.Fix + Filter.Graph + Filter.Graphic + Filter.MonadFix + Filter.OneWay + Filter.TwoWay + FourierSeries + Sox + Sox.File + Sox.Play + Synthesizer.Utility + Synthesizer.ApplicativeUtility + Synthesizer.Format + Synthesizer.RandomKnuth + Synthesizer.Piecewise + Synthesizer.Basic.Distortion + Synthesizer.Basic.DistortionControlled + Synthesizer.Basic.Phase + Synthesizer.Basic.Wave + Synthesizer.Basic.WaveSmoothed + Synthesizer.Frame.Stereo + Synthesizer.Plain.Signal + Synthesizer.Plain.Analysis + Synthesizer.Plain.Cut + Synthesizer.Plain.Control + Synthesizer.Plain.Displacement + Synthesizer.Plain.Filter.NonRecursive + Synthesizer.Plain.Filter.Recursive + Synthesizer.Plain.Filter.Recursive.Allpass + Synthesizer.Plain.Filter.Recursive.AllpassPoly + Synthesizer.Plain.Filter.Recursive.Butterworth + Synthesizer.Plain.Filter.Recursive.Chebyshev + Synthesizer.Plain.Filter.Recursive.Comb + Synthesizer.Plain.Filter.Recursive.FirstOrder + Synthesizer.Plain.Filter.Recursive.Integration + Synthesizer.Plain.Filter.Recursive.Moog + Synthesizer.Plain.Filter.Recursive.MovingAverage + Synthesizer.Plain.Filter.Recursive.SecondOrder + Synthesizer.Plain.Filter.Recursive.Universal + Synthesizer.Plain.Filter.Recursive.Test + Synthesizer.Plain.Filter.Delay + Synthesizer.Plain.Filter.Delay.ST + Synthesizer.Plain.Filter.Delay.List + Synthesizer.Plain.Filter.Delay.Block + Synthesizer.Plain.Filter.LinearPredictive + Synthesizer.Plain.Interpolation + Synthesizer.Plain.LorenzAttractor + Synthesizer.Plain.Modifier + Synthesizer.Plain.Noise + Synthesizer.Plain.Oscillator + Synthesizer.Plain.ToneModulation + Synthesizer.Plain.Miscellaneous + Synthesizer.Plain.Instrument + Synthesizer.Plain.Effect + Synthesizer.Plain.Effect.Fly + Synthesizer.Plain.Effect.Glass + Synthesizer.FusionList.Control + Synthesizer.FusionList.Filter.NonRecursive + Synthesizer.FusionList.Oscillator + Synthesizer.FusionList.Signal + Synthesizer.Storable.Cut + Synthesizer.Storable.Oscillator + Synthesizer.Storable.Signal + Synthesizer.Storable.Filter.Recursive.Comb + Synthesizer.State.Analysis + Synthesizer.State.Control + Synthesizer.State.Cut + Synthesizer.State.Displacement + Synthesizer.State.Filter.NonRecursive + Synthesizer.State.Filter.Delay + Synthesizer.State.Filter.Recursive.Comb + Synthesizer.State.Filter.Recursive.Integration + Synthesizer.State.Filter.Recursive.MovingAverage + Synthesizer.State.Interpolation + Synthesizer.State.Miscellaneous + Synthesizer.State.Noise + Synthesizer.State.NoiseCustom + Synthesizer.State.Oscillator + Synthesizer.State.Signal + Synthesizer.Causal.Process + Synthesizer.Causal.Displacement + Synthesizer.Causal.Interpolation + Synthesizer.Causal.Oscillator + Synthesizer.Generic.Analysis + Synthesizer.Generic.Control + Synthesizer.Generic.Displacement + Synthesizer.Generic.Filter.NonRecursive + Synthesizer.Generic.Filter.Delay + Synthesizer.Generic.Filter.Recursive.Integration + Synthesizer.Generic.Filter.Recursive.MovingAverage + Synthesizer.Generic.Interpolation + Synthesizer.Generic.Noise + Synthesizer.Generic.Oscillator + Synthesizer.Generic.SampledValue + Synthesizer.Generic.Signal + -- + Synthesizer.Physical + Synthesizer.Physical.Cut + Synthesizer.Physical.Control + Synthesizer.Physical.File + Synthesizer.Physical.Filter + Synthesizer.Physical.Noise + Synthesizer.Physical.Oscillator + Synthesizer.Physical.Play + Synthesizer.Physical.Signal + Synthesizer.Physical.Displacement + Synthesizer.Amplitude.Signal + Synthesizer.Amplitude.Cut + Synthesizer.Amplitude.Control + Synthesizer.Amplitude.Filter + Synthesizer.Amplitude.Displacement + Synthesizer.SampleRateContext.Rate + Synthesizer.SampleRateContext.Signal + Synthesizer.SampleRateContext.Oscillator + Synthesizer.SampleRateContext.Cut + Synthesizer.SampleRateContext.Control + Synthesizer.SampleRateContext.Filter + Synthesizer.SampleRateContext.Displacement + Synthesizer.SampleRateContext.Noise + Synthesizer.SampleRateContext.Play + Synthesizer.Inference.DesignStudy.Applicative + Synthesizer.Inference.DesignStudy.Arrow + Synthesizer.Inference.DesignStudy.Monad + Synthesizer.Inference.Func.Cut + Synthesizer.Inference.Func.Signal + Synthesizer.Inference.Reader.Play + Synthesizer.Inference.Reader.Process + Synthesizer.Inference.Reader.Signal + Synthesizer.Inference.Reader.Control + Synthesizer.Inference.Reader.Cut + Synthesizer.Inference.Reader.Filter + Synthesizer.Inference.Reader.Noise + Synthesizer.Inference.Reader.Oscillator + -- + Synthesizer.Dimensional.Abstraction.Flat + Synthesizer.Dimensional.Abstraction.Homogeneous + Synthesizer.Dimensional.Abstraction.RateIndependent + Synthesizer.Dimensional.Amplitude.Analysis + Synthesizer.Dimensional.Amplitude.Cut + Synthesizer.Dimensional.Amplitude.Control + Synthesizer.Dimensional.Amplitude.Displacement + Synthesizer.Dimensional.Amplitude.Filter + Synthesizer.Dimensional.Amplitude.Signal + Synthesizer.Dimensional.Causal.Process + Synthesizer.Dimensional.ControlledProcess + Synthesizer.Dimensional.Cyclic.Signal + Synthesizer.Dimensional.Process + Synthesizer.Dimensional.Rate + Synthesizer.Dimensional.RatePhantom + Synthesizer.Dimensional.RateWrapper + Synthesizer.Dimensional.Rate.Analysis + Synthesizer.Dimensional.Rate.Control + Synthesizer.Dimensional.Rate.Cut + Synthesizer.Dimensional.Rate.Filter + Synthesizer.Dimensional.Rate.Oscillator + Synthesizer.Dimensional.RateAmplitude.Analysis + Synthesizer.Dimensional.RateAmplitude.Cut + Synthesizer.Dimensional.RateAmplitude.Control + Synthesizer.Dimensional.RateAmplitude.Displacement + Synthesizer.Dimensional.RateAmplitude.File + Synthesizer.Dimensional.RateAmplitude.Filter + Synthesizer.Dimensional.RateAmplitude.Instrument + Synthesizer.Dimensional.RateAmplitude.Noise + Synthesizer.Dimensional.RateAmplitude.Play + Synthesizer.Dimensional.RateAmplitude.Signal + Synthesizer.Dimensional.Straight.Displacement + Synthesizer.Dimensional.Straight.Signal + +Executable demonstration + If !flag(buildExamples) + Buildable: False + GHC-Options: -Wall -O2 -fexcess-precision -fvia-C -optc-O2 +-- -ddump-simpl-stats + Hs-Source-Dirs: src + Main-Is: Synthesizer/Dimensional/RateAmplitude/Demonstration.hs + +Executable traumzauberbaum + If !flag(buildExamples) + Buildable: False + GHC-Options: -Wall -O2 -fexcess-precision -fvia-C -optc-O2 + Hs-Source-Dirs: src + Main-Is: Synthesizer/Dimensional/RateAmplitude/Traumzauberbaum.hs + +Executable test + If !flag(buildTests) + Buildable: False + GHC-Options: -Wall + Hs-Source-Dirs: src + Other-Modules: + Test.Utility + Test.Sound.Synthesizer.Plain.Analysis + Test.Sound.Synthesizer.Plain.Control + Test.Sound.Synthesizer.Plain.Filter + Test.Sound.Synthesizer.Plain.Interpolation + Test.Sound.Synthesizer.Plain.Oscillator + Test.Sound.Synthesizer.Plain.ToneModulation + Test.Sound.Synthesizer.Plain.Wave + Main-Is: Test/Main.hs + +Executable fusiontest + If !flag(buildProfilers) + Buildable: False + GHC-Options: -Wall -fexcess-precision -ddump-simpl-stats + Hs-Source-Dirs: speedtest, src + Main-Is: FusionTest.hs + +Executable speedtest + If !flag(buildProfilers) + Buildable: False + GHC-Options: -Wall -fexcess-precision -optc-ffast-math -optc-O3 + -- -funfolding-use-threshold=20 -funfolding-creation-threshold=100 + -- -optc-march=pentium4 -optc-mfpmath=sse + Hs-Source-Dirs: speedtest, src + Main-Is: SpeedTest.hs + +Executable speedtest-exp + If !flag(buildProfilers) + Buildable: False + GHC-Options: -Wall -fexcess-precision + Hs-Source-Dirs: speedtest, src + Main-Is: SpeedTestExp.hs + If flag(splitBase) + Build-Depends: + old-time >= 1.0 && < 1.1, directory >= 1.0 && < 1.1 + +Executable speedtest-simple + If !flag(buildProfilers) + Buildable: False + GHC-Options: -Wall + Hs-Source-Dirs: speedtest, src + Main-Is: SpeedTestSimple.hs