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/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/src/Demonstration.hs b/src/Demonstration.hs
new file mode 100644
--- /dev/null
+++ b/src/Demonstration.hs
@@ -0,0 +1,6 @@
+module Main where
+
+import qualified Synthesizer.Dimensional.RateAmplitude.Demonstration as Demo
+
+main :: IO ()
+main = Demo.main
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,91 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{- |
+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.Amplitude as Amp
+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.D scalar y) yv where
+ toSamples =
+ SigA.vectorSamples (DN.toNumber . DN.rewriteDimension Dim.toScalar)
+-}
+
+{-
+instance (C flat y, OccScalar.C y amp, Amp.C amp, Ring.C y) =>
+ C (SigA.T amp flat) y where
+ unwrappedToSamples =
+ SigA.scalarSamples OccScalar.toScalar .
+ (\x ->
+ SigA.fromSamples
+ (SigA.privateAmplitude x)
+ (unwrappedToSamples (SigA.signal x)))
+-}
+
+{-
+we could use OccasionallyScalar class,
+but this would flood user code with OccScalar.C y y constraints
+-}
+class Amp.C amp => Amplitude y amp where
+ toScalar :: amp -> y
+
+instance Ring.C y => Amplitude y Amp.Flat where
+ toScalar = const Ring.one
+
+instance (Dim.IsScalar v) => Amplitude y (DN.T v y) where
+ toScalar = DN.toNumber . DN.rewriteDimension Dim.toScalar
+
+instance (C flat y, Amplitude y amp, Ring.C y) =>
+ C (SigA.T amp flat) y where
+ unwrappedToSamples =
+ SigA.scalarSamples 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,71 @@
+{- |
+Copyright : (c) Henning Thielemann 2008-2009
+License : GPL
+
+Maintainer : synthesizer@henning-thielemann.de
+Stability : provisional
+Portability : requires multi-parameter type classes
+
+Class that allows unified handling of
+@SigS.T@ and @SigA.R 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 Synthesizer.Dimensional.Amplitude as Amp
+
+{-
+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.processSamplesPrivate (unwrappedProcessSamples f)
+
+instance (C sig, Amp.C amp) => C (SigA.T amp sig) where
+ unwrappedProcessSamples f =
+ (\(SigA.Cons amp sig) ->
+ SigA.Cons amp (unwrappedProcessSamples f sig))
diff --git a/src/Synthesizer/Dimensional/Abstraction/HomogeneousGen.hs b/src/Synthesizer/Dimensional/Abstraction/HomogeneousGen.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/Dimensional/Abstraction/HomogeneousGen.hs
@@ -0,0 +1,125 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{- |
+Copyright : (c) Henning Thielemann 2009
+License : GPL
+
+Maintainer : synthesizer@henning-thielemann.de
+Stability : provisional
+Portability : requires multi-parameter type classes
+
+Class similar to "Synthesizer.Dimensional.Abstraction.Homogeneous"
+but it can be used for different storage types.
+-}
+module Synthesizer.Dimensional.Abstraction.HomogeneousGen where
+
+import Synthesizer.Dimensional.Amplitude (Flat(Flat))
+import qualified Synthesizer.Dimensional.Amplitude as Amp
+import qualified Synthesizer.State.Signal as Sig
+import qualified Synthesizer.Storable.Signal as SigSt
+import qualified Synthesizer.Basic.WaveSmoothed as WaveSmooth
+import qualified Synthesizer.Basic.Wave as Wave
+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 Data.Tuple.HT (mapSnd, )
+
+-- import NumericPrelude
+-- import PreludeBase
+-- import Prelude ()
+
+{-# INLINE processSamples #-}
+processSamples ::
+ (C amp storage0 signal0, C amp storage1 signal1) =>
+ (storage0 y0 -> storage1 y1) -> RP.T s signal0 y0 -> RP.T s signal1 y1
+processSamples f =
+ RP.fromSignal . plainProcessSamples f . RP.toSignal
+
+
+plainProcessSamples ::
+ (C amp storage0 signal0, C amp storage1 signal1) =>
+ (storage0 y0 -> storage1 y1) ->
+ (signal0 y0 -> signal1 y1)
+plainProcessSamples f =
+ plainWrap . mapSnd f . plainUnwrap
+
+
+wrap ::
+ (C amp storage signal) =>
+ (amp, storage y) -> RP.T s signal y
+wrap =
+ RP.fromSignal . plainWrap
+
+unwrap ::
+ (C amp storage signal) =>
+ RP.T s signal y -> (amp, storage y)
+unwrap =
+ plainUnwrap . RP.toSignal
+
+
+{- |
+Functions using this class might define their own class with functional dependencies,
+that allow to infer automatically, say,
+that an amplitude input signal requires an amplitude output signal.
+-}
+class C amp storage signal |
+ signal -> amp storage where
+ plainWrap :: (amp, storage y) -> signal y
+ plainUnwrap :: signal y -> (amp, storage y)
+
+instance C Flat Sig.T Sig.T where
+ plainWrap = snd
+ plainUnwrap = (,) Flat
+
+instance C Flat SigSt.T SigSt.T where
+ plainWrap = snd
+ plainUnwrap = (,) Flat
+
+instance C Flat sig (SigS.T sig) where
+ plainWrap = SigS.Cons . snd
+ plainUnwrap = (,) Flat . SigS.samples
+
+instance (Amp.C amp) => C amp sig (SigA.T amp (SigS.T sig)) where
+ plainWrap = uncurry SigA.Cons . mapSnd SigS.Cons
+ plainUnwrap (SigA.Cons amp sig) = (amp, SigS.samples sig)
+
+
+
+
+
+{- |
+These instances are used in oscillator
+where we even do not need homogenity,
+since values from the waveform
+go untouched to the output signal.
+-}
+
+instance C Flat (Wave.T t) (Wave.T t) where
+ plainWrap = snd
+ plainUnwrap = (,) Flat
+
+instance C Flat (WaveSmooth.T t) (WaveSmooth.T t) where
+ plainWrap = snd
+ plainUnwrap = (,) Flat
+
+instance (Amp.C amp) => C amp (Wave.T t) (SigA.T amp (Wave.T t)) where
+ plainWrap = uncurry SigA.Cons
+ plainUnwrap (SigA.Cons amp sig) = (amp, sig)
+
+instance (Amp.C amp) => C amp (WaveSmooth.T t) (SigA.T amp (WaveSmooth.T t)) where
+ plainWrap = uncurry SigA.Cons
+ plainUnwrap (SigA.Cons amp sig) = (amp, 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.hs b/src/Synthesizer/Dimensional/Amplitude.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/Dimensional/Amplitude.hs
@@ -0,0 +1,27 @@
+module Synthesizer.Dimensional.Amplitude where
+
+import qualified Number.DimensionTerm as DN
+import qualified Algebra.DimensionTerm as Dim
+
+{- |
+Can be used as amplitude value in 'Synthesizer.Dimensional.Causal.Process.T'
+or in 'Synthesizer.Dimensional.Abstraction.HomogeneousGen',
+whenever the signal has no amplitude.
+It would be a bad idea to omit the @Flat@ parameter
+in 'Synthesizer.Dimensional.Causal.Process.applyFlat' routine,
+since 'Synthesizer.Dimensional.Causal.Process.apply' can still be used
+but the correspondence between amplitude type and sample type is lost.
+-}
+data Flat = Flat
+
+{- |
+This class is used to make 'Synthesizer.Dimensional.Causal.Process.mapAmplitude'
+both flexible and a bit safe.
+Its instances are dimensional numbers 'DN.T' and 'Flat'.
+It should not be necessary to add more instances.
+-}
+class C amp where
+
+instance C Flat where
+
+instance Dim.C v => C (DN.T v y) where
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,171 @@
+{- |
+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 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.S 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,221 @@
+{- |
+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 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,125 @@
+{- |
+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 contrast 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
+ (SigA.vectorSamples (toAmplitudeScalar z) x +
+ SigA.vectorSamples (toAmplitudeScalar z) 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 -> (SigA.vectorSamples (toAmplitudeScalar z) 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
+
+{- |
+Distort the signal using a flat function.
+The first signal gives the scaling of the function.
+If the scaling is c and the input sample is y,
+then @c * f(y/c)@ is output.
+This way we can use an (efficient) flat function
+and have a simple, yet dimension conform, way of controlling the distortion.
+E.g. if the distortion function is @tanh@
+then the value @c@ controls the saturation level.
+-}
+{-# 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,232 @@
+{- |
+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.Dimensional.Amplitude as Amp
+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 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 amp sig yv =
+ Cons {
+ privateAmplitude :: amp {-^ scaling of the values -}
+ , signal :: sig yv {-^ the embedded signal -}
+ }
+-- deriving (Eq, Show)
+
+instance (Show amp, Format.C sig) => Format.C (T amp sig) where
+ format p (Cons amp sig) =
+ showParen (p >= 10)
+ (showString "amplitudeSignal " . showsPrec 11 amp .
+ showString " " . Format.format 11 sig)
+
+instance (Show amp, Show yv, Format.C sig) => Show (T amp sig yv) where
+ showsPrec = Format.format
+
+type R s v y yv = RP.T s (S v y) yv
+type S v y = D v y SigS.S -- kind * -> *
+type D v y = T (DN.T v y)
+
+{-
+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 (D v y s) where
+ fmap f (Cons amp ss) = Cons amp (map f ss)
+-}
+
+{-# INLINE amplitude #-}
+amplitude :: (Ind.C w, Dim.C v) =>
+ w (D v y sig) yv -> DN.T v y
+amplitude = privateAmplitude . Ind.toSignal
+
+{-# INLINE samples #-}
+samples :: (Ind.C w, Dim.C v) =>
+ w (D v y (SigS.T sig)) yv -> sig yv
+samples = privateSamples . Ind.toSignal
+
+{-# INLINE privateSamples #-}
+privateSamples :: (Amp.C amp) =>
+ T amp (SigS.T sig) yv -> sig yv
+privateSamples = SigS.samples . signal
+
+{-# INLINE phantomSignal #-}
+phantomSignal ::
+ RP.T s (D 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 (D 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 :: (Ind.C w, Ring.C y, Amp.C amp) =>
+ (amp -> y) -> w (T amp SigS.S) y -> Sig.T y
+scalarSamples toAmpScalar =
+ scalarSamplesPrivate toAmpScalar . Ind.toSignal
+
+{-# INLINE scalarSamplesGeneric #-}
+scalarSamplesGeneric ::
+ (Ind.C w, Ring.C y, Dim.C v, SigG.Transform sig y) =>
+ (DN.T v y -> y) -> w (D 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) -> D v0 y sig yv -> D 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 -> SigS.R s yv -> RP.T s (T amp SigS.S) 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.S 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.S 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 :: (Ring.C y, Amp.C amp) =>
+ (amp -> y) -> T amp SigS.S 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, SigG.Transform sig y) =>
+ (DN.T v y -> y) -> D 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 :: (Dim.C v) => DN.T v y -> Sig.T yv -> R s v y yv
+fromSamples :: {- (Amp.C amp) => -} amp -> Sig.T yv -> RP.T s (T amp SigS.S) yv
+fromSamples amp = fromSignal amp . SigS.fromSamples
+
+{-# INLINE fromScalarSamples #-}
+fromScalarSamples :: {- (Amp.C amp) => -}
+ amp -> Sig.T y -> RP.T s (T amp SigS.S) y
+fromScalarSamples = fromSamples
+
+{-# INLINE fromVectorSamples #-}
+fromVectorSamples :: {- (Amp.C amp) => -}
+ amp -> Sig.T yv -> RP.T s (T amp SigS.S) yv
+fromVectorSamples = fromSamples
+
+{-# INLINE replaceAmplitude #-}
+replaceAmplitude :: (Ind.C w, Dim.C v0, Dim.C v1) =>
+ DN.T v1 y -> w (D v0 y sig) yv -> w (D v1 y sig) yv
+replaceAmplitude amp = Ind.processSignal (replaceAmplitudePrivate amp)
+
+{-# INLINE replaceSamples #-}
+replaceSamples :: (Ind.C w, Dim.C v) =>
+ sig1 yv1 -> w (D v y sig0) yv0 -> w (D 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 -> D v0 y sig yv -> D v1 y sig yv
+replaceAmplitudePrivate amp = Cons amp . signal
+
+{-# INLINE replaceSamplesPrivate #-}
+replaceSamplesPrivate :: (Dim.C v) =>
+ sig1 yv1 -> D v y sig0 yv0 -> D 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 (D v y (SigS.T sig0)) yv0 -> w (D v y (SigS.T sig1)) yv1
+processSamples f =
+ Ind.processSignal (processSamplesPrivate f)
+
+{-# INLINE processSamplesPrivate #-}
+processSamplesPrivate :: (Dim.C v) =>
+ (sig0 yv0 -> sig1 yv1) ->
+ D v y (SigS.T sig0) yv0 -> D v y (SigS.T sig1) yv1
+processSamplesPrivate f (Cons amp sig) =
+ Cons amp (SigS.processSamplesPrivate f sig)
+
+
+{-# INLINE asTypeOfAmplitude #-}
+asTypeOfAmplitude :: y -> w (D v y sig) yv -> y
+asTypeOfAmplitude = const
diff --git a/src/Synthesizer/Dimensional/Arrow.hs b/src/Synthesizer/Dimensional/Arrow.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/Dimensional/Arrow.hs
@@ -0,0 +1,140 @@
+{- |
+Adaption of "Control.Arrow" to signal processes involving amplitudes.
+This class unifies "Synthesizer.Dimensional.Map"
+and "Synthesizer.Dimensional.Causal.Process".
+-}
+module Synthesizer.Dimensional.Arrow where
+
+import qualified Synthesizer.Dimensional.Map as Map
+import Data.Tuple.HT (mapFst, mapSnd, mapPair, )
+
+import qualified Prelude as P
+import Prelude hiding (map, id, fst, snd, )
+
+
+class C arrow where
+ map ::
+ Map.T amp0 amp1 yv0 yv1 ->
+ arrow amp0 amp1 yv0 yv1
+ (>>>) ::
+ arrow amp0 amp1 yv0 yv1 ->
+ arrow amp1 amp2 yv1 yv2 ->
+ arrow amp0 amp2 yv0 yv2
+ first ::
+ arrow amp0 amp1 yv0 yv1 ->
+ arrow (amp0, amp) (amp1, amp) (yv0, yv) (yv1, yv)
+ second ::
+ arrow amp0 amp1 yv0 yv1 ->
+ arrow (amp, amp0) (amp, amp1) (yv, yv0) (yv, yv1)
+ (***) ::
+ arrow amp0 amp1 yv0 yv1 ->
+ arrow amp2 amp3 yv2 yv3 ->
+ arrow (amp0, amp2) (amp1, amp3) (yv0, yv2) (yv1, yv3)
+ (&&&) ::
+ arrow amp amp0 yv yv0 ->
+ arrow amp amp1 yv yv1 ->
+ arrow amp (amp0, amp1) yv (yv0, yv1)
+
+ {-# INLINE second #-}
+ second arr = Map.swap ^<< first arr <<^ Map.swap
+ {-# INLINE (***) #-}
+ f *** g = first f <<< second g
+ {-# INLINE (&&&) #-}
+ f &&& g = f***g <<^ Map.double
+
+
+instance C Map.T where
+ map = P.id
+ (Map.Cons f) >>> (Map.Cons g) =
+ Map.Cons $ \x ->
+ let (y, h) = f x
+ (z, k) = g y
+ in (z, k . h)
+ first (Map.Cons f) =
+ Map.Cons $ \(x,z) ->
+ let (y, g) = f x
+ in ((y,z), mapFst g)
+ second (Map.Cons f) =
+ Map.Cons $ \(z,x) ->
+ let (y, g) = f x
+ in ((z,y), mapSnd g)
+ (Map.Cons f) *** (Map.Cons g) =
+ Map.Cons $ \(x,y) ->
+ let (z, h) = f x
+ (w, k) = g y
+ in ((z,w), mapPair (h,k))
+ (Map.Cons f) &&& (Map.Cons g) =
+ Map.Cons $ \x ->
+ let (y, h) = f x
+ (z, k) = g x
+ in ((y,z), \s -> (h s, k s))
+
+
+infixr 3 ***
+infixr 3 &&&
+infixr 1 >>>, ^>>, >>^
+infixr 1 <<<, ^<<, <<^
+
+
+{-# INLINE compose #-}
+compose :: (C arrow) =>
+ arrow amp0 amp1 yv0 yv1 ->
+ arrow amp1 amp2 yv1 yv2 ->
+ arrow amp0 amp2 yv0 yv2
+compose = (>>>)
+
+{-# INLINE (<<<) #-}
+(<<<) :: (C arrow) =>
+ arrow amp1 amp2 yv1 yv2 ->
+ arrow amp0 amp1 yv0 yv1 ->
+ arrow amp0 amp2 yv0 yv2
+(<<<) = flip (>>>)
+
+
+{-# INLINE split #-}
+split :: (C arrow) =>
+ arrow amp0 amp1 yv0 yv1 ->
+ arrow amp2 amp3 yv2 yv3 ->
+ arrow (amp0, amp2) (amp1, amp3) (yv0, yv2) (yv1, yv3)
+split = (***)
+
+{-# INLINE fanout #-}
+fanout :: (C arrow) =>
+ arrow amp amp0 yv yv0 ->
+ arrow amp amp1 yv yv1 ->
+ arrow amp (amp0, amp1) yv (yv0, yv1)
+fanout = (&&&)
+
+-- * map functions
+
+{-# INLINE (^>>) #-}
+-- | Precomposition with a pure function.
+(^>>) :: (C arrow) =>
+ Map.T amp0 amp1 yv0 yv1 ->
+ arrow amp1 amp2 yv1 yv2 ->
+ arrow amp0 amp2 yv0 yv2
+f ^>> a = map f >>> a
+
+{-# INLINE (>>^) #-}
+-- | Postcomposition with a pure function.
+(>>^) :: (C arrow) =>
+ arrow amp0 amp1 yv0 yv1 ->
+ Map.T amp1 amp2 yv1 yv2 ->
+ arrow amp0 amp2 yv0 yv2
+a >>^ f = a >>> map f
+
+{-# INLINE (<<^) #-}
+-- | Precomposition with a pure function (right-to-left variant).
+(<<^) :: (C arrow) =>
+ arrow amp1 amp2 yv1 yv2 ->
+ Map.T amp0 amp1 yv0 yv1 ->
+ arrow amp0 amp2 yv0 yv2
+a <<^ f = a <<< map f
+
+{-# INLINE (^<<) #-}
+-- | Postcomposition with a pure function (right-to-left variant).
+(^<<) :: (C arrow) =>
+ Map.T amp1 amp2 yv1 yv2 ->
+ arrow amp0 amp1 yv0 yv1 ->
+ arrow amp0 amp2 yv0 yv2
+f ^<< a = map f <<< a
diff --git a/src/Synthesizer/Dimensional/Causal/ControlledProcess.hs b/src/Synthesizer/Dimensional/Causal/ControlledProcess.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/Dimensional/Causal/ControlledProcess.hs
@@ -0,0 +1,502 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE Rank2Types #-}
+{- |
+Copyright : (c) Henning Thielemann 2008
+License : GPL
+
+Maintainer : synthesizer@henning-thielemann.de
+Stability : provisional
+Portability : requires multi-parameter type classes (Flat)
+
+
+Basic definitions for causal signal processors
+which are controlled by another signal.
+Additionally to "Synthesizer.Dimensional.ControlledProcess"
+you can convert those processes to plain causal processes
+in the case of equal audio and control rates (synchronous control).
+
+It is sensible to bundle the functions
+"computation of internal parameters" and
+"running the main process",
+since computation of the internal parameters
+depends on the sample rate of the main process
+in case of frequency control values
+even though the computation of internal parameters happens
+at a different sample rate.
+
+ToDo:
+ - Is it better to provide the conversion method not by a record
+ but by a type class?
+ The difficulty with this is,
+ how to handle global parameters like the filter order?
+ - Note, that parameters might be computed by different ways.
+ Thus a type class with functional dependencies
+ for automatic selection of input types and conversion
+ will not always be flexible enough.
+ - Is it possible and reasonable to hide the type parameter
+ for the internal control parameter
+ since the user does not need to know it?
+ - The internal parameters that the converter generate
+ usually depend on the sample rate of the (target) audio signal.
+ However, it does not depend on the sample rate of control signal
+ where it is applied to.
+ How can we ensure that it is not used somewhere else?
+ We could discourage access to it at all.
+ But it might be sensible to define new external parameters
+ in terms of existing ones.
+ We could add a phantom 's' type parameter
+ to internal control parameters.
+ Would this do the trick? Is this convenient?
+-}
+module Synthesizer.Dimensional.Causal.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.Straight.Displacement as DispS
+import qualified Synthesizer.Dimensional.Amplitude.Signal as SigA
+import qualified Synthesizer.Dimensional.Causal.Process as CausalD
+import qualified Synthesizer.Dimensional.Map as MapD
+import qualified Synthesizer.Dimensional.Amplitude as Amp
+import qualified Synthesizer.Causal.Process as Causal
+import qualified Synthesizer.Causal.Interpolation as Interpolation
+import qualified Synthesizer.Interpolation.Class as Interpol
+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 Foreign.Storable.Newtype as Store
+import Foreign.Storable (Storable(..))
+
+import NumericPrelude
+import PreludeBase as P
+
+
+{- |
+This is quite analogous to Dimensional.Causal.Process
+but adds the @conv@ parameter for conversion
+from intuitive external parameters to internal parameters.
+-}
+data T conv proc = Cons {
+ converter :: conv,
+ processor :: proc
+ }
+
+
+{- |
+The Functor instance allows
+to define an allpass phaser as ControlledProcess,
+reusing the allpass cascade provided as ControlledProcess.
+It is also possible to define a lowpass filter
+with resonance as ControlledProcess
+based on the universal filter ControlledProcess.
+-}
+instance Functor (T conv) where
+ fmap f proc =
+ Cons (converter proc) (f $ processor proc)
+
+{- |
+@ecAmp@ is a set of physical units for the external control parameters,
+@ec@ is the type for the external control parameters,
+@ic@ for internal control parameters.
+-}
+type Converter s ecAmp ec ic =
+ MapD.T ecAmp Amp.Flat ec (RateDep s ic)
+
+newtype RateDep s ic = RateDep {unRateDep :: ic}
+
+instance Interpol.C a ic => Interpol.C a (RateDep s ic) where
+ scaleAndAccumulate =
+ Interpol.makeMac RateDep unRateDep
+
+instance Storable ic => Storable (RateDep s ic) where
+ sizeOf = Store.sizeOf unRateDep
+ alignment = Store.alignment unRateDep
+ peek = Store.peek RateDep
+ poke = Store.poke unRateDep
+
+
+{- |
+This function is intended for implementing high-level dimensional processors
+from low-level processors.
+It introduces the sample rate tag @s@.
+-}
+{-# INLINE makeConverter #-}
+makeConverter ::
+ (ecAmp -> ec -> ic) -> Converter s ecAmp ec ic
+makeConverter f =
+ MapD.Cons $ (,) Amp.Flat . (RateDep.) . f
+
+{-# INLINE causalFromConverter #-}
+causalFromConverter ::
+ Converter s ecAmp ec ic ->
+ CausalD.T s ecAmp CausalD.Flat ec (RateDep s ic)
+causalFromConverter = CausalD.map
+
+
+{-# INLINE joinSynchronousPlain #-}
+joinSynchronousPlain ::
+ T (Converter s ecAmp ec ic)
+ (CausalD.T s (ampIn, CausalD.Flat) ampOut (sampIn, RateDep s ic) sampOut) ->
+ CausalD.T s (ecAmp, ampIn) ampOut (ec, sampIn) sampOut
+joinSynchronousPlain p =
+ processor p CausalD.<<<
+ MapD.swap CausalD.^<<
+ CausalD.first (causalFromConverter (converter p))
+
+{-# INLINE joinSynchronous #-}
+joinSynchronous ::
+ Proc.T s u t
+ (T (Converter s ecAmp ec ic)
+ (CausalD.T s (ampIn, CausalD.Flat) ampOut (sampIn, RateDep s ic) sampOut)) ->
+ Proc.T s u t (CausalD.T s (ecAmp, ampIn) ampOut (ec, sampIn) sampOut)
+joinSynchronous cp =
+ fmap joinSynchronousPlain cp
+
+
+{-# INLINE joinFirstSynchronousPlain #-}
+joinFirstSynchronousPlain ::
+ T (Converter s ecAmp ec ic, a)
+ (CausalD.T s (ampIn, CausalD.Flat) ampOut (sampIn, RateDep s ic) sampOut) ->
+ T a
+ (CausalD.T s (ecAmp, ampIn) ampOut (ec, sampIn) sampOut)
+joinFirstSynchronousPlain p =
+ Cons {
+ converter = snd (converter p),
+ processor = joinSynchronousPlain (Cons (fst (converter p)) (processor p))
+ }
+
+{-
+With this signature we deconstruct a right biased pair tree in the ampIn parameter of T
+and build a left biased pair tree in the corresponding output parameter.
+We could also use a pair of heterogeneous lists.
+But the effect is always, that the list is reversed.
+-}
+{-# INLINE joinFirstSynchronous #-}
+joinFirstSynchronous ::
+ Proc.T s u t
+ (T (Converter s ecAmp ec ic, a)
+ (CausalD.T s (ampIn, CausalD.Flat) ampOut (sampIn, RateDep s ic) sampOut)) ->
+ Proc.T s u t
+ (T a
+ (CausalD.T s (ecAmp, ampIn) ampOut (ec, sampIn) sampOut))
+joinFirstSynchronous cp =
+ fmap joinFirstSynchronousPlain cp
+
+{-
+{-# INLINE runSynchronous #-}
+runSynchronous ::
+ Proc.T s u t (T s (Convert ecAmp ec ic) (CausalD.Flat, ampIn) ampOut (RateDep s ic, sampIn) sampOut) ->
+ Proc.T s u t (CausalD.T s (ecAmp, ampIn) ampOut (ec, sampIn) sampOut)
+runSynchronous cp =
+ do p <- cp
+ return (processor p . converter p)
+-}
+
+{-# INLINE runSynchronous1 #-}
+runSynchronous1 :: (Dim.C v) =>
+ Proc.T s u t
+ (T (Converter s (DN.T v ecAmp) ec ic)
+ (CausalD.T s (ampIn, CausalD.Flat) ampOut (sampIn, RateDep s ic) sampOut)) ->
+ Proc.T s u t
+ (SigA.R s v ecAmp ec -> CausalD.T s ampIn ampOut sampIn sampOut)
+runSynchronous1 =
+ fmap CausalD.applyFst . joinSynchronous
+
+
+{-# INLINE runSynchronousPlain2 #-}
+runSynchronousPlain2 :: (Dim.C v0, Dim.C v1) =>
+ (T (Converter s (DN.T v0 ecAmp0, DN.T v1 ecAmp1) (ec0, ec1) ic)
+ (CausalD.T s (ampIn, CausalD.Flat) ampOut (sampIn, RateDep s ic) sampOut)) ->
+ (SigA.R s v0 ecAmp0 ec0 ->
+ SigA.R s v1 ecAmp1 ec1 ->
+ CausalD.T s ampIn ampOut sampIn sampOut)
+runSynchronousPlain2 causal =
+ let causalPairs =
+ joinSynchronousPlain causal CausalD.<<^ MapD.balanceLeft
+ in \x y ->
+ (causalPairs `CausalD.applyFst` x) `CausalD.applyFst` y
+
+{-# INLINE runSynchronous2 #-}
+runSynchronous2 :: (Dim.C v0, Dim.C v1) =>
+ Proc.T s u t
+ (T (Converter s (DN.T v0 ecAmp0, DN.T v1 ecAmp1) (ec0, ec1) ic)
+ (CausalD.T s (ampIn, CausalD.Flat) ampOut (sampIn, RateDep s ic) sampOut)) ->
+ Proc.T s u t
+ (SigA.R s v0 ecAmp0 ec0 ->
+ SigA.R s v1 ecAmp1 ec1 ->
+ CausalD.T s ampIn ampOut sampIn sampOut)
+runSynchronous2 cp =
+ fmap runSynchronousPlain2 cp
+
+{-
+{-# INLINE runSynchronous3 #-}
+runSynchronous3 ::
+ Proc.T s u t (T s (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, RealField.C t) =>
+ Interpolation.T t (RateDep s ic) ->
+ Proc.T s u t
+ (T (Converter s ecAmp ec ic)
+ (CausalD.T s (ampIn, CausalD.Flat) ampOut (sampIn, RateDep s ic) sampOut)) ->
+ Rate.T r u t ->
+ SigS.R r (RateDep s ic) ->
+ Proc.T s u t
+ (CausalD.T s ampIn ampOut sampIn sampOut)
+runAsynchronous ip cp srcRate sig =
+ do p <- cp
+ k <- fmap
+ (DN.divToScalar (Rate.toDimensionNumber srcRate))
+ Proc.getSampleRate
+ return $
+ CausalD.applyFlatFst (processor p CausalD.<<^ MapD.swap) $
+ RP.fromSignal $
+ Causal.apply
+ (Interpolation.relativeConstantPad ip zero (SigS.toSamples sig))
+ (Sig.repeat k)
+
+{-# INLINE runAsynchronousBuffered #-}
+runAsynchronousBuffered ::
+ (Dim.C u, RealField.C t) =>
+ Interpolation.T t (RateDep s ic) ->
+ Proc.T s u t
+ (T (Converter s ecAmp ec ic)
+ (CausalD.T s (ampIn, CausalD.Flat) ampOut (sampIn, RateDep s ic) sampOut)) ->
+ Rate.T r u t ->
+ SigS.R r (RateDep s ic) ->
+ Proc.T s u t
+ (CausalD.T s ampIn ampOut sampIn sampOut)
+runAsynchronousBuffered ip cp srcRate sig =
+ do p <- cp
+ k <- fmap
+ (DN.divToScalar (Rate.toDimensionNumber srcRate))
+ Proc.getSampleRate
+ return $
+ CausalD.applyFlatFst (processor p CausalD.<<^ MapD.swap) $
+ RP.fromSignal $
+ Causal.apply
+ (Interpolation.relativeConstantPad ip zero
+ (Sig.fromList $ Sig.toList $ SigS.toSamples sig))
+ (Sig.repeat k)
+
+
+{-# INLINE applyConverter1 #-}
+applyConverter1 :: (Dim.C v) =>
+ Converter s (DN.T v ecAmp) ec ic ->
+ SigA.R s v ecAmp ec -> SigS.R s (RateDep s ic)
+applyConverter1 (MapD.Cons f) x =
+ DispS.map (snd $ f (SigA.amplitude x)) (SigA.phantomSignal x)
+
+{-# INLINE runAsynchronous1 #-}
+runAsynchronous1 ::
+ (Dim.C u, Dim.C v, RealField.C t) =>
+ Interpolation.T t (RateDep s ic) ->
+ Proc.T s u t
+ (T (Converter s (DN.T v ecAmp) ec ic)
+ (CausalD.T s (ampIn, CausalD.Flat) ampOut (sampIn, RateDep s ic) sampOut)) ->
+ SigP.T u t (SigA.S v ecAmp) ec ->
+ Proc.T s u t
+ (CausalD.T s ampIn ampOut sampIn sampOut)
+runAsynchronous1 ip cp x =
+ let (srcRate,sig) = SigP.toSignal x
+ in do p <- cp
+ runAsynchronous ip cp srcRate (applyConverter1 (converter p) sig)
+
+{-# INLINE processAsynchronous1 #-}
+processAsynchronous1 ::
+ (Dim.C u, Dim.C v, RealField.C t) =>
+ Interpolation.T t (RateDep s ic) ->
+ Proc.T s u t
+ (T (Converter s (DN.T v ecAmp) ec ic)
+ (CausalD.T s (ampIn, CausalD.Flat) ampOut (sampIn, RateDep s ic) sampOut)) ->
+ DN.T (Dim.Recip u) t ->
+ (forall r. Proc.T r u t (SigA.R r v ecAmp ec)) ->
+ Proc.T s u t
+ (CausalD.T s ampIn ampOut sampIn sampOut)
+processAsynchronous1 ip cp rate x =
+ let sig = RP.fromSignal $ Proc.run rate (fmap RP.toSignal x)
+ in do p <- cp
+ runAsynchronous ip cp (Rate.fromDimensionNumber rate)
+ (applyConverter1 (converter p) sig)
+
+
+{-# INLINE applyConverter2 #-}
+applyConverter2 :: (Dim.C v0, Dim.C v1) =>
+ Converter s (DN.T v0 ecAmp0, DN.T v1 ecAmp1) (ec0, ec1) ic ->
+ SigA.R s v0 ecAmp0 ec0 ->
+ SigA.R s v1 ecAmp1 ec1 ->
+ SigS.R s (RateDep s ic)
+applyConverter2 (MapD.Cons f) x y =
+ SigS.fromSamples $
+ Sig.map (snd $ f (SigA.amplitude x, SigA.amplitude y)) $
+ Sig.zip (SigA.samples x) (SigA.samples y)
+
+{- |
+Using two SigP.T's as input has the disadvantage
+that their rates must be compared dynamically.
+It is not possible with our data structures
+to use one rate for multiple signals.
+We could also allow the input of a Rate.T and two Proc.T's,
+since this is the form we get from the computation routines.
+But this way we lose sharing.
+-}
+{-# INLINE runAsynchronous2 #-}
+runAsynchronous2 ::
+ (Dim.C u, Dim.C v0, Dim.C v1, RealField.C t) =>
+ Interpolation.T t (RateDep s ic) ->
+ Proc.T s u t
+ (T (Converter s (DN.T v0 ecAmp0, DN.T v1 ecAmp1) (ec0, ec1) ic)
+ (CausalD.T s (ampIn, CausalD.Flat) ampOut (sampIn, RateDep s ic) sampOut)) ->
+ SigP.T u t (SigA.S v0 ecAmp0) ec0 ->
+ SigP.T u t (SigA.S v1 ecAmp1) ec1 ->
+ Proc.T s u t
+ (CausalD.T s ampIn ampOut sampIn sampOut)
+runAsynchronous2 ip cp x y =
+ let (srcRateX,sigX) = SigP.toSignal x
+ (srcRateY,sigY) = SigP.toSignal y
+ srcRate = Rate.common "ControlledProcess.runAsynchronous2" srcRateX srcRateY
+ in do p <- cp
+ runAsynchronous ip cp srcRate
+ (applyConverter2 (converter p) sigX sigY)
+
+
+{- |
+This function will be more commonly used than 'runAsynchronous2',
+but it disallows sharing of control signals.
+It can be easily defined in terms of 'runAsynchronous2' and 'SigP.runProcess',
+but the implementation here does not need the check for equal sample rates.
+-}
+{-# INLINE processAsynchronous2 #-}
+processAsynchronous2 ::
+ (Dim.C u, Dim.C v0, Dim.C v1, RealField.C t) =>
+ Interpolation.T t (RateDep s ic) ->
+ Proc.T s u t
+ (T (Converter s (DN.T v0 ecAmp0, DN.T v1 ecAmp1) (ec0, ec1) ic)
+ (CausalD.T s (ampIn, CausalD.Flat) ampOut (sampIn, RateDep s ic) sampOut)) ->
+ DN.T (Dim.Recip u) t ->
+ (forall r. Proc.T r u t (SigA.R r v0 ecAmp0 ec0)) ->
+ (forall r. Proc.T r u t (SigA.R r v1 ecAmp1 ec1)) ->
+ Proc.T s u t
+ (CausalD.T s ampIn ampOut sampIn sampOut)
+processAsynchronous2 ip cp rate x y =
+ let sigX = RP.fromSignal $ Proc.run rate (fmap RP.toSignal x)
+ sigY = RP.fromSignal $ Proc.run rate (fmap RP.toSignal y)
+ in do p <- cp
+ runAsynchronous ip cp (Rate.fromDimensionNumber rate)
+ (applyConverter2 (converter p) sigX sigY)
+
+
+{-# INLINE processAsynchronousNaive2 #-}
+processAsynchronousNaive2 ::
+ (Dim.C u, Dim.C v0, Dim.C v1, RealField.C t) =>
+ Interpolation.T t (RateDep s ic) ->
+ Proc.T s u t
+ (T (Converter s (DN.T v0 ecAmp0, DN.T v1 ecAmp1) (ec0, ec1) ic)
+ (CausalD.T s (ampIn, CausalD.Flat) ampOut (sampIn, RateDep s ic) sampOut)) ->
+ DN.T (Dim.Recip u) t ->
+ (forall r. Proc.T r u t (SigA.R r v0 ecAmp0 ec0)) ->
+ (forall r. Proc.T r u t (SigA.R r v1 ecAmp1 ec1)) ->
+ Proc.T s u t
+ (CausalD.T s ampIn ampOut sampIn sampOut)
+processAsynchronousNaive2 ip cp rate x y =
+ runAsynchronous2 ip cp
+ (SigP.runProcess rate x) (SigP.runProcess rate y)
+
+
+{-
+This uses lazy StorableVector for buffering
+of the internal control parameters.
+This increases laziness granularity,
+but it should be faster, since interpolation needs frequent look-ahead,
+and this is faster on a Storable signal than on a plain stateful signal generator.
+Since the look-ahead is constant,
+it is interesting whether interpolation can be made more efficient
+without Storable.
+
+{-# INLINE processAsynchronousStorable2 #-}
+processAsynchronousStorable2 ::
+ (Dim.C u, Dim.C v0, Dim.C v1, Storable ic, RealField.C t) =>
+ Interpolation.T t (RateDep s ic) ->
+ Proc.T s u t
+ (T (Converter s (DN.T v0 ecAmp0, DN.T v1 ecAmp1) (ec0, ec1) ic)
+ (CausalD.T s (ampIn, CausalD.Flat) ampOut (sampIn, RateDep s ic) sampOut)) ->
+ DN.T (Dim.Recip u) t ->
+ (forall r. Proc.T r u t (SigA.R r v0 ecAmp0 ec0)) ->
+ (forall r. Proc.T r u t (SigA.R r v1 ecAmp1 ec1)) ->
+ Proc.T s u t
+ (CausalD.T s ampIn ampOut sampIn sampOut)
+processAsynchronousStorable2 ip cp rate x y =
+ let sigX = RP.fromSignal $ Proc.run rate (fmap RP.toSignal x)
+ sigY = RP.fromSignal $ Proc.run rate (fmap RP.toSignal y)
+ in do p <- cp
+ runAsynchronous ip cp (Rate.fromDimensionNumber rate)
+ (applyConverter2 (converter p) sigX sigY)
+-}
+
+{- |
+This buffers internal control parameters before interpolation.
+This should be faster, since interpolation needs frequent look-ahead,
+and this is faster on a buffered signal than on a plain stateful signal generator.
+
+Since the look-ahead is constant,
+it is interesting whether interpolation can be made more efficient
+without the inefficient intermediate list structure.
+-}
+{-# INLINE processAsynchronousBuffered2 #-}
+processAsynchronousBuffered2 ::
+ (Dim.C u, Dim.C v0, Dim.C v1, RealField.C t) =>
+ Interpolation.T t (RateDep s ic) ->
+ Proc.T s u t
+ (T (Converter s (DN.T v0 ecAmp0, DN.T v1 ecAmp1) (ec0, ec1) ic)
+ (CausalD.T s (ampIn, CausalD.Flat) ampOut (sampIn, RateDep s ic) sampOut)) ->
+ DN.T (Dim.Recip u) t ->
+ (forall r. Proc.T r u t (SigA.R r v0 ecAmp0 ec0)) ->
+ (forall r. Proc.T r u t (SigA.R r v1 ecAmp1 ec1)) ->
+ Proc.T s u t
+ (CausalD.T s ampIn ampOut sampIn sampOut)
+processAsynchronousBuffered2 ip cp rate x y =
+ let sigX = RP.fromSignal $ Proc.run rate (fmap RP.toSignal x)
+ sigY = RP.fromSignal $ Proc.run rate (fmap RP.toSignal y)
+ in do p <- cp
+ runAsynchronousBuffered ip cp (Rate.fromDimensionNumber rate)
+ (applyConverter2 (converter p) sigX sigY)
+
+
+{-
+{-# INLINE runAsynchronous3 #-}
+runAsynchronous3 ::
+ (Dim.C u, RealField.C t) =>
+ Interpolation.T t (RateDep s ic) ->
+ Proc.T s u t (T s (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/Causal/Displacement.hs b/src/Synthesizer/Dimensional/Causal/Displacement.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/Dimensional/Causal/Displacement.hs
@@ -0,0 +1,192 @@
+{- |
+Copyright : (c) Henning Thielemann 2008
+License : GPL
+
+Maintainer : synthesizer@henning-thielemann.de
+Stability : provisional
+Portability : requires multi-parameter type classes
+-}
+module Synthesizer.Dimensional.Causal.Displacement (
+ mix, mixVolume,
+ fanoutAndMixMulti, fanoutAndMixMultiVolume,
+ raise, distort,
+ ) where
+
+import qualified Synthesizer.Dimensional.Process as Proc
+
+import qualified Synthesizer.Dimensional.Causal.Process as CausalD
+import qualified Synthesizer.Causal.Process as Causal
+import Control.Arrow ((^<<), (&&&), )
+
+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 Control.Monad.Trans.Reader (Reader, runReader, ask, )
+
+import PreludeBase
+import NumericPrelude
+import Prelude ()
+
+
+{- * Mixing -}
+
+{- |
+Mix two signals.
+In contrast 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 (CausalD.T s (DN.T v y, DN.T v y) (DN.T v y) (yv,yv) yv)
+mix =
+ Proc.pure $
+ fromAmplitudeReader $ \(amp0,amp1) ->
+ (DN.abs amp0 + DN.abs amp1, mixCore amp0 amp1)
+
+{-# INLINE mixVolume #-}
+mixVolume ::
+ (Field.C y, Module.C y yv, Dim.C v) =>
+ DN.T v y ->
+ Proc.T s u t (CausalD.T s (DN.T v y, DN.T v y) (DN.T v y) (yv,yv) yv)
+mixVolume amp =
+ Proc.pure $
+ fromAmplitudeReader $ \(amp0,amp1) ->
+ (amp, mixCore amp0 amp1)
+
+{-# INLINE mixCore #-}
+mixCore ::
+ (Field.C y, Module.C y yv, Dim.C v) =>
+ DN.T v y -> DN.T v y ->
+ Reader (DN.T v y) (Causal.T (yv,yv) yv)
+mixCore amp0 amp1 =
+ do toSamp0 <- toAmplitudeVector amp0
+ toSamp1 <- toAmplitudeVector amp1
+ return $
+ Causal.map (\(y0,y1) -> toSamp0 y0 + toSamp1 y1)
+
+{- |
+Mix one or more signals.
+-}
+{-# INLINE fanoutAndMixMulti #-}
+fanoutAndMixMulti ::
+ (Real.C y, Field.C y, Module.C y yv, Dim.C v) =>
+ [Proc.T s u t (CausalD.T s ampIn (DN.T v y) yvIn yv)] ->
+ Proc.T s u t (CausalD.T s ampIn (DN.T v y) yvIn yv)
+fanoutAndMixMulti =
+ fmap fanoutAndMixMultiPlain . sequence
+
+{-# INLINE fanoutAndMixMultiPlain #-}
+fanoutAndMixMultiPlain ::
+ (Real.C y, Field.C y, Module.C y yv, Dim.C v) =>
+ [CausalD.T s ampIn (DN.T v y) yvIn yv] ->
+ CausalD.T s ampIn (DN.T v y) yvIn yv
+fanoutAndMixMultiPlain cs =
+ fromAmplitudeReader $ \ampIn ->
+ let ampCs = map (\(CausalD.Cons f) -> f ampIn) cs
+ in (maximum (map fst ampCs),
+ fanoutAndMixMultiVolumeCore ampCs)
+
+{-# INLINE fanoutAndMixMultiVolume #-}
+fanoutAndMixMultiVolume ::
+ (Field.C y, Module.C y yv, Dim.C v) =>
+ DN.T v y ->
+ [Proc.T s u t (CausalD.T s ampIn (DN.T v y) yvIn yv)] ->
+ Proc.T s u t (CausalD.T s ampIn (DN.T v y) yvIn yv)
+fanoutAndMixMultiVolume amp =
+ fmap (fanoutAndMixMultiVolumePlain amp) . sequence
+
+{-# INLINE fanoutAndMixMultiVolumePlain #-}
+fanoutAndMixMultiVolumePlain ::
+ (Field.C y, Module.C y yv, Dim.C v) =>
+ DN.T v y ->
+ [CausalD.T s ampIn (DN.T v y) yvIn yv] ->
+ CausalD.T s ampIn (DN.T v y) yvIn yv
+fanoutAndMixMultiVolumePlain amp cs =
+ fromAmplitudeReader $ \ampIn ->
+ (amp, fanoutAndMixMultiVolumeCore $
+ map (\(CausalD.Cons f) -> f ampIn) cs)
+
+{-# INLINE fanoutAndMixMultiVolumeCore #-}
+fanoutAndMixMultiVolumeCore ::
+ (Field.C y, Module.C y yv, Dim.C v) =>
+ [(DN.T v y, Causal.T yvIn yv)] ->
+ Reader (DN.T v y) (Causal.T yvIn yv)
+fanoutAndMixMultiVolumeCore cs =
+ foldr
+ (\(ampX,c) acc ->
+ do toSamp <- toAmplitudeVector ampX
+ rest <- acc
+ return $ uncurry (+) ^<< (toSamp ^<< c) &&& rest)
+ (return $ Causal.map (const zero)) cs
+
+
+{- |
+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 (CausalD.T s (DN.T v y) (DN.T v y) yv yv)
+raise y' yv =
+ Proc.pure $
+ fromAmplitudeReader $ \amp ->
+ (amp, do toSamp <- toAmplitudeVector y'
+ return $ Causal.map (toSamp yv +))
+
+{- |
+Distort the signal using a flat function.
+The first signal gives the scaling of the function.
+If the scaling is c and the input sample is y,
+then @c * f(y/c)@ is output.
+This way we can use an (efficient) flat function
+and have a simple, yet dimension conform, way of controlling the distortion.
+E.g. if the distortion function is @tanh@
+then the value @c@ controls the saturation level.
+-}
+{-# INLINE distort #-}
+distort :: (Field.C y, Module.C y yv, Dim.C v) =>
+ (yv -> yv) ->
+ Proc.T s u t (CausalD.T s (DN.T v y, DN.T v y) (DN.T v y) (y,yv) yv)
+distort f =
+ Proc.pure $
+ fromAmplitudeReader $ \(ampCtrl,ampIn) ->
+ (ampIn, do toSamp <- toAmplitudeScalar ampCtrl
+ return $
+ Causal.map (\(c,y) ->
+ let c' = toSamp c
+ in c' *> f (recip c' *> y)))
+
+
+{-# INLINE toAmplitudeScalar #-}
+toAmplitudeScalar ::
+ (Field.C y, Dim.C u) =>
+ DN.T u y -> Reader (DN.T u y) (y -> y)
+toAmplitudeScalar ampIn =
+ do ampOut <- ask
+ return (DN.divToScalar ampIn ampOut *)
+
+{-# INLINE toAmplitudeVector #-}
+toAmplitudeVector ::
+ (Module.C y yv, Field.C y, Dim.C u) =>
+ DN.T u y -> Reader (DN.T u y) (yv -> yv)
+toAmplitudeVector ampIn =
+ do ampOut <- ask
+ return (DN.divToScalar ampIn ampOut *> )
+
+{-# INLINE fromAmplitudeReader #-}
+fromAmplitudeReader ::
+ (ampIn -> (ampOut, Reader ampOut (Causal.T yv0 yv1))) ->
+ CausalD.T s ampIn ampOut yv0 yv1
+fromAmplitudeReader f =
+ CausalD.Cons $ \ampIn ->
+ let (ampOut, rd) = f ampIn
+ in (ampOut, runReader rd ampOut)
diff --git a/src/Synthesizer/Dimensional/Causal/Filter.hs b/src/Synthesizer/Dimensional/Causal/Filter.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/Dimensional/Causal/Filter.hs
@@ -0,0 +1,708 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{- |
+Copyright : (c) Henning Thielemann 2008
+License : GPL
+
+Maintainer : synthesizer@henning-thielemann.de
+Stability : provisional
+Portability : requires multi-parameter type classes
+-}
+module Synthesizer.Dimensional.Causal.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 -}
+ ResonantFilter,
+ FrequencyFilter,
+
+ {- ** Without resonance -}
+ firstOrderLowpass,
+ firstOrderHighpass,
+
+ butterworthLowpass,
+ butterworthHighpass,
+ chebyshevALowpass,
+ chebyshevAHighpass,
+ chebyshevBLowpass,
+ chebyshevBHighpass,
+
+ butterworthLowpassPole,
+ butterworthHighpassPole,
+ chebyshevALowpassPole,
+ chebyshevAHighpassPole,
+ chebyshevBLowpassPole,
+ chebyshevBHighpassPole,
+
+ {- ** With resonance -}
+ universal,
+ highpassFromUniversal,
+ bandpassFromUniversal,
+ lowpassFromUniversal,
+ bandlimitFromUniversal,
+ moogLowpass,
+
+ {- ** Allpass -}
+ allpassCascade,
+ allpassPhaser,
+ FiltR.allpassFlangerPhase,
+
+{-
+ {- ** Reverb -}
+ comb,
+ combProc,
+-}
+
+ {- ** Filter operators from calculus -}
+ integrate,
+) where
+
+import qualified Synthesizer.Dimensional.Process as Proc
+-- import qualified Synthesizer.Dimensional.Rate as Rate
+import qualified Synthesizer.Dimensional.Causal.ControlledProcess as CCProc
+import qualified Synthesizer.Dimensional.Causal.Process as CausalD
+import qualified Synthesizer.Causal.Process as Causal
+import Control.Arrow ((<<^), (^<<), (&&&), )
+
+-- import Synthesizer.Dimensional.Process ((.:), (.^), )
+
+-- import qualified Synthesizer.Dimensional.Abstraction.Flat as Flat
+
+-- import qualified Synthesizer.State.Signal as Sig
+import qualified Synthesizer.Plain.Modifier as Modifier
+import Synthesizer.Plain.Signal (Modifier)
+
+import Synthesizer.Dimensional.RateAmplitude.Signal
+ ({- toTimeScalar, -} toFrequencyScalar, DimensionGradient, )
+
+import qualified Synthesizer.Dimensional.Rate.Filter as FiltR
+
+-- import qualified Synthesizer.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.State.Filter.Recursive.Integration as Integrate
+-- import qualified Synthesizer.State.Filter.Recursive.MovingAverage as MA
+import qualified Synthesizer.Plain.Filter.Recursive as FiltRec
+-- import qualified Synthesizer.State.Filter.NonRecursive as FiltNR
+
+-- import qualified Synthesizer.Generic.Filter.Recursive.Comb as Comb
+-- import qualified Synthesizer.Dimensional.Causal.Displacement as DispC
+
+import Synthesizer.Utility (affineComb, )
+
+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 Foreign.Storable (Storable)
+
+-- import Control.Monad(liftM2)
+
+import Data.Tuple.HT (swap, mapFst, )
+
+import NumericPrelude hiding (negate)
+import PreludeBase as P
+import Prelude ()
+
+
+{- | The amplification factor must be positive. -}
+{-# INLINE amplify #-}
+amplify :: (Module.C y amp) =>
+ y ->
+ Proc.T s u t (CausalD.T s amp amp yv yv)
+amplify volume =
+ Proc.pure $ CausalD.mapAmplitudeSameType (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 (CausalD.T s (DN.T v1 y) (DN.T (Dim.Mul v0 v1) y) yv yv)
+amplifyDimension volume =
+ Proc.pure $ CausalD.mapAmplitude (volume &*&)
+
+
+{-# INLINE negate #-}
+negate :: (Additive.C yv) =>
+ Proc.T s u t (CausalD.T s amp amp yv yv)
+negate =
+ Proc.pure $ homogeneousMap Additive.negate
+
+
+{-# INLINE envelope #-}
+envelope :: (Ring.C y) =>
+ Proc.T s u t (CausalD.T s (CausalD.Flat, amp) amp (y,y) y)
+envelope =
+ Proc.pure $ CausalD.Cons $ \(CausalD.Flat, amp) ->
+ (amp, Causal.map (uncurry (*)))
+
+{-# INLINE envelopeVector #-}
+envelopeVector :: (Module.C y yv) =>
+ Proc.T s u t (CausalD.T s (CausalD.Flat, amp) amp (y,yv) yv)
+envelopeVector =
+ Proc.pure $ CausalD.Cons $ \(CausalD.Flat, amp) ->
+ (amp, Causal.map (uncurry (*>)))
+
+{-# INLINE envelopeVectorDimension #-}
+envelopeVectorDimension ::
+ (Module.C y0 yv, Ring.C y, Dim.C u, Dim.C v0, Dim.C v1) =>
+ Proc.T s u t
+ (CausalD.T s (DN.T v0 y, DN.T v1 y) (DN.T (Dim.Mul v0 v1) y) (y0,yv) yv)
+envelopeVectorDimension =
+ Proc.pure $ CausalD.Cons $ \(ampEnv, ampSig) ->
+ (ampEnv &*& ampSig, Causal.map (uncurry (*>)))
+
+
+{-# INLINE differentiate #-}
+differentiate :: (Additive.C yv, Ring.C q, Dim.C u, Dim.C v) =>
+ Proc.T s u q
+ (CausalD.T s (DN.T v q) (DN.T (DimensionGradient u v) q) yv yv)
+differentiate =
+ do rate <- Proc.getSampleRate
+ return $ CausalD.Cons $ \ amp ->
+ (rate &*& amp,
+ uncurry (-) ^<< Causal.id &&& Causal.consInit zero)
+-- Causal.crochetL (\x0 x1 -> Just (x0-x1, x0)) zero)
+
+
+{-
+{- | 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) =>
+ 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.D v q SigS.S) 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
+
+{-# 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
+-}
+
+
+type FrequencyFilter s u q ic amp yv0 yv1 =
+ Proc.T s u q
+ (CCProc.T
+ (CCProc.Converter s
+ (DN.T (Dim.Recip u) q)
+ q {- v signal for cut off and band center frequency -}
+ ic)
+ (CausalD.T s
+ (amp, CausalD.Flat) amp
+ (yv0, CCProc.RateDep s ic) yv1))
+
+{-# INLINE firstOrderLowpass #-}
+{-# INLINE firstOrderHighpass #-}
+firstOrderLowpass, firstOrderHighpass ::
+ (Trans.C q, Module.C q yv, Dim.C u) =>
+ FrequencyFilter s u q (Filt1.Parameter q) amp yv yv
+firstOrderLowpass = firstOrderGen Filt1.lowpassModifier
+firstOrderHighpass = firstOrderGen Filt1.highpassModifier
+
+{-# INLINE firstOrderGen #-}
+firstOrderGen ::
+ (Trans.C q, Module.C q yv, Dim.C u) =>
+ (Modifier yv (Filt1.Parameter q) yv yv)
+-- (Sig.T (Filt1.Parameter q) -> Sig.T yv -> Sig.T yv)
+ -> FrequencyFilter s u q (Filt1.Parameter q) amp yv yv
+firstOrderGen modif =
+ frequencyControl Filt1.parameter (Causal.fromSimpleModifier modif)
+
+
+
+{-# INLINE butterworthLowpass #-}
+{-# INLINE butterworthHighpass #-}
+{-# INLINE chebyshevALowpass #-}
+{-# INLINE chebyshevAHighpass #-}
+{-# INLINE chebyshevBLowpass #-}
+{-# INLINE chebyshevBHighpass #-}
+
+butterworthLowpass, butterworthHighpass ::
+ (Trans.C a, Module.C a yv, Storable a, Storable yv, Dim.C u) =>
+ NonNeg.Int {- ^ Order of the filter, must be even,
+ the higher the order, the sharper is the separation of frequencies. -} ->
+ ResonantFilter s u a (Butter.Parameter a) amp yv yv
+
+chebyshevALowpass, chebyshevAHighpass ::
+ (Trans.C a, Module.C a yv, Storable a, Storable yv, Dim.C u) =>
+ NonNeg.Int ->
+ ResonantFilter s u a (Cheby.ParameterA a) amp yv yv
+
+chebyshevBLowpass, chebyshevBHighpass ::
+ (Trans.C a, Module.C a yv, Storable a, Storable yv, Dim.C u) =>
+ NonNeg.Int ->
+ ResonantFilter s u a (Cheby.ParameterB a) amp yv yv
+
+butterworthLowpass = higherOrderNoResoGen (Butter.parameter FiltRec.Lowpass) Butter.causal
+butterworthHighpass = higherOrderNoResoGen (Butter.parameter FiltRec.Highpass) Butter.causal
+chebyshevALowpass = higherOrderNoResoGen (Cheby.parameterA FiltRec.Lowpass) Cheby.causalA
+chebyshevAHighpass = higherOrderNoResoGen (Cheby.parameterA FiltRec.Highpass) Cheby.causalA
+chebyshevBLowpass = higherOrderNoResoGen (Cheby.parameterB FiltRec.Lowpass) Cheby.causalB
+chebyshevBHighpass = higherOrderNoResoGen (Cheby.parameterB FiltRec.Highpass) Cheby.causalB
+
+
+{- TODO:
+initial value
+-}
+{-# INLINE higherOrderNoResoGen #-}
+higherOrderNoResoGen ::
+ (Field.C a, Module.C a yv, Storable a, Storable yv, Dim.C u) =>
+ (Int -> FiltRec.Pole a -> param) ->
+ (Int -> Causal.T (param, yv) yv) ->
+ NonNeg.Int ->
+ ResonantFilter s u a param amp yv yv
+
+higherOrderNoResoGen mkParam causal order =
+ let orderInt = NonNeg.toNumber order
+ in frequencyResonanceControl
+ (mkParam orderInt)
+ (causal orderInt)
+
+
+
+{-# INLINE butterworthLowpassPole #-}
+{-# INLINE butterworthHighpassPole #-}
+{-# INLINE chebyshevALowpassPole #-}
+{-# INLINE chebyshevAHighpassPole #-}
+{-# INLINE chebyshevBLowpassPole #-}
+{-# INLINE chebyshevBHighpassPole #-}
+
+butterworthLowpassPole, butterworthHighpassPole,
+ chebyshevALowpassPole, chebyshevAHighpassPole,
+ chebyshevBLowpassPole, chebyshevBHighpassPole ::
+ (Trans.C q, Module.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. -} ->
+ ResonantFilter s u q (FiltRec.Pole q) amp yv yv
+
+butterworthLowpassPole = higherOrderNoResoGenPole Butter.lowpassCausalPole
+butterworthHighpassPole = higherOrderNoResoGenPole Butter.highpassCausalPole
+chebyshevALowpassPole = higherOrderNoResoGenPole Cheby.lowpassACausalPole
+chebyshevAHighpassPole = higherOrderNoResoGenPole Cheby.highpassACausalPole
+chebyshevBLowpassPole = higherOrderNoResoGenPole Cheby.lowpassBCausalPole
+chebyshevBHighpassPole = higherOrderNoResoGenPole Cheby.highpassBCausalPole
+
+
+{- TODO:
+initial value
+-}
+{-# INLINE higherOrderNoResoGenPole #-}
+higherOrderNoResoGenPole ::
+ (Field.C q, Dim.C u) =>
+ (Int -> Causal.T (FiltRec.Pole q, yv) yv) ->
+ NonNeg.Int ->
+ ResonantFilter s u q (FiltRec.Pole q) amp yv yv
+
+higherOrderNoResoGenPole filt order =
+ let orderInt = NonNeg.toNumber order
+ in frequencyResonanceControl id (filt orderInt)
+
+
+
+
+type ResonantFilter s u q ic amp yv0 yv1 =
+ Proc.T s u q
+ (CCProc.T
+ (CCProc.Converter s
+ (DN.Scalar q, DN.T (Dim.Recip u) q)
+ (q,q)
+ {- v signal for resonance,
+ i.e. factor of amplification at the resonance frequency
+ relatively to the transition band. -}
+ {- v signal for cut off and band center frequency -}
+ ic)
+ (CausalD.T s
+ (amp, CausalD.Flat) amp
+ (yv0, CCProc.RateDep s ic) yv1))
+
+
+type ResonantFilterFlat s u q ic amp yv0 yv1 =
+ Proc.T s u q
+ (CCProc.T
+ (CCProc.Converter s
+ (CausalD.Flat, DN.T (Dim.Recip u) q)
+ (q,q)
+ {- v signal for resonance,
+ i.e. factor of amplification at the resonance frequency
+ relatively to the transition band. -}
+ {- v signal for cut off and band center frequency -}
+ ic)
+ (CausalD.T s
+ (amp, CausalD.Flat) amp
+ (yv0, CCProc.RateDep s ic) yv1))
+
+
+
+{-# INLINE highpassFromUniversal #-}
+{-# INLINE bandpassFromUniversal #-}
+{-# INLINE lowpassFromUniversal #-}
+{-# INLINE bandlimitFromUniversal #-}
+highpassFromUniversal, lowpassFromUniversal,
+ bandpassFromUniversal, bandlimitFromUniversal ::
+ CausalD.T s amp amp (UniFilter.Result yv) yv
+-- Proc.T s u q (CausalD.T s amp amp (UniFilter.Result yv) yv)
+highpassFromUniversal = homogeneousMap UniFilter.highpass
+bandpassFromUniversal = homogeneousMap UniFilter.bandpass
+lowpassFromUniversal = homogeneousMap UniFilter.lowpass
+bandlimitFromUniversal = homogeneousMap UniFilter.bandlimit
+
+homogeneousMap ::
+ (yv0 -> yv1) ->
+ CausalD.T s amp amp yv0 yv1
+-- Proc.T s u t (CausalD.T s amp amp yv0 yv1)
+homogeneousMap f =
+ CausalD.homogeneous (Causal.map f)
+-- Proc.pure (CausalD.homogeneous (Causal.map f))
+
+{-# INLINE universal #-}
+universal ::
+ (Trans.C q, Module.C q yv, Dim.C u) =>
+ ResonantFilter s u q (UniFilter.Parameter q) amp yv (UniFilter.Result yv)
+universal =
+ frequencyResonanceControl
+ UniFilter.parameter
+ UniFilter.causal
+
+{-# INLINE moogLowpass #-}
+moogLowpass ::
+ (Trans.C q, Module.C q yv, Dim.C u) =>
+ NonNeg.Int
+ -> ResonantFilter s u q (Moog.Parameter q) amp yv yv
+moogLowpass order =
+ let orderInt = NonNeg.toNumber order
+ in frequencyResonanceControl
+ (Moog.parameter orderInt)
+ (Moog.lowpassCausal orderInt)
+
+
+{-# INLINE allpassCascade #-}
+{- | the lowest comb frequency is used as the filter frequency -}
+allpassCascade :: (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 -}
+ -> FrequencyFilter s u q (Allpass.Parameter q) amp yv yv
+allpassCascade order phase =
+ let orderInt = NonNeg.toNumber order
+ in frequencyControl
+ (Allpass.parameter orderInt phase)
+ (Allpass.cascadeCausal orderInt)
+
+{-# INLINE allpassPhaser #-}
+{- |
+We use the mixing ratio as resonance parameter.
+Mixing ratio @r@ means:
+Amplify input by @r@ and delayed signal by @1-r@.
+Maximum effect is achieved for @r=0.5@.
+-}
+allpassPhaser :: (Trans.C q, Module.C q yv, Dim.C u) =>
+ NonNeg.Int {- ^ order, number of filters in the cascade -}
+ -> ResonantFilter s u q (q, Allpass.Parameter q) amp yv yv
+allpassPhaser order =
+ let orderInt = NonNeg.toNumber order
+ in frequencyResonanceControl
+ (\x ->
+ (FiltRec.poleResonance x,
+ Allpass.parameter orderInt Allpass.flangerPhase $
+ FiltRec.poleFrequency x))
+ (uncurry affineComb ^<<
+ Causal.second (Causal.fanout
+ (Allpass.cascadeCausal orderInt) (Causal.map snd))
+ <<^ (\((r,p),x) -> (r,(p,x))))
+
+{-
+The handling of amplitudes is not efficient and the results may surprise.
+Due to rounding errors the output amplitude may differ from input amplitude.
+This problem can only be overcome by a specialised low-level routine.
+
+allpassPhaser :: (Trans.C q, Module.C q yv, Dim.C u) =>
+ NonNeg.Int {- ^ order, number of filters in the cascade -}
+ -> q {- ^ mixing ratio @x@ means:
+ amplify input by @x@ and
+ amplify delayed signal by @1-x@.
+ Maximum effect is achieved for @x=0.5@. -}
+ -> FrequencyFilter s u q (Allpass.Parameter q) amp yv yv
+allpassPhaser order r =
+-- incomplete
+ fmap
+ (fmap $ \ap ->
+ mix CausalD.<<<
+ CausalD.fanout
+ (amplify r)
+ (amplify (1-r) CausalD.<<< ap))
+ (Filt.allpassCascade 20 Filt.allpassFlangerPhase)
+-}
+
+
+{-# INLINE frequencyControl #-}
+frequencyControl ::
+ (Field.C q, Dim.C u) =>
+ (q -> ic) ->
+ Causal.T (ic, yv0) yv1 ->
+ FrequencyFilter s u q ic amp yv0 yv1
+
+frequencyControl mkParam filt =
+ do toFreq <- Proc.withParam toFrequencyScalar
+ return $ CCProc.Cons
+ (CCProc.makeConverter $ \ freqAmp ->
+ let k = toFreq freqAmp
+ in \ freq -> mkParam $ k*freq)
+ (CausalD.Cons $ \ (xAmp, CausalD.Flat) ->
+ (xAmp, filt <<^ mapFst CCProc.unRateDep . swap))
+-- (\ params -> SigA.processSamples (filt params))
+
+
+{-# INLINE frequencyResonanceControl #-}
+frequencyResonanceControl ::
+ (Field.C q, Dim.C u) =>
+ (FiltRec.Pole q -> ic) ->
+ Causal.T (ic, yv0) yv1 ->
+ ResonantFilter s u q ic amp yv0 yv1
+
+frequencyResonanceControl mkParam filt =
+ do toFreq <- Proc.withParam toFrequencyScalar
+ return $ CCProc.Cons
+ (CCProc.makeConverter $ \ (resoAmp, freqAmp) ->
+ let k = toFreq freqAmp
+ in \ (reso, freq) -> mkParam $
+ FiltRec.Pole (DN.toNumber resoAmp * reso) (k*freq))
+ (CausalD.Cons $ \ (xAmp, CausalD.Flat) ->
+ (xAmp, filt <<^ mapFst CCProc.unRateDep . swap))
+ -- CausalD.homogeneous almost fits, but it cannot handle the control input
+
+
+{-# INLINE frequencyResonanceControlFlat #-}
+frequencyResonanceControlFlat ::
+ (Field.C q, Dim.C u) =>
+ (FiltRec.Pole q -> ic) ->
+ Modifier.Simple state ic yv0 yv1 ->
+ ResonantFilterFlat s u q ic amp yv0 yv1
+
+frequencyResonanceControlFlat mkParam filt =
+ do toFreq <- Proc.withParam toFrequencyScalar
+ return $ CCProc.Cons
+ (CCProc.makeConverter $ \ (CausalD.Flat, freqAmp) ->
+ let k = toFreq freqAmp
+ in \ (reso, freq) ->
+ mkParam $ FiltRec.Pole reso (k*freq))
+ (CausalD.Cons $ \ (xAmp, CausalD.Flat) ->
+ (xAmp, Causal.fromSimpleModifier filt <<^ mapFst CCProc.unRateDep . swap))
+ -- CausalD.homogeneous almost fits, but it cannot handle the control input
+
+
+{-
+{- | 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
+-}
+
+
+{-# INLINE integrate #-}
+integrate :: (Additive.C yv, Field.C q, Dim.C u, Dim.C v) =>
+ Proc.T s u q
+ (CausalD.T s (DN.T v q) (DN.T (Dim.Mul u v) q) yv yv)
+integrate =
+ do rate <- Proc.getSampleRate
+ return $ CausalD.Cons $ \ amp ->
+ (DN.rewriteDimension
+ (Dim.commute . Dim.applyRightMul Dim.invertRecip) $
+ amp &/& rate,
+ Integrate.causal)
diff --git a/src/Synthesizer/Dimensional/Causal/Oscillator.hs b/src/Synthesizer/Dimensional/Causal/Oscillator.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/Dimensional/Causal/Oscillator.hs
@@ -0,0 +1,303 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE FlexibleContexts #-}
+{- |
+Copyright : (c) Henning Thielemann 2009
+License : GPL
+
+Maintainer : synthesizer@henning-thielemann.de
+Stability : provisional
+Portability : requires multi-parameter type classes
+
+-}
+module Synthesizer.Dimensional.Causal.Oscillator (
+{-
+ static,
+ staticAntiAlias,
+-}
+ freqMod,
+ freqModAntiAlias,
+ phaseMod,
+ phaseFreqMod,
+ shapeMod,
+ shapeFreqMod,
+{-
+ staticSample,
+ freqModSample,
+-}
+-- shapeFreqModSample,
+ shapeFreqModFromSampledTone,
+ shapePhaseFreqModFromSampledTone,
+ ) where
+
+import qualified Synthesizer.Dimensional.Causal.Process as CausalD
+import qualified Synthesizer.Causal.Process as Causal
+import Control.Arrow ((<<^), (<<<), second, )
+
+import qualified Synthesizer.Dimensional.Abstraction.HomogeneousGen as Hom
+import qualified Synthesizer.Dimensional.RateWrapper as SigP
+import qualified Synthesizer.Dimensional.Rate as Rate
+
+import qualified Synthesizer.Causal.Oscillator as Osci
+
+import qualified Synthesizer.Generic.Signal as SigG
+
+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.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 qualified Algebra.Ring as Ring
+
+import NumericPrelude
+import PreludeBase as P
+
+
+{-
+{- | 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 -}
+ -> DN.T (Dim.Recip u) t
+ {- ^ frequency -}
+ -> Proc.T s u t (SigS.R s y)
+static wave phase =
+ staticAuxHom (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 -}
+ -> DN.T (Dim.Recip u) t
+ {- ^ frequency -}
+ -> Proc.T s u t (SigS.R s y)
+staticAntiAlias wave phase =
+ staticAuxHom (SigS.fromSamples . Osci.staticAntiAlias wave phase)
+-}
+
+{- | oscillator with a functional waveform with modulated frequency -}
+{-# INLINE freqMod #-}
+freqMod :: (RealField.C t, Dim.C u, Hom.C amp (Wave.T t) wave) =>
+ wave y {- ^ waveform -}
+ -> Phase.T t {- ^ start phase -}
+ -> Proc.T s u t
+ (CausalD.T s (DN.T (Dim.Recip u) t) amp t y)
+freqMod wave phase =
+ staticAuxHom wave $ \toFreq freqAmp w ->
+ Osci.freqMod w phase <<< amplify (toFreq freqAmp)
+
+{- | oscillator with a functional waveform with modulated frequency -}
+{-# INLINE freqModAntiAlias #-}
+freqModAntiAlias :: (RealField.C t, Dim.C u, Hom.C amp (WaveSmooth.T t) wave) =>
+ wave y
+ {- ^ waveform -}
+ -> Phase.T t {- ^ start phase -}
+ -> Proc.T s u t
+ (CausalD.T s (DN.T (Dim.Recip u) t) amp t y)
+freqModAntiAlias wave phase =
+ freqModAuxHom wave $ \scaleFreq freqAmp w ->
+ Osci.freqModAntiAlias w phase <<< scaleFreq freqAmp
+
+{- | oscillator with modulated phase -}
+{-# INLINE phaseMod #-}
+phaseMod :: (RealField.C t, Dim.C u, Hom.C amp (Wave.T t) wave) =>
+ wave y {- ^ waveform -}
+ -> DN.T (Dim.Recip u) t
+ {- ^ frequency -}
+ -> Proc.T s u t
+ (CausalD.T s CausalD.Flat amp t y)
+phaseMod wave freq =
+ staticAuxHom wave $ \toFreq CausalD.Flat w ->
+ Osci.phaseMod w $ toFreq freq
+
+{- | oscillator with modulated shape -}
+{-# INLINE shapeMod #-}
+shapeMod :: (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
+ (CausalD.T s CausalD.Flat CausalD.Flat c y)
+shapeMod wave phase freq =
+ staticAux $ \toFreq CausalD.Flat ->
+ Osci.shapeMod wave phase $ toFreq freq
+
+
+{- | oscillator with a functional waveform with modulated phase and frequency -}
+{-# INLINE phaseFreqMod #-}
+phaseFreqMod :: (RealField.C t, Dim.C u, Hom.C amp (Wave.T t) wave) =>
+ wave y {- ^ waveform -}
+ -> Proc.T s u t
+ (CausalD.T s (CausalD.Flat, DN.T (Dim.Recip u) t) amp (t,t) y)
+phaseFreqMod wave =
+ freqModAuxHom wave $ \scaleFreq (CausalD.Flat, freqAmp) w ->
+ Osci.phaseFreqMod w <<< second (scaleFreq freqAmp)
+
+{- | oscillator with both shape and frequency modulation -}
+{-# INLINE shapeFreqMod #-}
+shapeFreqMod :: (RealField.C t, Dim.C u) =>
+ (c -> Wave.T t y)
+ {- ^ waveform -}
+ -> Phase.T t {- ^ phase -}
+ -> Proc.T s u t
+ (CausalD.T s (CausalD.Flat, DN.T (Dim.Recip u) t) CausalD.Flat (c,t) y)
+shapeFreqMod wave phase =
+ freqModAux $ \scaleFreq (CausalD.Flat, freqAmp) ->
+ Osci.shapeFreqMod wave phase <<< second (scaleFreq freqAmp)
+
+
+{-
+We could decouple source time and target time which yields
+
+ DN.T (Dim.Recip u0) t
+ {- ^ source frequency -}
+ -> SigP.T u0 (SigA.D v y (SigS.T sig)) y
+ -> t -> Phase.T t
+ -> Proc.T s u1 t (
+ CausalD.T s (DN.T (Dim.Div u0 u1) t, DN.T (Dim.Recip u1) t) CausalD.Flat (t,t) y)
+
+but most oftenly we do not need the conversion of the time scale.
+If we need it, we can use the frequency modulation function.
+
+We could measure the shape parameter in multiples of the source wave period.
+This would yield
+
+ DN.T (Dim.Recip u0) t
+ {- ^ source frequency -}
+ -> SigP.T u0 (SigA.D v y (SigS.T sig)) y
+ -> t -> Phase.T t
+ -> Proc.T s u1 t (
+ CausalD.T s (DN.T (Dim.Recip u1) t, DN.T (Dim.Recip u1) t) CausalD.Flat (t,t) y)
+
+but this way, adjustment of the shape parameter is coupled to the source period.
+-}
+{-# INLINE shapeFreqModFromSampledTone #-}
+shapeFreqModFromSampledTone ::
+ (RealField.C t, SigG.Transform storage yv, Dim.C u,
+ Hom.C amp storage signal) =>
+ Interpolation.T t yv
+ -> Interpolation.T t yv
+ -> DN.T (Dim.Recip u) t
+ {- ^ source frequency -}
+ -> SigP.T u t signal yv
+ -> t -> Phase.T t
+ -> Proc.T s u t
+ (CausalD.T s
+ (CausalD.Flat, DN.T (Dim.Recip u) t) amp
+ (t,t) yv)
+shapeFreqModFromSampledTone
+ ipLeap ipStep srcFreq sampledTone shape0 phase =
+ let (srcRate, srcSignal) = SigP.toSignal sampledTone
+ (amp, samples) = Hom.unwrap srcSignal
+ in do toFreq <- Proc.withParam toFrequencyScalar
+ return $
+ CausalD.Cons $ \(CausalD.Flat, freqAmp) ->
+ (amp,
+ Osci.shapeFreqModFromSampledTone
+ ipLeap ipStep
+ (DN.divToScalar (Rate.toDimensionNumber srcRate) srcFreq)
+ samples
+ shape0 phase
+ <<< second (amplify (toFreq freqAmp)))
+
+
+{-# INLINE shapePhaseFreqModFromSampledTone #-}
+shapePhaseFreqModFromSampledTone ::
+ (RealField.C t, SigG.Transform storage yv, Dim.C u,
+ Hom.C amp storage signal) =>
+ Interpolation.T t yv
+ -> Interpolation.T t yv
+ -> DN.T (Dim.Recip u) t
+ {- ^ source frequency -}
+ -> SigP.T u t signal yv
+ -> t -> Phase.T t
+ -> Proc.T s u t
+ (CausalD.T s
+ (CausalD.Flat, CausalD.Flat, DN.T (Dim.Recip u) t) amp
+ (t,t,t) yv)
+shapePhaseFreqModFromSampledTone
+ ipLeap ipStep srcFreq sampledTone shape0 phase =
+ let (srcRate, srcSignal) = SigP.toSignal sampledTone
+ (amp, samples) = Hom.unwrap srcSignal
+ in do toFreq <- Proc.withParam toFrequencyScalar
+ return $
+ CausalD.Cons $ \(CausalD.Flat, CausalD.Flat, freqAmp) ->
+ (amp,
+ Osci.shapePhaseFreqModFromSampledTone
+ ipLeap ipStep
+ (DN.divToScalar (Rate.toDimensionNumber srcRate) srcFreq)
+ samples
+ shape0 phase
+ <<^
+ (\(s,p,f) -> (s,p, toFreq freqAmp * f)))
+{-
+ Causal.packTriple
+ ^<<
+ second (amplify (toFreq freqAmp))
+ <<^
+ Causal.unpackTriple
+-}
+
+
+-- helper functions
+
+{-# INLINE freqModAux #-}
+freqModAux :: (Dim.C u, Field.C t) =>
+ ((DN.T (Dim.Recip u) t -> Causal.T t t) -> amp0 -> Causal.T yv0 yv1) ->
+ Proc.T s u t (CausalD.T s1 amp0 CausalD.Flat yv0 yv1)
+freqModAux f =
+ staticAux $ \toFreq amp -> f (amplify . toFreq) amp
+
+{-# INLINE staticAux #-}
+staticAux :: (Dim.C u, Field.C t) =>
+ ((DN.T (Dim.Recip u) t -> t) -> amp0 -> Causal.T yv0 yv1) ->
+ Proc.T s u t (CausalD.T s1 amp0 CausalD.Flat yv0 yv1)
+staticAux f =
+ do toFreq <- Proc.withParam toFrequencyScalar
+ return $ CausalD.Cons $ \amp ->
+ (CausalD.Flat, f toFreq amp)
+
+
+{-# INLINE freqModAuxHom #-}
+freqModAuxHom :: (Dim.C u, Field.C t, Hom.C amp1 waveStore wave) =>
+ wave y ->
+ ((DN.T (Dim.Recip u) t -> Causal.T t t) ->
+ amp0 -> waveStore y -> Causal.T yv0 yv1) ->
+ Proc.T s u t (CausalD.T s1 amp0 amp1 yv0 yv1)
+freqModAuxHom wave f =
+ staticAuxHom wave $ \toFreq amp0 w -> f (amplify . toFreq) amp0 w
+
+{-# INLINE staticAuxHom #-}
+staticAuxHom :: (Dim.C u, Field.C t, Hom.C amp1 waveStore wave) =>
+ wave y ->
+ ((DN.T (Dim.Recip u) t -> t) ->
+ amp0 -> waveStore y -> Causal.T yv0 yv1) ->
+ Proc.T s u t (CausalD.T s1 amp0 amp1 yv0 yv1)
+staticAuxHom wave f =
+ let (amp1, w) = Hom.plainUnwrap wave
+ in do toFreq <- Proc.withParam toFrequencyScalar
+ return $ CausalD.Cons $ \amp ->
+ (amp1, f toFreq amp w)
+
+
+-- move to Causal.Filter
+amplify :: (Ring.C a) => a -> Causal.T a a
+amplify x = Causal.map (x Ring.*)
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,372 @@
+{-# LANGUAGE FlexibleContexts #-}
+module Synthesizer.Dimensional.Causal.Process (
+ module Synthesizer.Dimensional.Causal.Process,
+ Flat(Flat),
+ ) where
+
+import qualified Synthesizer.Dimensional.Arrow as ArrowD
+import qualified Synthesizer.Dimensional.Map as Map
+
+import qualified Synthesizer.Dimensional.RatePhantom as RP
+import qualified Synthesizer.Dimensional.Amplitude.Signal as SigA
+import qualified Synthesizer.Dimensional.Abstraction.HomogeneousGen as Hom
+import qualified Synthesizer.Dimensional.Amplitude as Amplitude
+import qualified Synthesizer.Dimensional.Abstraction.Flat as Flat
+
+import Synthesizer.Dimensional.Amplitude (Flat(Flat))
+
+import qualified Synthesizer.Causal.Process as Causal
+
+import Control.Applicative (Applicative, liftA, liftA2, )
+
+import qualified Synthesizer.State.Signal as Sig
+import qualified Synthesizer.Generic.Signal2 as SigG2
+
+import qualified Algebra.Module as Module
+import qualified Algebra.Field as Field
+import qualified Algebra.Ring as Ring
+import Algebra.Module ((*>))
+
+import qualified Number.DimensionTerm as DN
+import qualified Algebra.DimensionTerm as Dim
+
+import qualified Control.Arrow as Arrow
+
+import Data.Tuple.HT as TupleHT (mapSnd, )
+
+import NumericPrelude (one)
+import Prelude hiding (map, id, fst, snd, )
+
+
+
+{-
+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.
+
+Should the 's' parameter be provided by a RatePhantom?
+There are causal processes, namely @map@s,
+which do not depend on the sample rate.
+For these it would make sense to omit the 's'.
+On the other hand what other wrappers could be useful?
+RateWrapper around T is not sensible,
+since it provides the sample rate as value,
+not as an input parameter.
+Note, that RatePhantom has the signal element type as parameter.
+This would accidentally match here, but is it sensible?
+-}
+newtype T s amp0 amp1 yv0 yv1 =
+ Cons (amp0 -> (amp1, Causal.T yv0 yv1))
+
+instance ArrowD.C (T s) where
+ map = map
+ (>>>) = (>>>)
+ first = first
+ second = second
+ (***) = (***)
+ (&&&) = (&&&)
+
+
+{-# INLINE apply #-}
+apply ::
+ (Hom.C amp0 Sig.T signal0, Hom.C amp1 Sig.T signal1) =>
+ T s amp0 amp1 yv0 yv1 ->
+ RP.T s signal0 yv0 -> RP.T s signal1 yv1
+apply (Cons f) x =
+ let (xAmp, samples) = Hom.unwrap x
+ (yAmp, causal) = f xAmp
+ in Hom.wrap (yAmp, Causal.apply causal samples)
+
+{-# INLINE applyGeneric #-}
+applyGeneric ::
+ (Hom.C amp0 storage signal0, Hom.C amp1 storage signal1,
+ SigG2.Transform storage yv0 yv1) =>
+ T s amp0 amp1 yv0 yv1 ->
+ RP.T s signal0 yv0 -> RP.T s signal1 yv1
+applyGeneric (Cons f) x =
+ let (xAmp, samples) = Hom.unwrap x
+ (yAmp, causal) = f xAmp
+ in Hom.wrap (yAmp, Causal.applyGeneric causal samples)
+
+
+{-# INLINE applyConst #-}
+applyConst :: (Dim.C v0, Dim.C v1, Ring.C y0) =>
+ T s (DN.T v0 y0) (DN.T v1 y1) y0 yv1 ->
+ DN.T v0 y0 -> SigA.R s v1 y1 yv1
+applyConst (Cons f) x =
+ let (yAmp, causal) = f x
+ in SigA.fromSamples yAmp (Causal.applyConst causal one)
+
+
+infixl 0 $/:, $/-
+
+{-# INLINE ($/:) #-}
+($/:) :: (Dim.C v0, Dim.C v1, Applicative f) =>
+ f (T s (DN.T v0 y0) (DN.T v1 y1) yv0 yv1) ->
+ f (SigA.R s v0 y0 yv0) -> f (SigA.R s v1 y1 yv1)
+($/:) = liftA2 apply
+
+{-# INLINE ($/-) #-}
+($/-) :: (Dim.C v0, Dim.C v1, Applicative f, Ring.C y0) =>
+ f (T s (DN.T v0 y0) (DN.T v1 y1) y0 yv1) ->
+ DN.T v0 y0 -> f (SigA.R s v1 y1 yv1)
+($/-) p x = liftA (flip applyConst x) p
+
+
+infixl 9 `apply`, `applyFst`, `applyFlat`, `applyFlatFst`
+
+{-# INLINE applyFst #-}
+applyFst, applyFst' :: (Dim.C v) =>
+ T s (DN.T v y, restAmpIn) restAmpOut (yv, restSampIn) restSampOut ->
+ SigA.R s v y yv ->
+ T s restAmpIn restAmpOut restSampIn restSampOut
+applyFst c x = c <<< feedFst x
+
+applyFst' (Cons f) x =
+ Cons $ \yAmp ->
+ let (zAmp, causal) = f (SigA.amplitude x, yAmp)
+ in (zAmp, Causal.applyFst causal (SigA.samples x))
+
+
+{-# INLINE feedFst #-}
+feedFst :: (Dim.C v) =>
+ SigA.R s v y yv ->
+ T s restAmp (DN.T v y, restAmp) restSamp (yv, restSamp)
+feedFst x =
+ Cons $ \yAmp ->
+ ((SigA.amplitude x, yAmp), Causal.feedFst (SigA.samples x))
+
+
+{-# INLINE applyFlat #-}
+applyFlat :: (Dim.C v1, Flat.C sig yv0) =>
+ T s Flat (DN.T v1 y1) yv0 yv1 ->
+ RP.T s sig yv0 -> SigA.R s v1 y1 yv1
+applyFlat (Cons f) x =
+ let (yAmp, causal) = f Flat
+ in SigA.fromSamples yAmp (Causal.apply causal (Flat.toSamples x))
+
+
+{-# INLINE applyFlatFst #-}
+applyFlatFst, applyFlatFst' :: (Flat.C sig yv) =>
+ T s (Flat, restAmpIn) restAmpOut (yv, restSampIn) restSampOut ->
+ RP.T s sig yv ->
+ T s restAmpIn restAmpOut restSampIn restSampOut
+applyFlatFst f x =
+ f <<< feedFlatFst x
+
+applyFlatFst' (Cons f) x =
+ Cons $ \yAmp ->
+ let (zAmp, causal) = f (Flat, yAmp)
+ in (zAmp, Causal.applyFst causal (Flat.toSamples x))
+
+{-# INLINE feedFlatFst #-}
+feedFlatFst :: (Flat.C sig yv) =>
+ RP.T s sig yv ->
+ T s restAmp (Flat, restAmp) restSamp (yv, restSamp)
+feedFlatFst x =
+ Cons $ \yAmp ->
+ ((Flat, yAmp), Causal.feedFst (Flat.toSamples x))
+
+
+
+{-# INLINE map #-}
+map ::
+ Map.T amp0 amp1 yv0 yv1 ->
+ T s amp0 amp1 yv0 yv1
+map (Map.Cons f) =
+ Cons $ mapSnd Causal.map . f
+
+
+{- |
+We restrict the amplitude types to those of class 'Amplitude'.
+Otherwise 'mapAmplitude' could be abused
+for bringing amplitudes and respective sample values out of sync.
+For mapping amplitudes that are nested in some pairs,
+use it in combination with 'first' and 'second'.
+-}
+{-# INLINE mapAmplitude #-}
+mapAmplitude ::
+ (Amplitude.C amp0, Amplitude.C amp1) =>
+ (amp0 -> amp1) ->
+ T s amp0 amp1 yv yv
+mapAmplitude f =
+ Cons $ \ xAmp -> (f xAmp, Causal.id)
+
+{-# INLINE mapAmplitudeSameType #-}
+mapAmplitudeSameType ::
+ (amp -> amp) ->
+ T s amp amp yv yv
+mapAmplitudeSameType f =
+ Cons $ \ xAmp -> (f xAmp, Causal.id)
+
+{- |
+Lift a low-level homogeneous process to a dimensional one.
+
+Note that the @amp@ type variable is unrestricted.
+This way we show, that the amplitude is not touched,
+which also means that the underlying low-level process must be homogeneous.
+-}
+{-# INLINE homogeneous #-}
+homogeneous ::
+ Causal.T yv0 yv1 ->
+ T s amp amp yv0 yv1
+homogeneous c =
+ Cons $ \ xAmp -> (xAmp, c)
+
+
+infixr 3 ***
+infixr 3 &&&
+infixr 1 >>>, ^>>, >>^
+infixr 1 <<<, ^<<, <<^
+
+
+{-# INLINE compose #-}
+{-# INLINE (>>>) #-}
+compose, (>>>) ::
+ T s amp0 amp1 yv0 yv1 ->
+ T s amp1 amp2 yv1 yv2 ->
+ T s 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 s amp1 amp2 yv1 yv2 ->
+ T s amp0 amp1 yv0 yv1 ->
+ T s amp0 amp2 yv0 yv2
+(<<<) = flip (>>>)
+
+
+{-# INLINE first #-}
+first ::
+ T s amp0 amp1 yv0 yv1 ->
+ T s (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 s amp0 amp1 yv0 yv1 ->
+ T s (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 s amp0 amp1 yv0 yv1 ->
+ T s amp2 amp3 yv2 yv3 ->
+ T s (amp0, amp2) (amp1, amp3) (yv0, yv2) (yv1, yv3)
+split f g =
+ compose (first f) (second g)
+
+(***) = split
+
+{-# INLINE fanout #-}
+{-# INLINE (&&&) #-}
+fanout, (&&&) ::
+ T s amp amp0 yv yv0 ->
+ T s amp amp1 yv yv1 ->
+ T s amp (amp0, amp1) yv (yv0, yv1)
+fanout f g =
+ compose (map Map.double) (split f g)
+
+(&&&) = fanout
+
+
+-- * map functions
+
+{-# INLINE (^>>) #-}
+-- | Precomposition with a pure function.
+(^>>) ::
+ Map.T amp0 amp1 yv0 yv1 ->
+ T s amp1 amp2 yv1 yv2 ->
+ T s amp0 amp2 yv0 yv2
+f ^>> a = map f >>> a
+
+{-# INLINE (>>^) #-}
+-- | Postcomposition with a pure function.
+(>>^) ::
+ T s amp0 amp1 yv0 yv1 ->
+ Map.T amp1 amp2 yv1 yv2 ->
+ T s amp0 amp2 yv0 yv2
+a >>^ f = a >>> map f
+
+{-# INLINE (<<^) #-}
+-- | Precomposition with a pure function (right-to-left variant).
+(<<^) ::
+ T s amp1 amp2 yv1 yv2 ->
+ Map.T amp0 amp1 yv0 yv1 ->
+ T s amp0 amp2 yv0 yv2
+a <<^ f = a <<< map f
+
+{-# INLINE (^<<) #-}
+-- | Postcomposition with a pure function (right-to-left variant).
+(^<<) ::
+ Map.T amp1 amp2 yv1 yv2 ->
+ T s amp0 amp1 yv0 yv1 ->
+ T s amp0 amp2 yv0 yv2
+f ^<< a = 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 s (restAmpIn, DN.T v y) (restAmpOut, DN.T v y) (restSampIn, yv) (restSampOut, yv) ->
+ T s restAmpIn restAmpOut restSampIn restSampOut
+loop ampIn (Cons f) =
+ Cons $ \restAmpIn ->
+ let ((restAmpOut, ampOut), causal) = f (restAmpIn, ampIn)
+ in (restAmpOut,
+ Causal.loop (causal Arrow.>>^
+ mapSnd (DN.divToScalar ampOut ampIn *>)))
+
+{-# INLINE loop2 #-}
+-- loop2 :: a (b, (d,e)) (c, (d,e)) -> a b c
+loop2 (amp0,amp1) p =
+ loop amp0 $
+ loop amp1 $
+ (Map.balanceRight ^>> p >>^ Map.balanceLeft)
+
+loop2, loop2' ::
+ (Field.C y0, Module.C y0 yv0, Dim.C v0,
+ Field.C y1, Module.C y1 yv1, Dim.C v1) =>
+ (DN.T v0 y0, DN.T v1 y1) ->
+ T s
+ (restAmpIn, (DN.T v0 y0, DN.T v1 y1))
+ (restAmpOut, (DN.T v0 y0, DN.T v1 y1))
+ (restSampIn, (yv0,yv1))
+ (restSampOut, (yv0,yv1)) ->
+ T s restAmpIn restAmpOut restSampIn restSampOut
+loop2' ampIn@(ampIn0,ampIn1) (Cons f) =
+ Cons $ \restAmpIn ->
+ let ((restAmpOut, (ampOut0,ampOut1)), causal) = f (restAmpIn, ampIn)
+ in (restAmpOut,
+ Causal.loop (causal Arrow.>>^
+ Arrow.second ((DN.divToScalar ampOut0 ampIn0 *>) Arrow.***
+ (DN.divToScalar ampOut1 ampIn1 *>))))
+
+
+
+{-# INLINE id #-}
+id ::
+ T s amp amp yv yv
+id =
+ homogeneous Causal.id
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,158 @@
+{- |
+Copyright : (c) Henning Thielemann 2008
+License : GPL
+
+Maintainer : synthesizer@henning-thielemann.de
+Stability : provisional
+Portability : Haskell 98
+
+
+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,
+the ratio between audio and control rate must be integral,
+and they use constant interpolation exclusively.
+With some more sophisticated interpolation
+one may choose a larger gap between control and audio rate.
+-}
+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.
+-}
+data T s ec ic a = Cons {
+ converter :: ec -> Sig.T ic,
+ processor :: Sig.T ic -> a
+ }
+
+
+{-# INLINE runSynchronous #-}
+runSynchronous ::
+ Proc.T s u t (T s ec ic a) ->
+ Proc.T s u t (ec -> a)
+runSynchronous cp =
+ do p <- cp
+ return (processor p . converter p)
+
+{-# INLINE runSynchronous1 #-}
+runSynchronous1 ::
+ Proc.T s u t (T s (RP.T s sig0 ec0) ic a) ->
+ Proc.T s u t (RP.T s sig0 ec0 -> a)
+runSynchronous1 = runSynchronous
+
+{-# INLINE runSynchronous2 #-}
+runSynchronous2 ::
+ Proc.T s u t (T s (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 ::
+ Proc.T s u t (T s (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 ->
+ Proc.T s u t (T s ec ic a) ->
+ Rate.T r u t ->
+ ec ->
+ Proc.T s u t a
+runAsynchronous ip cp srcRate sig =
+ do p <- cp
+ k <- fmap
+ (DN.divToScalar (Rate.toDimensionNumber srcRate))
+ Proc.getSampleRate
+ return $
+ processor p $
+ Causal.apply
+ (Interpolation.relativeConstantPad ip zero (converter p sig))
+ (Sig.repeat k)
+
+{-# INLINE runAsynchronous1 #-}
+runAsynchronous1 ::
+ (Dim.C u, Additive.C ic, RealField.C t) =>
+ Interpolation.T t ic ->
+ Proc.T s u t (T s (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 ->
+ Proc.T s u t (T s (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 ->
+ Proc.T s u t (T s (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/Map.hs b/src/Synthesizer/Dimensional/Map.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/Dimensional/Map.hs
@@ -0,0 +1,91 @@
+{- |
+Maps that handle pairs of amplitudes and sampled values.
+They are a special form of arrows.
+-}
+module Synthesizer.Dimensional.Map where
+
+{-
+import qualified Number.DimensionTerm as DN
+import qualified Algebra.DimensionTerm as Dim
+-}
+
+import qualified Data.Tuple as Tuple
+import Data.Tuple.HT as TupleHT (swap, )
+
+import Prelude hiding (map, id, fst, snd, )
+
+
+
+{- |
+This type shall ensure, that you do not accidentally
+bring amplitudes and the corresponding low-level signal values out of sync.
+We also use it for generation of internal control parameters
+in "Synthesizer.Dimensional.Causal.ControlledProcess".
+In principle this could also be 'Causal.T',
+but maps are not bound to a sampling rate,
+and thus do not need the @s@ type parameter.
+-}
+newtype T amp0 amp1 yv0 yv1 =
+ Cons (amp0 -> (amp1, yv0 -> yv1))
+
+independent ::
+ (amp0 -> amp1) -> (yv0 -> yv1) ->
+ T amp0 amp1 yv0 yv1
+independent f g =
+ Cons (\amp -> (f amp, g))
+
+double ::
+ T amp (amp, amp)
+ y (y, y)
+double =
+ let aux = \x -> (x, x)
+ in independent aux aux
+
+fst ::
+ T (amp0,amp1) amp0
+ (y0,y1) y0
+fst =
+ let aux = Tuple.fst
+ in independent aux aux
+
+snd ::
+ T (amp0,amp1) amp1
+ (y0,y1) y1
+snd =
+ let aux = Tuple.snd
+ in independent aux aux
+
+swap ::
+ T (amp0,amp1) (amp1,amp0)
+ (y0,y1) (y1,y0)
+swap =
+ let aux = TupleHT.swap
+ in independent aux aux
+
+balanceRight ::
+ T ((amp0,amp1), amp2) (amp0, (amp1,amp2))
+ ((y0,y1), y2) (y0, (y1,y2))
+balanceRight =
+ let aux = \((a,b), c) -> (a, (b,c))
+ in independent aux aux
+
+balanceLeft ::
+ T (amp0, (amp1,amp2)) ((amp0,amp1), amp2)
+ (y0, (y1,y2)) ((y0,y1), y2)
+balanceLeft =
+ let aux = \(a, (b,c)) -> ((a,b), c)
+ in independent aux aux
+
+packTriple ::
+ T (amp0,(amp1,amp2)) (amp0,amp1,amp2)
+ (y0,(y1,y2)) (y0,y1,y2)
+packTriple =
+ let aux = \(a,(b,c)) -> (a,b,c)
+ in independent aux aux
+
+unpackTriple ::
+ T (amp0,amp1,amp2) (amp0,(amp1,amp2))
+ (y0,y1,y2) (y0,(y1,y2))
+unpackTriple =
+ let aux = \(a,b,c) -> (a,(b,c))
+ in independent aux aux
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 @@
+{-# LANGUAGE Rank2Types #-}
+{- |
+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.Trans.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,79 @@
+{- |
+
+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
+
+{- |
+This function is somehow dangerous
+because it drops the 's' parameter.
+-}
+{-# 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
+
+{- |
+This function is somehow dangerous
+because it drops the 's' parameter.
+-}
+{-# 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.S q -> DN.T u q
+centroid = makePhysicalLength Ana.centroid
+
+{-# INLINE length #-}
+length :: (Field.C t, Dim.C u) =>
+ SigP.T u t SigS.S 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.S 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 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{- |
+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/Dirac.hs b/src/Synthesizer/Dimensional/Rate/Dirac.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/Dimensional/Rate/Dirac.hs
@@ -0,0 +1,79 @@
+{-# LANGUAGE FlexibleContexts #-}
+module Synthesizer.Dimensional.Rate.Dirac where
+
+import qualified Synthesizer.Generic.Cut as Cut
+
+import qualified Synthesizer.Dimensional.RatePhantom as RP
+import qualified Synthesizer.Dimensional.Amplitude.Signal as SigA
+import qualified Synthesizer.Dimensional.Straight.Signal as SigS
+import qualified Synthesizer.Dimensional.Process as Proc
+
+import qualified Data.Monoid as Mn
+
+-- import qualified Number.DimensionTerm as DN
+import qualified Algebra.DimensionTerm as Dim
+
+-- import qualified Algebra.Field as Field
+import qualified Algebra.Ring as Ring
+
+import Data.Tuple.HT (mapPair, mapSnd, )
+
+import NumericPrelude (zero, one, )
+
+
+{- |
+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 T s sig = Cons {decons :: sig Bool}
+
+instance Mn.Monoid (sig Bool) => Mn.Monoid (T s sig) where
+ mempty = Cons Mn.mempty
+ mappend (Cons x) (Cons y) = Cons (Mn.mappend x y)
+
+instance Cut.Read (sig Bool) => Cut.Read (T s sig) where
+ {-# INLINE null #-}
+ null = Cut.null . decons
+ {-# INLINE length #-}
+ length = Cut.length . decons
+
+instance Cut.Transform (sig Bool) => Cut.Transform (T s sig) where
+ {-# INLINE take #-}
+ take n = Cons . Cut.take n . decons
+ {-# INLINE drop #-}
+ drop n = Cons . Cut.drop n . decons
+ {-# INLINE splitAt #-}
+ splitAt n = mapPair (Cons, Cons) . Cut.splitAt n . decons
+ {-# INLINE dropMarginRem #-}
+ dropMarginRem n m = mapSnd Cons . Cut.dropMarginRem n m . decons
+ {-# INLINE reverse #-}
+ reverse = Cons . Cut.reverse . decons
+
+{- |
+This is the most frequently needed transformation
+of a stream of peaks, if not the only one.
+It converts to a signal of peaks with area 1.
+This convention is especially useful for smoothing filters
+that produce frequency progress curves from zero crossings.
+-}
+{-# INLINE toAmplitudeSignal #-}
+toAmplitudeSignal ::
+ (Ring.C q, Dim.C u, Functor sig) =>
+ Proc.T s u q (T s sig -> RP.T s (SigA.D (Dim.Recip u) q (SigS.T sig)) q)
+toAmplitudeSignal =
+ fmap
+ (\rate ->
+ RP.fromSignal . SigA.Cons rate . SigS.Cons .
+ fmap (\c -> if c then one else zero) .
+ decons)
+ Proc.getSampleRate
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,623 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{- |
+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,
+ bandlimitFromUniversal,
+ moogLowpass,
+
+ {- ** Allpass -}
+ allpassCascade,
+ allpassFlangerPhase,
+
+ {- ** 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 FiltRec
+
+import qualified Synthesizer.Storable.Signal as SigSt
+import qualified Synthesizer.Generic.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.Signal2 as SigG2
+
+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 Foreign.Storable (Storable, )
+
+-- 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) =>
+ 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, Storable q, Storable 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 :: (Storable a) => Sig.T a -> SigSt.T a
+toStorable = Sig.toStorableSignal SigSt.defaultChunkSize
+
+{-# INLINE fromStorable #-}
+fromStorable :: (Storable 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,
+ Storable q, Storable 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,
+ SigG2.Transform sig q yv, SigG.Write sig 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 (
+ RP.T s (SigA.D 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 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 t,
+ Additive.C yv, RealField.C t, Dim.C u) =>
+ Interpolation.T t yv
+ -> Proc.T s u t (
+ RP.T s flat t {- 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 ::
+ (Hom.C sig, Flat.C flat t,
+ Additive.C yv, RealField.C t, Dim.C u) =>
+ Interpolation.T t yv
+ -> SigP.T u t sig yv
+ {- ToDo: We could also allow any signal from Generic.Read class. -}
+ -> Proc.T s u t (
+ RP.T s flat t {- v frequency factors -}
+ -> RP.T s sig yv)
+frequencyModulationDecoupled ip y =
+ fmap
+ (\toFreq factors ->
+ RP.fromSignal $
+ flip Hom.unwrappedProcessSamples (SigP.signal y) $
+ interpolateMultiRelativeZeroPad ip $
+ SigA.scalarSamples toFreq $
+ SigA.fromSamples (SigP.sampleRate y) $
+ Flat.toSamples 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,
+ Storable q, Storable 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,
+ Storable q, Storable 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,
+ Storable q, Storable 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, Flat.C flat q, Trans.C q, Module.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. -}
+ -> Proc.T s u q (
+ RP.T s flat q {- v The attenuation at the cut-off frequency.
+ Should be between 0 and 1. -}
+ -> 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.lowpassPole
+butterworthHighpass = higherOrderNoResoGen Butter.highpassPole
+chebyshevALowpass = higherOrderNoResoGen Cheby.lowpassAPole
+chebyshevAHighpass = higherOrderNoResoGen Cheby.highpassAPole
+chebyshevBLowpass = higherOrderNoResoGen Cheby.lowpassBPole
+chebyshevBHighpass = higherOrderNoResoGen Cheby.highpassBPole
+
+
+{-# INLINE higherOrderNoResoGen #-}
+higherOrderNoResoGen ::
+ (Hom.C sig, Flat.C flat q, Field.C q, Dim.C u) =>
+ (Int -> [q] -> [q] -> [yv] -> [yv])
+ -> NonNeg.Int
+ -> Proc.T s u q (
+ RP.T s flat q
+ -> SigA.R s (Dim.Recip u) q q
+ -> RP.T s sig yv
+ -> RP.T s sig yv)
+higherOrderNoResoGen filt order =
+ fmap flip $ frequencyControl $ \ freqs ratios ->
+ Hom.processSampleList
+ (filt (NonNeg.toNumber order) (Sig.toList (Flat.toSamples ratios)) (Sig.toList freqs))
+
+
+
+{-# INLINE highpassFromUniversal #-}
+{-# INLINE bandpassFromUniversal #-}
+{-# INLINE lowpassFromUniversal #-}
+{-# INLINE bandlimitFromUniversal #-}
+highpassFromUniversal, lowpassFromUniversal,
+ bandpassFromUniversal, bandlimitFromUniversal ::
+ (Hom.C sig) =>
+ RP.T s sig (UniFilter.Result yv)
+ -> RP.T s sig yv
+{-
+ (Hom.C sig, Dim.C u) =>
+ Proc.T s u q (
+ RP.T s sig (UniFilter.Result yv)
+ -> RP.T s sig yv)
+-}
+highpassFromUniversal = homogeneousMap UniFilter.highpass
+bandpassFromUniversal = homogeneousMap UniFilter.bandpass
+lowpassFromUniversal = homogeneousMap UniFilter.lowpass
+bandlimitFromUniversal = homogeneousMap UniFilter.bandlimit
+
+homogeneousMap ::
+ (Hom.C sig, Ind.C w) =>
+ (y0 -> y1) ->
+ w sig y0 -> w sig y1
+homogeneousMap f =
+ Ind.processSignal (Hom.unwrappedProcessSamples (Sig.map f))
+
+{-
+homogeneousMap0 :: (Hom.C sig) =>
+ (y0 -> y1) ->
+ RP.T s sig y0 -> RP.T s sig y1
+homogeneousMap0 f =
+ Hom.processSamples (Sig.map f)
+
+homogeneousMap1 :: (Hom.C sig) =>
+ (y0 -> y1) ->
+ Proc.T s1 u t (RP.T s sig y0 -> RP.T s sig y1)
+homogeneousMap1 f =
+ Proc.pure (Hom.processSamples (Sig.map f))
+-}
+
+
+{-# 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 FiltRec.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 FiltRec.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
+
+{-# INLINE allpassFlangerPhase #-}
+allpassFlangerPhase :: Trans.C a => a
+allpassFlangerPhase = Allpass.flangerPhase
+
+
+{- | Infinitely many equi-delayed exponentially decaying echos. -}
+{-# INLINE comb #-}
+comb :: (Hom.C sig, RealField.C t, Module.C y yv, Dim.C u, Storable 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,378 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{- |
+Copyright : (c) Henning Thielemann 2008, 2009
+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,
+-- shapeFreqModSample,
+ shapeFreqModFromSampledTone,
+ shapePhaseFreqModFromSampledTone,
+ ) where
+
+import qualified Synthesizer.Dimensional.Abstraction.HomogeneousGen as Hom
+import qualified Synthesizer.Dimensional.Abstraction.Flat as Flat
+
+import qualified Synthesizer.Dimensional.Amplitude as Amp
+import qualified Synthesizer.Dimensional.RatePhantom as RP
+import qualified Synthesizer.Dimensional.RateWrapper as SigP
+
+import qualified Synthesizer.State.Oscillator as Osci
+import qualified Synthesizer.State.Signal as Sig
+
+import qualified Synthesizer.Dimensional.Causal.Process as CausalD
+import qualified Synthesizer.Dimensional.Causal.Oscillator as OsciC
+import qualified Synthesizer.Dimensional.Map as MapD
+
+import qualified Synthesizer.Generic.Signal as SigG
+
+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.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
+
+{- |
+This class is similar to the Homogeneous class
+in the implementation,
+but it is even more strict semantically.
+It requires that values from the waveform
+go untouched to the output signal,
+whereas Homogeneous class still allows homogeneous
+(aka amplitude-unit-independent) operations.
+
+We could use the Homogeneous constraints
+immediately in the oscillator functions,
+but with the functional dependencies
+we get more from type inference.
+This way, the compiler knows,
+that when we apply an oscillator to a flat wave,
+that we want a flat signal as output.
+-}
+class (Hom.C amp (Wave.T t) wave, Hom.C amp Sig.T signal) =>
+ Simple amp t wave signal
+ | wave -> t, signal t -> wave, wave -> signal,
+ signal -> amp, wave -> amp where
+
+instance Simple CausalD.Flat t (Wave.T t) (SigS.T Sig.T) where
+
+instance (Amp.C amp) =>
+ Simple amp t (SigA.T amp (Wave.T t)) (SigA.T amp (SigS.T Sig.T)) where
+
+
+class (Hom.C amp (WaveSmooth.T t) wave, Hom.C amp Sig.T signal) =>
+ Smooth amp t wave signal
+ | wave -> t, signal t -> wave, wave -> signal,
+ signal -> amp, wave -> amp where
+
+instance Smooth CausalD.Flat t (WaveSmooth.T t) (SigS.T Sig.T) where
+
+instance (Amp.C amp) =>
+ Smooth amp t (SigA.T amp (WaveSmooth.T t)) (SigA.T amp (SigS.T Sig.T)) where
+
+
+withWave ::
+ (Hom.C amp waveStore wave, Hom.C amp Sig.T sig) =>
+ wave y -> (waveStore y -> Sig.T y) -> RP.T s sig y
+withWave w f =
+ RP.fromSignal $ Hom.plainProcessSamples f w
+
+
+{- * Oscillators with constant waveforms -}
+
+{- | oscillator with a functional waveform with constant frequency -}
+{-# INLINE static #-}
+static ::
+ (RealField.C t, Dim.C u,
+ Simple amp t wave sig) =>
+ wave y {- ^ waveform -}
+ -> Phase.T t {- ^ start phase -}
+ -> DN.T (Dim.Recip u) t
+ {- ^ frequency -}
+ -> Proc.T s u t (RP.T s sig y)
+static wave phase =
+ staticAux (\freq -> withWave wave $ \w -> Osci.static w phase freq)
+
+{- | oscillator with a functional waveform with constant frequency -}
+{-# INLINE staticAntiAlias #-}
+staticAntiAlias ::
+ (RealField.C t, Dim.C u,
+ Smooth amp t wave sig) =>
+ wave y
+ {- ^ waveform -}
+ -> Phase.T t {- ^ start phase -}
+ -> DN.T (Dim.Recip u) t
+ {- ^ frequency -}
+ -> Proc.T s u t (RP.T s sig y)
+staticAntiAlias wave phase =
+ staticAux (\freq -> withWave wave $ \w -> Osci.staticAntiAlias w phase freq)
+
+{- | oscillator with a functional waveform with modulated frequency -}
+{-# INLINE freqMod #-}
+freqMod ::
+ (RealField.C t, Dim.C u,
+ Simple amp t wave sig) =>
+ wave y {- ^ waveform -}
+ -> Phase.T t {- ^ start phase -}
+ -> Proc.T s u t (
+ SigA.R s (Dim.Recip u) t t
+ {- v frequency control -}
+ -> RP.T s sig y)
+freqMod wave phase =
+ freqModAux (\t -> withWave wave $ \w -> Osci.freqMod w phase t)
+
+{- | oscillator with a functional waveform with modulated frequency -}
+{-# INLINE freqModAntiAlias #-}
+freqModAntiAlias ::
+ (RealField.C t, Dim.C u,
+ Smooth amp t wave sig) =>
+ wave y
+ {- ^ waveform -}
+ -> Phase.T t {- ^ start phase -}
+ -> Proc.T s u t (
+ SigA.R s (Dim.Recip u) t t
+ {- v frequency control -}
+ -> RP.T s sig y)
+freqModAntiAlias wave phase =
+ freqModAux (\t -> withWave wave $ \w -> Osci.freqModAntiAlias w phase t)
+
+{- | oscillator with modulated phase -}
+{-# INLINE phaseMod #-}
+phaseMod ::
+ (Flat.C flat t, RealField.C t, Dim.C u,
+ Simple amp t wave sig) =>
+ wave 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 -}
+ -> RP.T s sig y)
+phaseMod wave =
+ staticAux (\freq sig ->
+ withWave wave $ \w -> Osci.phaseMod w freq . Flat.toSamples $ sig)
+
+{- | 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,
+ Simple amp t wave sig) =>
+ wave 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 -}
+ -> RP.T s sig y)
+phaseFreqMod wave =
+ fmap flip $
+ freqModAux (\ freqs phases ->
+ withWave wave $ \w ->
+ Osci.phaseFreqMod w (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.
+You can also achieve this with a waveform constructed by 'Wave.sample'.
+-}
+{-# INLINE staticSample #-}
+staticSample :: (RealField.C t, Dim.C u) =>
+ Interpolation.T t y
+ -> SigC.R r y {- ^ waveform -}
+ -> Phase.T t {- ^ start phase -}
+ -> 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 -}
+ -> 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 shapeFreqModSample #-}
+shapeFreqModSample :: (RealField.C c, RealField.C t) =>
+ Interpolation.T c (Wave.T t y)
+ -> sig (Wave.T t y)
+ -> c -> Phase.T t
+ -> 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)
+shapeFreqModSample ip waves shape0 phase =
+ uncurry Wave.apply ^<<
+ (InterpolationC.relativeConstantPad ip shape0 waves ***
+ freqsToPhases phase)
+-}
+
+{-# INLINE shapeFreqModFromSampledTone #-}
+shapeFreqModFromSampledTone ::
+ (RealField.C t, SigG.Transform storage yv, Dim.C u,
+ Hom.C amp storage input, Hom.C amp Sig.T output,
+ Flat.C flat t) =>
+ Interpolation.T t yv
+ -> Interpolation.T t yv
+ -> DN.T (Dim.Recip u) t
+ {- ^ source frequency -}
+ -> SigP.T u t input yv
+ -> t -> Phase.T t
+ -> Proc.T s u t (
+ RP.T s flat t
+ {- v shape control -}
+ -> SigA.R s (Dim.Recip u) t t
+ {- v frequency control -}
+ -> RP.T s output yv)
+shapeFreqModFromSampledTone
+ ipLeap ipStep srcFreq sampledTone shape0 phase =
+ flip fmap
+ (OsciC.shapeFreqModFromSampledTone
+ ipLeap ipStep srcFreq sampledTone shape0 phase)
+ (\osci ->
+ \shapes freqs ->
+ osci
+ `CausalD.applyFlatFst`
+ shapes
+ `CausalD.apply`
+ freqs)
+
+
+{-# INLINE shapePhaseFreqModFromSampledTone #-}
+shapePhaseFreqModFromSampledTone ::
+ (RealField.C t, SigG.Transform storage yv, Dim.C u,
+ Hom.C amp storage input, Hom.C amp Sig.T output,
+ Flat.C flatS t, Flat.C flatP t) =>
+ Interpolation.T t yv
+ -> Interpolation.T t yv
+ -> DN.T (Dim.Recip u) t
+ {- ^ source frequency -}
+ -> SigP.T u t input yv
+ -> t -> Phase.T t
+ -> Proc.T s u t (
+ RP.T s flatS t
+ {- v shape control -}
+ -> RP.T s flatP t
+ {- v phase control -}
+ -> SigA.R s (Dim.Recip u) t t
+ {- v frequency control -}
+ -> RP.T s output yv)
+shapePhaseFreqModFromSampledTone
+ ipLeap ipStep srcFreq sampledTone shape0 phase =
+ flip fmap
+ (OsciC.shapePhaseFreqModFromSampledTone
+ ipLeap ipStep srcFreq sampledTone shape0 phase)
+ (\osci ->
+ \shapes phaseDistort freqs ->
+ (osci CausalD.<<^ MapD.packTriple)
+ `CausalD.applyFlatFst`
+ shapes
+ `CausalD.applyFlatFst`
+ phaseDistort
+ `CausalD.apply`
+ freqs)
+
+
+{-# 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 =
+ fmap
+ (\toFreq -> f . SigA.scalarSamples toFreq)
+ (Proc.withParam toFrequencyScalar)
+
+{-# 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,358 @@
+{- |
+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 qualified Synthesizer.Dimensional.Rate.Dirac as Dirac
+
+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 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.D 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.D 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.D v0 y SigS.S) 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 =
+ fmap
+ (\fp -> fp . Dirac.Cons . Ana.zeros . SigA.samples)
+ Dirac.toAmplitudeSignal
+
+
+
+{- |
+Fourier analysis
+-}
+{-# INLINE toFrequencySpectrum #-}
+toFrequencySpectrum :: (Trans.C q, Dim.C u, Dim.C v) =>
+ SigP.T u q (SigA.D v q (SigC.T Sig.T)) (Complex.T q) ->
+ SigP.T (Dim.Recip u) q (SigA.D (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.D (Dim.Mul u v) q (SigC.T Sig.T)) (Complex.T q) ->
+ SigP.T u q (SigA.D 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 Foreign.Storable (Storable, )
+
+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, Storable 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,810 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ExistentialQuantification #-}
+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.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.Causal.Filter as FiltC
+import qualified Synthesizer.Dimensional.Causal.Displacement as DispC
+import qualified Synthesizer.Dimensional.Causal.Process as CausalD
+import qualified Synthesizer.Dimensional.Causal.ControlledProcess as CProc
+
+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.Causal.Process (($/:))
+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 Foreign.Storable (Storable, )
+
+import qualified Synthesizer.Interpolation.Custom as Interpolation
+import qualified Synthesizer.Interpolation.Module as IpMod
+import qualified Synthesizer.Interpolation.Class as Interpol
+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 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.Time (getClockTime, diffClockTimes, tdSec, tdPicosec, )
+import System.IO (hFlush, stdout, )
+import System.Exit (ExitCode)
+
+import System.Random (Random, randomRs, mkStdGen, )
+
+import Data.Tuple.HT (snd3, )
+
+import PreludeBase
+import NumericPrelude
+
+
+
+
+{-# INLINE sineLow #-}
+sineLow ::
+ (RealField.C q, Trans.C q, Module.C q q, Storable 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, Storable 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, Storable 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, Storable 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, Storable 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, Storable 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, Storable 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, Storable 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, Storable 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 IpMod.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, Storable 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, Storable 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 sweepFrequency #-}
+sweepFrequency ::
+ (Trans.C q, RealField.C q) =>
+ Proc.T s Dim.Time q (SigA.R s Dim.Frequency q q)
+sweepFrequency =
+ mapExponential 2 (DN.frequency 1000) $^
+ Osci.static Wave.sine zero (DN.frequency 0.2)
+
+{-# INLINE deepSaw #-}
+deepSaw ::
+ (RealField.C q) =>
+ Proc.T s Dim.Time q (SigS.R s q)
+deepSaw =
+ Osci.static Wave.saw zero (DN.frequency 110)
+
+{-# INLINE universalLowpassDirect #-}
+universalLowpassDirect ::
+ (RealField.C q, Trans.C q, Module.C q q, Random q, Storable q) =>
+ Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q)
+universalLowpassDirect =
+ Filt.lowpassFromUniversal $^
+ (Filt.universal
+ $- DN.scalar 20
+ $: sweepFrequency
+ $: DN.voltage 0.2 &*^ deepSaw)
+
+{-# INLINE universalLowpassSync #-}
+universalLowpassSync ::
+ (RealField.C q, Trans.C q, Module.C q q, Random q, Storable q) =>
+ Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q)
+universalLowpassSync =
+ Filt.lowpassFromUniversal $^
+ (CProc.runSynchronous2 FiltC.universal
+ $- DN.scalar 20
+ $: sweepFrequency
+ $/: DN.voltage 0.2 &*^ deepSaw)
+
+{-# INLINE universalLowpassAsyncLinear #-}
+universalLowpassAsyncLinear ::
+ (RealField.C q, Trans.C q, Module.C q q, Interpol.C q q, Random q, Storable q) =>
+ Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q)
+universalLowpassAsyncLinear =
+ Filt.lowpassFromUniversal $^
+ (CProc.processAsynchronousBuffered2 Interpolation.linear FiltC.universal
+ (DN.frequency 10)
+-- (Rate.fromNumber Dim.frequency 100)
+ (Ctrl.constant (DN.scalar 20))
+ sweepFrequency
+ $/: DN.voltage 0.2 &*^ deepSaw)
+
+{-# INLINE universalLowpassAsyncConstant #-}
+universalLowpassAsyncConstant ::
+ (RealField.C q, Trans.C q, Module.C q q, Random q, Storable q) =>
+ Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q)
+universalLowpassAsyncConstant =
+ Filt.lowpassFromUniversal $^
+ (CProc.processAsynchronousBuffered2 Interpolation.constant FiltC.universal
+ (DN.frequency 100)
+-- (Rate.fromNumber Dim.frequency 100)
+ (Ctrl.constant (DN.scalar 20))
+ sweepFrequency
+ $/: DN.voltage 0.2 &*^ deepSaw)
+
+
+{-# INLINE allpassPhaserDirect #-}
+allpassPhaserDirect ::
+ (RealField.C q, Trans.C q, Module.C q q, Random q, Storable q) =>
+ Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q)
+allpassPhaserDirect =
+ let tone = DN.voltage 0.5 &*^ deepSaw
+ in Disp.mix
+ $: (Filt.allpassCascade 20 Filt.allpassFlangerPhase
+ $: sweepFrequency
+ $: tone)
+ $: tone
+
+{-# INLINE allpassPhaserCausal #-}
+allpassPhaserCausal ::
+ (RealField.C q, Trans.C q, Module.C q q, Random q, Storable q) =>
+ Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q)
+allpassPhaserCausal =
+ let tone = DN.voltage 0.5 &*^ deepSaw
+ phaser =
+ do mix <- DispC.mix
+ apcCtrl <- CProc.joinSynchronous (FiltC.allpassCascade 20 FiltC.allpassFlangerPhase)
+ ctrl <- sweepFrequency
+ return $
+ mix CausalD.<<<
+ CausalD.fanout CausalD.id (CausalD.applyFst apcCtrl ctrl)
+ in phaser $/: tone
+
+
+{-# INLINE moogSawDirect #-}
+moogSawDirect ::
+ (RealField.C q, Trans.C q, Module.C q q, Random q, Storable q) =>
+ Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q)
+moogSawDirect =
+ Filt.moogLowpass 10
+ $- DN.scalar 20
+ $: sweepFrequency
+ $: DN.voltage 0.2 &*^ deepSaw
+
+{-# INLINE moogSawCausal #-}
+moogSawCausal ::
+ (RealField.C q, Trans.C q, Module.C q q, Random q, Storable q) =>
+ Proc.T s Dim.Time q (SigA.R s Dim.Voltage q q)
+moogSawCausal =
+ CProc.runSynchronous2 (FiltC.moogLowpass 10)
+ $- DN.scalar 20
+ $: sweepFrequency
+ $/: DN.voltage 0.2 &*^ deepSaw
+
+
+data Filter a v =
+ forall param. Interpol.C a param => Filter {
+ filterResonance :: a,
+ filterDirect :: forall s. Proc.T s Dim.Time a
+ (-- SigS.R s a ->
+ SigA.R s Dim.Scalar a a ->
+ SigA.R s Dim.Frequency a a ->
+ SigA.R s Dim.Voltage a v ->
+ SigA.R s Dim.Voltage a v),
+ filterCausal :: forall s.
+ FiltC.ResonantFilter s Dim.Time a param (DN.Voltage a) v v}
+
+
+
+{- |
+We do not create noise at a low sampling and resample it by intention.
+Resampling is intended for maintaining maximum quality
+and not for relying on the bad quality of constant interpolation.
+Instead we generate a piecewise constant function manually.
+-}
+{-# 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, Storable 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, Storable 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, Storable 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, Storable 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)
+ <- [("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::[Int]))))
+
+{- |
+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)
+ <- [("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::[Int]))))
+
+
+{-# 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))))
+
+
+measureTime :: String -> IO ExitCode -> IO ()
+measureTime name act =
+ do putStr (name++": ")
+ hFlush stdout
+ timeA <- getClockTime
+ act
+ timeB <- getClockTime
+ let td = diffClockTimes timeB timeA
+ print (fromIntegral (tdSec td) +
+ fromInteger (tdPicosec td) * 1e-12 :: Double)
+
+renderToAIFF :: (Ring.C a) =>
+ (DN.Frequency a -> String -> t -> IO ExitCode) ->
+ String ->
+ t ->
+ IO ()
+renderToAIFF render name sound =
+ measureTime name $
+ render (DN.frequency 44100) (name++".aiff") sound
+
+
+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) ->
+ renderToAIFF
+ File.renderTimeVoltageStereoDoubleToInt16
+ 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, filt@(Filter _filtResonance _filtDirect filtCausal)) ->
+ let render :: String -> (forall s. Proc.T s Dim.Time Double (SigA.R s Dim.Voltage Double Double)) -> IO ()
+ render ext sound =
+ let subName = name ++ "-" ++ ext
+ in renderToAIFF
+ File.renderTimeVoltageMonoDoubleToInt16
+ subName
+ (Cut.take (DN.time 10) $: sound)
+ in do render "direct"
+ (filterDirect filt
+ $- DN.scalar (filterResonance filt)
+ $: sweepFrequency
+ $: DN.voltage 1 &*^ deepSaw)
+ render "sync"
+ (CProc.runSynchronous2 (filtCausal)
+ $- DN.scalar (filterResonance filt)
+ $: sweepFrequency
+ $/: DN.voltage 1 &*^ deepSaw)
+ render "async-constant"
+ (CProc.processAsynchronousBuffered2 Interpolation.constant (filtCausal)
+ (DN.frequency 100)
+ (Ctrl.constant (DN.scalar (filterResonance filt)))
+ sweepFrequency
+ $/: DN.voltage 1 &*^ deepSaw)
+ render "async-linear"
+ (CProc.processAsynchronousBuffered2 Interpolation.linear (filtCausal)
+ (DN.frequency 10)
+ (Ctrl.constant (DN.scalar (filterResonance filt)))
+ sweepFrequency
+ $/: DN.voltage 1 &*^ deepSaw)) $
+ ("allpass-phaser",
+ Filter 0.5
+-- (Filt.allpassPhaser 10)
+ (fmap (\p q f -> CausalD.apply (p q f)) $
+ CProc.runSynchronous2 (FiltC.allpassPhaser 10))
+ (FiltC.allpassPhaser 10)) :
+ ("moog-lowpass",
+ Filter 20
+ (Filt.moogLowpass 10)
+ (FiltC.moogLowpass 10)) :
+ ("universal-lowpass",
+ Filter 20
+ (fmap (\p r f -> Filt.lowpassFromUniversal . p r f) $
+ Filt.universal)
+ (fmap (fmap (\p -> FiltC.lowpassFromUniversal CausalD.<<< p)) $
+ FiltC.universal)) :
+ ("butterworth-lowpass",
+ Filter 0.5
+ (Filt.butterworthLowpass 10)
+ (FiltC.butterworthLowpass 10)) :
+ ("butterworth-highpass",
+ Filter 0.5
+ (Filt.butterworthHighpass 10)
+ (FiltC.butterworthHighpass 10)) :
+ ("chebyshev-a-lowpass",
+ Filter 0.5
+ (Filt.chebyshevALowpass 10)
+ (FiltC.chebyshevALowpass 10)) :
+ ("chebyshev-a-highpass",
+ Filter 0.5
+ (Filt.chebyshevAHighpass 10)
+ (FiltC.chebyshevAHighpass 10)) :
+ ("chebyshev-b-lowpass",
+ Filter 0.5
+ (Filt.chebyshevBLowpass 10)
+ (FiltC.chebyshevBLowpass 10)) :
+ ("chebyshev-b-highpass",
+ Filter 0.5
+ (Filt.chebyshevBHighpass 10)
+ (FiltC.chebyshevBHighpass 10)) :
+ []
+
+ mapM_
+ (\(name, sound) ->
+ renderToAIFF
+ File.renderTimeVoltageMonoDoubleToInt16
+ name (fromSound sound)) $
+
+ {-
+ Moog, Allpass, Universal.lowPass are redundant here,
+ but we leave them for demonstration purposes.
+ -}
+ ("moog-saw-direct",
+ Sound (Cut.take (DN.time 10) $: moogSawDirect)) :
+ ("moog-saw-causal",
+ Sound (Cut.take (DN.time 10) $: moogSawCausal)) :
+
+ ("allpass-phaser-direct",
+ Sound (Cut.take (DN.time 10) $: allpassPhaserDirect)) :
+ ("allpass-phaser-causal",
+ Sound (Cut.take (DN.time 10) $: allpassPhaserCausal)) :
+
+ ("universal-lowpass",
+ Sound (Cut.take (DN.time 10) $: universalLowpassDirect)) :
+ ("universal-lowpass-sync",
+ Sound (Cut.take (DN.time 10) $: universalLowpassSync)) :
+ ("universal-lowpass-async-linear",
+ Sound (Cut.take (DN.time 10) $: universalLowpassAsyncLinear)) :
+ ("universal-lowpass-async-constant",
+ Sound (Cut.take (DN.time 10) $: universalLowpassAsyncConstant)) :
+
+ ("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) ->
+ renderToAIFF
+ File.renderTimeVoltageMonoDoubleToInt16
+ fileName
+ (fromSound tone)
+
+ flip mapM_ (harmonicExamples ++ harmonicMorph ++ waveforms) $
+ \(fileName, tone) ->
+ renderToAIFF
+ File.renderTimeVoltageMonoDoubleToInt16
+ 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,108 @@
+{- |
+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
+
+{- |
+Distort the signal using a flat function.
+The first signal gives the scaling of the function.
+If the scaling is c and the input sample is y,
+then @c * f(y/c)@ is output.
+This way we can use an (efficient) flat function
+and have a simple, yet dimension conform, way of controlling the distortion.
+E.g. if the distortion function is @tanh@
+then the value @c@ controls the saturation level.
+-}
+{-# 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,138 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE Rank2Types #-}
+module Synthesizer.Dimensional.RateAmplitude.File (
+ write,
+ writeTimeVoltage,
+ writeTimeVoltageMonoDoubleToInt16,
+ writeTimeVoltageStereoDoubleToInt16,
+ renderTimeVoltageMonoDoubleToInt16,
+ renderTimeVoltageStereoDoubleToInt16,
+ ) where
+
+import qualified Sound.Sox.Write as Write
+import qualified Sound.Sox.Option.Format as SoxOpt
+import qualified Sound.Sox.Frame as Frame
+import qualified Synthesizer.Basic.Binary as BinSmp
+import qualified Data.StorableVector.Lazy.Builder as Builder
+import Foreign.Storable (Storable, )
+
+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.ToInteger as ToInteger
+-- 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
+
+
+
+{- |
+The output format is determined by SoX by the file name extension.
+The sample precision is determined by the provided 'Builder.Builder' function.
+
+Example:
+
+> import qualified Data.StorableVector.Lazy.Builder as Builder
+>
+> write (DN.frequency one) (DN.voltage one) (\i -> Builder.put (i::Int16)) "test.aiff" sound
+-}
+{-# INLINE write #-}
+write ::
+ (Bounded int, ToInteger.C int, Storable int, Frame.C int, BinSmp.C yv,
+ Dim.C u, RealField.C t,
+ Dim.C v, Module.C y yv, Field.C y) =>
+ DN.T (Dim.Recip u) t ->
+ DN.T v y ->
+ (int -> Builder.Builder int) ->
+ FilePath ->
+ SigP.T u t (SigA.S v y) yv ->
+-- SigP.T u t (SigA.D v y SigS.S) yv ->
+ IO ExitCode
+write freqUnit amp put name sig =
+ let opts =
+ SoxOpt.numberOfChannels (BinSmp.numberOfSignalChannels sig)
+ sampleRate =
+ DN.divToScalar (SigP.sampleRate sig) freqUnit
+ in Write.extended SigSt.hPut opts SoxOpt.none name
+ (round sampleRate)
+ (Builder.toLazyStorableVector SigSt.defaultChunkSize $
+ Sig.monoidConcatMap (BinSmp.outputFromCanonical put) $
+ SigA.vectorSamples (flip DN.divToScalar amp) sig)
+
+
+{-# INLINE writeTimeVoltage #-}
+writeTimeVoltage ::
+ (Bounded int, ToInteger.C int, Storable int, Frame.C int, BinSmp.C yv,
+ RealField.C t,
+ Module.C y yv, Field.C y) =>
+ (int -> Builder.Builder int) ->
+ FilePath ->
+ SigP.T Dim.Time t (SigA.S Dim.Voltage y) yv ->
+-- SigP.T Dim.Time t (SigA.D Dim.Voltage y SigS.S) yv ->
+ IO ExitCode
+writeTimeVoltage =
+ write (DN.frequency one) (DN.voltage one)
+
+
+
+{-# INLINE writeTimeVoltageMonoDoubleToInt16 #-}
+writeTimeVoltageMonoDoubleToInt16 ::
+ FilePath ->
+ SigP.T Dim.Time Double (SigA.S Dim.Voltage Double) Double ->
+-- SigP.T Dim.Time t (SigA.D Dim.Voltage y SigS.S) yv ->
+ IO ExitCode
+writeTimeVoltageMonoDoubleToInt16 name sig =
+ let rate = DN.toNumberWithDimension Dim.frequency (SigP.sampleRate sig)
+ in Write.simple SigSt.hPut SoxOpt.none name (round rate)
+ (SigP.signal (SigRA.toStorableInt16Mono sig))
+
+
+{-# INLINE writeTimeVoltageStereoDoubleToInt16 #-}
+writeTimeVoltageStereoDoubleToInt16 ::
+ FilePath ->
+ SigP.T Dim.Time Double (SigA.S Dim.Voltage Double) (Stereo.T Double) ->
+-- SigP.T Dim.Time t (SigA.D Dim.Voltage y SigS.S) yv ->
+ IO ExitCode
+writeTimeVoltageStereoDoubleToInt16 name sig =
+ let rate = DN.toNumberWithDimension Dim.frequency (SigP.sampleRate sig)
+ in Write.simple SigSt.hPut SoxOpt.none name (round rate)
+ (SigP.signal (SigRA.toStorableInt16Stereo sig))
+
+{-# INLINE renderTimeVoltageMonoDoubleToInt16 #-}
+renderTimeVoltageMonoDoubleToInt16 ::
+ DN.T Dim.Frequency Double ->
+ FilePath ->
+ (forall s. Proc.T s Dim.Time Double (SigA.R s Dim.Voltage Double Double)) ->
+ IO ExitCode
+renderTimeVoltageMonoDoubleToInt16 rate name sig =
+ writeTimeVoltageMonoDoubleToInt16 name (SigP.runProcess rate sig)
+
+{-# INLINE renderTimeVoltageStereoDoubleToInt16 #-}
+renderTimeVoltageStereoDoubleToInt16 ::
+ DN.T Dim.Frequency Double ->
+ FilePath ->
+ (forall s. Proc.T s Dim.Time Double (SigA.R s Dim.Voltage Double (Stereo.T Double))) ->
+ IO ExitCode
+renderTimeVoltageStereoDoubleToInt16 rate name sig =
+ writeTimeVoltageStereoDoubleToInt16 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,584 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{- |
+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,
+ FiltR.bandlimitFromUniversal,
+ moogLowpass,
+
+ {- ** Allpass -}
+ allpassCascade,
+ FiltR.allpassFlangerPhase,
+
+ {- ** 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.Straight.Signal as SigS
+import qualified Synthesizer.Dimensional.RateAmplitude.Signal as SigA
+import qualified Synthesizer.Dimensional.RateWrapper as SigP
+import qualified Synthesizer.Dimensional.RatePhantom as RP
+-- 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.Frame.Stereo as Stereo
+import Foreign.Storable (Storable, )
+
+-- import qualified Synthesizer.State.Displacement as Disp
+import qualified Synthesizer.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.State.Filter.Recursive.Integration as Integrate
+import qualified Synthesizer.State.Filter.Recursive.MovingAverage as MA
+import qualified Synthesizer.Plain.Filter.Recursive as FiltRec
+import qualified Synthesizer.State.Filter.NonRecursive as FiltNR
+
+import qualified Synthesizer.Storable.Signal as SigSt
+import qualified Synthesizer.Generic.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,
+ Storable q, Storable 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,
+ Storable q, Storable 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.D v q SigS.S) 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,
+ Storable q, Storable 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,
+ Storable q, Storable 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,
+ Storable q, Storable 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)
+-}
+
+
+type FrequencyFilter s u q r ic v yv0 yv1 =
+ Proc.T s u q
+ (CProc.T s
+ (SigA.R r (Dim.Recip u) q q)
+ {- v Control signal for the cut-off frequency. -}
+ ic
+ (SigA.R s v q yv0 ->
+ {- v Input signal -}
+ SigA.R s v q yv1))
+ {- v Output signal -}
+
+{-# INLINE firstOrderLowpass #-}
+{-# INLINE firstOrderHighpass #-}
+firstOrderLowpass, firstOrderHighpass ::
+ (Trans.C q, Module.C q yv, Dim.C u, Dim.C v) =>
+ FrequencyFilter s u q r (Filt1.Parameter q) v yv 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)
+ -> FrequencyFilter s u q r (Filt1.Parameter q) v yv 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 ::
+ (Flat.C flat q, Trans.C q, Module.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. -}
+ -> ResonantFilter s u q r flat (FiltRec.Pole q) v yv yv
+
+butterworthLowpass = higherOrderNoResoGen Butter.lowpassPole
+butterworthHighpass = higherOrderNoResoGen Butter.highpassPole
+chebyshevALowpass = higherOrderNoResoGen Cheby.lowpassAPole
+chebyshevAHighpass = higherOrderNoResoGen Cheby.highpassAPole
+chebyshevBLowpass = higherOrderNoResoGen Cheby.lowpassBPole
+chebyshevBHighpass = higherOrderNoResoGen Cheby.highpassBPole
+
+{- FIXME:
+currently only frequencies can be interpolated not the filter parameters,
+this is not very efficient
+-}
+{- TODO:
+initial value
+-}
+{-# INLINE higherOrderNoResoGen #-}
+higherOrderNoResoGen ::
+ (Flat.C flat q, Field.C q, Dim.C u, Dim.C v) =>
+ (Int -> [q] -> [q] -> [yv] -> [yv])
+ -> NonNeg.Int
+ -> ResonantFilter s u q r flat (FiltRec.Pole q) v yv yv
+
+higherOrderNoResoGen filt order =
+ frequencyResonanceControl id
+ (\ cs xs ->
+ let csl = Sig.toList cs
+ in Sig.fromList (filt (NonNeg.toNumber order)
+ (map FiltRec.poleResonance csl)
+ (map FiltRec.poleFrequency csl)
+ (Sig.toList xs)))
+
+
+type ResonantFilter s u q r flat ic v yv0 yv1 =
+ Proc.T s u q
+ (CProc.T s
+ (RP.T r flat q
+ {- v signal for resonance,
+ i.e. factor of amplification at the resonance frequency
+ relatively to the transition band. -},
+ SigA.R r (Dim.Recip u) q q
+ {- v signal for cut off frequency -} )
+ ic
+ (SigA.R s v q yv0 ->
+ SigA.R s v q yv1))
+
+
+{-# INLINE universal #-}
+universal ::
+ (Flat.C flat q, Trans.C q, Module.C q yv, Dim.C u, Dim.C v) =>
+ ResonantFilter s u q r flat (UniFilter.Parameter q) v yv (UniFilter.Result yv)
+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
+ -> ResonantFilter s u q r flat (Moog.Parameter q) v yv yv
+moogLowpass order =
+ let orderInt = NonNeg.toNumber order
+ in frequencyResonanceControl
+ (Moog.parameter orderInt)
+ (Sig.modifyModulated (Moog.lowpassModifier orderInt))
+
+
+{-# INLINE allpassCascade #-}
+{- | the lowest comb frequency is used as the filter frequency -}
+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 -}
+ -> FrequencyFilter s u q r (Allpass.Parameter q) v yv 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 q, Dim.C u, Dim.C v) =>
+ (q -> ic) ->
+ (Sig.T ic -> Sig.T yv0 -> Sig.T yv1) ->
+ FrequencyFilter s u q r ic v yv0 yv1
+
+frequencyControl mkParam filt =
+ do toFreq <- Proc.withParam toFrequencyScalar
+ return $ CProc.Cons
+ (\ freqs -> Sig.map mkParam (SigA.scalarSamples toFreq freqs))
+ (\ params -> SigA.processSamples (filt params))
+
+
+{-# INLINE frequencyResonanceControl #-}
+frequencyResonanceControl ::
+ (Flat.C flat q, Field.C q, Dim.C u, Dim.C v) =>
+ (FiltRec.Pole q -> ic) ->
+ (Sig.T ic -> Sig.T yv0 -> Sig.T yv1) ->
+ ResonantFilter s u q r flat ic v yv0 yv1
+
+frequencyResonanceControl mkParam filt =
+ do toFreq <- Proc.withParam toFrequencyScalar
+ return $ CProc.Cons
+ (\ (resos, freqs) ->
+ Sig.map mkParam $
+ Sig.zipWith FiltRec.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, Storable 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,
+ Dim.C u, Dim.C v, Storable yv) =>
+ 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,543 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+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 Foreign.Storable (Storable, )
+
+import qualified Algebra.DimensionTerm as Dim
+import qualified Number.DimensionTerm as DN
+
+import Number.DimensionTerm ((*&), (&*&), )
+
+import qualified Synthesizer.Interpolation.Module 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 Filt.allpassFlangerPhase
+ $: 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
+{-
+renderTimeVoltageMonoDoubleToInt16 (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.renderTimeVoltageMonoDoubleToInt16 (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, 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, Storable 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 ::
+ (Random a, RealField.C a, Trans.C a, Module.C a a, Storable 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,144 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{- |
+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.Rate.Dirac as Dirac
+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 instantaneous 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 occurrence 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 occurrence is represented by a peak of area 1. -}
+randomPeeksGen g =
+ Proc.withParam $ \ dens ->
+ do freq <- SigA.toFrequencyScalar (SigA.amplitude dens)
+ Dirac.toAmplitudeSignal $#
+ (Dirac.Cons $
+ 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,117 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE Rank2Types #-}
+module Synthesizer.Dimensional.RateAmplitude.Play (
+ auto,
+ timeVoltage,
+ timeVoltageMonoDoubleToInt16,
+ timeVoltageStereoDoubleToInt16,
+ renderTimeVoltageMonoDoubleToInt16,
+ renderTimeVoltageStereoDoubleToInt16,
+ ) where
+
+import qualified Sound.Sox.Play as Play
+import qualified Sound.Sox.Option.Format as SoxOpt
+import qualified Sound.Sox.Frame as Frame
+import qualified Synthesizer.Basic.Binary as BinSmp
+import qualified Data.StorableVector.Lazy.Builder as Builder
+import Foreign.Storable (Storable, )
+
+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.State.Signal as Sig
+
+import qualified Synthesizer.Frame.Stereo as Stereo
+
+import qualified Algebra.DimensionTerm as Dim
+import qualified Number.DimensionTerm as DN
+
+import qualified Algebra.ToInteger as ToInteger
+-- 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.Exit(ExitCode)
+
+import NumericPrelude
+import PreludeBase
+
+
+{-# INLINE auto #-}
+auto ::
+ (Bounded int, ToInteger.C int, Storable int, Frame.C int, BinSmp.C yv,
+ Dim.C u, RealField.C t,
+ Dim.C v, Module.C y yv, Field.C y) =>
+ DN.T (Dim.Recip u) t ->
+ DN.T v y ->
+ (int -> Builder.Builder int) ->
+ SigP.T u t (SigA.S v y) yv ->
+-- SigP.T u t (SigA.D v y SigS.S) yv ->
+ IO ExitCode
+auto freqUnit amp put sig =
+ let opts =
+ SoxOpt.numberOfChannels (BinSmp.numberOfSignalChannels sig)
+ sampleRate =
+ DN.divToScalar (SigP.sampleRate sig) freqUnit
+ in Play.extended SigSt.hPut opts SoxOpt.none
+ (round sampleRate)
+ (Builder.toLazyStorableVector SigSt.defaultChunkSize $
+ Sig.monoidConcatMap (BinSmp.outputFromCanonical put) $
+ SigA.vectorSamples (flip DN.divToScalar amp) sig)
+
+
+{-# INLINE timeVoltage #-}
+timeVoltage ::
+ (Bounded int, ToInteger.C int, Storable int, Frame.C int, BinSmp.C yv,
+ RealField.C t,
+ Module.C y yv, Field.C y) =>
+ (int -> Builder.Builder int) ->
+ SigP.T Dim.Time t (SigA.S Dim.Voltage y) yv ->
+-- SigP.T Dim.Time t (SigA.D Dim.Voltage y SigS.S) yv ->
+ IO ExitCode
+timeVoltage =
+ auto (DN.frequency one) (DN.voltage one)
+
+
+{-# INLINE timeVoltageMonoDoubleToInt16 #-}
+timeVoltageMonoDoubleToInt16 ::
+ SigP.T Dim.Time Double (SigA.S Dim.Voltage Double) Double ->
+ IO ExitCode
+timeVoltageMonoDoubleToInt16 sig =
+ let rate = DN.toNumberWithDimension Dim.frequency (SigP.sampleRate sig)
+ in Play.simple SigSt.hPut SoxOpt.none (round rate)
+ (SigP.signal (SigRA.toStorableInt16Mono sig))
+
+
+{-# INLINE timeVoltageStereoDoubleToInt16 #-}
+timeVoltageStereoDoubleToInt16 ::
+ SigP.T Dim.Time Double (SigA.S Dim.Voltage Double) (Stereo.T Double) ->
+-- SigP.T Dim.Time t (SigA.D Dim.Voltage y SigS.S) yv ->
+ IO ExitCode
+timeVoltageStereoDoubleToInt16 sig =
+ let rate = DN.toNumberWithDimension Dim.frequency (SigP.sampleRate sig)
+ in Play.simple SigSt.hPut SoxOpt.none (round rate)
+ (SigP.signal (SigRA.toStorableInt16Stereo sig))
+
+
+{-# INLINE renderTimeVoltageMonoDoubleToInt16 #-}
+renderTimeVoltageMonoDoubleToInt16 ::
+ DN.T Dim.Frequency Double ->
+ (forall s. Proc.T s Dim.Time Double (SigA.R s Dim.Voltage Double Double)) ->
+ IO ExitCode
+renderTimeVoltageMonoDoubleToInt16 rate sig =
+ timeVoltageMonoDoubleToInt16 (SigP.runProcess rate sig)
+
+{-# INLINE renderTimeVoltageStereoDoubleToInt16 #-}
+renderTimeVoltageStereoDoubleToInt16 ::
+ DN.T Dim.Frequency Double ->
+ (forall s. Proc.T s Dim.Time Double (SigA.R s Dim.Voltage Double (Stereo.T Double))) ->
+ IO ExitCode
+renderTimeVoltageStereoDoubleToInt16 rate sig =
+ timeVoltageStereoDoubleToInt16 (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,183 @@
+{- |
+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 (
+ D, R,
+ Proc.toTimeScalar,
+ Proc.toFrequencyScalar,
+ toAmplitudeScalar,
+ toGradientScalar,
+ DimensionGradient,
+ amplitude, samples,
+ fromSignal, fromSamples,
+ scalarSamples, fromScalarSamples, scalarSamplesGeneric,
+ vectorSamples, fromVectorSamples,
+ replaceAmplitude,
+ replaceSamples,
+ processSamples,
+ asTypeOfAmplitude,
+ ($-), ($&),
+ (&*^), (&*>^),
+ 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.Frame.Stereo as Stereo
+import qualified Synthesizer.Basic.Binary as BinSmp
+import Data.Int (Int16)
+import Foreign.Storable (Storable, )
+
+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, 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)
+
+
+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'.
+This is no longer important
+since the processes which expects those inputs
+can use the Flat type class.
+-}
+{-# 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, Storable yv0) =>
+ Proc.T s u t (w (D v y SigS.S) yv0) ->
+ Proc.T s u t (w (D v y SigS.S) yv0)
+cache =
+ fmap (processSamples
+ (Sig.fromStorableSignal . Sig.toStorableSignal SigSt.defaultChunkSize))
+
+{-# INLINE bindCached #-}
+bindCached ::
+ (Dim.C v, Ind.C w, Storable yv0) =>
+ Proc.T s u t (w (D v y SigS.S) yv0) ->
+ (w (D v y SigS.S) 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, Storable yv0) =>
+ Proc.T s u t (w (D v y SigS.S) yv0) ->
+ (Proc.T s u t (w (D v y SigS.S) 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) =>
+ w (SigA.S Dim.Voltage a) a ->
+ w SigSt.T Int16
+toStorableInt16Mono =
+ Ind.processSignal
+ (Sig.toStorableSignal SigSt.defaultChunkSize .
+ Sig.map BinSmp.int16FromCanonical .
+ SigA.scalarSamplesPrivate (DN.toNumberWithDimension Dim.voltage))
+
+{-# INLINE toStorableInt16Stereo #-}
+toStorableInt16Stereo ::
+ (Ind.C w, Module.C a a, RealField.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.int16FromCanonical) .
+ 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,463 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+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.Frame.Stereo as Stereo
+
+-- import qualified Synthesizer.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.renderTimeVoltageStereoDoubleToInt16
+ (DN.frequency (44100::Double))
+-- (Cut.take (DN.time 2) $: songSignal)
+ songSignal
+-- accompaniment
+-- bassSignal
+ >> return ()
+
+{-
+ File.renderTimeVoltageStereoDoubleToInt16 "traumzauberbaum"
+ (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,195 @@
+{-# LANGUAGE Rank2Types #-}
+{- |
+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
+
+
+{- |
+Render a signal generated by a signal processor
+at the given sample rate,
+and leave the sample rate context.
+If you want to render multiple signals,
+then convert them with 'fromProcess'
+and move them out of the sample rate context
+all at once using 'Proc.run'.
+-}
+{-# 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.S v -> w SigS.S v -> w SigS.S 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.S v -> w SigS.S 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.S 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.S c ->
+ w SigS.S a ->
+ w SigS.S 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,90 @@
+{- |
+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 S yv
+type S = T Sig.T
+
+{- |
+In contrast to 'Synthesizer.Dimensional.Rate.Dirac'
+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/synthesizer-dimensional.cabal b/synthesizer-dimensional.cabal
new file mode 100644
--- /dev/null
+++ b/synthesizer-dimensional.cabal
@@ -0,0 +1,136 @@
+Name: synthesizer-dimensional
+Version: 0.2
+License: GPL
+License-File: LICENSE
+Author: Henning Thielemann
+Maintainer: Henning Thielemann
+Homepage: http://www.haskell.org/haskellwiki/Synthesizer
+Category: Sound
+Synopsis: Audio signal processing with static physical dimensions
+Description:
+ High-level functions which use physical units and
+ abstract from the sample rate in a statically type safe way.
+Stability: Experimental
+Tested-With: GHC==6.4.1, GHC==6.8.2
+Cabal-Version: >=1.6
+Build-Type: Simple
+
+-- Extra-Source-Files:
+-- Makefile
+
+Flag splitBase
+ description: Choose the new smaller, split-up base package.
+
+Flag optimizeAdvanced
+ description: Enable advanced optimizations. They slow down compilation considerably.
+ default: True
+
+Flag buildExamples
+ description: Build example executables
+ default: False
+
+
+Source-Repository this
+ Tag: 0.2
+ Type: darcs
+ Location: http://code.haskell.org/synthesizer/dimensional/
+
+Source-Repository head
+ Type: darcs
+ Location: http://code.haskell.org/synthesizer/dimensional/
+
+Library
+ Build-Depends:
+ synthesizer-core >=0.2 && <0.3,
+ transformers >=0.0.1 && <0.2,
+ event-list >=0.0.8 && <0.1,
+ non-negative >=0.0.5 && <0.1,
+ numeric-prelude >=0.1.1 && <0.2,
+ utility-ht >=0.0.5 && <0.1,
+ storable-record >=0.0.1 && <0.1,
+ sox >=0.0 && <0.1,
+ storablevector >=0.2.3 && <0.3,
+ binary >=0.1 && <1,
+ bytestring >= 0.9 && <0.10
+
+ If flag(splitBase)
+ Build-Depends:
+ base >= 3 && <5,
+ random >=1.0 && <2.0,
+ old-time >=1.0 && <2,
+ process >=1.0 && <1.1
+ Else
+ Build-Depends:
+ base >= 1.0 && < 2,
+ special-functors >= 1.0 && <1.1
+
+ GHC-Options: -Wall
+ Hs-source-dirs: src
+ Exposed-modules:
+ Synthesizer.Dimensional.Abstraction.Flat
+ Synthesizer.Dimensional.Abstraction.Homogeneous
+ Synthesizer.Dimensional.Abstraction.HomogeneousGen
+ Synthesizer.Dimensional.Abstraction.RateIndependent
+ Synthesizer.Dimensional.Amplitude
+ 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.Arrow
+ Synthesizer.Dimensional.Map
+ Synthesizer.Dimensional.Causal.Process
+ Synthesizer.Dimensional.Causal.ControlledProcess
+ Synthesizer.Dimensional.Causal.Displacement
+ Synthesizer.Dimensional.Causal.Filter
+ Synthesizer.Dimensional.Causal.Oscillator
+ 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.Dirac
+ 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
+
+-- Other-Modules:
+
+
+Executable demonstration
+ If !flag(buildExamples)
+ Buildable: False
+ GHC-Options: -Wall -fexcess-precision
+ If flag(optimizeAdvanced)
+ GHC-Options: -O2 -fvia-C -optc-O2
+-- -ddump-simpl-stats
+ Hs-Source-Dirs: src
+ Main-Is:
+ Demonstration.hs
+ Other-Modules:
+ Synthesizer.Dimensional.RateAmplitude.Demonstration
+
+Executable traumzauberbaum
+ If !flag(buildExamples)
+ Buildable: False
+ GHC-Options: -Wall -fexcess-precision
+ If flag(optimizeAdvanced)
+ GHC-Options: -O2 -fvia-C -optc-O2
+ Hs-Source-Dirs: src
+ Main-Is: Synthesizer/Dimensional/RateAmplitude/Traumzauberbaum.hs