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/alinea/Alinea.hs b/alinea/Alinea.hs
new file mode 100644
--- /dev/null
+++ b/alinea/Alinea.hs
@@ -0,0 +1,219 @@
+{-# OPTIONS -fno-implicit-prelude -fglasgow-exts #-}
+module Main where
+
+import Number.SI as SIValue
+import Number.SI.Unit as SIUnit
+ (yocto, zepto, atto, femto, pico, nano, micro, milli, centi, deci,
+ one, deca, hecto, kilo, mega, giga, tera, peta, exa, zetta, yotta)
+
+import qualified Synthesizer.Inference.Monad.SignalSeq as SigI
+import qualified Synthesizer.Inference.Monad.File as FileI
+import qualified UniqueLogicNP.Explicit.Process as ProcI
+
+import qualified Synthesizer.Inference.Monad.SignalSeq.Control as CtrlI
+import qualified Synthesizer.Inference.Monad.SignalSeq.Cut as CutI
+import qualified Synthesizer.Inference.Monad.SignalSeq.Filter as FiltI
+import qualified Synthesizer.Inference.Monad.SignalSeq.Noise as NoiseI
+import qualified Synthesizer.Inference.Monad.SignalSeq.Oscillator as OsciI
+import qualified Synthesizer.Inference.Monad.SignalSeq.Displacement as SynI
+
+import qualified Synthesizer.Plain.Interpolation as Interpolation
+import qualified Synthesizer.Basic.Wave as Wave
+
+import qualified Algebra.NormedSpace.Maximum as NormedMax
+import qualified Algebra.VectorSpace as VectorSpace
+import qualified Synthesizer.Basic.Binary as BinSmp
+
+import System.Random(StdGen,mkStdGen)
+
+import NumericPrelude
+import PreludeBase as P
+
+-- import Presentation (SIDouble, SigInfPhysDouble) from dafx package
+type SIDouble = SIValue.T Double Double
+type SigInfPhysDouble = SigI.Process Double SIDouble Double
+
+
+c :: SIDouble -> SigInfPhysDouble
+c = CtrlI.constant
+
+noise :: SigInfPhysDouble
+noise = noiseGen (mkStdGen 32954)
+
+noiseGen :: StdGen -> SigInfPhysDouble
+noiseGen g =
+ NoiseI.whiteGen g (10 * kilo * hertz) (0.26*volt)
+
+burst, click ::
+ StdGen -> SigInfPhysDouble
+burst g =
+ CutI.take
+ (100*milli*second)
+ (noiseGen g)
+click g =
+ FiltI.envelope
+ (CtrlI.exponential2 (20*milli*second) 1)
+ (noiseGen g)
+
+stereoNoise :: (StdGen -> SigInfPhysDouble) -> SigInfPhysDoubleStereo
+stereoNoise sound =
+ CutI.zip (sound (mkStdGen 1223)) (sound (mkStdGen 71))
+
+
+tonk :: SIDouble -> SIDouble -> SigInfPhysDouble
+tonk excite detune =
+ FiltI.envelope
+ (CtrlI.exponential2 (10*milli*second) 1)
+ (OsciI.phaseMod Wave.sine (0.5*volt) (200*hertz + detune)
+ (FiltI.envelope
+ (CtrlI.exponential2 (10*milli*second) excite)
+ (OsciI.static Wave.sine 1 0 (200*hertz))))
+
+tink, bloik, spring, glass, dropSnd, blob, whistle ::
+ SIDouble -> SigInfPhysDouble
+tink detune =
+ FiltI.envelope
+ (CtrlI.exponential2 (10*milli*second) 1)
+ (SynI.mixMulti
+ [OsciI.static Wave.sine (0.5*volt) 0 (2000*hertz + detune),
+ OsciI.static Wave.sine (0.5*volt) 0 (3000*hertz + detune)])
+bloik detune =
+ FiltI.envelope
+ (CtrlI.exponential2 (10*milli*second) 1)
+ (OsciI.phaseFreqMod Wave.sine (1*volt)
+ (FiltI.envelope
+ (CtrlI.exponential2 (10*milli*second) 1)
+ (OsciI.static Wave.sine 1 0 (200*hertz)))
+ (CtrlI.mapExponential
+ 2 (100*hertz + detune)
+ (CtrlI.exponential2 (10*milli*second) 1)))
+spring detune =
+ do freqCtrl <- ProcI.share
+ (CtrlI.mapExponential
+ 2 (1000*hertz + detune)
+ (CtrlI.linear (1/second) (-1)))
+ FiltI.envelope
+ (CtrlI.exponential2 (100*milli*second) 1)
+ (OsciI.phaseFreqMod Wave.sine (1*volt)
+ (FiltI.envelope
+ (CtrlI.exponential2 (100*milli*second) 1)
+ (OsciI.freqMod Wave.sine 1 0 freqCtrl))
+ freqCtrl)
+glass detune =
+ FiltI.envelope
+ (CtrlI.exponential2 (100*milli*second) 1)
+ (OsciI.phaseMod Wave.sine (1*volt) (1000*hertz + detune)
+ (FiltI.envelope
+ (CtrlI.exponential2 (10*milli*second) 1)
+ (OsciI.static Wave.sine 1 0 (1000*hertz + detune))))
+dropSnd detune =
+ FiltI.envelope
+ (CtrlI.exponential2 (50*milli*second) 1)
+ (OsciI.freqMod Wave.sine volt 0
+ (FiltI.firstOrderLowpass
+ (c (10*hertz))
+-- (FiltI.butterworthLowpass
+-- 4 (c 0.5) (c (1*hertz))
+ (CtrlI.exponential2 (50*milli*second) (2000*hertz + detune))))
+blob detune =
+ FiltI.envelope
+ (CtrlI.exponential2 (30*milli*second) 1)
+ (OsciI.freqMod Wave.sine volt 0
+ (CtrlI.exponential2 (200*milli*second) (500*hertz + detune)))
+
+whistle detune =
+ CutI.take
+ (0.4*second)
+ (OsciI.freqMod Wave.sine volt 0
+ (CtrlI.mapLinear (100*hertz) (2000*hertz + detune)
+ (OsciI.static Wave.square 1 0 (40*hertz))))
+
+stereoOsci :: (SIDouble -> SigInfPhysDouble) -> SigInfPhysDoubleStereo
+stereoOsci sound =
+ CutI.zip (sound (10*hertz)) (sound (-10*hertz))
+
+
+explosion, rocket, phaser ::
+ SigInfPhysDoubleStereo
+explosion =
+ FiltI.envelope
+ (CtrlI.exponential2 (0.3*second) 10)
+ (FiltI.chebyshevBLowpass 4
+ (c 0.02)
+ (CtrlI.exponential2 (1*second) (500*hertz))
+ (FiltI.phaserStereo Interpolation.constant (0.003*second)
+ (CtrlI.exponential2 (0.5*second) (0.003*second))
+ noise))
+
+rocket =
+ FiltI.envelope
+ (CtrlI.exponential2 (0.5*second) 5)
+ (FiltI.chebyshevALowpass 4
+ (c 0.7)
+ (CtrlI.exponential2 (2*second) (2000*hertz))
+ (FiltI.phaserStereo Interpolation.constant (0.003*second)
+ (CtrlI.exponential2 (0.5*second) (0.003*second))
+ noise))
+
+phaser =
+ CutI.take
+ (3*second)
+ (FiltI.phaserStereo Interpolation.constant (0.001*second)
+ (OsciI.static Wave.sine (0.001*second) 0 (0.5*hertz))
+ noise)
+
+
+
+sounds :: [(FilePath, SigInfPhysDouble)]
+sounds =
+ ("burst", burst (mkStdGen 123)) :
+ ("click", click (mkStdGen 123)) :
+ ("tink", tink (0*hertz)) :
+ ("bloik", bloik (0*hertz)) :
+ ("spring", spring (0*hertz)) :
+ ("glass", glass (0*hertz)) :
+ ("tonk", tonk 1 (0*hertz)) :
+ ("zonk", tonk 5 (0*hertz)) :
+ ("drop", dropSnd (0*hertz)) :
+ ("blob", blob (0*hertz)) :
+ ("whistle", whistle (0*hertz)) :
+ []
+
+
+type SigInfPhysDoubleStereo = SigI.Process Double SIDouble (Double,Double)
+
+stereoSounds :: [(FilePath, SigInfPhysDoubleStereo)]
+stereoSounds =
+ ("burst", stereoNoise burst) :
+ ("click", stereoNoise click) :
+ ("tink", stereoOsci tink ) :
+ ("bloik", stereoOsci bloik ) :
+ ("spring", stereoOsci spring ) :
+ ("glass", stereoOsci glass ) :
+ ("tonk", stereoOsci (tonk 1)) :
+ ("zonk", stereoOsci (tonk 5)) :
+ ("drop", stereoOsci dropSnd) :
+ ("blob", stereoOsci blob ) :
+ ("whistle", stereoOsci whistle) :
+ ("explosion", explosion) :
+ ("rocket", rocket) :
+ ("phaser", phaser) :
+ []
+
+
+writeSound ::
+ (BinSmp.C v, VectorSpace.C Double v, NormedMax.C Double v) =>
+ FilePath -> FilePath ->
+ SigI.Process Double SIDouble v -> IO ()
+writeSound path name signal =
+ do FileI.writeToInt16 hertz volt (path++name)
+ (SigI.fixSampleRate (44100*hertz)
+ (CutI.takeUntilPause (0.01*volt) (10*milli*second) signal))
+ return ()
+
+
+
+main :: IO ()
+main =
+ do mapM_ (uncurry (writeSound "alinea/stereo/")) stereoSounds
+ mapM_ (uncurry (writeSound "alinea/mono/")) sounds
diff --git a/src/Synthesizer/Amplitude/Control.hs b/src/Synthesizer/Amplitude/Control.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/Amplitude/Control.hs
@@ -0,0 +1,88 @@
+{- |
+Copyright : (c) Henning Thielemann 2008
+License : GPL
+
+Maintainer : synthesizer@henning-thielemann.de
+Stability : provisional
+Portability : requires multi-parameter type classes
+
+
+Control curves which can be used
+as envelopes, for controlling filter parameters and so on.
+-}
+module Synthesizer.Amplitude.Control
+ ({- * Primitives -}
+ constant, constantVector,
+ {- * Preparation -}
+ mapLinear, mapExponential,
+ ) where
+
+import qualified Synthesizer.Plain.Control as Ctrl
+
+import qualified Synthesizer.Amplitude.Signal as SigV
+import Synthesizer.Amplitude.Signal (toAmplitudeScalar)
+
+import qualified Algebra.OccasionallyScalar as OccScalar
+import qualified Algebra.Module as Module
+import qualified Algebra.Transcendental as Trans
+import qualified Algebra.Field as Field
+import qualified Algebra.Real as Real
+import qualified Algebra.Ring as Ring
+import qualified Algebra.Additive as Additive
+
+import NumericPrelude
+import PreludeBase as P
+import Prelude ()
+
+
+constant :: (Field.C y', Real.C y', OccScalar.C y y') =>
+ y' {-^ value -}
+ -> SigV.T y y' y
+constant y =
+ constantVector (abs y) (OccScalar.toScalar (signum y))
+
+{- |
+The amplitude must be positive!
+This is not checked.
+-}
+constantVector :: -- (Field.C y', Real.C y', OccScalar.C y y') =>
+ y' {-^ amplitude -}
+ -> yv {-^ value -}
+ -> SigV.T y y' yv
+constantVector y yv =
+ SigV.Cons y (Ctrl.constant yv)
+
+
+{- |
+Map a control curve without amplitude unit
+by a linear (affine) function with a unit.
+-}
+mapLinear :: (Ring.C y, Field.C y', Real.C y', OccScalar.C y y') =>
+ y' {- ^ range: one is mapped to @center+range@ -}
+ -> y' {- ^ center: zero is mapped to @center@ -}
+ -> SigV.T y y' y
+ -> SigV.T y y' y
+mapLinear range center (SigV.Cons amp ss) =
+ let absRange = abs range * amp
+ absCenter = abs center
+ rng = toAmplitudeScalar z absRange
+ cnt = toAmplitudeScalar z absCenter
+ z = SigV.Cons
+ (absRange + absCenter)
+ (map (\y -> cnt + rng*y) ss)
+ in z
+-- SynI.mapScalar 1 (absRange + absCenter) (\y -> cnt + rng*y) x
+
+{- |
+Map a control curve without amplitude unit
+exponentially to one with a unit.
+-}
+mapExponential :: (Field.C y', Trans.C y, Module.C y y') =>
+ y {- ^ range: one is mapped to @center*range@, must be positive -}
+ -> y' {- ^ center: zero is mapped to @center@ -}
+ -> SigV.T y y y
+ -> SigV.T y y' y
+mapExponential range center (SigV.Cons amp ss) =
+ let b = range**amp
+ in SigV.Cons (b*>center) (map (\x -> b**(x-one)) ss)
+-- SynI.mapScalar 1 center (range**)
diff --git a/src/Synthesizer/Amplitude/Cut.hs b/src/Synthesizer/Amplitude/Cut.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/Amplitude/Cut.hs
@@ -0,0 +1,156 @@
+{- |
+Copyright : (c) Henning Thielemann 2008
+License : GPL
+
+Maintainer : synthesizer@henning-thielemann.de
+Stability : provisional
+Portability : requires multi-parameter type classes
+-}
+module Synthesizer.Amplitude.Cut (
+ {- * dissection -}
+ unzip,
+ unzip3,
+
+ {- * glueing -}
+ concat, concatVolume,
+ append, appendVolume,
+ zip, zipVolume,
+ zip3, zip3Volume,
+ ) where
+
+import qualified Synthesizer.Amplitude.Signal as SigV
+import Synthesizer.Amplitude.Signal (toAmplitudeScalar)
+
+-- import qualified Algebra.NormedSpace.Maximum as NormedMax
+import qualified Algebra.OccasionallyScalar as OccScalar
+import qualified Algebra.Module as Module
+import qualified Algebra.Field as Field
+-- import qualified Algebra.Ring as Ring
+
+import qualified Data.List as List
+
+import PreludeBase (Ord, max, map)
+-- import NumericPrelude
+import Prelude ()
+
+
+{- * dissection -}
+
+unzip ::
+ SigV.T y y' (yv0, yv1) ->
+ (SigV.T y y' yv0, SigV.T y y' yv1)
+unzip x =
+ let (ss0,ss1) = List.unzip (SigV.samples x)
+ in (SigV.replaceSamples ss0 x, SigV.replaceSamples ss1 x)
+
+unzip3 ::
+ SigV.T y y' (yv0, yv1, yv2) ->
+ (SigV.T y y' yv0, SigV.T y y' yv1, SigV.T y y' yv2)
+unzip3 x =
+ let (ss0,ss1,ss2) = List.unzip3 (SigV.samples x)
+ in (SigV.replaceSamples ss0 x, SigV.replaceSamples ss1 x, SigV.replaceSamples ss2 x)
+
+
+
+{- * glueing -}
+
+{- |
+Similar to @foldr1 append@ but more efficient and accurate,
+because it reduces the number of amplifications.
+Does not work for infinite lists,
+because no maximum amplitude can be computed.
+-}
+concat ::
+ (Ord y', Field.C y', OccScalar.C y y',
+ Module.C y yv) =>
+ [SigV.T y y' yv] -> SigV.T y y' yv
+concat xs =
+ concatVolume (List.maximum (map SigV.amplitude xs)) xs
+
+{- |
+Give the output volume explicitly.
+Does also work for infinite lists.
+-}
+concatVolume ::
+ (Field.C y', OccScalar.C y y',
+ Module.C y yv) =>
+ y' -> [SigV.T y y' yv] -> SigV.T y y' yv
+concatVolume amp xs =
+ let smps = map (SigV.vectorSamples (toAmplitudeScalar z)) xs
+ z = SigV.Cons amp (List.concat smps)
+ in z
+
+
+merge ::
+ (Ord y', Field.C y', OccScalar.C y y',
+ Module.C y yv0, Module.C y yv1) =>
+ ([yv0] -> [yv1] -> [yv2]) ->
+ SigV.T y y' yv0 -> SigV.T y y' yv1 -> SigV.T y y' yv2
+merge f x0 x1 =
+ mergeVolume f (max (SigV.amplitude x0) (SigV.amplitude x1)) x0 x1
+
+mergeVolume ::
+ (Field.C y', OccScalar.C y y',
+ Module.C y yv0, Module.C y yv1) =>
+ ([yv0] -> [yv1] -> [yv2]) ->
+ y' ->
+ SigV.T y y' yv0 -> SigV.T y y' yv1 -> SigV.T y y' yv2
+mergeVolume f amp x y =
+ let sampX = SigV.vectorSamples (toAmplitudeScalar z) x
+ sampY = SigV.vectorSamples (toAmplitudeScalar z) y
+ z = SigV.Cons amp (f sampX sampY)
+ in z
+
+
+append ::
+ (Ord y', Field.C y', OccScalar.C y y',
+ Module.C y yv) =>
+ SigV.T y y' yv -> SigV.T y y' yv -> SigV.T y y' yv
+append = merge (List.++)
+
+appendVolume ::
+ (Field.C y', OccScalar.C y y',
+ Module.C y yv) =>
+ y' ->
+ SigV.T y y' yv -> SigV.T y y' yv -> SigV.T y y' yv
+appendVolume = mergeVolume (List.++)
+
+
+zip ::
+ (Ord y', Field.C y', OccScalar.C y y',
+ Module.C y yv0, Module.C y yv1) =>
+ SigV.T y y' yv0 -> SigV.T y y' yv1 -> SigV.T y y' (yv0,yv1)
+zip = merge List.zip
+
+zipVolume ::
+ (Field.C y', OccScalar.C y y',
+ Module.C y yv0, Module.C y yv1) =>
+ y' ->
+ SigV.T y y' yv0 -> SigV.T y y' yv1 -> SigV.T y y' (yv0,yv1)
+zipVolume = mergeVolume List.zip
+
+
+
+zip3 ::
+ (Ord y', Field.C y', OccScalar.C y y',
+ Module.C y yv0, Module.C y yv1, Module.C y yv2) =>
+ SigV.T y y' yv0 -> SigV.T y y' yv1 -> SigV.T y y' yv2 ->
+ SigV.T y y' (yv0,yv1,yv2)
+zip3 x0 x1 x2 =
+ zip3Volume
+ (SigV.amplitude x0 `max` SigV.amplitude x1 `max` SigV.amplitude x2)
+ x0 x1 x2
+
+zip3Volume ::
+ (Field.C y', OccScalar.C y y',
+ Module.C y yv0, Module.C y yv1, Module.C y yv2) =>
+ y' ->
+ SigV.T y y' yv0 -> SigV.T y y' yv1 -> SigV.T y y' yv2 ->
+ SigV.T y y' (yv0,yv1,yv2)
+zip3Volume amp x0 x1 x2 =
+ let sampX0 = SigV.vectorSamples (toAmplitudeScalar z) x0
+ sampX1 = SigV.vectorSamples (toAmplitudeScalar z) x1
+ sampX2 = SigV.vectorSamples (toAmplitudeScalar z) x2
+ z = SigV.Cons amp (List.zip3 sampX0 sampX1 sampX2)
+ in z
+
diff --git a/src/Synthesizer/Amplitude/Displacement.hs b/src/Synthesizer/Amplitude/Displacement.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/Amplitude/Displacement.hs
@@ -0,0 +1,88 @@
+{- |
+Copyright : (c) Henning Thielemann 2008
+License : GPL
+
+Maintainer : synthesizer@henning-thielemann.de
+Stability : provisional
+Portability : requires multi-parameter type classes
+-}
+module Synthesizer.Amplitude.Displacement (
+ mix, mixVolume,
+ mixMulti, mixMultiVolume,
+ raise,
+ ) where
+
+import qualified Synthesizer.Amplitude.Signal as SigV
+
+import Synthesizer.Amplitude.Signal (toAmplitudeScalar)
+
+import qualified Synthesizer.Plain.Displacement as Synthesizer
+
+import qualified Algebra.OccasionallyScalar as OccScalar
+import qualified Algebra.Module as Module
+-- import qualified Algebra.Transcendental as Trans
+import qualified Algebra.Field as Field
+import qualified Algebra.Real as Real
+-- import qualified Algebra.Ring as Ring
+import qualified Algebra.Additive as Additive
+
+import Algebra.Module ((*>))
+
+import PreludeBase
+import NumericPrelude
+import Prelude ()
+
+
+{- * Mixing -}
+
+{-| Mix two signals.
+ In opposition to 'zipWith' the result has the length of the longer signal. -}
+mix ::
+ (Real.C y', Field.C y', Module.C y yv, OccScalar.C y y') =>
+ SigV.T y y' yv
+ -> SigV.T y y' yv
+ -> SigV.T y y' yv
+mix x y =
+ mixVolume (abs (SigV.amplitude x) + abs (SigV.amplitude y)) x y
+
+mixVolume ::
+ (Real.C y', Field.C y', Module.C y yv, OccScalar.C y y') =>
+ y'
+ -> SigV.T y y' yv
+ -> SigV.T y y' yv
+ -> SigV.T y y' yv
+mixVolume v x y =
+ let z = SigV.Cons v
+ (toAmplitudeScalar z (SigV.amplitude x) *> SigV.samples x +
+ toAmplitudeScalar z (SigV.amplitude y) *> SigV.samples y)
+ in z
+
+{-| Mix one or more signals. -}
+mixMulti ::
+ (Real.C y', Field.C y', Module.C y yv, OccScalar.C y y') =>
+ [SigV.T y y' yv]
+ -> SigV.T y y' yv
+mixMulti x =
+ mixMultiVolume (sum (map (abs . SigV.amplitude) x)) x
+
+mixMultiVolume ::
+ (Real.C y', Field.C y', Module.C y yv, OccScalar.C y y') =>
+ y'
+ -> [SigV.T y y' yv]
+ -> SigV.T y y' yv
+mixMultiVolume v x =
+ let z = SigV.Cons v
+ (foldr (\y -> (toAmplitudeScalar z (SigV.amplitude y) *>
+ SigV.samples y +)) [] x)
+ in z
+
+{-| Add a number to all of the signal values.
+ This is useful for adjusting the center of a modulation. -}
+raise :: (Field.C y', Module.C y yv, OccScalar.C y y') =>
+ y'
+ -> yv
+ -> SigV.T y y' yv
+ -> SigV.T y y' yv
+raise y' yv x =
+ SigV.Cons (SigV.amplitude x)
+ (Synthesizer.raise (toAmplitudeScalar x y' *> yv) (SigV.samples x))
diff --git a/src/Synthesizer/Amplitude/Filter.hs b/src/Synthesizer/Amplitude/Filter.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/Amplitude/Filter.hs
@@ -0,0 +1,58 @@
+{- |
+Copyright : (c) Henning Thielemann 2008
+License : GPL
+
+Maintainer : synthesizer@henning-thielemann.de
+Stability : provisional
+Portability : requires multi-parameter type classes
+-}
+module Synthesizer.Amplitude.Filter (
+ {- * Non-recursive -}
+
+ {- ** Amplification -}
+ amplify,
+ negate,
+ envelope,
+
+) where
+
+
+import qualified Synthesizer.Amplitude.Signal as SigV
+
+import qualified Synthesizer.Plain.Filter.NonRecursive as FiltNR
+
+-- import qualified Algebra.OccasionallyScalar as OccScalar
+-- import qualified Algebra.Transcendental as Trans
+-- import qualified Algebra.Field as Field
+import qualified Algebra.Ring as Ring
+import qualified Algebra.Additive as Additive
+import qualified Algebra.Module as Module
+
+import NumericPrelude hiding (negate)
+-- import PreludeBase as P
+import Prelude ()
+
+
+{- | The amplification factor must be positive. -}
+amplify :: (Ring.C y') =>
+ y'
+ -> SigV.T y y' yv
+ -> SigV.T y y' yv
+amplify volume x =
+ SigV.Cons (volume * SigV.amplitude x) (SigV.samples x)
+
+negate :: (Additive.C yv) =>
+ SigV.T y y' yv
+ -> SigV.T y y' yv
+negate x =
+ SigV.Cons (SigV.amplitude x) (Additive.negate (SigV.samples x))
+
+
+envelope :: (Module.C y0 yv, Ring.C y') =>
+ SigV.T y y' y0 {- ^ the envelope -}
+ -> SigV.T y y' yv {- ^ the signal to be enveloped -}
+ -> SigV.T y y' yv
+envelope y x =
+ SigV.Cons
+ (SigV.amplitude y * SigV.amplitude x)
+ (FiltNR.envelopeVector (SigV.samples y) (SigV.samples x))
diff --git a/src/Synthesizer/Amplitude/Signal.hs b/src/Synthesizer/Amplitude/Signal.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/Amplitude/Signal.hs
@@ -0,0 +1,61 @@
+{- |
+Copyright : (c) Henning Thielemann 2008
+License : GPL
+
+Maintainer : synthesizer@henning-thielemann.de
+Stability : provisional
+Portability : requires multi-parameter type classes (OccasionallyScalar)
+
+Signals equipped with a volume information that may carry a unit.
+-}
+module Synthesizer.Amplitude.Signal where
+
+import qualified Algebra.OccasionallyScalar as OccScalar
+import qualified Algebra.Module as Module
+import qualified Algebra.Field as Field
+import qualified Algebra.Ring as Ring
+
+import Algebra.OccasionallyScalar (toScalar)
+
+import NumericPrelude
+import PreludeBase as P
+import Prelude ()
+
+
+data T y y' yv =
+ Cons {
+ amplitude :: y' {-^ scaling of the values -}
+ , samples :: [yv] {-^ the sampled values -}
+ }
+ deriving (Eq, Show)
+
+
+instance Functor (T y y') where
+ fmap f (Cons amp ss) = Cons amp (map f ss)
+
+
+toAmplitudeScalar :: (Field.C y', OccScalar.C y y') =>
+ T y y' yv -> y' -> y
+toAmplitudeScalar sig y =
+ toScalar (y / amplitude sig)
+
+
+scalarSamples :: (Ring.C y) =>
+ (y' -> y) -> T y y' y -> [y]
+scalarSamples toAmpScalar sig =
+ let y = toAmpScalar (amplitude sig)
+ in map (y*) (samples sig)
+
+vectorSamples :: (Module.C y yv) =>
+ (y' -> y) -> T y y' yv -> [yv]
+vectorSamples toAmpScalar sig =
+ let y = toAmpScalar (amplitude sig)
+ in y *> samples sig
+
+
+
+replaceAmplitude :: y1' -> T y y0' yv -> T y y1' yv
+replaceAmplitude amp (Cons _ ss) = Cons amp ss
+
+replaceSamples :: [yv1] -> T y y' yv0 -> T y y' yv1
+replaceSamples ss (Cons amp _) = Cons amp ss
diff --git a/src/Synthesizer/Inference/Fix.hs b/src/Synthesizer/Inference/Fix.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/Inference/Fix.hs
@@ -0,0 +1,399 @@
+{- |
+In this modules we try to infer sampling parameters
+using the unique-logic package.
+
+Every signal is equipped with input and output parameters
+that allow inference of sampling parameters.
+However, this way, signals are functions
+and their body cannot easily be shared.
+In general signals should not be used explicitly.
+Instead you should combine small signal processors to larger signal processors.
+In fact, this boils down to "Control.Arrow" operations,
+although we cannot use the @Arrow@ class.
+We can however use the same set of combinators adapted to our needs.
+We even cannot hide the peano numbers of unique-logic in the arrows,
+since the number of needed peano counters depends on the number of inputs
+and outputs of an arrow.
+-}
+
+{-
+Inference by expressing a 'let' construct by a fixed point.
+
+@
+let input = ping
+ output = mix input (delay output)
+in output
+@
+
+@
+snd $ fix (\ ~(input, output) -> (ping, mix input (delay output)))
+@
+
+
+Split into atomic equations which fit the equation solver framework.
+@
+let input = ping
+ delayedOutput = delay output
+ output = mix input delayedOutput
+in output
+@
+
+Enrich equations with information for the lazy knot.
+Signal parameters for the function results
+are included in the signals,
+but signal parameters of the inputs are returned separately.
+@
+let input =
+ ping [parametersOf input, inputParam0]
+ (delayedOutput, outputParam0) =
+ delay [parametersOf delayedOutput, delayOutputParam0] output
+ (output, (inputParam0, delayOutputParam0)) =
+ mix [parametersOf output, outputParam0] input delayedOutput
+in output
+@
+
+@
+let input =
+ ping input [inputParam0]
+ (delayedOutput, outputParam0) =
+ delay delayedOutput [delayOutputParam0] output
+ (output, (inputParam0, delayOutputParam0)) =
+ mix output [outputParam0] input delayedOutput
+in output
+@
+
+@
+let input@(inputStream, inputParam0) =
+ ping [inputParam0, inputParam1]
+ (delayedOutput@(delayedOutputStream, delayedOutputParam0), outputParam1) =
+ delay [delayedOutputParam0, delayOutputParam1] output
+ (output@(outputStream, outputParam0), (inputParam1, delayOutputParam1)) =
+ mix [outputParam0, outputParam1] input delayedOutput
+in output
+@
+
+The first list argument of each computation function contains signals,
+but only the parameters are used and the data stream is ignored.
+@
+let input = ping [input]
+ (delayedOutput, output0) =
+ delay [delayedOutput, delayedOutput0] output
+ (output, (input0,delayedOutput0)) =
+ mix [output,output0] input delayedOutput
+in output
+@
+
+
+
+
+
+Develop a simpler example:
+
+Work out
+@
+envelope exponential oscillator
+@
+
+@
+\zp0 ->
+ let x = exponential xp0
+ y = oscillator yp0
+ (z,(xp1,yp1)) = envelope zp0 x y
+ xp0 = closeCycle xp1
+ yp0 = closeCycle yp1
+ in z
+@
+
+Now with sharing of the 'exponential'.
+The model is
+@
+let x = exponential
+in envelope x (oscillator x)
+@
+or
+@
+snd $ fix \ (x, _) ->
+ (exponential, envelope x (oscillator x))
+@
+
+@
+\zp0 ->
+ let x = exponential xp0
+ (y,xp1) = oscillator yp0 x
+ (z,(xp2,yp1)) = envelope zp0 (replaceParam xp1 x) y
+ xp0 = closeCycle xp2
+ yp0 = closeCycle yp1
+ in z
+@
+
+With fixed point operator
+@
+\((x,xp0), (_,zp0)) ->
+ let (y,xp1) = oscillator yp0 x
+ (z,(xp2,yp1)) = envelope zp0 (replaceParam xp1 x) y
+ yp0 = closeCycle yp1
+ in ((xp2, exponential xp0), (undefined,z))
+@
+
+Many generators with the same sample rate
+can be handled elegantly with the monad (SharedVariable a).
+@
+\zp0 -> evalSharing $ mdo
+ x <- initial exponential
+ y <- share (oscillator yp0) x
+ (z,yp1) <- share (envelope zp0 y) x
+ let yp0 = closeCycle yp1
+ return z
+@
+-}
+
+module Synthesizer.Inference.Fix where
+
+
+import qualified Synthesizer.Physical.Signal as SigP
+
+import qualified UniqueLogicNP.Lazy.SingleStep as Logic
+
+
+-- * custom interface
+
+type Parameter a = Logic.Variable a
+
+type Result a = Parameter a
+
+type Parameters t y = (Parameter t, Parameter y)
+
+type Results t y = (Result t, Result y)
+
+type InputSignal t t' y y' yv = SigP.T t (Parameter t') y (Parameter y') yv
+
+type OutputSignal t t' y y' yv = SigP.T t (Result t') y (Result y') yv
+
+
+
+infixr 9 .%, .%&
+infixr 0 $%, $%%, $$%&
+
+
+
+{- |
+Combinator function:
+Since the interim signal is not seen anywhere else,
+we know of all influences to its value.
+These are the backward-constraints of @f@
+and the forward-constraints of @g@
+and we can simply fuse them using 'Logic.closeCycle'.
+
+*** The order of input and output values should be flipped,
+in order to match that of @(->)@.
+-}
+{-
+(.%) ::
+ ((Parameters tc' yc', InputSignal tb tb' yb yb' ybv) ->
+ (OutputSignal tc tc' yc yc' ycv, Results tb' yb')) ->
+ ((Parameters tb' yb', InputSignal ta ta' ya ya' yav) ->
+ (OutputSignal tb tb' yb yb' ybv, Results ta' ya')) ->
+ ((Parameters tc' yc', InputSignal ta ta' ya ya' yav) ->
+ (OutputSignal tc tc' yc yc' ycv, Results ta' ya'))
+-}
+(.%) ::
+ ((params, InputSignal ta ta' ya ya' yav) ->
+ (output, Results ta' ya')) ->
+ ((Parameters ta' ya', input) ->
+ (OutputSignal ta ta' ya ya' yav, result)) ->
+ ((params, input) ->
+ (output, result))
+(f .% g) (zParams, x) =
+ let (y,xResults) = g (yParams,x)
+ (z,yResults) = f (zParams,y)
+ yParams = closeParameterCycles yResults
+ in (z,xResults)
+
+($%) ::
+ ((params, InputSignal ta ta' ya ya' yav) ->
+ (output, Results ta' ya')) ->
+ (Parameters ta' ya' ->
+ OutputSignal ta ta' ya ya' yav) ->
+ (params ->
+ output)
+(f $% g) zParams =
+ let y = g yParams
+ (z,yResults) = f (zParams,y)
+ yParams = closeParameterCycles yResults
+ in z
+
+($%%) ::
+ ((params, (InputSignal ta ta' ya ya' yav, InputSignal tb tb' yb yb' ybv)) ->
+ (output, (Results ta' ya', Results tb' yb'))) ->
+ (Parameters ta' ya' -> OutputSignal ta ta' ya ya' yav,
+ Parameters tb' yb' -> OutputSignal tb tb' yb yb' ybv) ->
+ (params ->
+ output)
+(f $%% (ga,gb)) zParams =
+ let ya = ga yaParams
+ yb = gb ybParams
+ (z,(yaResults,ybResults)) =
+ f (zParams,(ya,yb))
+ yaParams = closeParameterCycles yaResults
+ ybParams = closeParameterCycles ybResults
+ in z
+
+
+(.%&) ::
+ ((params, (InputSignal ta ta' ya ya' yav, InputSignal tb tb' yb yb' ybv)) ->
+ (output, (Results ta' ya', Results tb' yb'))) ->
+ (((Parameters ta' ya', Parameters tb' yb'), input) ->
+ ((OutputSignal ta ta' ya ya' yav, OutputSignal tb tb' yb yb' ybv), result)) ->
+ ((params, input) ->
+ (output, result))
+(f .%& g) (zParams, x) =
+ let ((ya,yb), xResults) = g ((yaParams,ybParams),x)
+ (z,(yaResults,ybResults)) = f (zParams,(ya,yb))
+ yaParams = closeParameterCycles yaResults
+ ybParams = closeParameterCycles ybResults
+ in (z,xResults)
+
+{-
+($%&) ::
+ ((params, (InputSignal ta ta' ya ya' yav, InputSignal tb tb' yb yb' ybv)) ->
+ (output, (Results ta' ya', Results tb' yb'))) ->
+ ((Parameters ta' ya', Parameters tb' yb') ->
+ (OutputSignal ta ta' ya ya' yav, OutputSignal tb tb' yb yb' ybv)) ->
+ (params ->
+ output)
+(f $%& g) zParams =
+ let ya = ga yaParams
+ yb = gb ybParams
+ (z,(yaResults,ybResults)) = f (zParams,(ya,yb))
+ yaParams = closeParameterCycles yaResults
+ ybParams = closeParameterCycles ybResults
+ in z
+-}
+
+($$%&) ::
+ ((paramsA, InputSignal ta ta' ya ya' yav) ->
+ (outputA, Results ta' ya'),
+ (paramsB, InputSignal tb tb' yb yb' ybv) ->
+ (outputB, Results tb' yb')) ->
+ ((Parameters ta' ya', Parameters tb' yb') ->
+ (OutputSignal ta ta' ya ya' yav, OutputSignal tb tb' yb yb' ybv)) ->
+ ((paramsA,paramsB) ->
+ (outputA,outputB))
+((fa,fb) $$%& x) (yaParams,ybParams) =
+ let (xa,xb) = x (xaParams,xbParams)
+ (ya,xaResults) = fa (yaParams,xa)
+ (yb,xbResults) = fb (ybParams,xb)
+ xaParams = closeParameterCycles xaResults
+ xbParams = closeParameterCycles xbResults
+ in (ya,yb)
+
+
+{-
+ ((paramsA, InputSignal t t' y y' yv) ->
+ (outputA, Results t' y')) ->
+ ((paramsB, InputSignal t t' y y' yv) ->
+ (outputB, Results t' y')) ->
+ (Parameters t' y' ->
+ OutputSignal t t' y y' yv) ->
+ ((paramsA,paramsB) ->
+ (outputA,outputB))
+-}
+{-
+Is this function implemented correctly?
+-}
+share2 ::
+ (Parameters t' y' ->
+ OutputSignal t t' y y' yv) ->
+ ((Parameters t' y', Parameters t' y') ->
+ (OutputSignal t t' y y' yv, OutputSignal t t' y y' yv))
+share2 x ((sr0,amp0),(sr1,amp1)) =
+ let srResult = Logic.merge sr0 sr1
+ ampResult = Logic.merge amp0 amp1
+ y = x (srResult, ampResult)
+ in (y, y)
+
+share2' :: (Eq t', Eq y') =>
+ (Parameters t' y' ->
+ OutputSignal t t' y y' yv) ->
+ ((Parameters t' y', Parameters t' y') ->
+ (OutputSignal t t' y y' yv, OutputSignal t t' y y' yv))
+share2' x ((sr0,amp0),(sr1,amp1)) =
+ let (sr0Result, sr1Result) = Logic.equal sr0 sr1
+ (amp0Result, amp1Result) = Logic.equal amp0 amp1
+ y0 = x (sr0Result, amp0Result)
+ y1 = x (sr1Result, amp1Result)
+ in (y0, SigP.replaceSamples (SigP.samples y0) y1)
+
+
+fix ::
+ ((Parameters t' y', InputSignal t t' y y' yv) ->
+ (OutputSignal t t' y y' yv, Results t' y')) ->
+ (Parameters t' y' ->
+ OutputSignal t t' y y' yv)
+fix x (ySR,yAmp) =
+ let (y,(zSR,zAmp)) = x ((xSR,xAmp), y)
+ xSR = Logic.closeCycle $ Logic.merge ySR zSR
+ xAmp = Logic.closeCycle $ Logic.merge yAmp zAmp
+{-
+ xSR = Logic.merge ySR zSR
+ xAmp = Logic.merge yAmp zAmp
+-}
+ in y
+
+{-
+Probably this needs a different interface (signature)
+in order to be used flawlessly in a signal processing algorithm.
+-}
+fixSampleRate ::
+ t' ->
+ OutputSignal t t' y y' yv ->
+ OutputSignal t t' y y' yv
+fixSampleRate sr = SigP.replaceSampleRate (Logic.constant sr)
+
+
+run ::
+ (Parameters t' y' ->
+ OutputSignal t t' y y' yv) ->
+ SigP.T t t' y y' yv
+run x =
+ let y = x (sr,amp)
+ srResult = SigP.sampleRate y
+ ampResult = SigP.amplitude y
+ sr = Logic.closeCycle srResult
+ amp = Logic.closeCycle ampResult
+ in SigP.replaceParameters
+ (Logic.variableValue srResult)
+ (Logic.variableValue ampResult)
+ y
+
+
+{-
+Shall 'replaceParameter' check
+whether the replaced variables have the same value?
+-}
+
+closeParameterCycles ::
+ Results t' y' -> Parameters t' y'
+closeParameterCycles ~(sr,amp) =
+ (Logic.closeCycle sr, Logic.closeCycle amp)
+
+
+-- * arrow interface
+
+newtype Processor inSignal results params outSignal =
+ Processor ((params, inSignal) -> (outSignal, results))
+
+infixr 1 <<<
+
+{- |
+The same as '(.%)'.
+-}
+(<<<) ::
+ Processor
+ (InputSignal t t' y y' yv) (Results t' y')
+ params output ->
+ Processor
+ input result
+ (Parameters t' y') (OutputSignal t t' y y' yv) ->
+ Processor input result params output
+Processor f <<< Processor g = Processor $ f .% g
diff --git a/src/Synthesizer/Inference/Fix/Cut.hs b/src/Synthesizer/Inference/Fix/Cut.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/Inference/Fix/Cut.hs
@@ -0,0 +1,282 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{- |
+Copyright : (c) Henning Thielemann 2007, 2008
+License : GPL
+
+Maintainer : synthesizer@henning-thielemann.de
+Stability : provisional
+Portability : portable
+
+Design test of Synthesizer.Inference.Fix for basic Cut functions.
+This is still a copy of "Synthesizer.Inference.Func.Cut"
+and I assume that I remove it some time in the future
+because the underlying approach seems to be inferior
+to that of "Synthesizer.SampleRateContext.Cut".
+-}
+module Synthesizer.Inference.Fix.Cut (
+ {- * dissection -}
+ -- splitAt,
+ -- take,
+ -- drop,
+ takeUntilPause,
+ -- unzip,
+ -- unzip3,
+
+ {- * glueing -}
+ concat,
+ concatVolume,
+ append,
+ zip,
+ -- zip3,
+ arrange,
+ arrangeVolume,
+ ) where
+
+import qualified Synthesizer.Physical.Signal as SigP
+import qualified Synthesizer.Physical.Cut as CutP
+import qualified Synthesizer.Inference.Func.Signal as SigF
+
+import qualified Synthesizer.SampleRateContext.Signal as SigC
+import qualified Synthesizer.SampleRateContext.Rate as Rate
+import qualified Synthesizer.SampleRateContext.Cut as CutC
+
+import qualified Data.EventList.Relative.TimeBody as EventList
+import qualified Numeric.NonNegative.Class as NonNeg
+
+import qualified Algebra.NormedSpace.Maximum as NormedMax
+import qualified Algebra.OccasionallyScalar as OccScalar
+import qualified Algebra.Module as Module
+import qualified Algebra.RealField as RealField
+import qualified Algebra.Field as Field
+import qualified Algebra.Real as Real
+import qualified Algebra.Ring as Ring
+
+-- import qualified Data.List as List
+
+-- import Control.Monad.Fix(mfix)
+
+import PreludeBase hiding (zip, zip3, concat, )
+-- import NumericPrelude
+import Prelude (RealFrac)
+
+{-
+{- * dissection -}
+
+splitAt :: (RealField.C a, Field.C q, OccScalar.C a q) =>
+ q -> SigI.T a q v -> Process.T q (SigI.T a q v, SigI.T a q v)
+splitAt t0 x@(Cons sr amp ss) =
+ do t <- SigI.toTimeScalar x (Expr.constant t0)
+ let (ss0,ss1) = List.splitAt (round t) ss
+ return (Cons sr amp ss0, Cons sr amp ss1)
+
+take :: (RealField.C a, Field.C q, OccScalar.C a q) =>
+ q -> SigI.T a q v -> SigI.Process a q v
+take t = fmap fst . splitAt t
+
+drop :: (RealField.C a, Field.C q, OccScalar.C a q) =>
+ q -> SigI.T a q v -> SigI.Process a q v
+drop t = fmap snd . splitAt t
+-}
+
+takeUntilPause :: (RealField.C t, Ring.C t', OccScalar.C t t',
+ Field.C y', NormedMax.C y yv, OccScalar.C y y') =>
+ y' -> t' -> SigF.T t t' y y' yv -> SigF.T t t' y y' yv
+takeUntilPause y' t' x =
+ SigF.cons $ \infered@(isr,iamp) ->
+ let x' = SigF.eval x infered
+ xp = SigP.replaceParameters isr iamp x'
+ zp = CutP.takeUntilPause y' t' xp
+ in SigP.replaceParameters
+ (SigP.sampleRate x') (SigP.amplitude x') zp
+
+
+{-
+How can we assert sharing of the input signal
+with the output signals?
+
+unzip ::
+ SigF.T t t' y y' (yv0, yv1)
+ -> (SigF.T t t' y y' yv0, SigF.T t t' y y' yv1)
+unzip x =
+ (SigF.cons $ \inferedY@(isrY,iampY) -> ,
+ SigF.cons $ \inferedZ@(isrZ,iampZ) -> )
+
+
+unzip3 ::
+ SigF.T t t' y y' (yv0, yv1, yv2)
+ -> (SigF.T t t' y y' yv0, SigF.T t t' y y' yv1, SigF.T t t' y y' yv2)
+unzip3 = return . CutC.unzip3
+-}
+
+
+{- * glueing -}
+
+{- |
+ Similar to @foldr1 append@ but more efficient and accurate,
+ because it reduces the number of amplifications.
+ Does not work for infinite lists,
+ because in this case a maximum amplitude cannot be computed.
+-}
+concat ::
+ (Eq t', Real.C y', Field.C y', Module.C y yv, OccScalar.C y y') =>
+ [SigF.T t t' y y' yv]
+ -> SigF.T t t' y y' yv
+concat xs =
+ SigF.cons $ \(isr,iamp) ->
+ let xs' = zipWith (\x amp -> SigF.eval x (isr, amp)) xs amps
+ amps = map SigF.guessAmplitude xs'
+ xps = zipWith SigF.contextFixAmplitude amps xs'
+ sampleRate = SigF.mergeSampleRates xs'
+ in SigF.fromContextCheckAmplitude sampleRate iamp
+ (CutC.concat (Rate.fromNumber isr) xps)
+
+{- |
+ Like 'concat' but it expects a fixed output amplitude.
+ This way it can also handle infinitely many inputs
+ if one input or the output has a fixed sample rate.
+
+ 'concatVolume' is one reason for the complicated handling
+ of sampling rates by lists of @Maybe@s.
+
+ The problem of finding an apropriate sampling rate is that
+ we must have an order of processing parallel signal processors
+ which guarantees termination if termination is possible.
+ Say @mix (concat infinitelist0) (concat infinitelist1)@.
+ Either infinite list can have signal with fixed sample rate or not.
+ There is no way to determine this a priori.
+ The only safe way is to process them in parallel.
+ That's why we must have a @[Maybe t']@ instead of @Maybe t'@.
+ Also @[t']@ is not enough,
+ because e.g. a concatenation of infinitely many sounds
+ with undetermined sampling rate
+ would have an empty list representing the sampling rate,
+ but computing the empty list needs infinite time.
+-}
+concatVolume ::
+ (Eq t', Real.C y', Field.C y', Module.C y yv, OccScalar.C y y') =>
+ [SigF.T t t' y y' yv]
+ -> SigF.T t t' y y' yv
+concatVolume xs =
+ SigF.cons $ \(isr,iamp) ->
+ let xs' = zipWith (\x amp -> SigF.eval x (isr, amp)) xs amps
+ amps = map SigF.guessAmplitude xs'
+ xps = zipWith SigF.contextFixAmplitude amps xs'
+ sampleRate = SigF.mergeSampleRates xs'
+ in SigF.fromContextFreeAmplitude sampleRate
+ (CutC.concatVolume iamp (Rate.fromNumber isr) xps)
+
+
+merge :: (Eq t', Real.C y', Field.C y', OccScalar.C y y',
+ Module.C y v0, Module.C y v1) =>
+ (Rate.T t t' -> SigC.T y y' v0 -> SigC.T y y' v1 -> SigC.T y y' v2)
+ -> SigF.T t t' y y' v0
+ -> SigF.T t t' y y' v1
+ -> SigF.T t t' y y' v2
+merge f x y =
+ SigF.cons $ \(isr,iamp) ->
+ let x' = SigF.eval x (isr, ampX)
+ y' = SigF.eval y (isr, ampY)
+ ampX = SigF.guessAmplitude x'
+ ampY = SigF.guessAmplitude y'
+ xp = SigF.contextFixAmplitude ampX x'
+ yp = SigF.contextFixAmplitude ampY y'
+ sampleRate = SigF.mergeSampleRate x' y'
+ in SigF.fromContextCheckAmplitude sampleRate iamp
+ (f (Rate.fromNumber isr) xp yp)
+
+
+append :: (Eq t', Real.C y', Field.C y', OccScalar.C y y',
+ Module.C y yv) =>
+ SigF.T t t' y y' yv
+ -> SigF.T t t' y y' yv
+ -> SigF.T t t' y y' yv
+append = merge CutC.append
+
+
+zip :: (Eq t', Real.C y', Field.C y', OccScalar.C y y',
+ Module.C y v0, Module.C y v1) =>
+ SigF.T t t' y y' v0
+ -> SigF.T t t' y y' v1
+ -> SigF.T t t' y y' (v0,v1)
+zip = merge CutC.zip
+
+{-
+zip3 :: (Real.C q, Field.C q, Ord q, OccScalar.C a q,
+ Module.C a v0, Module.C a v1, Module.C a v2)
+ => SigI.T a q v0
+ -> SigI.T a q v1
+ -> SigI.T a q v2
+ -> SigI.Process a q (v0, v1, v2)
+zip3 x0 x1 x2 =
+ mfix (\z ->
+ do sampleRate <- Process.equalValues
+ [SigP.sampleRate x0, SigP.sampleRate x1, SigP.sampleRate x2]
+ amplitude <- Process.fromExpr
+ (Expr.maximum [amplitudeExpr x0, amplitudeExpr x1, amplitudeExpr x2])
+ samp0 <- SigI.vectorSamples (toAmplitudeScalar z) x0
+ samp1 <- SigI.vectorSamples (toAmplitudeScalar z) x1
+ samp2 <- SigI.vectorSamples (toAmplitudeScalar z) x2
+ SigI.returnCons sampleRate amplitude
+ (List.zip3 samp0 samp1 samp2))
+-}
+
+
+
+scheduleToContext ::
+ t'
+ -> EventList.T time (SigF.T t t' y y' yv)
+ -> (SigF.Parameter t',
+ EventList.T time (SigC.T y y' yv))
+scheduleToContext isr sched =
+ let xps =
+ EventList.mapBody
+ (\x ->
+ let y = SigF.eval x (isr, amp)
+ amp = SigF.guessAmplitude y
+ z = SigF.contextFixAmplitude amp y
+ in (y,z)) sched
+ schedp = EventList.mapBody snd xps
+ sampleRate = SigF.mergeSampleRates (map fst (EventList.getBodies xps))
+ in (sampleRate, schedp)
+
+
+{- |
+ Given a list of signals with time stamps,
+ mix them into one signal as they occur in time.
+ Ideally for composing music.
+ Infinite schedules are not supported,
+ because no maximum amplitude can be computed.
+-}
+arrange ::
+ (RealFrac t, NonNeg.C t, Eq t', Ring.C t, Ring.C t', OccScalar.C t t',
+ Ord y', Field.C y', OccScalar.C y y',
+ Module.C y yv) =>
+ t'
+ -> EventList.T t (SigF.T t t' y y' yv)
+ {-^ A list of pairs: (relative start time, signal part),
+ The start time is relative
+ to the start time of the previous event. -}
+ -> SigF.T t t' y y' yv
+ {-^ The mixed signal. -}
+arrange unit sched =
+ SigF.cons $ \(isr,iamp) ->
+ let (sampleRate, schedp) = scheduleToContext isr sched
+ in SigF.fromContextCheckAmplitude sampleRate iamp
+ (CutC.arrange unit (Rate.fromNumber isr) schedp)
+
+arrangeVolume ::
+ (RealFrac t, NonNeg.C t, Eq t', Ring.C t, Ring.C t', OccScalar.C t t',
+ Field.C y', OccScalar.C y y',
+ Module.C y yv) =>
+ t'
+ -> EventList.T t (SigF.T t t' y y' yv)
+ {-^ A list of pairs: (relative start time, signal part),
+ The start time is relative
+ to the start time of the previous event. -}
+ -> SigF.T t t' y y' yv
+ {-^ The mixed signal. -}
+arrangeVolume unit sched =
+ SigF.cons $ \(isr,iamp) ->
+ let (sampleRate, schedp) = scheduleToContext isr sched
+ in SigF.fromContextFreeAmplitude sampleRate
+ (CutC.arrangeVolume iamp unit (Rate.fromNumber isr) schedp)
diff --git a/src/Synthesizer/Inference/Fix/Filter.hs b/src/Synthesizer/Inference/Fix/Filter.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/Inference/Fix/Filter.hs
@@ -0,0 +1,377 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{- |
+Copyright : (c) Henning Thielemann 2006
+License : GPL
+
+Maintainer : synthesizer@henning-thielemann.de
+Stability : provisional
+Portability : requires multi-parameter type classes
+-}
+module Synthesizer.Inference.Fix.Filter (
+ {- * Non-recursive -}
+
+ {- ** Amplification -}
+ amplify,
+ negate,
+{-
+ envelope,
+-}
+ {- ** Filter operators from calculus -}
+ differentiate,
+
+{-
+ {- ** Smooth -}
+ mean,
+
+ {- ** Delay -}
+ delay,
+ phaseModulation,
+ phaser,
+ phaserStereo,
+
+
+ {- * Recursive -}
+
+ {- ** Without resonance -}
+ firstOrderLowpass,
+ firstOrderHighpass,
+ butterworthLowpass,
+ butterworthHighpass,
+ chebyshevALowpass,
+ chebyshevAHighpass,
+ chebyshevBLowpass,
+ chebyshevBHighpass,
+ {- ** With resonance -}
+ universal,
+ moogLowpass,
+ {- ** Allpass -}
+ allpassCascade,
+ {- ** Reverb -}
+ comb,
+-}
+ {- ** Filter operators from calculus -}
+ integrate
+) where
+
+-- import qualified InferenceFix.Signal as SigF
+import Synthesizer.Inference.Fix (InputSignal, OutputSignal, Parameters, Results)
+
+import qualified UniqueLogicNP.Lazy.SingleStep as Logic
+
+{-
+import InferenceFix.Signal
+ (toTimeScalar, toFrequencyScalar, sampleRateExpr,
+ amplitudeExpr)
+-}
+
+
+import qualified Synthesizer.Physical.Signal as SigP
+{-
+import qualified Synthesizer.Plain.Displacement as Syn
+import qualified Synthesizer.Plain.Interpolation as Interpolation
+import qualified Synthesizer.Plain.Filter.Delay.ST as Delay
+import qualified Synthesizer.Plain.Filter.Recursive as FiltR
+-}
+import qualified Synthesizer.Plain.Filter.Recursive.Integration as Integrate
+import qualified Synthesizer.Plain.Filter.NonRecursive as FiltNR
+{-
+import qualified InferenceFunc.Synthesizer as SynI
+import qualified Synthesizer.Inference.Func.Cut as CutI
+
+import Data.Ord.HT (limit)
+
+import qualified Algebra.OccasionallyScalar as OccScalar
+import qualified Algebra.VectorSpace as VectorSpace
+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(liftM2)
+
+-- import NumericPrelude hiding (negate)
+import PreludeBase as P
+
+
+{- | The amplification factor must be positive. -}
+amplify :: (Eq t', Field.C y') =>
+ y' ->
+ (Parameters t' y', InputSignal t t' y y' yv) ->
+ (OutputSignal t t' y y' yv, Results t' y')
+amplify volume ((srY,ampY), sigX) =
+ let (srYResult, srXResult) = Logic.equal srY (SigP.sampleRate sigX)
+ (ampYResult, ampXResult) = Logic.scale volume ampY (SigP.amplitude sigX)
+ in (SigP.replaceParameters srYResult ampYResult sigX,
+ (srXResult, ampXResult))
+
+negate :: (Additive.C yv, Eq t', Eq y') =>
+ (Parameters t' y', InputSignal t t' y y' yv) ->
+ (OutputSignal t t' y y' yv, Results t' y')
+negate ((srY,ampY), sigX) =
+ let (srYResult, srXResult) = Logic.equal srY (SigP.sampleRate sigX)
+ (ampYResult, ampXResult) = Logic.equal ampY (SigP.amplitude sigX)
+ in (SigP.cons srYResult ampYResult
+ (Additive.negate (SigP.samples sigX)),
+ (srXResult, ampXResult))
+
+
+{-
+envelope :: (Module.C y v, Field.C q, Eq q) =>
+ SigI.T a q y {- ^ the envelope -}
+ -> SigI.T a q v {- ^ the signal to be enveloped -}
+ -> SigI.Process a q v
+envelope y x =
+ do sampleRate <- Process.fromExpr (sampleRateExpr x =!= sampleRateExpr y)
+ amplitude <- Process.fromExpr (amplitudeExpr x * amplitudeExpr y)
+ SigI.returnCons sampleRate amplitude
+ (FiltNR.envelopeVector (SigP.samples y) (SigP.samples x))
+-}
+
+
+{- |
+Although the routine could derive the sample rate
+from the ratio of amplitudes,
+this seems to be not very sensible,
+since the choice of amplitude value is quite arbitrary
+and the choice of sample rates is not.
+-}
+differentiate :: (Eq ty', Field.C ty', Additive.C yv) =>
+ (Parameters ty' ty', InputSignal t ty' y ty' yv) ->
+ (OutputSignal t ty' y ty' yv, Results ty' ty')
+differentiate ((srY,ampY), sigX) =
+ let srX = SigP.sampleRate sigX
+ (srYResult, srXResult) = Logic.equal srY srX
+ (_, ampXResult, ampYResult) = Logic.mul srX (SigP.amplitude sigX) ampY
+ in (SigP.cons srYResult ampYResult (FiltNR.differentiate (SigP.samples sigX)),
+ (srXResult, ampXResult))
+
+
+{-
+{- | needs a good handling of boundaries, yet -}
+mean :: (Additive.C v, Field.C q, Eq q, RealField.C a,
+ Module.C a v, OccScalar.C a q) =>
+ q {- ^ time length of the window -}
+ -> SigI.T a q v
+ -> SigI.Process a q v
+mean time x =
+ do t <- toTimeScalar x (Expr.constant time)
+ let tInt = round ((t-1)/2)
+ let width = tInt*2+1
+ returnModified []
+ ((SigP.asTypeOfAmplitude (recip (fromIntegral width)) x *> ) .
+ Filt.sums width . FiltNR.delay tInt) x
+
+
+delay :: (Additive.C v, Field.C q, Eq q, RealField.C a, OccScalar.C a q) =>
+ q
+ -> SigI.T a q v
+ -> SigI.Process a q v
+delay time x =
+ do t <- toTimeScalar x (Expr.constant time)
+ returnModified [] (FiltNR.delay (round t)) x
+
+
+phaseModulation ::
+ (Additive.C v, Field.C q, Eq q, RealField.C a, OccScalar.C a q) =>
+ Interpolation.T a v
+ -> q {- ^ minDelay, minimal delay, may be negative -}
+ -> q {- ^ maxDelay, maximal delay, it must be @minDelay <= maxDelay@
+ and the modulation must always be
+ in the range [minDelay,maxDelay]. -}
+ -> SigI.T a q a
+ {- ^ delay control, positive numbers mean delay,
+ negative numbers mean prefetch -}
+ -> SigI.T a q v
+ -> SigI.Process a q v
+phaseModulation ip minDelay maxDelay delays x =
+ do t0 <- toTimeScalar x (Expr.constant minDelay)
+ t1 <- toTimeScalar x (Expr.constant maxDelay)
+ let tInt0 = floor t0
+ let tInt1 = ceiling t1
+ let tInt0Neg = Additive.negate tInt0
+ ds <- SigI.scalarSamples (toTimeScalar delays) delays
+ returnModified [SigP.sampleRate delays]
+ (FiltNR.delay tInt0 .
+ Delay.modulated ip (tInt1-tInt0+1)
+ (FiltNR.delay tInt0Neg
+ (Syn.raise (fromIntegral tInt0Neg)
+ (map (limit (t0,t1)) ds)))) x
+
+
+{- | symmetric phaser -}
+phaser :: (Additive.C v, Field.C q, Eq q, RealField.C a,
+ Module.C a v, OccScalar.C a q) =>
+ Interpolation.T a v
+ -> q {- ^ maxDelay, must be positive -}
+ -> SigI.T a q a
+ {- ^ delay control -}
+ -> SigI.T a q v
+ -> SigI.Process a q v
+phaser ip maxDelay delays x =
+ amplify (asTypeOf 0.5 maxDelay) =<<
+ uncurry SynI.mix =<< phaserCore ip maxDelay delays x
+
+phaserStereo :: (Additive.C v, Field.C q, Eq q, Real.C q, RealField.C a,
+ Module.C a v, OccScalar.C a q) =>
+ Interpolation.T a v
+ -> q {- ^ maxDelay, must be positive -}
+ -> SigI.T a q a
+ {- ^ delay control -}
+ -> SigI.T a q v
+ -> SigI.Process a q (v,v)
+phaserStereo ip maxDelay delays x =
+ uncurry CutI.zip =<< phaserCore ip maxDelay delays x
+
+phaserCore :: (Additive.C v, Field.C q, Eq q, RealField.C a,
+ Module.C a v, OccScalar.C a q) =>
+ Interpolation.T a v
+ -> q {- ^ maxDelay, must be positive -}
+ -> SigI.T a q a
+ {- ^ delay control -}
+ -> SigI.T a q v
+ -> Process.T q (SigI.T a q v, SigI.T a q v)
+phaserCore ip maxDelay delays x =
+ do let minDelay = Additive.negate maxDelay
+ negDelays <- InferenceFunc.Filter.negate delays
+ liftM2 (,)
+ (phaseModulation ip minDelay maxDelay delays x)
+ (phaseModulation ip minDelay maxDelay negDelays x)
+
+
+
+firstOrderLowpass, firstOrderHighpass ::
+ (Trans.C a, Trans.C q, Eq q, Module.C a v, OccScalar.C a q) =>
+ SigI.T a q a {- ^ Control signal for the cut-off frequency. -}
+ -> SigI.T a q v {- ^ Input signal -}
+ -> SigI.Process a q v
+firstOrderLowpass = firstOrderGen Syn.lowpass1stOrder
+firstOrderHighpass = firstOrderGen Syn.highpass1stOrder
+
+firstOrderGen :: (Trans.C a, Trans.C q, Eq q, Module.C a v, OccScalar.C a q) =>
+ ([a] -> [v] -> [v])
+ -> SigI.T a q a
+ -> SigI.T a q v
+ -> SigI.Process a q v
+firstOrderGen filt freq x =
+ do freqs <- SigI.scalarSamples (toFrequencyScalar x) freq
+ returnModified [SigP.sampleRate freq]
+ (filt (map Syn.lowpass1stOrderParam freqs)) x
+
+
+butterworthLowpass, butterworthHighpass,
+ chebyshevALowpass, chebyshevAHighpass,
+ chebyshevBLowpass, chebyshevBHighpass ::
+ (Field.C q, Eq q, Trans.C a, VectorSpace.C a v, OccScalar.C a q) =>
+ Int {- ^ Order of the filter, must be even,
+ the higher the order, the sharper is the separation of frequencies. -}
+ -> a {- ^ The attenuation at the cut-off frequency.
+ Should be between 0 and 1. -}
+ -> SigI.T a q a {- ^ Control signal for the cut-off frequency. -}
+ -> SigI.T a q v {- ^ Input signal -}
+ -> SigI.Process a q v
+
+butterworthLowpass = higherOrderNoResoGen Syn.butterworthLowpass
+butterworthHighpass = higherOrderNoResoGen Syn.butterworthHighpass
+chebyshevALowpass = higherOrderNoResoGen Syn.chebyshevALowpass
+chebyshevAHighpass = higherOrderNoResoGen Syn.chebyshevAHighpass
+chebyshevBLowpass = higherOrderNoResoGen Syn.chebyshevBLowpass
+chebyshevBHighpass = higherOrderNoResoGen Syn.chebyshevBHighpass
+
+higherOrderNoResoGen ::
+ (Field.C q, Eq q, Ring.C a, OccScalar.C a q) =>
+ (Int -> a -> [a] -> [v] -> [v])
+ -> Int
+ -> a
+ -> SigI.T a q a
+ -> SigI.T a q v
+ -> SigI.Process a q v
+higherOrderNoResoGen filt order ratio freq x =
+ do freqs <- SigI.scalarSamples (toFrequencyScalar x) freq
+ returnModified [SigP.sampleRate freq]
+ (filt order ratio freqs) x
+
+
+
+universal :: (Trans.C a, Module.C a v, Field.C q, Eq q, OccScalar.C a q) =>
+ SigI.T a q a {- ^ signal for resonance,
+ i.e. factor of amplification at the resonance frequency
+ relatively to the transition band. -}
+ -> SigI.T a q a {- ^ signal for cut off and band center frequency -}
+ -> SigI.T a q v {- ^ input signal -}
+ -> SigI.Process a q (v,v,v) {- ^ highpass, bandpass, lowpass filter -}
+universal reso freq x =
+ do resos <- SigI.scalarSamples (Process.exprToScalar) reso
+ freqs <- SigI.scalarSamples (toFrequencyScalar x) freq
+ let params =
+ map UniFilter.parameter
+ (zipWith Syn.Pole resos freqs)
+ returnModified [SigP.sampleRate reso, SigP.sampleRate freq]
+ (UniFilter.run params) x
+
+moogLowpass :: (Trans.C a, Module.C a v, Field.C q, Eq q, OccScalar.C a q) =>
+ Int
+ -> SigI.T a q a {- ^ signal for resonance,
+ i.e. factor of amplification at the resonance frequency
+ relatively to the transition band. -}
+ -> SigI.T a q a {- ^ signal for cut off and band center frequency -}
+ -> SigI.T a q v
+ -> SigI.Process a q v
+moogLowpass order reso freq x =
+ do resos <- SigI.scalarSamples (Process.exprToScalar) reso
+ freqs <- SigI.scalarSamples (toFrequencyScalar x) freq
+ let params =
+ map (Moog.parameter order)
+ (zipWith Syn.Pole resos freqs)
+ returnModified [SigP.sampleRate reso, SigP.sampleRate freq]
+ (Moog.lowpass order params) x
+
+allpassCascade :: (Trans.C a, Module.C a v, Field.C q, Eq q, OccScalar.C a q) =>
+ Int {- ^ order, number of filters in the cascade -}
+ -> a {- ^ the phase shift to be achieved for the given frequency -}
+ -> SigI.T a q a {- ^ lowest comb frequency -}
+ -> SigI.T a q v
+ -> SigI.Process a q v
+allpassCascade order phase freq x =
+ do freqs <- SigI.scalarSamples (toFrequencyScalar x) freq
+ let params = map (Syn.allpassCascadeParam order phase) freqs
+ returnModified [SigP.sampleRate freq]
+ (Syn.allpassCascade order params) x
+
+
+
+{- | Infinitely many equi-delayed exponentially decaying echos. -}
+comb :: (RealField.C a, Field.C q, Eq q, OccScalar.C a q, Module.C a v) =>
+ q -> a -> SigI.T a q v -> SigI.Process a q v
+comb time gain x =
+ do t <- toTimeScalar x (Expr.constant time)
+ returnModified [] (FiltR.comb (round t) gain) x
+-}
+
+
+integrate :: (Eq ty', Field.C ty', Additive.C yv) =>
+ (Parameters ty' ty', InputSignal t ty' y ty' yv) ->
+ (OutputSignal t ty' y ty' yv, Results ty' ty')
+integrate ((srY,ampY), sigX) =
+ let srX = SigP.sampleRate sigX
+ (srYResult, srXResult) = Logic.equal srY srX
+ (_, ampYResult, ampXResult) = Logic.mul srX ampY (SigP.amplitude sigX)
+ in (SigP.cons srYResult ampYResult (Integrate.run (SigP.samples sigX)),
+ (srXResult, ampXResult))
+
+
+{-
+returnModified :: (Eq q) =>
+ [Process.Value q] -> ([v] -> [w]) -> SigI.T a q v -> SigI.Process a q w
+returnModified sampleRates proc x =
+ do let sampleRate = SigP.sampleRate x
+ mapM_ (Process.equalValue sampleRate) sampleRates
+ SigI.returnCons
+ sampleRate (SigP.amplitude x)
+ (proc (SigP.samples x))
+-}
diff --git a/src/Synthesizer/Inference/Func/Cut.hs b/src/Synthesizer/Inference/Func/Cut.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/Inference/Func/Cut.hs
@@ -0,0 +1,276 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{- |
+Copyright : (c) Henning Thielemann 2006, 2008
+License : GPL
+
+Maintainer : synthesizer@henning-thielemann.de
+Stability : provisional
+Portability : requires multi-parameter type classes
+-}
+module Synthesizer.Inference.Func.Cut (
+ {- * dissection -}
+ -- splitAt,
+ -- take,
+ -- drop,
+ takeUntilPause,
+ -- unzip,
+ -- unzip3,
+
+ {- * glueing -}
+ concat,
+ concatVolume,
+ append,
+ zip,
+ -- zip3,
+ arrange,
+ arrangeVolume,
+ ) where
+
+import qualified Synthesizer.Physical.Signal as SigP
+import qualified Synthesizer.Physical.Cut as CutP
+import qualified Synthesizer.Inference.Func.Signal as SigF
+
+import qualified Synthesizer.SampleRateContext.Signal as SigC
+import qualified Synthesizer.SampleRateContext.Rate as Rate
+import qualified Synthesizer.SampleRateContext.Cut as CutC
+
+import qualified Data.EventList.Relative.TimeBody as EventList
+import qualified Numeric.NonNegative.Class as NonNeg
+
+import qualified Algebra.NormedSpace.Maximum as NormedMax
+import qualified Algebra.OccasionallyScalar as OccScalar
+import qualified Algebra.Module as Module
+import qualified Algebra.RealField as RealField
+import qualified Algebra.Field as Field
+import qualified Algebra.Real as Real
+import qualified Algebra.Ring as Ring
+
+-- import qualified Data.List as List
+
+-- import Control.Monad.Fix(mfix)
+
+import PreludeBase hiding (zip, zip3, concat, )
+-- import NumericPrelude
+import Prelude (RealFrac)
+
+{-
+{- * dissection -}
+
+splitAt :: (RealField.C a, Field.C q, OccScalar.C a q) =>
+ q -> SigI.T a q v -> Process.T q (SigI.T a q v, SigI.T a q v)
+splitAt t0 x@(Cons sr amp ss) =
+ do t <- SigI.toTimeScalar x (Expr.constant t0)
+ let (ss0,ss1) = List.splitAt (round t) ss
+ return (Cons sr amp ss0, Cons sr amp ss1)
+
+take :: (RealField.C a, Field.C q, OccScalar.C a q) =>
+ q -> SigI.T a q v -> SigI.Process a q v
+take t = fmap fst . splitAt t
+
+drop :: (RealField.C a, Field.C q, OccScalar.C a q) =>
+ q -> SigI.T a q v -> SigI.Process a q v
+drop t = fmap snd . splitAt t
+-}
+
+takeUntilPause :: (RealField.C t, Ring.C t', OccScalar.C t t',
+ Field.C y', NormedMax.C y yv, OccScalar.C y y') =>
+ y' -> t' -> SigF.T t t' y y' yv -> SigF.T t t' y y' yv
+takeUntilPause y' t' x =
+ SigF.cons $ \infered@(isr,iamp) ->
+ let x' = SigF.eval x infered
+ xp = SigP.replaceParameters isr iamp x'
+ zp = CutP.takeUntilPause y' t' xp
+ in SigP.replaceParameters
+ (SigP.sampleRate x') (SigP.amplitude x') zp
+
+
+{-
+How can we assert sharing of the input signal
+with the output signals?
+
+unzip ::
+ SigF.T t t' y y' (yv0, yv1)
+ -> (SigF.T t t' y y' yv0, SigF.T t t' y y' yv1)
+unzip x =
+ (SigF.cons $ \inferedY@(isrY,iampY) -> ,
+ SigF.cons $ \inferedZ@(isrZ,iampZ) -> )
+
+
+unzip3 ::
+ SigF.T t t' y y' (yv0, yv1, yv2)
+ -> (SigF.T t t' y y' yv0, SigF.T t t' y y' yv1, SigF.T t t' y y' yv2)
+unzip3 = return . CutC.unzip3
+-}
+
+
+{- * glueing -}
+
+{- |
+ Similar to @foldr1 append@ but more efficient and accurate,
+ because it reduces the number of amplifications.
+ Does not work for infinite lists,
+ because in this case a maximum amplitude cannot be computed.
+-}
+concat ::
+ (Eq t', Real.C y', Field.C y', Module.C y yv, OccScalar.C y y') =>
+ [SigF.T t t' y y' yv]
+ -> SigF.T t t' y y' yv
+concat xs =
+ SigF.cons $ \(isr,iamp) ->
+ let xs' = zipWith (\x amp -> SigF.eval x (isr, amp)) xs amps
+ amps = map SigF.guessAmplitude xs'
+ xps = zipWith SigF.contextFixAmplitude amps xs'
+ sampleRate = SigF.mergeSampleRates xs'
+ in SigF.fromContextCheckAmplitude sampleRate iamp
+ (CutC.concat (Rate.fromNumber isr) xps)
+
+{- |
+ Like 'concat' but it expects a fixed output amplitude.
+ This way it can also handle infinitely many inputs
+ if one input or the output has a fixed sample rate.
+
+ 'concatVolume' is one reason for the complicated handling
+ of sampling rates by lists of @Maybe@s.
+
+ The problem of finding an apropriate sampling rate is that
+ we must have an order of processing parallel signal processors
+ which guarantees termination if termination is possible.
+ Say @mix (concat infinitelist0) (concat infinitelist1)@.
+ Either infinite list can have signal with fixed sample rate or not.
+ There is no way to determine this a priori.
+ The only safe way is to process them in parallel.
+ That's why we must have a @[Maybe t']@ instead of @Maybe t'@.
+ Also @[t']@ is not enough,
+ because e.g. a concatenation of infinitely many sounds
+ with undetermined sampling rate
+ would have an empty list representing the sampling rate,
+ but computing the empty list needs infinite time.
+-}
+concatVolume ::
+ (Eq t', Real.C y', Field.C y', Module.C y yv, OccScalar.C y y') =>
+ [SigF.T t t' y y' yv]
+ -> SigF.T t t' y y' yv
+concatVolume xs =
+ SigF.cons $ \(isr,iamp) ->
+ let xs' = zipWith (\x amp -> SigF.eval x (isr, amp)) xs amps
+ amps = map SigF.guessAmplitude xs'
+ xps = zipWith SigF.contextFixAmplitude amps xs'
+ sampleRate = SigF.mergeSampleRates xs'
+ in SigF.fromContextFreeAmplitude sampleRate
+ (CutC.concatVolume iamp (Rate.fromNumber isr) xps)
+
+
+merge :: (Eq t', Real.C y', Field.C y', OccScalar.C y y',
+ Module.C y v0, Module.C y v1) =>
+ (Rate.T t t' -> SigC.T y y' v0 -> SigC.T y y' v1 -> SigC.T y y' v2)
+ -> SigF.T t t' y y' v0
+ -> SigF.T t t' y y' v1
+ -> SigF.T t t' y y' v2
+merge f x y =
+ SigF.cons $ \(isr,iamp) ->
+ let x' = SigF.eval x (isr, ampX)
+ y' = SigF.eval y (isr, ampY)
+ ampX = SigF.guessAmplitude x'
+ ampY = SigF.guessAmplitude y'
+ xp = SigF.contextFixAmplitude ampX x'
+ yp = SigF.contextFixAmplitude ampY y'
+ sampleRate = SigF.mergeSampleRate x' y'
+ in SigF.fromContextCheckAmplitude sampleRate iamp
+ (f (Rate.fromNumber isr) xp yp)
+
+
+append :: (Eq t', Real.C y', Field.C y', OccScalar.C y y',
+ Module.C y yv) =>
+ SigF.T t t' y y' yv
+ -> SigF.T t t' y y' yv
+ -> SigF.T t t' y y' yv
+append = merge CutC.append
+
+
+zip :: (Eq t', Real.C y', Field.C y', OccScalar.C y y',
+ Module.C y v0, Module.C y v1) =>
+ SigF.T t t' y y' v0
+ -> SigF.T t t' y y' v1
+ -> SigF.T t t' y y' (v0,v1)
+zip = merge CutC.zip
+
+{-
+zip3 :: (Real.C q, Field.C q, Ord q, OccScalar.C a q,
+ Module.C a v0, Module.C a v1, Module.C a v2)
+ => SigI.T a q v0
+ -> SigI.T a q v1
+ -> SigI.T a q v2
+ -> SigI.Process a q (v0, v1, v2)
+zip3 x0 x1 x2 =
+ mfix (\z ->
+ do sampleRate <- Process.equalValues
+ [SigP.sampleRate x0, SigP.sampleRate x1, SigP.sampleRate x2]
+ amplitude <- Process.fromExpr
+ (Expr.maximum [amplitudeExpr x0, amplitudeExpr x1, amplitudeExpr x2])
+ samp0 <- SigI.vectorSamples (toAmplitudeScalar z) x0
+ samp1 <- SigI.vectorSamples (toAmplitudeScalar z) x1
+ samp2 <- SigI.vectorSamples (toAmplitudeScalar z) x2
+ SigI.returnCons sampleRate amplitude
+ (List.zip3 samp0 samp1 samp2))
+-}
+
+
+
+scheduleToContext ::
+ t'
+ -> EventList.T time (SigF.T t t' y y' yv)
+ -> (SigF.Parameter t',
+ EventList.T time (SigC.T y y' yv))
+scheduleToContext isr sched =
+ let xps =
+ EventList.mapBody
+ (\x ->
+ let y = SigF.eval x (isr, amp)
+ amp = SigF.guessAmplitude y
+ z = SigF.contextFixAmplitude amp y
+ in (y,z)) sched
+ schedp = EventList.mapBody snd xps
+ sampleRate = SigF.mergeSampleRates (map fst (EventList.getBodies xps))
+ in (sampleRate, schedp)
+
+
+{- |
+ Given a list of signals with time stamps,
+ mix them into one signal as they occur in time.
+ Ideally for composing music.
+ Infinite schedules are not supported,
+ because no maximum amplitude can be computed.
+-}
+arrange ::
+ (RealFrac t, NonNeg.C t, Eq t', Ring.C t, Ring.C t', OccScalar.C t t',
+ Ord y', Field.C y', OccScalar.C y y',
+ Module.C y yv) =>
+ t'
+ -> EventList.T t (SigF.T t t' y y' yv)
+ {-^ A list of pairs: (relative start time, signal part),
+ The start time is relative
+ to the start time of the previous event. -}
+ -> SigF.T t t' y y' yv
+ {-^ The mixed signal. -}
+arrange unit sched =
+ SigF.cons $ \(isr,iamp) ->
+ let (sampleRate, schedp) = scheduleToContext isr sched
+ in SigF.fromContextCheckAmplitude sampleRate iamp
+ (CutC.arrange unit (Rate.fromNumber isr) schedp)
+
+arrangeVolume ::
+ (RealFrac t, NonNeg.C t, Eq t', Ring.C t, Ring.C t', OccScalar.C t t',
+ Field.C y', OccScalar.C y y',
+ Module.C y yv) =>
+ t'
+ -> EventList.T t (SigF.T t t' y y' yv)
+ {-^ A list of pairs: (relative start time, signal part),
+ The start time is relative
+ to the start time of the previous event. -}
+ -> SigF.T t t' y y' yv
+ {-^ The mixed signal. -}
+arrangeVolume unit sched =
+ SigF.cons $ \(isr,iamp) ->
+ let (sampleRate, schedp) = scheduleToContext isr sched
+ in SigF.fromContextFreeAmplitude sampleRate
+ (CutC.arrangeVolume iamp unit (Rate.fromNumber isr) schedp)
diff --git a/src/Synthesizer/Inference/Func/Signal.hs b/src/Synthesizer/Inference/Func/Signal.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/Inference/Func/Signal.hs
@@ -0,0 +1,299 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{- |
+
+Copyright : (c) Henning Thielemann 2006, 2008
+License : GPL
+
+Maintainer : synthesizer@henning-thielemann.de
+Stability : provisional
+Portability : requires multi-parameter type classes
+
+-}
+module Synthesizer.Inference.Func.Signal where
+
+import qualified Synthesizer.Physical.Signal as SigP
+import qualified Synthesizer.SampleRateContext.Signal as SigC
+
+-- import qualified Algebra.OccasionallyScalar as OccScalar
+-- import qualified Algebra.Module as Module
+-- import qualified Algebra.Field as Field
+-- import qualified Algebra.Ring as Ring
+
+-- import Algebra.OccasionallyScalar (toScalar)
+
+import Control.Monad.Fix (fix, )
+import Data.Maybe (catMaybes, isJust, )
+import Data.List (transpose, )
+import Data.List.HT (shearTranspose, )
+
+-- import NumericPrelude
+import PreludeBase as P
+
+{- |
+Each process must work the following way:
+If the signal processor has a fixed sample rate or amplitude
+either implied by its parameters or its inputs
+then this parameter should be set as @Just@
+in the corresponding fields of @SigP.T@.
+These fields must be computed
+independently from the function argument of type @(t',y')@.
+This function argument is the pair of eventually used signal parameters
+sample rate and amplitude.
+If you set signal parameters to @Just@ with a value,
+then you can expect that the corresponding pair member has the same value.
+-}
+newtype T t t' y y' yv =
+ Cons {eval :: (t',y') -> Evaluated t t' y y' yv}
+
+type Evaluated t t' y y' yv = SigP.T t (Parameter t') y (Parameter y') yv
+{- |
+Since all 'Just' values must contain the same value,
+we could also use the data structure '(Peano, a)'
+just like in the @unique-logic@ package.
+-}
+newtype Parameter a = Parameter {parameterDesc :: [Maybe a]}
+
+liftParam2 ::
+ ([Maybe a] -> [Maybe b] -> [Maybe c]) ->
+ Parameter a -> Parameter b -> Parameter c
+liftParam2 f (Parameter x) (Parameter y) = Parameter (f x y)
+
+cons :: ((t',y') -> SigP.T t (Parameter t') y (Parameter y') yv) -> T t t' y y' yv
+cons = Cons
+
+
+contextFixAmplitude ::
+ y'
+ -> Evaluated t t' y y' yv
+ -> SigC.T y y' yv
+contextFixAmplitude amp =
+ SigC.replaceAmplitude amp . SigP.content
+
+fromContextFreeAmplitude ::
+ Parameter t'
+ -> SigC.T y y' yv
+ -> Evaluated t t' y y' yv
+fromContextFreeAmplitude sr (SigC.Cons _amp ss) =
+ SigP.cons sr anyParameter ss
+
+fromContextCheckAmplitude :: (Eq y') =>
+ Parameter t'
+ -> y'
+ -> SigC.T y y' yv
+ -> Evaluated t t' y y' yv
+fromContextCheckAmplitude sr iamp (SigC.Cons amp ss) =
+ SigP.cons sr (justParameter amp)
+ (if iamp==amp then ss else error "fromContextCheckAmplitude: amplitudes differ")
+
+
+anyParameter :: Parameter q
+anyParameter = Parameter []
+
+justParameter :: q -> Parameter q
+justParameter x = Parameter [Just x]
+
+inSampleRate :: (t',y') -> t'
+inSampleRate = fst
+
+inAmplitude :: (t',y') -> y'
+inAmplitude = snd
+
+
+
+{-
+vectorSamples :: (Eq t', Module.C y yv) =>
+ (y' -> y) -> T t t' y y' yv -> (t' -> [yv])
+vectorSamples toAmpScalar sig =
+ \inferedSampleRate ->
+ let x' = eval sig (inferedSampleRate, amp')
+ amp' = guessParameter
+ "vectorSamples: input amplitude"
+ (SigP.amplitude x')
+ amp = toAmpScalar amp' `SigP.asTypeOfAmplitude` x'
+ in amp *> SigP.samples x'
+
+scalarSamples :: (Eq t', Ring.C y) =>
+ (y' -> y) -> T t t' y y' y -> (t' -> [y])
+scalarSamples toAmpScalar sig =
+ \inferedSampleRate ->
+ let x' = sig (inferParameter inferedSampleRate (SigP.sampleRate x'),
+ amp')
+ amp' = fromMaybe (error "scalarSamples: undetermined input amplitude")
+ (SigP.amplitude x')
+ amp = toAmpScalar amp' `SigP.asTypeOfAmplitude` x'
+ in map (amp*) (SigP.samples x')
+
+
+
+inferParameter :: Eq q => q -> Maybe q -> q
+inferParameter infered =
+ maybe infered
+ (\x -> if x == infered
+ then x
+ else error ("inferParameter:" ++
+ " requested value and infered one differ"))
+-}
+
+equalParameter :: Eq q => String -> Maybe q -> Maybe q -> Maybe q
+equalParameter name x y =
+ case (x,y) of
+ (Nothing,_) -> y
+ (_,Nothing) -> x
+ (Just xv, Just yv) ->
+ if xv == yv
+ then Just xv
+ else error ("equalParameter: " ++ name ++ " differ")
+
+equalSampleRate :: Eq t' => Maybe t' -> Maybe t' -> Maybe t'
+equalSampleRate = equalParameter "sample rate"
+
+
+zipJut :: (a -> a -> a) -> [a] -> [a] -> [a]
+zipJut f =
+ let aux (x:xs) (y:ys) = f x y : aux xs ys
+ aux [] ys = ys
+ aux xs [] = xs
+ in aux
+
+{-|
+ Merge the @Just@s of two lists.
+ It does not check for validity of the data.
+-}
+mergeParameter :: Parameter q -> Parameter q -> Parameter q
+mergeParameter =
+ liftParam2 (zipJut (\x y -> if isJust x then x else y))
+
+mergeSampleRate ::
+ Evaluated t t' y0 y0' yv0 -> Evaluated t t' y1 y1' yv1 -> Parameter t'
+mergeSampleRate x y =
+ mergeParameter (SigP.sampleRate x) (SigP.sampleRate y)
+
+
+mergeParameterEq :: Eq q => String -> Parameter q -> Parameter q -> Parameter q
+mergeParameterEq name =
+ liftParam2 (zipJut (equalParameter name))
+
+mergeSampleRateEq :: Eq t' => Parameter t' -> Parameter t' -> Parameter t'
+mergeSampleRateEq = mergeParameterEq "sample rate"
+
+-- cf. Examples.merge
+merge :: [a] -> [a] -> [a]
+merge (x:xs) ys = x : merge ys xs
+merge [] ys = ys
+
+propMerge :: Eq a => [a] -> [a] -> Bool
+propMerge xs ys = merge xs ys == concat (transpose [xs,ys])
+
+mergeParameter' :: Parameter t' -> Parameter t' -> Parameter t'
+mergeParameter' = liftParam2 merge
+
+checkParameter :: Eq q => String -> q -> Maybe q -> q
+checkParameter name x =
+ maybe x (\y -> if x == y
+ then x
+ else error ("checkParameter: deviation from common " ++ name))
+
+checkSampleRate :: Eq t' => t' -> Maybe t' -> t'
+checkSampleRate = checkParameter "sample rate"
+
+checkAmplitude :: Eq y' => y' -> Maybe y' -> y'
+checkAmplitude = checkParameter "amplitude"
+
+
+{-|
+ This routine is prepared for infinite lists.
+ In order to handle them we employ a Cantor diagonalization scheme.
+ It does not check for validity of the data
+ (i.e. equal @Just@ values)
+ but it does only keep some @Just@s,
+ and thus allows for a quick search of a guess of a parameter value.
+-}
+mergeParameters :: [Parameter q] -> Parameter q
+mergeParameters =
+ Parameter . map (head . (++[Nothing]) . filter isJust)
+ . shearTranspose . map parameterDesc
+
+mergeSampleRates :: [Evaluated t t' y y' yv] -> Parameter t'
+mergeSampleRates =
+ mergeParameters . map SigP.sampleRate
+
+mergeParametersEq :: Eq q => String -> [Parameter q] -> Parameter q
+mergeParametersEq name =
+ Parameter . map (foldl (equalParameter name) Nothing)
+ . shearTranspose . map parameterDesc
+
+mergeSampleRatesEq :: Eq t' => [Parameter t'] -> Parameter t'
+mergeSampleRatesEq = mergeParametersEq "sample rate"
+
+{- |
+This is a simple working version of 'mergeParameters',
+which does not need @Eq@ constraint.
+However, flattening a three-dimensional list
+does handle different dimensions differently,
+that is slower than the others.
+-}
+mergeParameters' :: [Parameter q] -> Parameter q
+mergeParameters' =
+ Parameter . concat . shearTranspose . map parameterDesc
+
+
+{-
+equalParameters :: Eq q => String -> [Parameter q] -> Parameter q
+equalParameters name xs =
+ let cxs = catMaybes xs
+ in if and (zipWith (==) cxs (tail cxs))
+ then listToMaybe cxs
+ else error ("equalParameters: " ++ name ++ " differ")
+
+equalSampleRates :: Eq t' => [Maybe t'] -> Maybe t'
+equalSampleRates = equalParameters "sample rates"
+-}
+
+guessParameter :: String -> Parameter q -> q
+guessParameter context =
+ head . (++ error (context ++ " undetermined")) . catMaybes . parameterDesc
+
+guessSampleRate :: Evaluated t t' y y' yv -> t'
+guessSampleRate = guessParameter "sample rate" . SigP.sampleRate
+
+guessAmplitude :: Evaluated t t' y y' yv -> y'
+guessAmplitude = guessParameter "amplitude" . SigP.amplitude
+
+
+
+{- |
+ A complex signal graph can be built without ever mentioning a sampling rate.
+ However when it comes to playing or writing a file,
+ we must determine the sampling rate eventually.
+ This function simply passes a signal through
+ while forcing it to the given sampling rate.
+-}
+fixSampleRate :: (Eq t') =>
+ t' {-^ sample rate -}
+ -> T t t' y y' yv {-^ passed through signal -}
+ -> T t t' y y' yv
+fixSampleRate forcedSampleRate input =
+ Cons $ \infered ->
+ let inputSig = eval input infered
+ in SigP.cons
+ (justParameter forcedSampleRate)
+ (SigP.amplitude inputSig)
+ (if inSampleRate infered == forcedSampleRate
+ then SigP.samples inputSig
+ else error "fixSampleRate: sampleRates differ")
+
+-- ***** Is this one correct? Has the usage of 'infered' a cycle?
+{- | Create a loop (feedback) from one node to another one.
+ That is, compute the fix point of a process iteration. -}
+loop :: (Eq t') =>
+ (T t t' y y' yv -> T t t' y y' yv)
+ {-^ process chain that shall be looped -}
+ -> T t t' y y' yv
+loop f =
+ fix (\x -> f (Cons $ \infered ->
+ SigP.cons anyParameter anyParameter
+ (SigP.samples (eval x infered))))
+
+-- example: loop (\y -> x + delay y)
diff --git a/src/Synthesizer/Inference/Monad/File.hs b/src/Synthesizer/Inference/Monad/File.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/Inference/Monad/File.hs
@@ -0,0 +1,21 @@
+module Synthesizer.Inference.Monad.File where
+
+import qualified Synthesizer.Basic.Binary as BinSmp
+
+import qualified Synthesizer.Inference.Monad.Signal as SigI
+import qualified Synthesizer.Physical.File as FileP
+
+import System.Exit(ExitCode)
+
+import qualified Algebra.OccasionallyScalar as OccScalar
+import qualified Algebra.Algebraic as Algebraic
+import qualified Algebra.VectorSpace as VectorSpace
+import qualified Algebra.RealField as RealField
+
+
+writeToInt16 ::
+ (RealField.C a, Algebraic.C q, Ord q, BinSmp.C v,
+ OccScalar.C a q, VectorSpace.C a v) =>
+ q -> q -> FilePath -> SigI.Process a q v -> IO ExitCode
+writeToInt16 freqUnit amp name proc =
+ FileP.writeToInt16 freqUnit amp name (SigI.run proc)
diff --git a/src/Synthesizer/Inference/Monad/Play.hs b/src/Synthesizer/Inference/Monad/Play.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/Inference/Monad/Play.hs
@@ -0,0 +1,21 @@
+module Synthesizer.Inference.Monad.Play where
+
+import qualified Synthesizer.Basic.Binary as BinSmp
+
+import qualified Synthesizer.Inference.Monad.Signal as SigI
+import qualified Synthesizer.Physical.Play as PlayP
+
+import qualified Algebra.OccasionallyScalar as OccScalar
+import qualified Algebra.VectorSpace as VectorSpace
+import qualified Algebra.Field as Field
+import qualified Algebra.RealField as RealField
+
+import System.Exit(ExitCode)
+
+
+toInt16 ::
+ (RealField.C a, Field.C q, Ord q, BinSmp.C v,
+ OccScalar.C a q, VectorSpace.C a v) =>
+ q -> q -> SigI.Process a q v -> IO ExitCode
+toInt16 freqUnit amp proc =
+ PlayP.toInt16 freqUnit amp (SigI.run proc)
diff --git a/src/Synthesizer/Inference/Monad/Signal.hs b/src/Synthesizer/Inference/Monad/Signal.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/Inference/Monad/Signal.hs
@@ -0,0 +1,153 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{- |
+
+Copyright : (c) Henning Thielemann 2006
+License : GPL
+
+Maintainer : synthesizer@henning-thielemann.de
+Stability : provisional
+Portability : requires multi-parameter type classes
+
+
+
+This module provides processors like that in "UniqueLogicNP.Explicit.Process"
+but is specialized to signals.
+
+Signal processors which modify a signal have a signature
+ @SigI.T a q v -> SigI.Process a q v@ .
+
+This let you easily share the result of a computation.
+@
+do
+ x <- generator
+ proc x x
+@
+However you have to write everything with @do@ notation,
+and you have to invent variable names,
+or you use monadic composition '=<<' instead of '.'
+and the 'Inference.MonadUtility.liftP' functions.
+
+For a more functional style of processor composition see "Synthesizer.Inference.Monad.SignalSeq".
+-}
+module Synthesizer.Inference.Monad.Signal where
+
+import qualified UniqueLogicNP.Explicit.Process as ProcI
+import qualified UniqueLogicNP.Explicit.Expression as Expr
+import qualified UniqueLogicNP.Explicit.System as IS
+
+import UniqueLogicNP.Explicit.Process (Expr, Atom, )
+
+import qualified Synthesizer.Physical.Signal as SigP
+
+import qualified Algebra.OccasionallyScalar as OccScalar
+import qualified Algebra.Module as Module
+import qualified Algebra.Field as Field
+import qualified Algebra.Ring as Ring
+
+import Algebra.OccasionallyScalar (toScalar)
+
+import Control.Monad.Fix (mfix)
+import Control.Monad.Trans.RWS (evalRWS)
+
+import NumericPrelude
+import PreludeBase as P
+
+
+type T a q v = SigP.T a (Atom q) a (Atom q) v
+type Process a q v = ProcI.T q (T a q v)
+
+run :: (Eq q) =>
+ Process a q v -> SigP.T a q a q v
+run proc =
+ let (sig, rules) =
+ evalRWS proc dict 0
+ dict = IS.resolve rules
+ rate = IS.getValue dict (SigP.sampleRate sig)
+ amp = IS.getValue dict (SigP.amplitude sig)
+ ss = SigP.samples sig
+ in SigP.cons rate amp ss
+
+returnCons :: Monad m =>
+ t' -> y' -> [yv] -> m (SigP.T t t' y y' yv)
+returnCons sr amp sig = return $ SigP.cons sr amp sig
+
+sampleRateExpr :: SigP.T t (Atom t') y (Atom y') yv -> Expr t'
+sampleRateExpr x = Expr.fromAtom (SigP.sampleRate x)
+
+amplitudeExpr :: SigP.T t (Atom t') y (Atom y') yv -> Expr y'
+amplitudeExpr x = Expr.fromAtom (SigP.amplitude x)
+
+
+{- |
+This and the following function are quite the same as in "Synthesizer.Physical.Signal".
+-}
+toTimeScalar :: (Field.C t', OccScalar.C t t') =>
+ SigP.T t (Atom t') y (Atom y') yv -> Expr t' -> ProcI.T t' t
+toTimeScalar x t =
+ do s <- ProcI.fromExpr (t * sampleRateExpr x)
+ v <- ProcI.getValue s
+ return (toScalar v `SigP.asTypeOfTime` x)
+
+toFrequencyScalar :: (Field.C t', OccScalar.C t t') =>
+ SigP.T t (Atom t') y (Atom y') yv -> Expr t' -> ProcI.T t' t
+toFrequencyScalar x f =
+ do s <- ProcI.fromExpr (f / sampleRateExpr x)
+ v <- ProcI.getValue s
+ return (toScalar v `SigP.asTypeOfTime` x)
+
+toAmplitudeScalar :: (Field.C y', OccScalar.C y y') =>
+ SigP.T t (Atom t') y (Atom y') yv -> Expr y' -> ProcI.T y' y
+toAmplitudeScalar x y =
+ do s <- ProcI.fromExpr (y / amplitudeExpr x)
+ v <- ProcI.getValue s
+ return (toScalar v `SigP.asTypeOfAmplitude` x)
+
+toGradientScalar :: (Field.C q, OccScalar.C a q) =>
+ T a q v -> Expr q -> ProcI.T q a
+toGradientScalar x steepness =
+ toFrequencyScalar x (steepness / amplitudeExpr x)
+
+
+vectorSamples :: (Module.C a v) =>
+ (Expr q -> ProcI.T q a) -> T a q v -> ProcI.T q [v]
+vectorSamples toAmpScalar sig =
+ do y <- toAmpScalar (amplitudeExpr sig)
+ return (y *> SigP.samples sig)
+
+scalarSamples :: (Ring.C a) =>
+ (Expr q -> ProcI.T q a) -> T a q a -> ProcI.T q [a]
+scalarSamples toAmpScalar sig =
+ do y <- toAmpScalar (amplitudeExpr sig)
+ return (map (y*) (SigP.samples sig))
+
+
+{- |
+ A complex signal graph can be built without ever mentioning a sampling rate.
+ However when it comes to playing or writing a file,
+ we must determine the sampling rate eventually.
+ This function simply passes a signal through
+ while forcing it to the given sampling rate.
+-}
+fixSampleRate :: (Eq q) =>
+ q {-^ sample rate -}
+ -> T a q v {-^ passed through signal -}
+ -> Process a q v
+fixSampleRate sampleRate x =
+ do ProcI.equalValue (IS.constant sampleRate) (SigP.sampleRate x)
+ return x
+
+{- | Create a loop (feedback) from one node to another one.
+ That is, compute the fix point of a process iteration. -}
+loop :: (Eq q) =>
+ (T a q v -> Process a q v) {-^ process chain that shall be looped -}
+ -> Process a q v
+loop f = mfix (\signalIn ->
+ do sampleRateIn <- ProcI.newVariable
+ amplitudeIn <- ProcI.newVariable
+ signalOut <- f (SigP.cons sampleRateIn amplitudeIn
+ (SigP.samples signalIn))
+ ProcI.equalValue sampleRateIn (SigP.sampleRate signalOut)
+ ProcI.equalValue amplitudeIn (SigP.amplitude signalOut)
+ return signalOut)
diff --git a/src/Synthesizer/Inference/Monad/Signal/Control.hs b/src/Synthesizer/Inference/Monad/Signal/Control.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/Inference/Monad/Signal/Control.hs
@@ -0,0 +1,181 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{- |
+Copyright : (c) Henning Thielemann 2006
+License : GPL
+
+Maintainer : synthesizer@henning-thielemann.de
+Stability : provisional
+Portability : requires multi-parameter type classes
+
+
+Control curves which can be used
+as envelopes, for controlling filter parameters and so on.
+-}
+module Synthesizer.Inference.Monad.Signal.Control
+ ({- * Primitives -}
+ constant, linear, exponential, exponential2,
+ {- * Piecewise -}
+ piecewise, Control(..), ControlPiece(..),
+ (-|#), ( #|-), (=|#), ( #|=), (|#), ( #|), -- spaces before # for Haddock
+ {- * Preparation -}
+ mapLinear, mapExponential)
+ where
+
+
+import Synthesizer.Inference.Monad.Signal (toTimeScalar, toAmplitudeScalar, toGradientScalar)
+import Synthesizer.Plain.Control
+ (Control(..), ControlPiece(..), (-|#), ( #|-), (=|#), ( #|=), (|#), ( #|))
+
+import qualified Synthesizer.Plain.Control as Ctrl
+import qualified Synthesizer.Inference.Monad.Signal.Displacement as SynI
+
+import qualified UniqueLogicNP.Explicit.Process as Process
+import qualified UniqueLogicNP.Explicit.Expression as Expr
+import qualified UniqueLogicNP.Explicit.System as IS
+import qualified Synthesizer.Inference.Monad.Signal as SigI
+
+import qualified Algebra.OccasionallyScalar as OccScalar
+import qualified Algebra.Transcendental as Trans
+import qualified Algebra.RealField as RealField
+import qualified Algebra.Field as Field
+import qualified Algebra.Real as Real
+import qualified Algebra.Ring as Ring
+
+import Control.Monad (liftM, liftM2, liftM4)
+import Control.Monad.Fix (mfix)
+
+import NumericPrelude
+import PreludeBase as P
+
+
+constant :: (Field.C q, Real.C q, OccScalar.C a q) =>
+ q {-^ value -}
+ -> SigI.Process a q a
+constant y =
+ do sampleRate <- Process.newVariable
+ SigI.returnCons sampleRate (IS.constant (abs y))
+ (Ctrl.constant (OccScalar.toScalar (signum y)))
+
+{- Using the 'Ctrl.linear' instead of 'Ctrl.linearStable'
+ the type class constraints would be weaker.
+linear :: (Additive.C a, Field.C q, Real.C q, OccScalar.C a q) =>
+-}
+
+{- ***** problem: linear curves starting with zero are impossible
+ better: Let the user tell a maximum value? -}
+
+{- | Caution: This control curve can contain samples
+ with an absolute value greater than 1. -}
+linear :: (Field.C a, Field.C q, Real.C q, OccScalar.C a q) =>
+ q {-^ steepness of the curve -}
+ -> q {-^ initial value -}
+ -> SigI.Process a q a
+linear steepness y0 =
+ mfix (\z ->
+ do sampleRate <- Process.newVariable
+ steep <- toGradientScalar z (Expr.constant steepness)
+ SigI.returnCons sampleRate (IS.constant (abs y0))
+ (Ctrl.linearStable steep (OccScalar.toScalar (signum y0))))
+
+exponential :: (Trans.C a, Field.C q, Real.C q, OccScalar.C a q) =>
+ q {-^ time where the function reaches 1\/e of the initial value -}
+ -> q {-^ initial value -}
+ -> SigI.Process a q a
+exponential time y0 =
+ mfix (\z ->
+ do sampleRate <- Process.newVariable
+ t <- toTimeScalar z (Expr.constant time)
+ SigI.returnCons sampleRate (IS.constant (abs y0))
+ (Ctrl.exponentialStable t (OccScalar.toScalar (signum y0))))
+
+{-
+ take 1000 $ show (run (fixSampleRate 100 (exponential 0.1 1)) :: SigDouble)
+-}
+
+exponential2 :: (Trans.C a, Field.C q, Real.C q, OccScalar.C a q) =>
+ q {-^ half life, time where the function reaches 1\/2 of the initial value -}
+ -> q {-^ initial value -}
+ -> SigI.Process a q a
+exponential2 time y0 =
+ mfix (\z ->
+ do sampleRate <- Process.newVariable
+ t <- toTimeScalar z (Expr.constant time)
+ SigI.returnCons sampleRate (IS.constant (abs y0))
+ (Ctrl.exponential2Stable t (OccScalar.toScalar (signum y0))))
+
+
+
+{- |
+Since this function looks for the maximum node value,
+and since the signal parameter inference phase must be completed before signal processing,
+infinite descriptions cannot be used here.
+-}
+piecewise :: (Trans.C a, RealField.C a,
+ Real.C q, Field.C q, OccScalar.C a q) =>
+ [ControlPiece q]
+ -> SigI.Process a q a
+piecewise cs =
+ mfix (\z ->
+ do sampleRate <- Process.newVariable
+ let amplitude = maximum
+ (map (\c -> max (abs (Ctrl.pieceY0 c))
+ (abs (Ctrl.pieceY1 c))) cs)
+ ps <- mapM (\(Ctrl.ControlPiece typ y0 y1 d) ->
+ liftM4 Ctrl.ControlPiece
+ {- We cannot provide an default case,
+ because the returned constructors
+ have different parameter type. -}
+ (case typ of
+ CtrlStep -> return CtrlStep
+ CtrlLin -> return CtrlLin
+ -- this may exceed value range (-1,1)
+ CtrlCubic d0 d1 ->
+ liftM2 CtrlCubic
+ (toGradientScalar z (Expr.constant d0))
+ (toGradientScalar z (Expr.constant d1))
+ CtrlExp sat ->
+ liftM CtrlExp
+ (toAmplitudeScalar z
+ (Expr.constant sat))
+ CtrlCos -> return CtrlCos)
+ (toAmplitudeScalar z (Expr.constant y0))
+ (toAmplitudeScalar z (Expr.constant y1))
+ (toTimeScalar z (Expr.constant d))) cs
+ SigI.returnCons
+ sampleRate (IS.constant amplitude)
+ (Ctrl.piecewise ps))
+
+
+
+{- |
+Map a control curve without amplitude unit
+by a linear (affine) function with a unit.
+-}
+mapLinear :: (Ring.C a, Field.C q, Real.C q, OccScalar.C a q) =>
+ q {- ^ range: one is mapped to @center+range@ -}
+ -> q {- ^ center: zero is mapped to @center@ -}
+ -> SigI.T a q a
+ -> SigI.Process a q a
+mapLinear range center x =
+ mfix (\z ->
+ do let absRange = abs range
+ let absCenter = abs center
+ rng <- toAmplitudeScalar z (Expr.constant absRange)
+ cnt <- toAmplitudeScalar z (Expr.constant absCenter)
+ SynI.mapScalar 1 (absRange + absCenter) (\y -> cnt + rng*y) x)
+
+{- |
+Map a control curve without amplitude unit
+exponentially to one with a unit.
+
+ToDo: sample values should remain in the range (-1,1)
+-}
+mapExponential :: (Field.C q, Trans.C a, OccScalar.C a q) =>
+ a {- ^ range: one is mapped to @center*range@ -}
+ -> q {- ^ center: zero is mapped to @center@ -}
+ -> SigI.T a q a
+ -> SigI.Process a q a
+mapExponential range center =
+ SynI.mapScalar 1 center (range**)
diff --git a/src/Synthesizer/Inference/Monad/Signal/Cut.hs b/src/Synthesizer/Inference/Monad/Signal/Cut.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/Inference/Monad/Signal/Cut.hs
@@ -0,0 +1,211 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{- |
+Copyright : (c) Henning Thielemann 2006
+License : GPL
+
+Maintainer : synthesizer@henning-thielemann.de
+Stability : provisional
+Portability : requires multi-parameter type classes
+-}
+module Synthesizer.Inference.Monad.Signal.Cut (
+ {- * dissection -}
+ splitAt,
+ take,
+ drop,
+ takeUntilPause,
+ unzip,
+ unzip3,
+
+ {- * glueing -}
+ concat,
+ append,
+ zip,
+ zip3,
+ arrange,
+ ) where
+
+import qualified UniqueLogicNP.Explicit.Process as Process
+import qualified UniqueLogicNP.Explicit.Expression as Expr
+import qualified Synthesizer.Inference.Monad.Signal as SigI
+
+import qualified Synthesizer.Physical.Signal as SigP
+import qualified Synthesizer.Physical.Cut as CutP
+
+import qualified Synthesizer.Plain.Cut as CutS
+
+import Synthesizer.Inference.Monad.Signal
+ (toTimeScalar, toAmplitudeScalar,
+ amplitudeExpr)
+
+import qualified Algebra.NormedSpace.Maximum as NormedMax
+import qualified Algebra.OccasionallyScalar as OccScalar
+import qualified Algebra.Module as Module
+import qualified Algebra.RealField as RealField
+import qualified Algebra.Field as Field
+import qualified Algebra.Real as Real
+import qualified Algebra.Ring as Ring
+
+import qualified Data.EventList.Relative.TimeBody as EventList
+import qualified Number.NonNegative as NonNeg
+
+import qualified Data.List as List
+
+import Control.Monad.Fix(mfix)
+import PreludeBase (Ord, (<=), (.),
+ (>>), (>>=), fail, return, fmap, map, fst, snd, mapM)
+import NumericPrelude
+import Prelude (RealFrac)
+
+{- * dissection -}
+
+splitAt :: (RealField.C a, Field.C q, OccScalar.C a q) =>
+ q -> SigI.T a q v -> Process.T q (SigI.T a q v, SigI.T a q v)
+splitAt t0 x =
+ do t <- SigI.toTimeScalar x (Expr.constant t0)
+ let (ss0,ss1) = List.splitAt (round t) (SigP.samples x)
+ return (SigP.replaceSamples ss0 x, SigP.replaceSamples ss1 x)
+
+take :: (RealField.C a, Field.C q, OccScalar.C a q) =>
+ q -> SigI.T a q v -> SigI.Process a q v
+take t = fmap fst . splitAt t
+
+drop :: (RealField.C a, Field.C q, OccScalar.C a q) =>
+ q -> SigI.T a q v -> SigI.Process a q v
+drop t = fmap snd . splitAt t
+
+takeUntilPause :: (RealField.C a, Field.C q,
+ NormedMax.C a v, OccScalar.C a q) =>
+ q -> q -> SigI.T a q v -> SigI.Process a q v
+takeUntilPause y t x =
+ do t' <- SigI.toTimeScalar x (Expr.constant t)
+ y' <- SigI.toAmplitudeScalar x (Expr.constant y)
+ return (SigP.replaceSamples
+ (CutS.takeUntilInterval
+ ((<=y') . NormedMax.norm)
+ (ceiling t')
+ (SigP.samples x)) x)
+
+
+unzip ::
+ SigI.T a q (v0, v1) -> Process.T q (SigI.T a q v0, SigI.T a q v1)
+unzip = return . CutP.unzip
+
+unzip3 ::
+ SigI.T a q (v0, v1, v2)
+ -> Process.T q (SigI.T a q v0, SigI.T a q v1, SigI.T a q v2)
+unzip3 = return . CutP.unzip3
+
+
+
+{- * glueing -}
+
+{- |
+ Similar to @foldr1 append@ but more efficient and accurate,
+ because it reduces the number of amplifications.
+ Does not work for infinite lists,
+ because no maximum amplitude can be computed.
+-}
+concat :: (RealField.C q, Ord q, Ring.C q, OccScalar.C a q,
+ Module.C a v) =>
+ [SigI.T a q v] -> SigI.Process a q v
+concat xs =
+ mfix (\z ->
+ do sampleRate <- Process.equalValues (map SigP.sampleRate xs)
+ let ampExprs = List.map amplitudeExpr xs
+ amplitude <- Process.fromExpr (Expr.maximum ampExprs)
+ samps <- mapM (SigI.vectorSamples (toAmplitudeScalar z)) xs
+ SigI.returnCons sampleRate amplitude
+ (List.concat samps))
+
+{-
+This is the first one of several possible methods:
+
+* Compute the maximum amplitude of the operands
+ and amplify the other signal accordingly.
+* Let the user specify an output volume.
+* Expect a fixed output amplitude
+ and amplify the inputs accordingly.
+* Force input and output amplitudes to be equal.
+ If this cannot be achieved,
+ the user must insert amplifier processes.
+-}
+merge :: (Real.C q, Field.C q, Ord q, OccScalar.C a q,
+ Module.C a v0, Module.C a v1) =>
+ ([v0] -> [v1] -> [v2]) ->
+ SigI.T a q v0 -> SigI.T a q v1 -> SigI.Process a q v2
+merge f x y =
+ mfix (\z ->
+ do sampleRate <- Process.equalValues [SigP.sampleRate x, SigP.sampleRate y]
+ amplitude <- Process.fromExpr
+ (Expr.max (amplitudeExpr x) (amplitudeExpr y))
+ sampX <- SigI.vectorSamples (toAmplitudeScalar z) x
+ sampY <- SigI.vectorSamples (toAmplitudeScalar z) y
+ SigI.returnCons sampleRate amplitude
+ (f sampX sampY))
+
+
+append :: (Real.C q, Field.C q, Ord q, OccScalar.C a q,
+ Module.C a v) =>
+ SigI.T a q v -> SigI.T a q v -> SigI.Process a q v
+append = merge (List.++)
+
+
+zip :: (Real.C q, Field.C q, Ord q, OccScalar.C a q,
+ Module.C a v0, Module.C a v1)
+ => SigI.T a q v0
+ -> SigI.T a q v1
+ -> SigI.Process a q (v0, v1)
+zip = merge List.zip
+
+zip3 :: (Real.C q, Field.C q, Ord q, OccScalar.C a q,
+ Module.C a v0, Module.C a v1, Module.C a v2)
+ => SigI.T a q v0
+ -> SigI.T a q v1
+ -> SigI.T a q v2
+ -> SigI.Process a q (v0, v1, v2)
+zip3 x0 x1 x2 =
+ mfix (\z ->
+ do sampleRate <- Process.equalValues
+ [SigP.sampleRate x0, SigP.sampleRate x1, SigP.sampleRate x2]
+ amplitude <- Process.fromExpr
+ (Expr.maximum [amplitudeExpr x0, amplitudeExpr x1, amplitudeExpr x2])
+ samp0 <- SigI.vectorSamples (toAmplitudeScalar z) x0
+ samp1 <- SigI.vectorSamples (toAmplitudeScalar z) x1
+ samp2 <- SigI.vectorSamples (toAmplitudeScalar z) x2
+ SigI.returnCons sampleRate amplitude
+ (List.zip3 samp0 samp1 samp2))
+
+
+{- |
+ 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.
+-}
+arrange :: (Field.C q, Ord q, OccScalar.C a q,
+ RealFrac a, Module.C a v) =>
+ q {-^ Unit of the time values in the time ordered list. -}
+ -> EventList.T a (SigI.T a q v)
+ {-^ A list of pairs: (relative start time, signal part),
+ The start time is relative
+ to the start time of the previous event. -}
+ -> SigI.Process a q v
+ {-^ The mixed signal. -}
+arrange unit sched =
+ mfix (\z ->
+ do let xs = EventList.getBodies sched
+ sampleRate <- Process.equalValues
+ (map SigP.sampleRate xs)
+ unitRes <- SigI.toTimeScalar z (Expr.constant unit)
+ let ampExprs = List.map amplitudeExpr xs
+ amplitude <- Process.fromExpr (Expr.maximum ampExprs)
+ schedRes <-
+ EventList.mapBodyM
+ (SigI.vectorSamples (toAmplitudeScalar z))
+ (EventList.mapTime
+ (NonNeg.fromNumberMsg "Inference.Signal.Cut.arrange") sched)
+ SigI.returnCons sampleRate amplitude
+ (CutS.arrange
+ (EventList.resample (NonNeg.fromNumber unitRes) schedRes)))
diff --git a/src/Synthesizer/Inference/Monad/Signal/Displacement.hs b/src/Synthesizer/Inference/Monad/Signal/Displacement.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/Inference/Monad/Signal/Displacement.hs
@@ -0,0 +1,119 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{- |
+Copyright : (c) Henning Thielemann 2006
+License : GPL
+
+Maintainer : synthesizer@henning-thielemann.de
+Stability : provisional
+Portability : requires multi-parameter type classes
+
+-}
+
+module Synthesizer.Inference.Monad.Signal.Displacement (
+ {- * Non-linearities -}
+ mapScalar,
+ mapVector,
+
+ {- * Mixing -}
+ mix,
+ mixMulti,
+) where
+
+
+import qualified UniqueLogicNP.Explicit.Process as Process
+import qualified UniqueLogicNP.Explicit.Expression as Expr
+import qualified Synthesizer.Inference.Monad.Signal as SigI
+import qualified UniqueLogicNP.Explicit.System as IS
+
+import UniqueLogicNP.Explicit.Expression ((=!=))
+import Synthesizer.Inference.Monad.Signal
+ (toAmplitudeScalar,
+ sampleRateExpr, amplitudeExpr)
+
+import qualified Synthesizer.Physical.Signal as SigP
+import qualified Synthesizer.Plain.Displacement as Syn
+
+import qualified Algebra.OccasionallyScalar as OccScalar
+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 Control.Monad.Fix (mfix)
+
+import NumericPrelude
+import PreludeBase
+import qualified Data.List as List
+
+
+{- * Non-linearities -}
+
+{- | Apply a function to the signal values.
+ If input and output signal shall have the same global amplitude,
+ then it must hold @rateX * ampY = 1@. -}
+mapVector :: (Module.C a v0, Field.C q, OccScalar.C a q) =>
+ q {- ^ rateX: If @v@ is the physical value
+ which shall appear as 1 to @f@,
+ then choose @rateX * v == 1@. -}
+ -> q {- ^ ampY: The physical value of the output signal
+ which is associated with the value 1 of @f@. -}
+ -> (v0 -> v1)
+ {- ^ f, the mapping -}
+ -> SigI.T a q v0
+ -> SigI.Process a q v1
+mapVector rateX ampY f x =
+ do samples <- SigI.vectorSamples
+ (Process.exprToScalar . (Expr.constant rateX *)) x
+ SigI.returnCons (SigP.sampleRate x) (IS.constant ampY)
+ (List.map f samples)
+
+mapScalar :: (Ring.C a, Field.C q, OccScalar.C a q) =>
+ q {- ^ rateX: If @v@ is the physical value
+ which shall appear as 1 to @f@,
+ then choose @rateX * v == 1@. -}
+ -> q {- ^ ampY: The physical value of the output signal
+ which is associated with the value 1 of @f@. -}
+ -> (a -> a)
+ {- ^ f, the mapping -}
+ -> SigI.T a q a
+ -> SigI.Process a q a
+mapScalar rateX ampY f x =
+ do samples <- SigI.scalarSamples
+ (Process.exprToScalar . (Expr.constant rateX *)) x
+ SigI.returnCons (SigP.sampleRate x) (IS.constant ampY)
+ (List.map f samples)
+
+
+{- * Mixing -}
+
+{- | Mix two signals.
+ In opposition to 'zipWith' the result has the length of the longer signal. -}
+mix :: (Field.C q, Eq q, Module.C a v, OccScalar.C a q) =>
+ SigI.T a q v
+ -> SigI.T a q v
+ -> SigI.Process a q v
+mix x y =
+ do sampleRate <- Process.fromExpr (sampleRateExpr x =!= sampleRateExpr y)
+ amplitude <- Process.fromExpr (amplitudeExpr x + amplitudeExpr y)
+ mfix (\z ->
+ do sampX <- SigI.vectorSamples (toAmplitudeScalar z) x
+ sampY <- SigI.vectorSamples (toAmplitudeScalar z) y
+ SigI.returnCons sampleRate amplitude
+ (sampX + sampY))
+
+{- | Mix one or more signals. -}
+mixMulti :: (Field.C q, Eq q, Module.C a v, OccScalar.C a q) =>
+ [SigI.T a q v]
+ -> SigI.Process a q v
+mixMulti xs =
+ do sampleRate <- Process.equalValues (List.map SigP.sampleRate xs)
+ let ampExprs = List.map amplitudeExpr xs
+ amplitude <- Process.fromExpr (sum1 ampExprs)
+ {- 'sum1' must be used, because 'sum' introduces a zero,
+ which will probably have an incompatible unit. -}
+ mfix (\z ->
+ do samps <- mapM (SigI.vectorSamples (toAmplitudeScalar z)) xs
+ SigI.returnCons sampleRate amplitude
+ (Syn.mixMulti samps))
diff --git a/src/Synthesizer/Inference/Monad/Signal/Filter.hs b/src/Synthesizer/Inference/Monad/Signal/Filter.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/Inference/Monad/Signal/Filter.hs
@@ -0,0 +1,355 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{- |
+Copyright : (c) Henning Thielemann 2006
+License : GPL
+
+Maintainer : synthesizer@henning-thielemann.de
+Stability : provisional
+Portability : requires multi-parameter type classes
+-}
+module Synthesizer.Inference.Monad.Signal.Filter (
+ {- * Non-recursive -}
+
+ {- ** Amplification -}
+ amplify,
+ negate,
+ envelope,
+ {- ** Filter operators from calculus -}
+ differentiate,
+
+ {- ** Smooth -}
+ mean,
+
+ {- ** Delay -}
+ delay,
+ phaseModulation,
+ phaser,
+ phaserStereo,
+
+
+ {- * Recursive -}
+
+ {- ** Without resonance -}
+ firstOrderLowpass,
+ firstOrderHighpass,
+ butterworthLowpass,
+ butterworthHighpass,
+ chebyshevALowpass,
+ chebyshevAHighpass,
+ chebyshevBLowpass,
+ chebyshevBHighpass,
+ {- ** With resonance -}
+ universal,
+ moogLowpass,
+ {- ** Allpass -}
+ allpassCascade,
+ {- ** Reverb -}
+ comb,
+ {- ** Filter operators from calculus -}
+ integrate
+) where
+
+
+import qualified UniqueLogicNP.Explicit.Process as Process
+import qualified UniqueLogicNP.Explicit.Expression as Expr
+import qualified Synthesizer.Inference.Monad.Signal as SigI
+import qualified Synthesizer.Inference.Monad.Signal.Cut as CutI
+import qualified Synthesizer.Inference.Monad.Signal.Displacement as SynI
+
+import UniqueLogicNP.Explicit.Expression ((=!=))
+import Synthesizer.Inference.Monad.Signal
+ (toTimeScalar, toFrequencyScalar, sampleRateExpr,
+ amplitudeExpr)
+
+import qualified Synthesizer.Physical.Signal as SigP
+import qualified Synthesizer.Plain.Signal as Sig
+import qualified Synthesizer.Plain.Displacement as Syn
+import qualified Synthesizer.Plain.Interpolation as Interpolation
+import qualified Synthesizer.Plain.Filter.Delay.ST 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.Comb as Comb
+import qualified Synthesizer.Plain.Filter.Recursive.Integration as Integrate
+import qualified Synthesizer.Plain.Filter.Recursive.Butterworth as Butter
+import qualified Synthesizer.Plain.Filter.Recursive.Chebyshev as Cheby
+import qualified Synthesizer.Plain.Filter.Recursive as FiltR
+import qualified Synthesizer.Plain.Filter.NonRecursive as FiltNR
+
+import qualified Algebra.OccasionallyScalar as OccScalar
+import qualified Algebra.Transcendental as Trans
+import qualified Algebra.RealField as RealField
+import qualified Algebra.Field as Field
+import qualified Algebra.Real as Real
+import qualified Algebra.Ring as Ring
+import qualified Algebra.Additive as Additive
+import qualified Algebra.Module as Module
+import qualified Algebra.VectorSpace as VectorSpace
+
+import Control.Monad (liftM2, )
+
+import Data.Ord.HT (limit, )
+
+import NumericPrelude hiding (negate)
+import PreludeBase as P
+
+
+{- | The amplification factor must be positive. -}
+amplify :: (Field.C q) =>
+ q
+ -> SigI.T a q v
+ -> SigI.Process a q v
+amplify volume x =
+ do amplitude <- Process.fromExpr (Expr.constant volume * amplitudeExpr x)
+ SigI.returnCons (SigP.sampleRate x) amplitude (SigP.samples x)
+
+negate :: (Additive.C v, Eq q) =>
+ SigI.T a q v
+ -> SigI.Process a q v
+negate =
+ returnModified [] Additive.negate
+
+
+envelope :: (Module.C y v, Field.C q, Eq q) =>
+ SigI.T a q y {- ^ the envelope -}
+ -> SigI.T a q v {- ^ the signal to be enveloped -}
+ -> SigI.Process a q v
+envelope y x =
+ do sampleRate <- Process.fromExpr (sampleRateExpr x =!= sampleRateExpr y)
+ amplitude <- Process.fromExpr (amplitudeExpr x * amplitudeExpr y)
+ SigI.returnCons sampleRate amplitude
+ (FiltNR.envelopeVector (SigP.samples y) (SigP.samples x))
+
+
+differentiate :: (Additive.C v, Field.C q, Eq q) =>
+ SigI.T a q v
+ -> SigI.Process a q v
+differentiate x =
+ do amp <- Process.fromExpr (amplitudeExpr x * sampleRateExpr x)
+ SigI.returnCons
+ (SigP.sampleRate x) amp
+ (FiltNR.differentiate (SigP.samples x))
+
+
+{- | needs a good handling of boundaries, yet -}
+mean :: (Additive.C v, Field.C q, Eq q, RealField.C a,
+ Module.C a v, OccScalar.C a q) =>
+ q {- ^ time length of the window -}
+ -> SigI.T a q v
+ -> SigI.Process a q v
+mean time x =
+ do t <- toTimeScalar x (Expr.constant time)
+ let tInt = round ((t-1)/2)
+ let width = tInt*2+1
+ returnModified []
+ ((SigP.asTypeOfAmplitude (recip (fromIntegral width)) x *> ) .
+ FiltNR.sums width . FiltNR.delay tInt) x
+
+
+delay :: (Additive.C v, Field.C q, Eq q, RealField.C a, OccScalar.C a q) =>
+ q
+ -> SigI.T a q v
+ -> SigI.Process a q v
+delay time x =
+ do t <- toTimeScalar x (Expr.constant time)
+ returnModified [] (FiltNR.delay (round t)) x
+
+
+phaseModulation ::
+ (Additive.C v, Field.C q, Eq q, RealField.C a, OccScalar.C a q) =>
+ Interpolation.T a v
+ -> q {- ^ minDelay, minimal delay, may be negative -}
+ -> q {- ^ maxDelay, maximal delay, it must be @minDelay <= maxDelay@
+ and the modulation must always be
+ in the range [minDelay,maxDelay]. -}
+ -> SigI.T a q a
+ {- ^ delay control, positive numbers mean delay,
+ negative numbers mean prefetch -}
+ -> SigI.T a q v
+ -> SigI.Process a q v
+phaseModulation ip minDelay maxDelay delays x =
+ do t0 <- toTimeScalar x (Expr.constant minDelay)
+ t1 <- toTimeScalar x (Expr.constant maxDelay)
+ let tInt0 = floor t0
+ let tInt1 = ceiling t1
+ let tInt0Neg = Additive.negate tInt0
+ ds <- SigI.scalarSamples (toTimeScalar delays) delays
+ returnModified [SigP.sampleRate delays]
+ (FiltNR.delay tInt0 .
+ Delay.modulated ip (tInt1-tInt0+1)
+ (FiltNR.delay tInt0Neg
+ (Syn.raise (fromIntegral tInt0Neg)
+ (map (limit (t0,t1)) ds)))) x
+
+
+{- | symmetric phaser -}
+phaser :: (Additive.C v, Field.C q, Eq q, RealField.C a,
+ Module.C a v, OccScalar.C a q) =>
+ Interpolation.T a v
+ -> q {- ^ maxDelay, must be positive -}
+ -> SigI.T a q a
+ {- ^ delay control -}
+ -> SigI.T a q v
+ -> SigI.Process a q v
+phaser ip maxDelay delays x =
+ amplify (asTypeOf 0.5 maxDelay) =<<
+ uncurry SynI.mix =<< phaserCore ip maxDelay delays x
+
+phaserStereo :: (Additive.C v, Field.C q, Eq q, Real.C q, RealField.C a,
+ Module.C a v, OccScalar.C a q) =>
+ Interpolation.T a v
+ -> q {- ^ maxDelay, must be positive -}
+ -> SigI.T a q a
+ {- ^ delay control -}
+ -> SigI.T a q v
+ -> SigI.Process a q (v,v)
+phaserStereo ip maxDelay delays x =
+ uncurry CutI.zip =<< phaserCore ip maxDelay delays x
+
+phaserCore :: (Additive.C v, Field.C q, Eq q, RealField.C a,
+ Module.C a v, OccScalar.C a q) =>
+ Interpolation.T a v
+ -> q {- ^ maxDelay, must be positive -}
+ -> SigI.T a q a
+ {- ^ delay control -}
+ -> SigI.T a q v
+ -> Process.T q (SigI.T a q v, SigI.T a q v)
+phaserCore ip maxDelay delays x =
+ do let minDelay = Additive.negate maxDelay
+ negDelays <- negate delays -- FiltI.negate delays
+ liftM2 (,)
+ (phaseModulation ip minDelay maxDelay delays x)
+ (phaseModulation ip minDelay maxDelay negDelays x)
+
+
+
+firstOrderLowpass, firstOrderHighpass ::
+ (Trans.C a, Trans.C q, Eq q, Module.C a v, OccScalar.C a q) =>
+ SigI.T a q a {- ^ Control signal for the cut-off frequency. -}
+ -> SigI.T a q v {- ^ Input signal -}
+ -> SigI.Process a q v
+firstOrderLowpass = firstOrderGen Filt1.lowpass
+firstOrderHighpass = firstOrderGen Filt1.highpass
+
+firstOrderGen :: (Trans.C a, Trans.C q, Eq q, Module.C a v, OccScalar.C a q) =>
+ (Sig.T (Filt1.Parameter a) -> Sig.T v -> Sig.T v)
+ -> SigI.T a q a
+ -> SigI.T a q v
+ -> SigI.Process a q v
+firstOrderGen filt freq x =
+ do freqs <- SigI.scalarSamples (toFrequencyScalar x) freq
+ returnModified [SigP.sampleRate freq]
+ (filt (map Filt1.parameter freqs)) x
+
+
+butterworthLowpass, butterworthHighpass,
+ chebyshevALowpass, chebyshevAHighpass,
+ chebyshevBLowpass, chebyshevBHighpass ::
+ (Field.C q, Eq q, Trans.C a, VectorSpace.C a v, OccScalar.C a q) =>
+ Int {- ^ Order of the filter, must be even,
+ the higher the order, the sharper is the separation of frequencies. -}
+ -> SigI.T a q a {- ^ The attenuation at the cut-off frequency.
+ Should be between 0 and 1. -}
+ -> SigI.T a q a {- ^ Control signal for the cut-off frequency. -}
+ -> SigI.T a q v {- ^ Input signal -}
+ -> SigI.Process a q v
+
+butterworthLowpass = higherOrderNoResoGen Butter.lowpassPole
+butterworthHighpass = higherOrderNoResoGen Butter.highpassPole
+chebyshevALowpass = higherOrderNoResoGen Cheby.lowpassAPole
+chebyshevAHighpass = higherOrderNoResoGen Cheby.highpassAPole
+chebyshevBLowpass = higherOrderNoResoGen Cheby.lowpassBPole
+chebyshevBHighpass = higherOrderNoResoGen Cheby.highpassBPole
+
+higherOrderNoResoGen ::
+ (Field.C q, Eq q, Ring.C a, OccScalar.C a q) =>
+ (Int -> Sig.T a -> Sig.T a -> Sig.T v -> Sig.T v)
+ -> Int
+ -> SigI.T a q a
+ -> SigI.T a q a
+ -> SigI.T a q v
+ -> SigI.Process a q v
+higherOrderNoResoGen filt order ratio freq x =
+ do ratios <- SigI.scalarSamples (Process.exprToScalar) ratio
+ freqs <- SigI.scalarSamples (toFrequencyScalar x) freq
+ returnModified [SigP.sampleRate freq]
+ (filt order ratios freqs) x
+
+
+
+universal :: (Trans.C a, Module.C a v, Field.C q, Eq q, OccScalar.C a q) =>
+ SigI.T a q a {- ^ signal for resonance,
+ i.e. factor of amplification at the resonance frequency
+ relatively to the transition band. -}
+ -> SigI.T a q a {- ^ signal for cut off and band center frequency -}
+ -> SigI.T a q v {- ^ input signal -}
+ -> SigI.Process a q (UniFilter.Result v)
+ {- ^ highpass, bandpass, lowpass filter -}
+universal reso freq x =
+ do resos <- SigI.scalarSamples (Process.exprToScalar) reso
+ freqs <- SigI.scalarSamples (toFrequencyScalar x) freq
+ let params =
+ map UniFilter.parameter
+ (zipWith FiltR.Pole resos freqs)
+ returnModified [SigP.sampleRate reso, SigP.sampleRate freq]
+ (UniFilter.run params) x
+
+moogLowpass :: (Trans.C a, Module.C a v, Field.C q, Eq q, OccScalar.C a q) =>
+ Int
+ -> SigI.T a q a {- ^ signal for resonance,
+ i.e. factor of amplification at the resonance frequency
+ relatively to the transition band. -}
+ -> SigI.T a q a {- ^ signal for cut off and band center frequency -}
+ -> SigI.T a q v
+ -> SigI.Process a q v
+moogLowpass order reso freq x =
+ do resos <- SigI.scalarSamples (Process.exprToScalar) reso
+ freqs <- SigI.scalarSamples (toFrequencyScalar x) freq
+ let params =
+ map (Moog.parameter order)
+ (zipWith FiltR.Pole resos freqs)
+ returnModified [SigP.sampleRate reso, SigP.sampleRate freq]
+ (Moog.lowpass order params) x
+
+allpassCascade :: (Trans.C a, Module.C a v, Field.C q, Eq q, OccScalar.C a q) =>
+ Int {- ^ order, number of filters in the cascade -}
+ -> a {- ^ the phase shift to be achieved for the given frequency -}
+ -> SigI.T a q a {- ^ lowest comb frequency -}
+ -> SigI.T a q v
+ -> SigI.Process a q v
+allpassCascade order phase freq x =
+ do freqs <- SigI.scalarSamples (toFrequencyScalar x) freq
+ let params = map (Allpass.parameter order phase) freqs
+ returnModified [SigP.sampleRate freq]
+ (Allpass.cascade order params) x
+
+
+
+{- | Infinitely many equi-delayed exponentially decaying echos. -}
+comb :: (RealField.C a, Field.C q, Eq q, OccScalar.C a q, Module.C a v) =>
+ q -> a -> SigI.T a q v -> SigI.Process a q v
+comb time gain x =
+ do t <- toTimeScalar x (Expr.constant time)
+ returnModified [] (Comb.run (round t) gain) x
+
+
+integrate :: (Additive.C v, Field.C q, Eq q) =>
+ SigI.T a q v -> SigI.Process a q v
+integrate x =
+ do amp <- Process.fromExpr (amplitudeExpr x / sampleRateExpr x)
+ SigI.returnCons
+ (SigP.sampleRate x) amp
+ (Integrate.run (SigP.samples x))
+
+
+returnModified :: (Eq q) =>
+ [Process.Atom q] -> (Sig.T v -> Sig.T w) -> SigI.T a q v -> SigI.Process a q w
+returnModified sampleRates proc x =
+ do let sampleRate = SigP.sampleRate x
+ mapM_ (Process.equalValue sampleRate) sampleRates
+ SigI.returnCons
+ sampleRate (SigP.amplitude x)
+ (proc (SigP.samples x))
diff --git a/src/Synthesizer/Inference/Monad/Signal/Noise.hs b/src/Synthesizer/Inference/Monad/Signal/Noise.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/Inference/Monad/Signal/Noise.hs
@@ -0,0 +1,72 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{- |
+Copyright : (c) Henning Thielemann 2006
+License : GPL
+
+Maintainer : synthesizer@henning-thielemann.de
+Stability : provisional
+Portability : requires multi-parameter type classes
+
+-}
+module Synthesizer.Inference.Monad.Signal.Noise
+ (white,
+ whiteGen,
+ randomPeeks) where
+
+
+import qualified UniqueLogicNP.Explicit.Process as Process
+import qualified UniqueLogicNP.Explicit.Expression as Expr
+import qualified Synthesizer.Inference.Monad.Signal as SigI
+import qualified UniqueLogicNP.Explicit.System as IS
+
+import qualified Synthesizer.Physical.Signal as SigP
+import qualified Synthesizer.Plain.Noise as Noise
+
+import qualified Algebra.OccasionallyScalar as OccScalar
+import qualified Algebra.Algebraic as Algebraic
+import qualified Algebra.Field as Field
+import qualified Algebra.Ring as Ring
+
+import System.Random (Random, RandomGen, randomRs, mkStdGen)
+
+import NumericPrelude
+import PreludeBase as P
+
+
+
+white :: (Ring.C v, Random v, Algebraic.C q) =>
+ q {-^ width of the frequency band -}
+ -> q {-^ volume caused by the given frequency band -}
+ -> SigI.Process a q v
+ {-^ noise -}
+white = whiteGen (mkStdGen 6746)
+
+whiteGen :: (Ring.C v, Random v, RandomGen g, Algebraic.C q) =>
+ g {-^ random generator, can be used to choose a seed -}
+ -> q {-^ width of the frequency band -}
+ -> q {-^ volume caused by the given frequency band -}
+ -> SigI.Process a q v
+ {-^ noise -}
+whiteGen gen bandWidth volume =
+ do sampleRate <- Process.newVariable
+ amplitude <- Process.fromExpr
+ (sqrt (3 * Expr.fromAtom sampleRate / Expr.constant bandWidth)
+ * Expr.constant volume)
+ SigI.returnCons sampleRate amplitude (Noise.whiteGen gen)
+
+
+randomPeeks :: (Field.C a, Random a, Ord a,
+ Field.C q, OccScalar.C a q) =>
+ SigI.T a q a {- ^ momentary densities (frequency),
+ @p@ means that there is about one peak
+ in the time range of @1\/p@. -}
+ -> SigI.Process a q Bool
+ {- ^ Every occurence of 'True' represents a peak. -}
+randomPeeks dens =
+ do amp <- SigI.toFrequencyScalar dens (SigI.amplitudeExpr dens)
+ SigI.returnCons (SigP.sampleRate dens) (IS.constant 1)
+ (zipWith (<)
+ (randomRs (0, recip amp) (mkStdGen 876))
+ (SigP.samples dens))
diff --git a/src/Synthesizer/Inference/Monad/Signal/Oscillator.hs b/src/Synthesizer/Inference/Monad/Signal/Oscillator.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/Inference/Monad/Signal/Oscillator.hs
@@ -0,0 +1,101 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{- |
+Copyright : (c) Henning Thielemann 2006
+License : GPL
+
+Maintainer : synthesizer@henning-thielemann.de
+Stability : provisional
+Portability : requires multi-parameter type classes
+
+-}
+module Synthesizer.Inference.Monad.Signal.Oscillator (
+ {- * Oscillators with constant waveforms -}
+ static,
+ freqMod,
+ phaseMod,
+ phaseFreqMod,
+) where
+
+
+import qualified UniqueLogicNP.Explicit.Process as Process
+import qualified UniqueLogicNP.Explicit.Expression as Expr
+import qualified UniqueLogicNP.Explicit.System as IS
+import qualified Synthesizer.Inference.Monad.Signal as SigI
+
+import Synthesizer.Inference.Monad.Signal (toFrequencyScalar)
+
+import qualified Synthesizer.Physical.Signal as SigP
+import qualified Synthesizer.Plain.Oscillator as Osci
+import qualified Synthesizer.Basic.Wave as Wave
+
+import qualified Algebra.OccasionallyScalar as OccScalar
+import qualified Algebra.RealField as RealField
+import qualified Algebra.Field as Field
+
+import Control.Monad.Fix (mfix)
+
+-- import NumericPrelude
+import PreludeBase as P
+
+
+{- * Oscillators with constant waveforms -}
+
+{- | oscillator with a functional waveform with constant frequency -}
+static :: (RealField.C a, Field.C q, OccScalar.C a q) =>
+ Wave.T a v {- ^ waveform -}
+ -> q {- ^ amplitude -}
+ -> a {- ^ start phase from the range [0,1] -}
+ -> q {- ^ frequency -}
+ -> SigI.Process a q v
+static wave amplitude phase freq =
+ mfix (\z ->
+ do sampleRate <- Process.newVariable
+ f <- toFrequencyScalar z (Expr.constant freq)
+ SigI.returnCons sampleRate (IS.constant amplitude)
+ (Osci.static wave phase f))
+
+{- | oscillator with a functional waveform with modulated frequency -}
+freqMod :: (RealField.C a, Field.C q, OccScalar.C a q) =>
+ Wave.T a v {- ^ waveform -}
+ -> q {- ^ amplitude -}
+ -> a {- ^ start phase from the range [0,1] -}
+ -> SigI.T a q a {- ^ frequency control -}
+ -> SigI.Process a q v
+freqMod wave amplitude phase xs =
+ do freqs <- SigI.scalarSamples (toFrequencyScalar xs) xs
+ SigI.returnCons
+ (SigP.sampleRate xs) (IS.constant amplitude)
+ (Osci.freqMod wave phase freqs)
+
+{- | oscillator with modulated phase -}
+phaseMod :: (RealField.C a, Field.C q, OccScalar.C a q) =>
+ Wave.T a v {- ^ waveform -}
+ -> q {- ^ amplitude -}
+ -> q {- ^ frequency control -}
+ -> SigI.T a q a {- ^ phase modulation, phases must have no unit and
+ are from range [0,1] -}
+ -> SigI.Process a q v
+phaseMod wave amplitude freq xs =
+ do freqFac <- toFrequencyScalar xs (Expr.constant freq)
+ phases <- SigI.scalarSamples (Process.exprToScalar) xs
+ SigI.returnCons
+ (SigP.sampleRate xs) (IS.constant amplitude)
+ (Osci.phaseMod wave freqFac phases)
+
+{- | oscillator with a functional waveform with modulated phase and frequency -}
+phaseFreqMod :: (RealField.C a, Field.C q, Eq q, OccScalar.C a q) =>
+ Wave.T a v {- ^ waveform -}
+ -> q {- ^ amplitude -}
+ -> SigI.T a q a {- ^ phase control -}
+ -> SigI.T a q a {- ^ frequency control -}
+ -> SigI.Process a q v
+phaseFreqMod wave amplitude xs ys =
+ do phases <- SigI.scalarSamples (Process.exprToScalar) xs
+ freqs <- SigI.scalarSamples (toFrequencyScalar ys) ys
+ sampleRate <- Process.equalValues
+ [SigP.sampleRate xs, SigP.sampleRate ys]
+ SigI.returnCons
+ sampleRate (IS.constant amplitude)
+ (Osci.phaseFreqMod wave phases freqs)
diff --git a/src/Synthesizer/Inference/Monad/SignalSeq.hs b/src/Synthesizer/Inference/Monad/SignalSeq.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/Inference/Monad/SignalSeq.hs
@@ -0,0 +1,98 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{- |
+
+Copyright : (c) Henning Thielemann 2006
+License : GPL
+
+Maintainer : synthesizer@henning-thielemann.de
+Stability : provisional
+Portability : requires multi-parameter type classes
+
+
+
+Similar to "Synthesizer.Inference.Monad.Signal"
+but the functions have monadic input and sequentialize it.
+This allows for a more functional looking style of programming
+because the type signature of signal modifiers is essentially
+ @SigI.Process a q v -> SigI.Process a q v@
+and thus they are perfectly composable with (.)
+and normal function application.
+
+The processor sequentializes its inputs
+and the order is quite arbitrary,
+but actually the order within monad sequences
+influences only the order of inference of signal parameters.
+The core signal processing does not depend on the monad order.
+
+The interfaces used here allow for function calls like
+ @superProc (proc1 x) (proc2 y)@ .
+However, we have to be careful with sharing of the results of signal processors.
+E.g.
+ @superProc x x@
+does not mean, that the signal generated by @x@ is used twice.
+Instead it means that @x@ is computed twice.
+This can be avoided by explicitly sharing
+the result signal with 'Inference.Process.share'.
+This is absolutely the same situation as in "UniqueLogicNP.Explicit.Expression".
+
+@
+ do
+ y <- Process.share x
+ superProc y y
+@
+
+A rule of thumb:
+Whenever you use the @let@ syntax,
+you are probably planing to use the variable more than once.
+Thus you should better use @do@ notation together with 'Inference.Process.share'.
+
+-}
+module Synthesizer.Inference.Monad.SignalSeq
+(
+ T,
+ Process,
+
+ run,
+
+ returnCons,
+
+ sampleRateExpr,
+ amplitudeExpr,
+
+ toTimeScalar,
+ toFrequencyScalar,
+ toAmplitudeScalar,
+
+ fixSampleRate,
+ loop
+)
+where
+
+import qualified Synthesizer.Inference.Monad.Signal as SigI
+
+import Synthesizer.Inference.Monad.Signal (T, Process, run, returnCons,
+ sampleRateExpr, amplitudeExpr,
+ toTimeScalar, toFrequencyScalar, toAmplitudeScalar)
+
+import UniqueLogicNP.Monad(liftP)
+-- import NumericPrelude
+import PreludeBase as P
+
+
+
+fixSampleRate :: (Eq q) =>
+ q {-^ sample rate -}
+ -> Process a q v {-^ passed through signal -}
+ -> Process a q v
+fixSampleRate sampleRate =
+ liftP (SigI.fixSampleRate sampleRate)
+
+{- | Create a loop from one node to another one.
+ That is, compute the fix point of a process iteration. -}
+loop :: (Eq q) =>
+ (Process a q v -> Process a q v)
+ {-^ process chain that shall be looped -}
+ -> Process a q v
+loop f = SigI.loop (f . return)
diff --git a/src/Synthesizer/Inference/Monad/SignalSeq/Control.hs b/src/Synthesizer/Inference/Monad/SignalSeq/Control.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/Inference/Monad/SignalSeq/Control.hs
@@ -0,0 +1,59 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{- |
+Copyright : (c) Henning Thielemann 2006
+License : GPL
+
+Maintainer : synthesizer@henning-thielemann.de
+Stability : provisional
+Portability : requires multi-parameter type classes
+
+
+Control curves which can be used
+as envelopes, for controlling filter parameters and so on.
+-}
+module Synthesizer.Inference.Monad.SignalSeq.Control
+ ({- * Primitives -}
+ constant, linear, exponential, exponential2,
+ {- * Piecewise -}
+ piecewise, Control(..), ControlPiece(..),
+ (-|#), ( #|-), (=|#), ( #|=), (|#), ( #|), -- spaces before # for Haddock
+ {- * Preparation -}
+ mapLinear, mapExponential)
+ where
+
+
+import qualified Synthesizer.Inference.Monad.Signal as SigI
+import qualified Synthesizer.Inference.Monad.Signal.Control as CtrlI
+
+import Synthesizer.Inference.Monad.Signal.Control
+ (constant, linear, exponential, exponential2, piecewise,
+ Control(..), ControlPiece(..), (-|#), ( #|-), (=|#), ( #|=), (|#), ( #|))
+
+import qualified Algebra.OccasionallyScalar as OccScalar
+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 UniqueLogicNP.Monad(liftP)
+
+-- import NumericPrelude
+
+
+mapLinear :: (Ring.C a, Field.C q, Real.C q, OccScalar.C a q) =>
+ q
+ -> q
+ -> SigI.Process a q a
+ -> SigI.Process a q a
+mapLinear range center =
+ liftP (CtrlI.mapLinear range center)
+
+mapExponential :: (Field.C q, Trans.C a, OccScalar.C a q) =>
+ a
+ -> q
+ -> SigI.Process a q a
+ -> SigI.Process a q a
+mapExponential range center =
+ liftP (CtrlI.mapExponential range center)
diff --git a/src/Synthesizer/Inference/Monad/SignalSeq/Cut.hs b/src/Synthesizer/Inference/Monad/SignalSeq/Cut.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/Inference/Monad/SignalSeq/Cut.hs
@@ -0,0 +1,105 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{- |
+Copyright : (c) Henning Thielemann 2006
+License : GPL
+
+Maintainer : synthesizer@henning-thielemann.de
+Stability : provisional
+Portability : requires multi-parameter type classes
+
+
+Similar to "Synthesizer.Inference.Monad.Signal.Cut"
+but the functions have monadic input and sequentialize it.
+See "Synthesizer.Inference.Monad.SignalSeq".
+-}
+module Synthesizer.Inference.Monad.SignalSeq.Cut (
+ {- * dissection -}
+ splitAt,
+ take,
+ drop,
+ takeUntilPause,
+ unzip,
+ unzip3,
+
+ {- * glueing -}
+ concat,
+ append,
+ zip,
+ zip3) where
+
+import qualified UniqueLogicNP.Explicit.Process as Process
+import qualified Synthesizer.Inference.Monad.Signal as SigI
+import qualified Synthesizer.Inference.Monad.Signal.Cut as CutI
+
+import qualified Algebra.NormedSpace.Maximum as NormedMax
+import qualified Algebra.OccasionallyScalar as OccScalar
+import qualified Algebra.Module as Module
+import qualified Algebra.RealField as RealField
+import qualified Algebra.Field as Field
+import qualified Algebra.Real as Real
+import qualified Algebra.Ring as Ring
+
+import UniqueLogicNP.Monad(liftP, liftP2, liftP3)
+import PreludeBase (Ord, (.), sequence)
+-- import NumericPrelude
+
+{- * dissection -}
+
+splitAt :: (RealField.C a, Field.C q, OccScalar.C a q) =>
+ q -> SigI.Process a q v -> Process.T q (SigI.T a q v, SigI.T a q v)
+splitAt t = liftP (CutI.splitAt t)
+
+take :: (RealField.C a, Field.C q, OccScalar.C a q) =>
+ q -> SigI.Process a q v -> SigI.Process a q v
+take t = liftP (CutI.take t)
+
+drop :: (RealField.C a, Field.C q, OccScalar.C a q) =>
+ q -> SigI.Process a q v -> SigI.Process a q v
+drop t = liftP (CutI.drop t)
+
+takeUntilPause :: (RealField.C a, Field.C q,
+ NormedMax.C a v, OccScalar.C a q) =>
+ q -> q -> SigI.Process a q v -> SigI.Process a q v
+takeUntilPause y t = liftP (CutI.takeUntilPause y t)
+
+
+unzip ::
+ SigI.Process a q (v0, v1) -> Process.T q (SigI.T a q v0, SigI.T a q v1)
+unzip = liftP CutI.unzip
+
+unzip3 ::
+ SigI.Process a q (v0, v1, v2)
+ -> Process.T q (SigI.T a q v0, SigI.T a q v1, SigI.T a q v2)
+unzip3 = liftP CutI.unzip3
+
+
+
+{- * glueing -}
+
+{- More efficient than 'foldr1 append'
+ because it reduces the number of amplifications. -}
+concat :: (RealField.C q, Ord q, Ring.C q, OccScalar.C a q,
+ Module.C a v) =>
+ [SigI.Process a q v] -> SigI.Process a q v
+concat = liftP CutI.concat . sequence
+
+append :: (Real.C q, Field.C q, Ord q, OccScalar.C a q,
+ Module.C a v) =>
+ SigI.Process a q v -> SigI.Process a q v -> SigI.Process a q v
+append = liftP2 CutI.append
+
+
+zip :: (Real.C q, Field.C q, Ord q, OccScalar.C a q,
+ Module.C a v0, Module.C a v1)
+ => SigI.Process a q v0
+ -> SigI.Process a q v1
+ -> SigI.Process a q (v0, v1)
+zip = liftP2 CutI.zip
+
+zip3 :: (Real.C q, Field.C q, Ord q, OccScalar.C a q,
+ Module.C a v0, Module.C a v1, Module.C a v2)
+ => SigI.Process a q v0
+ -> SigI.Process a q v1
+ -> SigI.Process a q v2
+ -> SigI.Process a q (v0, v1, v2)
+zip3 = liftP3 CutI.zip3
diff --git a/src/Synthesizer/Inference/Monad/SignalSeq/Displacement.hs b/src/Synthesizer/Inference/Monad/SignalSeq/Displacement.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/Inference/Monad/SignalSeq/Displacement.hs
@@ -0,0 +1,66 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{- |
+
+Copyright : (c) Henning Thielemann 2006
+License : GPL
+
+Maintainer : synthesizer@henning-thielemann.de
+Stability : provisional
+Portability : requires multi-parameter type classes
+
+-}
+module Synthesizer.Inference.Monad.SignalSeq.Displacement(
+ {- * Non-linearities -}
+ mapScalar,
+ mapVector,
+
+ {- * Mixing -}
+ mix,
+ mixMulti,
+) where
+
+import qualified Synthesizer.Inference.Monad.Signal as SigI
+import qualified Synthesizer.Inference.Monad.Signal.Displacement as SynI
+
+import qualified Algebra.OccasionallyScalar as OccScalar
+import qualified Algebra.Module as Module
+import qualified Algebra.Field as Field
+import qualified Algebra.Ring as Ring
+
+import UniqueLogicNP.Monad(liftP, liftP2)
+-- import NumericPrelude
+import PreludeBase
+
+
+mapVector :: (Module.C a v0, Field.C q, OccScalar.C a q) =>
+ q
+ -> q
+ -> (v0 -> v1)
+ -> SigI.Process a q v0
+ -> SigI.Process a q v1
+mapVector rateX ampY f = liftP (SynI.mapVector rateX ampY f)
+
+mapScalar :: (Ring.C a, Field.C q, OccScalar.C a q) =>
+ q
+ -> q
+ -> (a -> a)
+ -> SigI.Process a q a
+ -> SigI.Process a q a
+mapScalar rateX ampY f = liftP (SynI.mapScalar rateX ampY f)
+
+
+{- | Mix two signals.
+ In opposition to 'zipWith' the result has the length of the longer signal. -}
+mix :: (Field.C q, Eq q, Module.C a v, OccScalar.C a q) =>
+ SigI.Process a q v
+ -> SigI.Process a q v
+ -> SigI.Process a q v
+mix = liftP2 SynI.mix
+
+{- | Mix one or more signals. -}
+mixMulti :: (Field.C q, Eq q, Module.C a v, OccScalar.C a q) =>
+ [SigI.Process a q v]
+ -> SigI.Process a q v
+mixMulti = liftP SynI.mixMulti . sequence
diff --git a/src/Synthesizer/Inference/Monad/SignalSeq/Filter.hs b/src/Synthesizer/Inference/Monad/SignalSeq/Filter.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/Inference/Monad/SignalSeq/Filter.hs
@@ -0,0 +1,212 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{- |
+
+Copyright : (c) Henning Thielemann 2006
+License : GPL
+
+Maintainer : synthesizer@henning-thielemann.de
+Stability : provisional
+Portability : requires multi-parameter type classes
+-}
+module Synthesizer.Inference.Monad.SignalSeq.Filter(
+ {- * Non-recursive -}
+
+ {- ** Amplification -}
+ amplify,
+ negate,
+ envelope,
+ {- ** Filter operators from calculus -}
+ differentiate,
+
+ {- ** Smooth -}
+ mean,
+
+ {- ** Delay -}
+ delay,
+ phaseModulation,
+ phaser,
+ phaserStereo,
+
+ {- * Recursive -}
+
+ {- ** Without resonance -}
+ firstOrderLowpass,
+ firstOrderHighpass,
+ butterworthLowpass,
+ butterworthHighpass,
+ chebyshevALowpass,
+ chebyshevAHighpass,
+ chebyshevBLowpass,
+ chebyshevBHighpass,
+ {- ** With resonance -}
+ universal,
+ moogLowpass,
+ {- ** Allpass -}
+ allpassCascade,
+ {- ** Reverb -}
+ comb,
+ {- ** Filter operators from calculus -}
+ integrate
+) where
+
+import qualified Synthesizer.Inference.Monad.Signal as SigI
+import qualified Synthesizer.Inference.Monad.Signal.Filter as FiltI
+
+import qualified Synthesizer.Plain.Interpolation as Interpolation
+import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilter
+
+import qualified Algebra.OccasionallyScalar as OccScalar
+import qualified Algebra.VectorSpace as VectorSpace
+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.Additive as Additive
+
+import UniqueLogicNP.Monad(liftP, liftP2, liftP3)
+import NumericPrelude
+import PreludeBase as P
+
+
+{- | The amplification factor must be positive. -}
+amplify :: (Field.C q, Eq q) =>
+ q
+ -> SigI.Process a q v
+ -> SigI.Process a q v
+amplify volume = liftP (FiltI.amplify volume)
+
+envelope :: (Module.C y v, Field.C q, Eq q) =>
+ SigI.Process a q y {- ^ the envelope -}
+ -> SigI.Process a q v {- ^ the signal to be enveloped -}
+ -> SigI.Process a q v
+envelope = liftP2 FiltI.envelope
+
+
+
+
+integrate :: (Additive.C v, Field.C q, Eq q) =>
+ SigI.Process a q v -> SigI.Process a q v
+integrate = liftP FiltI.integrate
+
+differentiate :: (Additive.C v, Field.C q, Eq q) =>
+ SigI.Process a q v -> SigI.Process a q v
+differentiate = liftP FiltI.differentiate
+
+
+
+
+
+mean :: (Additive.C v, Field.C q, Eq q, RealField.C a,
+ Module.C a v, OccScalar.C a q) =>
+ q {- ^ time length of the window -}
+ -> SigI.Process a q v
+ -> SigI.Process a q v
+mean time = liftP (FiltI.mean time)
+
+
+delay :: (Additive.C v, Field.C q, Eq q, RealField.C a, OccScalar.C a q) =>
+ q
+ -> SigI.Process a q v
+ -> SigI.Process a q v
+delay time = liftP (FiltI.delay time)
+
+
+phaseModulation ::
+ (Additive.C v, Field.C q, Eq q, RealField.C a, OccScalar.C a q) =>
+ Interpolation.T a v
+ -> q {- ^ minDelay, minimal delay, may be negative -}
+ -> q {- ^ maxDelay, maximal delay, it must be @minDelay <= maxDelay@
+ and the modulation must always be
+ in the range [minDelay,maxDelay]. -}
+ -> SigI.Process a q a
+ {- ^ delay control, positive numbers mean delay,
+ negative numbers mean prefetch -}
+ -> SigI.Process a q v
+ -> SigI.Process a q v
+phaseModulation ip minDelay maxDelay =
+ liftP2 (FiltI.phaseModulation ip minDelay maxDelay)
+
+
+{- | symmetric phaser -}
+phaser :: (Additive.C v, Field.C q, Eq q, RealField.C a,
+ Module.C a v, OccScalar.C a q) =>
+ Interpolation.T a v
+ -> q {- ^ maxDelay, must be positive -}
+ -> SigI.Process a q a
+ {- ^ delay control -}
+ -> SigI.Process a q v
+ -> SigI.Process a q v
+phaser ip maxDelay = liftP2 (FiltI.phaser ip maxDelay)
+
+phaserStereo :: (Additive.C v, Field.C q, Eq q, Real.C q, RealField.C a,
+ Module.C a v, OccScalar.C a q) =>
+ Interpolation.T a v
+ -> q {- ^ maxDelay, must be positive -}
+ -> SigI.Process a q a
+ {- ^ delay control -}
+ -> SigI.Process a q v
+ -> SigI.Process a q (v,v)
+phaserStereo ip maxDelay = liftP2 (FiltI.phaserStereo ip maxDelay)
+
+
+
+firstOrderLowpass, firstOrderHighpass ::
+ (Trans.C a, Trans.C q, Eq q,Module.C a v, OccScalar.C a q) =>
+ SigI.Process a q a
+ -> SigI.Process a q v
+ -> SigI.Process a q v
+firstOrderLowpass = liftP2 FiltI.firstOrderLowpass
+firstOrderHighpass = liftP2 FiltI.firstOrderHighpass
+
+
+butterworthLowpass, butterworthHighpass,
+ chebyshevALowpass, chebyshevAHighpass,
+ chebyshevBLowpass, chebyshevBHighpass ::
+ (Field.C q, Eq q, Trans.C a, VectorSpace.C a v, OccScalar.C a q) =>
+ Int
+ -> SigI.Process a q a
+ -> SigI.Process a q a
+ -> SigI.Process a q v
+ -> SigI.Process a q v
+
+butterworthLowpass order = liftP3 (FiltI.butterworthLowpass order)
+butterworthHighpass order = liftP3 (FiltI.butterworthHighpass order)
+chebyshevALowpass order = liftP3 (FiltI.chebyshevALowpass order)
+chebyshevAHighpass order = liftP3 (FiltI.chebyshevAHighpass order)
+chebyshevBLowpass order = liftP3 (FiltI.chebyshevBLowpass order)
+chebyshevBHighpass order = liftP3 (FiltI.chebyshevBHighpass order)
+
+
+universal :: (Trans.C a, Module.C a v, Field.C q, Eq q, OccScalar.C a q) =>
+ SigI.Process a q a
+ -> SigI.Process a q a
+ -> SigI.Process a q v
+ -> SigI.Process a q (UniFilter.Result v)
+universal = liftP3 FiltI.universal
+
+
+moogLowpass :: (Trans.C a, Module.C a v, Field.C q, Eq q, OccScalar.C a q) =>
+ Int
+ -> SigI.Process a q a
+ -> SigI.Process a q a
+ -> SigI.Process a q v
+ -> SigI.Process a q v
+moogLowpass order = liftP3 (FiltI.moogLowpass order)
+
+allpassCascade :: (Trans.C a, Module.C a v, Field.C q, Eq q, OccScalar.C a q) =>
+ Int
+ -> a
+ -> SigI.Process a q a
+ -> SigI.Process a q v
+ -> SigI.Process a q v
+allpassCascade order phase =
+ liftP2 (FiltI.allpassCascade order phase)
+
+
+{- | Infinitely many equi-delayed exponentially decaying echos. -}
+comb :: (RealField.C a, Field.C q, Eq q, OccScalar.C a q, Module.C a v) =>
+ q -> a -> SigI.Process a q v -> SigI.Process a q v
+comb time gain = liftP (FiltI.comb time gain)
diff --git a/src/Synthesizer/Inference/Monad/SignalSeq/Noise.hs b/src/Synthesizer/Inference/Monad/SignalSeq/Noise.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/Inference/Monad/SignalSeq/Noise.hs
@@ -0,0 +1,43 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{- |
+Copyright : (c) Henning Thielemann 2006
+License : GPL
+
+Maintainer : synthesizer@henning-thielemann.de
+Stability : provisional
+Portability : requires multi-parameter type classes
+
+-}
+module Synthesizer.Inference.Monad.SignalSeq.Noise
+ (white,
+ whiteGen,
+ randomPeeks) where
+
+
+import qualified Synthesizer.Inference.Monad.Signal as SigI
+
+import qualified Synthesizer.Inference.Monad.Signal.Noise as NoiseI
+import Synthesizer.Inference.Monad.Signal.Noise (white, whiteGen)
+
+import qualified Algebra.OccasionallyScalar as OccScalar
+import qualified Algebra.Field as Field
+
+import System.Random (Random)
+
+import UniqueLogicNP.Monad(liftP)
+-- import NumericPrelude
+import PreludeBase as P
+
+
+
+randomPeeks :: (Field.C a, Random a, Ord a,
+ Field.C q, OccScalar.C a q) =>
+ SigI.Process a q a
+ {- ^ momentary densities (frequency),
+ @p@ means that there is about one peak
+ in the time range of @1\/p@. -}
+ -> SigI.Process a q Bool
+ {- ^ Every occurence of 'True' represents a peak. -}
+randomPeeks = liftP NoiseI.randomPeeks
diff --git a/src/Synthesizer/Inference/Monad/SignalSeq/Oscillator.hs b/src/Synthesizer/Inference/Monad/SignalSeq/Oscillator.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/Inference/Monad/SignalSeq/Oscillator.hs
@@ -0,0 +1,68 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{- |
+
+Copyright : (c) Henning Thielemann 2006
+License : GPL
+
+Maintainer : synthesizer@henning-thielemann.de
+Stability : provisional
+Portability : requires multi-parameter type classes
+-}
+module Synthesizer.Inference.Monad.SignalSeq.Oscillator(
+ {- * Oscillators with constant waveforms -}
+ static,
+ freqMod,
+ phaseMod,
+ phaseFreqMod,
+) where
+
+import qualified Synthesizer.Inference.Monad.Signal as SigI
+
+import qualified Synthesizer.Inference.Monad.Signal.Oscillator as OsciI
+
+import Synthesizer.Inference.Monad.Signal.Oscillator (static)
+
+import qualified Synthesizer.Basic.Wave as Wave
+
+import qualified Algebra.OccasionallyScalar as OccScalar
+import qualified Algebra.RealField as RealField
+import qualified Algebra.Field as Field
+
+import UniqueLogicNP.Monad (liftP, liftP2)
+-- import NumericPrelude
+import PreludeBase
+
+
+{- * Oscillators with constant waveforms -}
+
+{- | oscillator with a functional waveform with modulated frequency -}
+freqMod :: (RealField.C a, Field.C q, OccScalar.C a q) =>
+ Wave.T a v
+ -> q
+ -> a
+ -> SigI.Process a q a
+ -> SigI.Process a q v
+freqMod wave amplitude phase =
+ liftP (OsciI.freqMod wave amplitude phase)
+
+{- | oscillator with modulated phase -}
+phaseMod :: (RealField.C a, Field.C q, OccScalar.C a q) =>
+ Wave.T a v
+ -> q
+ -> q
+ -> SigI.Process a q a
+ -> SigI.Process a q v
+phaseMod wave amplitude freq =
+ liftP (OsciI.phaseMod wave amplitude freq)
+
+{- | oscillator with modulated phase and frequency -}
+phaseFreqMod :: (RealField.C a, Field.C q, Eq q, OccScalar.C a q) =>
+ Wave.T a v
+ -> q
+ -> SigI.Process a q a
+ -> SigI.Process a q a
+ -> SigI.Process a q v
+phaseFreqMod wave amplitude =
+ liftP2 (OsciI.phaseFreqMod wave amplitude)
diff --git a/src/Synthesizer/Inference/Reader/Control.hs b/src/Synthesizer/Inference/Reader/Control.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/Inference/Reader/Control.hs
@@ -0,0 +1,169 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{- |
+Copyright : (c) Henning Thielemann 2007
+License : GPL
+
+Maintainer : synthesizer@henning-thielemann.de
+Stability : provisional
+Portability : requires multi-parameter type classes
+
+
+Control curves which can be used
+as envelopes, for controlling filter parameters and so on.
+-}
+module Synthesizer.Inference.Reader.Control
+ ({- * Primitives -}
+ constant, constantVector, linear, line, exponential, exponential2,
+ {- * Piecewise -}
+ piecewise, piecewiseVolume, Control(..), ControlPiece(..),
+ (-|#), ( #|-), (=|#), ( #|=), (|#), ( #|), -- spaces before # for Haddock
+ {- * Preparation -}
+ mapLinear, mapExponential, )
+ where
+
+
+import Synthesizer.Plain.Control
+ (Control(..), ControlPiece(..), (-|#), ( #|-), (=|#), ( #|=), (|#), ( #|))
+
+import qualified Synthesizer.SampleRateContext.Control as CtrlC
+
+{-
+if we import that, then GHC-6.4.1 will no longer complain,
+that Synthesizer.Plain.Control is unnecessarily imported
+import qualified Synthesizer.Plain.Control as Ctrl
+-}
+
+import qualified Synthesizer.Inference.Reader.Signal as SigR
+import qualified Synthesizer.Inference.Reader.Process as Proc
+
+import qualified Algebra.OccasionallyScalar as OccScalar
+import qualified Algebra.Module as Module
+import qualified Algebra.Transcendental as Trans
+import qualified Algebra.RealField as RealField
+import qualified Algebra.Field as Field
+import qualified Algebra.Real as Real
+import qualified Algebra.Ring as Ring
+
+-- import NumericPrelude
+-- import PreludeBase as P
+
+
+constant :: (Field.C y', Real.C y', OccScalar.C y y') =>
+ y' {-^ value -}
+ -> Proc.T t t' (SigR.T y y' y)
+constant y =
+ SigR.lift (CtrlC.constant y)
+
+{- |
+The amplitude must be positive!
+This is not checked.
+-}
+constantVector :: -- (Field.C y', Real.C y', OccScalar.C y y') =>
+ y' {-^ amplitude -}
+ -> yv {-^ value -}
+ -> Proc.T t t' (SigR.T y y' yv)
+constantVector y yv =
+ SigR.lift (CtrlC.constantVector y yv)
+
+{- Using the 'Ctrl.linear' instead of 'Ctrl.linearStable'
+ the type class constraints would be weaker.
+linear :: (Additive.C y, Field.C y', Real.C y', OccScalar.C y y') =>
+-}
+
+{- |
+Caution: This control curve can contain samples
+with an absolute value greater than 1.
+
+Linear curves starting with zero are impossible.
+Maybe you prefer using 'line'.
+-}
+linear ::
+ (Field.C q, Field.C q',
+ Real.C q', OccScalar.C q q') =>
+ q' {-^ slope of the curve -}
+ -> q' {-^ initial value -}
+ -> Proc.T q q' (SigR.T q q' q)
+linear slope y0 =
+ SigR.lift (CtrlC.linear slope y0)
+
+{- |
+Generates a finite ramp.
+-}
+line ::
+ (RealField.C q, Field.C q',
+ Real.C q', OccScalar.C q q') =>
+ q' {-^ duration of the ramp -}
+ -> (q',q') {-^ initial and final value -}
+ -> Proc.T q q' (SigR.T q q' q)
+line dur (y0,y1) =
+ SigR.lift (CtrlC.line dur (y0,y1))
+
+exponential :: (Trans.C q, Field.C q', Real.C q', OccScalar.C q q') =>
+ q' {-^ time where the function reaches 1\/e of the initial value -}
+ -> q' {-^ initial value -}
+ -> Proc.T q q' (SigR.T q q' q)
+exponential time y0 =
+ SigR.lift (CtrlC.exponential time y0)
+
+{-
+ take 1000 $ show (run (fixSampleRate 100 (exponential 0.1 1)) :: SigDouble)
+-}
+
+exponential2 :: (Trans.C q, Field.C q', Real.C q', OccScalar.C q q') =>
+ q' {-^ half life, time where the function reaches 1\/2 of the initial value -}
+ -> q' {-^ initial value -}
+ -> Proc.T q q' (SigR.T q q' q)
+exponential2 time y0 =
+ SigR.lift (CtrlC.exponential2 time y0)
+
+
+
+{- |
+Since this function looks for the maximum node value,
+and since the signal parameter inference phase must be completed before signal processing,
+infinite descriptions cannot be used here.
+-}
+piecewise :: (Trans.C q, RealField.C q,
+ Real.C q', Field.C q', OccScalar.C q q') =>
+ [ControlPiece q']
+ -> Proc.T q q' (SigR.T q q' q)
+piecewise cs =
+ SigR.lift (CtrlC.piecewise cs)
+
+piecewiseVolume ::
+ (Trans.C q, RealField.C q,
+ Real.C q', Field.C q', OccScalar.C q q') =>
+ [ControlPiece q']
+ -> q'
+ -> Proc.T q q' (SigR.T q q' q)
+piecewiseVolume cs amplitude =
+ SigR.lift (CtrlC.piecewiseVolume cs amplitude)
+
+
+{- |
+Map a control curve without amplitude unit
+by a linear (affine) function with a unit.
+-}
+mapLinear :: (Ring.C y, Field.C y', Real.C y', OccScalar.C y y') =>
+ y' {- ^ range: one is mapped to @center+range@ -}
+ -> y' {- ^ center: zero is mapped to @center@ -}
+ -> Proc.T t t'
+ (SigR.T y y' y
+ -> SigR.T y y' y)
+mapLinear range center =
+ SigR.lift (CtrlC.mapLinear range center)
+
+{- |
+Map a control curve without amplitude unit
+exponentially to one with a unit.
+-}
+mapExponential :: (Field.C y', Trans.C y, Module.C y y') =>
+ y {- ^ range: one is mapped to @center*range@, must be positive -}
+ -> y' {- ^ center: zero is mapped to @center@ -}
+ -> Proc.T t t'
+ (SigR.T y y y
+ -> SigR.T y y' y)
+mapExponential range center =
+ SigR.lift (CtrlC.mapExponential range center)
diff --git a/src/Synthesizer/Inference/Reader/Cut.hs b/src/Synthesizer/Inference/Reader/Cut.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/Inference/Reader/Cut.hs
@@ -0,0 +1,194 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{- |
+Copyright : (c) Henning Thielemann 2006
+License : GPL
+
+Maintainer : synthesizer@henning-thielemann.de
+Stability : provisional
+Portability : requires multi-parameter type classes
+-}
+module Synthesizer.Inference.Reader.Cut (
+ {- * dissection -}
+ splitAt,
+ take,
+ drop,
+ takeUntilPause,
+ unzip,
+ unzip3,
+
+ {- * glueing -}
+ concat, concatVolume,
+ append, appendVolume,
+ zip, zipVolume,
+ zip3, zip3Volume,
+ arrange, arrangeVolume,
+ ) where
+
+import qualified Synthesizer.SampleRateContext.Cut as CutC
+
+import qualified Synthesizer.Inference.Reader.Signal as SigR
+import qualified Synthesizer.Inference.Reader.Process as Proc
+
+import qualified Data.EventList.Relative.TimeBody as EventList
+import qualified Numeric.NonNegative.Class as NonNeg
+
+import qualified Algebra.NormedSpace.Maximum as NormedMax
+import qualified Algebra.OccasionallyScalar as OccScalar
+import qualified Algebra.Module as Module
+import qualified Algebra.RealField as RealField
+import qualified Algebra.Field as Field
+import qualified Algebra.Real as Real
+import qualified Algebra.Ring as Ring
+
+-- import qualified Data.List as List
+
+import PreludeBase ((.), Ord)
+-- import NumericPrelude
+import Prelude (RealFrac)
+
+
+{- * dissection -}
+
+splitAt :: (RealField.C t, Field.C t', OccScalar.C t t') =>
+ t' -> Proc.T t t' (SigR.T y y' yv -> (SigR.T y y' yv, SigR.T y y' yv))
+splitAt t = SigR.lift (CutC.splitAt t)
+
+take :: (RealField.C t, Field.C t', OccScalar.C t t') =>
+ t' -> Proc.T t t' (SigR.T y y' yv -> SigR.T y y' yv)
+take t = SigR.lift (CutC.take t)
+
+drop :: (RealField.C t, Field.C t', OccScalar.C t t') =>
+ t' -> Proc.T t t' (SigR.T y y' yv -> SigR.T y y' yv)
+drop t = SigR.lift (CutC.drop t)
+
+takeUntilPause ::
+ (RealField.C t, Ring.C t', OccScalar.C t t',
+ Field.C y', NormedMax.C y yv, OccScalar.C y y') =>
+ y' -> t' -> Proc.T t t' (SigR.T y y' yv -> SigR.T y y' yv)
+takeUntilPause y' t' = SigR.lift (CutC.takeUntilPause y' t')
+
+
+unzip ::
+ Proc.T t t'
+ (SigR.T y y' (yv0, yv1) ->
+ (SigR.T y y' yv0, SigR.T y y' yv1))
+unzip = SigR.lift CutC.unzip
+
+unzip3 ::
+ Proc.T t t'
+ (SigR.T y y' (yv0, yv1, yv2) ->
+ (SigR.T y y' yv0, SigR.T y y' yv1, SigR.T y y' yv2))
+unzip3 = SigR.lift CutC.unzip3
+
+
+{- * glueing -}
+
+{- |
+Similar to @foldr1 append@ but more efficient and accurate,
+because it reduces the number of amplifications.
+Does not work for infinite lists,
+because no maximum amplitude can be computed.
+-}
+concat ::
+ (Real.C y, Ord y', Field.C y', OccScalar.C y y',
+ Module.C y yv) =>
+ Proc.T t t' ([SigR.T y y' yv] -> SigR.T y y' yv)
+concat = SigR.lift CutC.concat
+
+{- |
+Give the output volume explicitly.
+Does also work for infinite lists.
+-}
+concatVolume ::
+ (Field.C y', OccScalar.C y y',
+ Module.C y yv) =>
+ y' -> Proc.T t t' ([SigR.T y y' yv] -> SigR.T y y' yv)
+concatVolume = SigR.lift . CutC.concatVolume
+
+
+append ::
+ (Real.C y, Ord y', Field.C y', OccScalar.C y y',
+ Module.C y yv) =>
+ Proc.T t t' (SigR.T y y' yv -> SigR.T y y' yv -> SigR.T y y' yv)
+append = SigR.lift CutC.append
+
+appendVolume ::
+ (Field.C y', OccScalar.C y y',
+ Module.C y yv) =>
+ y' ->
+ Proc.T t t' (SigR.T y y' yv -> SigR.T y y' yv -> SigR.T y y' yv)
+appendVolume = SigR.lift . CutC.appendVolume
+
+
+zip ::
+ (Real.C y, Ord y', Field.C y', OccScalar.C y y',
+ Module.C y yv0, Module.C y yv1) =>
+ Proc.T t t' (SigR.T y y' yv0 -> SigR.T y y' yv1 -> SigR.T y y' (yv0,yv1))
+zip = SigR.lift CutC.zip
+
+zipVolume ::
+ (Field.C y', OccScalar.C y y',
+ Module.C y yv0, Module.C y yv1) =>
+ y' ->
+ Proc.T t t' (SigR.T y y' yv0 -> SigR.T y y' yv1 -> SigR.T y y' (yv0,yv1))
+zipVolume = SigR.lift . CutC.zipVolume
+
+
+zip3 ::
+ (Real.C y, Ord y', Field.C y', OccScalar.C y y',
+ Module.C y yv0, Module.C y yv1, Module.C y yv2) =>
+ Proc.T t t' (SigR.T y y' yv0 -> SigR.T y y' yv1 -> SigR.T y y' yv2 ->
+ SigR.T y y' (yv0,yv1,yv2))
+zip3 = SigR.lift CutC.zip3
+
+zip3Volume ::
+ (Field.C y', OccScalar.C y y',
+ Module.C y yv0, Module.C y yv1, Module.C y yv2) =>
+ y' ->
+ Proc.T t t' (SigR.T y y' yv0 -> SigR.T y y' yv1 -> SigR.T y y' yv2 ->
+ SigR.T y y' (yv0,yv1,yv2))
+zip3Volume = SigR.lift . CutC.zip3Volume
+
+
+{- |
+Uses maximum input volume as output volume.
+-}
+arrange ::
+ (Ring.C t', OccScalar.C t t',
+ RealFrac t, NonNeg.C t,
+ Ord y', Field.C y', OccScalar.C y y',
+ Module.C y yv) =>
+ t' {-^ Unit of the time values in the time ordered list. -}
+ -> Proc.T t t'
+ (EventList.T t (SigR.T y y' yv)
+ {- A list of pairs: (relative start time, signal part),
+ The start time is relative
+ to the start time of the previous event. -}
+ -> SigR.T y y' yv
+ {- The mixed signal. -} )
+arrange = SigR.lift . CutC.arrange
+
+
+{- |
+Given a list of signals with time stamps,
+mix them into one signal as they occur in time.
+Ideally for composing music.
+Infinite schedules are not supported.
+Does not work for infinite lists,
+because no maximum amplitude can be computed.
+-}
+arrangeVolume ::
+ (Ring.C t', OccScalar.C t t',
+ RealFrac t, NonNeg.C t,
+ Field.C y', OccScalar.C y y',
+ Module.C y yv) =>
+ y' {-^ Output volume. -}
+ -> t' {-^ Unit of the time values in the time ordered list. -}
+ -> Proc.T t t'
+ (EventList.T t (SigR.T y y' yv)
+ {- A list of pairs: (relative start time, signal part),
+ The start time is relative
+ to the start time of the previous event. -}
+ -> SigR.T y y' yv
+ {- The mixed signal. -} )
+arrangeVolume amp = SigR.lift . CutC.arrangeVolume amp
diff --git a/src/Synthesizer/Inference/Reader/Filter.hs b/src/Synthesizer/Inference/Reader/Filter.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/Inference/Reader/Filter.hs
@@ -0,0 +1,342 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{- |
+Copyright : (c) Henning Thielemann 2007
+License : GPL
+
+Maintainer : synthesizer@henning-thielemann.de
+Stability : provisional
+Portability : requires multi-parameter type classes
+-}
+module Synthesizer.Inference.Reader.Filter (
+ {- * Non-recursive -}
+
+ {- ** Amplification -}
+ amplify,
+ negate,
+ envelope,
+ {- ** Filter operators from calculus -}
+ differentiate,
+
+{-
+ {- ** Smooth -}
+ mean,
+
+ {- ** Delay -}
+ delay,
+ phaseModulation,
+ phaser,
+ phaserStereo,
+
+
+ {- * Recursive -}
+
+ {- ** Without resonance -}
+ firstOrderLowpass,
+ firstOrderHighpass,
+ butterworthLowpass,
+ butterworthHighpass,
+ chebyshevALowpass,
+ chebyshevAHighpass,
+ chebyshevBLowpass,
+ chebyshevBHighpass,
+ {- ** With resonance -}
+ universal,
+ moogLowpass,
+ {- ** Allpass -}
+ allpassCascade,
+-}
+ {- ** Reverb -}
+ comb,
+
+ {- ** Filter operators from calculus -}
+ integrate,
+) where
+
+
+import qualified Synthesizer.SampleRateContext.Filter as FiltC
+
+import qualified Synthesizer.Inference.Reader.Signal as SigR
+import qualified Synthesizer.Inference.Reader.Process as Proc
+
+{-
+import Synthesizer.Inference.Reader.Signal
+ (toTimeScalar, toFrequencyScalar)
+
+import qualified Synthesizer.Physical.Signal as SigP
+import qualified Synthesizer.Plain.Displacement as Syn
+import qualified Synthesizer.Plain.Interpolation as Interpolation
+import qualified Synthesizer.Plain.Filter.Delay.Block as Delay
+import qualified Synthesizer.Plain.Filter.NonRecursive as Filt
+import qualified Synthesizer.Inference.Monad.Signal.Displacement as SynI
+import qualified Synthesizer.Inference.Monad.Signal.Cut as CutI
+-}
+
+import qualified Algebra.OccasionallyScalar as OccScalar
+-- import qualified Algebra.Transcendental as Trans
+import qualified Algebra.RealField as RealField
+import qualified Algebra.Field as Field
+-- import qualified Algebra.Real as Real
+import qualified Algebra.Ring as Ring
+import qualified Algebra.Additive as Additive
+import qualified Algebra.Module as Module
+-- import qualified Algebra.VectorSpace as VectorSpace
+
+{-
+import Data.Ord.HT (limit)
+
+import Control.Monad(liftM2)
+
+import NumericPrelude hiding (negate)
+import PreludeBase as P
+-}
+
+
+{- | The amplification factor must be positive. -}
+amplify :: (Field.C y') =>
+ y'
+ -> Proc.T t t'
+ (SigR.T y y' yv
+ -> SigR.T y y' yv)
+amplify volume = SigR.lift (FiltC.amplify volume)
+
+negate :: (Additive.C yv) =>
+ Proc.T t t'
+ (SigR.T y y' yv
+ -> SigR.T y y' yv)
+negate = SigR.lift FiltC.negate
+
+
+envelope :: (Module.C y yv, Field.C y') =>
+ Proc.T t t' (
+ SigR.T y y' y {- the envelope -}
+ -> SigR.T y y' yv {- the signal to be enveloped -}
+ -> SigR.T y y' yv)
+envelope = SigR.lift FiltC.envelope
+
+
+differentiate :: (Additive.C v, Field.C q') =>
+ Proc.T q q' (
+ SigR.T q q' v
+ -> SigR.T q q' v)
+differentiate = SigR.lift FiltC.differentiate
+
+
+{-
+{- | needs a good handling of boundaries, yet -}
+mean :: (Additive.C yv, Field.C y', RealField.C a,
+ Module.C a v, OccScalar.C a q) =>
+ q {- ^ time length of the window -}
+ -> SigR.T y y' yv
+ -> Proc.T t t' (SigR.T y y' yv)
+mean time x =
+ do t <- toTimeScalar x (Expr.constant time)
+ let tInt = round ((t-1)/2)
+ let width = tInt*2+1
+ returnModified []
+ ((SigP.asTypeOfAmplitude (recip (fromIntegral width)) x *> ) .
+ Filt.sums width . FiltNR.delay tInt) x
+
+
+delay :: (Additive.C yv, Field.C y', RealField.C a, OccScalar.C a q) =>
+ q
+ -> SigR.T y y' yv
+ -> Proc.T t t' (SigR.T y y' yv)
+delay time x =
+ do t <- toTimeScalar x (Expr.constant time)
+ returnModified [] (FiltNR.delay (round t)) x
+
+
+phaseModulation ::
+ (Additive.C yv, Field.C y', RealField.C a, OccScalar.C a q) =>
+ Interpolation.T a v
+ -> q {- ^ minDelay, minimal delay, may be negative -}
+ -> q {- ^ maxDelay, maximal delay, it must be @minDelay <= maxDelay@
+ and the modulation must always be
+ in the range [minDelay,maxDelay]. -}
+ -> SigI.T a q a
+ {- ^ delay control, positive numbers mean delay,
+ negative numbers mean prefetch -}
+ -> SigR.T y y' yv
+ -> Proc.T t t' (SigR.T y y' yv)
+phaseModulation ip minDelay maxDelay delays x =
+ do t0 <- toTimeScalar x (Expr.constant minDelay)
+ t1 <- toTimeScalar x (Expr.constant maxDelay)
+ let tInt0 = floor t0
+ let tInt1 = ceiling t1
+ let tInt0Neg = Additive.negate tInt0
+ ds <- SigI.scalarSamples (toTimeScalar delays) delays
+ returnModified [SigP.sampleRate delays]
+ (FiltNR.delay tInt0 .
+ Delay.modulated ip (tInt1-tInt0+1)
+ (FiltNR.delay tInt0Neg
+ (Syn.raise (fromIntegral tInt0Neg)
+ (map (limit (t0,t1)) ds)))) x
+
+
+{- | symmetric phaser -}
+phaser :: (Additive.C yv, Field.C y', RealField.C a,
+ Module.C a v, OccScalar.C a q) =>
+ Interpolation.T a v
+ -> q {- ^ maxDelay, must be positive -}
+ -> SigI.T a q a
+ {- ^ delay control -}
+ -> SigR.T y y' yv
+ -> Proc.T t t' (SigR.T y y' yv)
+phaser ip maxDelay delays x =
+ amplify (asTypeOf 0.5 maxDelay) =<<
+ uncurry SynI.mix =<< phaserCore ip maxDelay delays x
+
+phaserStereo :: (Additive.C yv, Field.C y', Real.C q, RealField.C a,
+ Module.C a v, OccScalar.C a q) =>
+ Interpolation.T a v
+ -> q {- ^ maxDelay, must be positive -}
+ -> SigI.T a q a
+ {- ^ delay control -}
+ -> SigR.T y y' yv
+ -> SigI.Process a q (v,v)
+phaserStereo ip maxDelay delays x =
+ uncurry CutI.zip =<< phaserCore ip maxDelay delays x
+
+phaserCore :: (Additive.C yv, Field.C y', RealField.C a,
+ Module.C a v, OccScalar.C a q) =>
+ Interpolation.T a v
+ -> q {- ^ maxDelay, must be positive -}
+ -> SigI.T a q a
+ {- ^ delay control -}
+ -> SigR.T y y' yv
+ -> Process.T q (SigR.T y y' yv, SigR.T y y' yv)
+phaserCore ip maxDelay delays x =
+ do let minDelay = Additive.negate maxDelay
+ negDelays <- Inference.Signal.Filter.negate delays
+ liftM2 (,)
+ (phaseModulation ip minDelay maxDelay delays x)
+ (phaseModulation ip minDelay maxDelay negDelays x)
+
+
+
+firstOrderLowpass, firstOrderHighpass ::
+ (Trans.C a, Trans.C q, Module.C a v, OccScalar.C a q) =>
+ SigI.T a q a {- ^ Control signal for the cut-off frequency. -}
+ -> SigR.T y y' yv {- ^ Input signal -}
+ -> Proc.T t t' (SigR.T y y' yv)
+firstOrderLowpass = firstOrderGen Syn.lowpass1stOrder
+firstOrderHighpass = firstOrderGen Syn.highpass1stOrder
+
+firstOrderGen :: (Trans.C a, Trans.C q, Module.C a v, OccScalar.C a q) =>
+ ([a] -> [v] -> [v])
+ -> SigI.T a q a
+ -> SigR.T y y' yv
+ -> Proc.T t t' (SigR.T y y' yv)
+firstOrderGen filt freq x =
+ do freqs <- SigI.scalarSamples (toFrequencyScalar x) freq
+ returnModified [SigP.sampleRate freq]
+ (filt (map Syn.lowpass1stOrderParam freqs)) x
+
+
+butterworthLowpass, butterworthHighpass,
+ chebyshevALowpass, chebyshevAHighpass,
+ chebyshevBLowpass, chebyshevBHighpass ::
+ (Field.C y', Trans.C a, VectorSpace.C a v, OccScalar.C a q) =>
+ Int {- ^ Order of the filter, must be even,
+ the higher the order, the sharper is the separation of frequencies. -}
+ -> a {- ^ The attenuation at the cut-off frequency.
+ Should be between 0 and 1. -}
+ -> SigI.T a q a {- ^ Control signal for the cut-off frequency. -}
+ -> SigR.T y y' yv {- ^ Input signal -}
+ -> Proc.T t t' (SigR.T y y' yv)
+
+butterworthLowpass = higherOrderNoResoGen Syn.butterworthLowpass
+butterworthHighpass = higherOrderNoResoGen Syn.butterworthHighpass
+chebyshevALowpass = higherOrderNoResoGen Syn.chebyshevALowpass
+chebyshevAHighpass = higherOrderNoResoGen Syn.chebyshevAHighpass
+chebyshevBLowpass = higherOrderNoResoGen Syn.chebyshevBLowpass
+chebyshevBHighpass = higherOrderNoResoGen Syn.chebyshevBHighpass
+
+higherOrderNoResoGen ::
+ (Field.C y', Ring.C a, OccScalar.C a q) =>
+ (Int -> a -> [a] -> [v] -> [v])
+ -> Int
+ -> a
+ -> SigI.T a q a
+ -> SigR.T y y' yv
+ -> Proc.T t t' (SigR.T y y' yv)
+higherOrderNoResoGen filt order ratio freq x =
+ do freqs <- SigI.scalarSamples (toFrequencyScalar x) freq
+ returnModified [SigP.sampleRate freq]
+ (filt order ratio freqs) x
+
+
+
+universal :: (Trans.C a, Module.C a v, Field.C y', OccScalar.C a q) =>
+ SigI.T a q a {- ^ signal for resonance,
+ i.e. factor of amplification at the resonance frequency
+ relatively to the transition band. -}
+ -> SigI.T a q a {- ^ signal for cut off and band center frequency -}
+ -> SigR.T y y' yv {- ^ input signal -}
+ -> SigI.Process a q (v,v,v) {- ^ highpass, bandpass, lowpass filter -}
+universal reso freq x =
+ do resos <- SigI.scalarSamples (Process.exprToScalar) reso
+ freqs <- SigI.scalarSamples (toFrequencyScalar x) freq
+ let params =
+ map UniFilter.parameter
+ (zipWith Syn.Pole resos freqs)
+ returnModified [SigP.sampleRate reso, SigP.sampleRate freq]
+ (UniFilter.run params) x
+
+moogLowpass :: (Trans.C a, Module.C a v, Field.C y', OccScalar.C a q) =>
+ Int
+ -> SigI.T a q a {- ^ signal for resonance,
+ i.e. factor of amplification at the resonance frequency
+ relatively to the transition band. -}
+ -> SigI.T a q a {- ^ signal for cut off and band center frequency -}
+ -> SigR.T y y' yv
+ -> Proc.T t t' (SigR.T y y' yv)
+moogLowpass order reso freq x =
+ do resos <- SigI.scalarSamples (Process.exprToScalar) reso
+ freqs <- SigI.scalarSamples (toFrequencyScalar x) freq
+ let params =
+ map (Moog.parameter order)
+ (zipWith Syn.Pole resos freqs)
+ returnModified [SigP.sampleRate reso, SigP.sampleRate freq]
+ (Moog.lowpass order params) x
+
+allpassCascade :: (Trans.C a, Module.C a v, Field.C y', OccScalar.C a q) =>
+ Int {- ^ order, number of filters in the cascade -}
+ -> a {- ^ the phase shift to be achieved for the given frequency -}
+ -> SigI.T a q a {- ^ lowest comb frequency -}
+ -> SigR.T y y' yv
+ -> Proc.T t t' (SigR.T y y' yv)
+allpassCascade order phase freq x =
+ do freqs <- SigI.scalarSamples (toFrequencyScalar x) freq
+ let params = map (Syn.allpassCascadeParam order phase) freqs
+ returnModified [SigP.sampleRate freq]
+ (Syn.allpassCascade order params) x
+-}
+
+
+
+{- | Infinitely many equi-delayed exponentially decaying echos. -}
+comb :: (RealField.C t, Ring.C t', OccScalar.C t t', Module.C y yv) =>
+ t' -> y -> Proc.T t t' (SigR.T y y' yv -> SigR.T y y' yv)
+comb time gain = SigR.lift (FiltC.comb time gain)
+
+
+integrate :: (Additive.C v, Field.C q') =>
+ Proc.T q q'
+ (SigR.T q q' v
+ -> SigR.T q q' v)
+integrate = SigR.lift FiltC.integrate
+
+
+{-
+returnModified :: (Eq q) =>
+ [Process.Value q] -> ([v] -> [w]) -> SigR.T y y' yv -> SigI.Process a q w
+returnModified sampleRates proc x =
+ do let sampleRate = SigP.sampleRate x
+ mapM_ (Process.equalValue sampleRate) sampleRates
+ SigI.returnCons
+ sampleRate (SigP.amplitude x)
+ (proc (SigP.samples x))
+-}
diff --git a/src/Synthesizer/Inference/Reader/Noise.hs b/src/Synthesizer/Inference/Reader/Noise.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/Inference/Reader/Noise.hs
@@ -0,0 +1,64 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{- |
+Copyright : (c) Henning Thielemann 2006
+License : GPL
+
+Maintainer : synthesizer@henning-thielemann.de
+Stability : provisional
+Portability : requires multi-parameter type classes
+
+-}
+module Synthesizer.Inference.Reader.Noise
+ (white,
+ whiteGen,
+ randomPeeks) where
+
+
+import qualified Synthesizer.SampleRateContext.Noise as NoiseC
+
+import qualified Synthesizer.Inference.Reader.Signal as SigR
+import qualified Synthesizer.Inference.Reader.Process as Proc
+
+import qualified Algebra.OccasionallyScalar as OccScalar
+import qualified Algebra.Algebraic as Algebraic
+import qualified Algebra.Field as Field
+import qualified Algebra.Ring as Ring
+
+import System.Random (Random, RandomGen)
+
+-- import NumericPrelude
+import PreludeBase as P
+
+
+
+white :: (Ring.C yv, Random yv, Algebraic.C q') =>
+ q' {-^ width of the frequency band -}
+ -> q' {-^ volume caused by the given frequency band -}
+ -> Proc.T t q' (SigR.T y q' yv)
+ {-^ noise -}
+white bandWidth volume = SigR.lift $ NoiseC.white bandWidth volume
+
+whiteGen :: (Ring.C yv, Random yv, RandomGen g, Algebraic.C q') =>
+ g {-^ random generator, can be used to choose a seed -}
+ -> q' {-^ width of the frequency band -}
+ -> q' {-^ volume caused by the given frequency band -}
+ -> Proc.T t q' (SigR.T y q' yv)
+ {-^ noise -}
+whiteGen gen bandWidth volume = SigR.lift (NoiseC.whiteGen gen bandWidth volume)
+
+{-
+The Field.C q constraint could be lifted to Ring.C
+if we would use direct division instead of toFrequencyScalar.
+-}
+randomPeeks ::
+ (Field.C q, Random q, Ord q,
+ Field.C q', OccScalar.C q q') =>
+ Proc.T q q'
+ ( SigR.T q q' q {- momentary densities (frequency),
+ @p@ means that there is about one peak
+ in the time range of @1\/p@. -}
+ -> [Bool])
+ {- Every occurence of 'True' represents a peak. -}
+randomPeeks = SigR.lift NoiseC.randomPeeks
diff --git a/src/Synthesizer/Inference/Reader/Oscillator.hs b/src/Synthesizer/Inference/Reader/Oscillator.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/Inference/Reader/Oscillator.hs
@@ -0,0 +1,81 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{- |
+Copyright : (c) Henning Thielemann 2006, 2008
+License : GPL
+
+Maintainer : synthesizer@henning-thielemann.de
+Stability : provisional
+Portability : requires multi-parameter type classes
+
+-}
+module Synthesizer.Inference.Reader.Oscillator (
+ {- * Oscillators with constant waveforms -}
+ static,
+ freqMod,
+ phaseMod,
+ phaseFreqMod,
+) where
+
+import qualified Synthesizer.SampleRateContext.Oscillator as OsciC
+
+-- import qualified Synthesizer.Plain.Oscillator as Osci
+import qualified Synthesizer.Basic.Wave as Wave
+
+import qualified Synthesizer.Inference.Reader.Signal as SigR
+import qualified Synthesizer.Inference.Reader.Process as Proc
+
+import qualified Algebra.OccasionallyScalar as OccScalar
+import qualified Algebra.RealField as RealField
+import qualified Algebra.Field as Field
+
+-- import NumericPrelude
+-- import PreludeBase as P
+
+
+{- * Oscillators with constant waveforms -}
+
+{- | oscillator with a functional waveform with constant frequency -}
+static :: (RealField.C t, Field.C t', OccScalar.C t t') =>
+ Wave.T t yv {- ^ waveform -}
+ -> y' {- ^ amplitude -}
+ -> t {- ^ start phase from the range [0,1] -}
+ -> t' {- ^ frequency -}
+ -> Proc.T t t' (SigR.T y y' yv)
+static wave amplitude phase freq =
+ SigR.lift (OsciC.static wave amplitude phase freq)
+
+{- | oscillator with a functional waveform with modulated frequency -}
+freqMod :: (RealField.C t, Field.C t', OccScalar.C t t') =>
+ Wave.T t yv {- ^ waveform -}
+ -> y' {- ^ amplitude -}
+ -> t {- ^ start phase from the range [0,1] -}
+ -> Proc.T t t' (
+ SigR.T t t' t {- frequency control -}
+ -> SigR.T y y' yv)
+freqMod wave amplitude phase =
+ SigR.lift (OsciC.freqMod wave amplitude phase)
+
+{- | oscillator with modulated phase -}
+phaseMod :: (RealField.C t, Field.C t', OccScalar.C t t') =>
+ Wave.T t yv {- ^ waveform -}
+ -> y' {- ^ amplitude -}
+ -> t' {- ^ frequency control -}
+ -> Proc.T t t' (
+ SigR.T t t t {- phase modulation, phases must have no unit and
+ are from range [0,1] -}
+ -> SigR.T y y' yv)
+phaseMod wave amplitude freq =
+ SigR.lift (OsciC.phaseMod wave amplitude freq)
+
+{- | oscillator with a functional waveform with modulated phase and frequency -}
+phaseFreqMod :: (RealField.C t, Field.C t', OccScalar.C t t') =>
+ Wave.T t yv {- ^ waveform -}
+ -> y' {- ^ amplitude -}
+ -> Proc.T t t' (
+ SigR.T t t t {- phase control -}
+ -> SigR.T t t' t {- frequency control -}
+ -> SigR.T y y' yv)
+phaseFreqMod wave amplitude =
+ SigR.lift (OsciC.phaseFreqMod wave amplitude)
diff --git a/src/Synthesizer/Inference/Reader/Play.hs b/src/Synthesizer/Inference/Reader/Play.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/Inference/Reader/Play.hs
@@ -0,0 +1,24 @@
+module Synthesizer.Inference.Reader.Play where
+
+import qualified Synthesizer.Basic.Binary as BinSmp
+
+import qualified Synthesizer.Inference.Reader.Signal as SigR
+import qualified Synthesizer.Inference.Reader.Process as ProcR
+import qualified Synthesizer.Physical.Play as PlayP
+
+import qualified Algebra.OccasionallyScalar as OccScalar
+import qualified Algebra.VectorSpace as VectorSpace
+import qualified Algebra.RealField as RealField
+import qualified Algebra.Field as Field
+
+import System.Exit(ExitCode)
+
+
+toInt16 ::
+ (RealField.C t, BinSmp.C yv,
+ Field.C t', OccScalar.C t t',
+ Field.C y', OccScalar.C y y',
+ VectorSpace.C y yv) =>
+ t' -> y' -> t' -> ProcR.T t t' (SigR.T y y' yv) -> IO ExitCode
+toInt16 freqUnit amp sampleRate proc =
+ PlayP.toInt16 freqUnit amp (SigR.run sampleRate proc)
diff --git a/src/Synthesizer/Inference/Reader/Process.hs b/src/Synthesizer/Inference/Reader/Process.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/Inference/Reader/Process.hs
@@ -0,0 +1,110 @@
+{- |
+
+Copyright : (c) Henning Thielemann 2007
+License : GPL
+
+Maintainer : synthesizer@henning-thielemann.de
+Stability : provisional
+Portability : requires multi-parameter type classes (OccasionallyScalar)
+
+
+
+Light-weight sample parameter inference which will fit most needs.
+We only do \"poor man's inference\", only for sample rates.
+The sample rate will be provided in a Reader monad.
+We almost do not need monad functionality
+but only "Control.Applicative" functionality.
+
+In contrast to the run-time inference approach,
+we have the static guarantee that the sample rate is fixed
+before passing a signal to the outside world.
+-}
+module Synthesizer.Inference.Reader.Process (
+ T(..),
+ run, share,
+ injectParam, extractParam, convertTimeParam,
+ loop, pure,
+ ($:), ($::), ($^), ($#),
+ (.:), (.^),
+ liftP, liftP2, liftP3, liftP4,
+ ) where
+
+import Control.Monad.Fix (MonadFix(mfix), )
+import Synthesizer.ApplicativeUtility
+import qualified Control.Applicative as App
+import Control.Applicative (Applicative)
+
+{-
+import NumericPrelude
+import PreludeBase as P
+-}
+
+
+{- |
+This wraps a function which computes a sample rate dependent result.
+Sample rate tells how many values per unit are stored
+for representation of a signal.
+-}
+newtype T t t' a = Cons {process :: t' -> a}
+
+
+instance Functor (T t t') where
+ fmap f x = Cons (f . process x)
+
+instance Applicative (T t t') where
+ pure = pure
+ (<*>) = apply
+
+instance Monad (T t t') where
+ return = pure
+ (>>=) = share
+
+instance MonadFix (T t t') where
+ mfix = loop . injectParam
+
+
+
+run ::
+ t' -> T t t' a -> (t', a)
+run sr (Cons p) = (sr, p sr)
+
+
+{- |
+Re-use a result several times without recomputing.
+With a simple @let@ you can re-use a result
+but it must be recomputed due to the dependency on the sample rate.
+-}
+share ::
+ T t t' a {-^ process that provides a result -}
+ -> (a -> T t t' b) {-^ function that can re-use that result as much as it wants -}
+ -> T t t' b
+share p f = Cons $ \sr ->
+ process (f (process p sr)) sr
+
+
+
+{- |
+This corresponds to 'Control.Applicative.pure'
+-}
+pure :: a -> T t t' a
+pure x = Cons $ const x
+
+apply :: T t t' (a -> b) -> T t t' a -> T t t' b
+apply f proc = Cons $ \sr ->
+ process f sr (process proc sr)
+
+extractParam :: T t t' (a -> b) -> (a -> T t t' b)
+extractParam = ($#)
+
+injectParam :: (a -> T t t' b) -> T t t' (a -> b)
+injectParam f = Cons $ \sr x ->
+ process (f x) sr
+
+{- |
+The first argument will be a function like 'InferenceReader.Signal.toTimeScalar'.
+If you use this function instead of 'InferenceReader.Signal.toTimeScalar' directly,
+the type @t@ can be automatically infered.
+-}
+convertTimeParam :: (t' -> t' -> t) -> t' -> (t -> a) -> T t t' a
+convertTimeParam convert t' f = Cons $ \sr ->
+ f (convert sr t')
diff --git a/src/Synthesizer/Inference/Reader/Signal.hs b/src/Synthesizer/Inference/Reader/Signal.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/Inference/Reader/Signal.hs
@@ -0,0 +1,138 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{- |
+
+Copyright : (c) Henning Thielemann 2007
+License : GPL
+
+Maintainer : synthesizer@henning-thielemann.de
+Stability : provisional
+Portability : requires multi-parameter type classes (OccasionallyScalar)
+-}
+module Synthesizer.Inference.Reader.Signal (
+ T(..),
+ run,
+ addSampleRate,
+ apply,
+ lift,
+ returnCons,
+
+ toTimeScalar,
+ toFrequencyScalar,
+ toAmplitudeScalar,
+ toGradientScalar,
+
+ scalarSamples,
+ vectorSamples,
+
+ ($-),
+ constant,
+ ) where
+
+import Synthesizer.Inference.Reader.Process (($:))
+import qualified Synthesizer.Inference.Reader.Process as Proc
+
+import qualified Synthesizer.SampleRateContext.Rate as Rate
+import qualified Synthesizer.SampleRateContext.Signal as SigC
+import qualified Synthesizer.Physical.Signal as SigP
+
+import Synthesizer.SampleRateContext.Signal (T(Cons, samples, amplitude))
+
+import qualified Algebra.OccasionallyScalar as OccScalar
+import qualified Algebra.Module as Module
+import qualified Algebra.Field as Field
+import qualified Algebra.Ring as Ring
+
+import Algebra.OccasionallyScalar (toScalar)
+
+import NumericPrelude
+import PreludeBase as P
+
+
+
+run ::
+ t' -> Proc.T t t' (T y y' yv) -> SigP.T t t' y y' yv
+run sr proc =
+ uncurry addSampleRate (Proc.run sr proc)
+
+{-
+run ::
+ Rate.T t t' -> Proc.T t t' (T y y' yv) -> SigP.T t t' y y' yv
+run sr proc =
+ uncurry addSampleRate (Proc.run (Rate.toNumber sr) proc)
+-}
+
+addSampleRate ::
+ t' -> T y y' yv -> SigP.T t t' y y' yv
+addSampleRate = SigP.addPlainSampleRate
+
+apply ::
+ (Proc.T t t' (T y0 y0' y0v -> T y1 y1' y1v))
+ -> SigP.T t t' y0 y0' y0v
+ -> SigP.T t t' y1 y1' y1v
+apply proc (SigP.Cons sr sig) =
+ let (sr', f) = Proc.run (Rate.toNumber sr) proc
+ in addSampleRate sr' (f sig)
+
+
+lift :: (Rate.T t t' -> a) -> Proc.T t t' a
+lift f = Proc.Cons $ f . Rate.fromNumber
+
+
+returnCons ::
+ y' -> [yv] -> Proc.T t t' (T y y' yv)
+returnCons amp sig = Proc.pure (Cons amp sig)
+
+{-
+sampleRateExpr :: SigP.T t (Value t') y (Value y') yv -> Expr t'
+sampleRateExpr x = Expr.fromAtom (SigP.sampleRate x)
+
+amplitudeExpr :: SigP.T t (Value t') y (Value y') yv -> Expr y'
+amplitudeExpr x = Expr.fromAtom (SigP.amplitude x)
+-}
+
+toTimeScalar :: (Ring.C t', OccScalar.C t t') =>
+ t' -> t' -> t
+toTimeScalar sampleRate t = toScalar (t * sampleRate)
+
+toFrequencyScalar :: (Field.C t', OccScalar.C t t') =>
+ t' -> t' -> t
+toFrequencyScalar sampleRate f = toScalar (f / sampleRate)
+
+toAmplitudeScalar :: (Field.C y', OccScalar.C y y') =>
+ T y y' yv -> y' -> y
+toAmplitudeScalar sig y =
+ toScalar (y / amplitude sig)
+
+toGradientScalar :: (Field.C q', OccScalar.C q q') =>
+ q' -> q' -> q' -> q
+toGradientScalar amp sampleRate steepness =
+ toFrequencyScalar sampleRate (steepness / amp)
+
+
+scalarSamples :: (Ring.C y) =>
+ (y' -> y) -> T y y' y -> [y]
+scalarSamples toAmpScalar sig =
+ let y = toAmpScalar (amplitude sig)
+ in map (y*) (samples sig)
+
+vectorSamples :: (Module.C y yv) =>
+ (y' -> y) -> T y y' yv -> [yv]
+vectorSamples toAmpScalar sig =
+ let y = toAmpScalar (amplitude sig)
+ in y *> samples sig
+
+
+{- |
+Take a scalar argument where a process expects a signal.
+-}
+($-) :: Ring.C yv =>
+ Proc.T t t' (T y y' yv -> a) -> y' -> Proc.T t t' a
+($-) f x = f $: Proc.pure (constant x)
+
+{-
+Should be in Control module.
+-}
+constant :: Ring.C yv => y' -> T y y' yv
+constant x = Cons x (repeat 1)
diff --git a/src/Synthesizer/Physical.hs b/src/Synthesizer/Physical.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/Physical.hs
@@ -0,0 +1,25 @@
+{- |
+
+Copyright : (c) Henning Thielemann 2006
+License : GPL
+
+Maintainer : synthesizer@henning-thielemann.de
+Stability : provisional
+Portability : requires multi-parameter type classes
+
+
+
+This module is for documentation purposes.
+But the modules below are exported
+in order to let you easily navigate to them.
+-}
+
+
+module Synthesizer.Physical
+ (module Synthesizer.Physical.Signal,
+ module Synthesizer.Physical.Cut,
+ module Synthesizer.Physical.Displacement) where
+
+import Synthesizer.Physical.Signal
+import Synthesizer.Physical.Cut
+import Synthesizer.Physical.Displacement
diff --git a/src/Synthesizer/Physical/Control.hs b/src/Synthesizer/Physical/Control.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/Physical/Control.hs
@@ -0,0 +1,72 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-|
+Control curve generation
+-}
+
+module Synthesizer.Physical.Control where
+
+import qualified Synthesizer.SampleRateContext.Control as CtrlC
+import qualified Synthesizer.Plain.Control as Ctrl
+import qualified Synthesizer.Physical.Signal as SigP
+import Synthesizer.Physical.Signal(toTimeScalar)
+
+import qualified Algebra.OccasionallyScalar as OccScalar
+import qualified Algebra.Module as Module
+import qualified Algebra.Transcendental as Trans
+import qualified Algebra.Real as Real
+import qualified Algebra.Ring as Ring
+
+-- import PreludeBase
+-- import NumericPrelude
+
+
+exponential :: (Trans.C a, Ring.C a', Real.C a', OccScalar.C a a') =>
+ a' {-^ sample rate -}
+ -> a' {-^ time where the function reaches 1\/e of the initial value -}
+ -> a' {-^ initial value -}
+ -> SigP.T a a' a a' a
+ {-^ exponential decay -}
+exponential sampleRate time y0 =
+ SigP.lift0 (CtrlC.exponential time y0) sampleRate
+
+
+exponential2 :: (Trans.C a, Ring.C a', Real.C a', OccScalar.C a a') =>
+ a' {-^ sample rate -}
+ -> a' {-^ half life -}
+ -> a' {-^ initial value -}
+ -> SigP.T a a' a a' a
+ {-^ exponential decay -}
+exponential2 sampleRate halfLife y0 =
+ SigP.lift0 (CtrlC.exponential2 halfLife y0) sampleRate
+
+
+vectorExponential ::
+ (Trans.C t, Ring.C t',
+ OccScalar.C t t', Module.C t yv) =>
+ t' {-^ sample rate -}
+ -> t' {-^ time where the function reaches 1\/e of the initial value -}
+ -> y' {-^ amplitude unit -}
+ -> yv {-^ initial value -}
+ -> SigP.T t t' y y' yv
+ {-^ exponential decay -}
+vectorExponential sampleRate time amplitude y0 =
+ let z = SigP.cons sampleRate amplitude
+ (Ctrl.vectorExponential
+ (toTimeScalar z time) y0)
+ in z
+
+
+vectorExponential2 ::
+ (Trans.C t, Ring.C t',
+ OccScalar.C t t', Module.C t yv) =>
+ t' {-^ sample rate -}
+ -> t' {-^ half life -}
+ -> y' {-^ amplitude unit -}
+ -> yv {-^ initial value -}
+ -> SigP.T t t' y y' yv
+ {-^ exponential decay -}
+vectorExponential2 sampleRate halfLife amplitude y0 =
+ let z = SigP.cons sampleRate amplitude
+ (Ctrl.vectorExponential2
+ (toTimeScalar z halfLife) y0)
+ in z
diff --git a/src/Synthesizer/Physical/Cut.hs b/src/Synthesizer/Physical/Cut.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/Physical/Cut.hs
@@ -0,0 +1,222 @@
+{- |
+Copyright : (c) Henning Thielemann 2006, 2008
+License : GPL
+
+Maintainer : synthesizer@henning-thielemann.de
+Stability : provisional
+Portability : requires multi-parameter type classes
+
+Cut signals
+
+-}
+module Synthesizer.Physical.Cut where
+
+import qualified Synthesizer.SampleRateContext.Cut as CutC
+import qualified Synthesizer.SampleRateContext.Signal as SigC
+import qualified Synthesizer.SampleRateContext.Rate as Rate
+
+import qualified Synthesizer.Physical.Signal as SigP
+
+import qualified Data.EventList.Relative.TimeBody as EventList
+import qualified Numeric.NonNegative.Class as NonNeg
+
+import qualified Algebra.NormedSpace.Maximum as NormedMax
+import qualified Algebra.OccasionallyScalar as OccScalar
+import qualified Algebra.Module as Module
+import qualified Algebra.RealField as RealField
+import qualified Algebra.Field as Field
+import qualified Algebra.Real as Real
+import qualified Algebra.Ring as Ring
+
+import Data.Tuple.HT (mapSnd, )
+
+import PreludeBase (Eq, Ord, Bool, uncurry, (.), (==), flip, fst, error)
+-- import NumericPrelude
+
+import Prelude (RealFrac)
+
+
+{- * Dissection -}
+
+splitAt :: (RealField.C t, Ring.C t', OccScalar.C t t') =>
+ t' -> SigP.T t t' y y' yv -> (SigP.T t t' y y' yv, SigP.T t t' y y' yv)
+splitAt t = SigP.liftR2 (CutC.splitAt t)
+
+take :: (RealField.C t, Ring.C t', OccScalar.C t t') =>
+ t' -> SigP.T t t' y y' yv -> SigP.T t t' y y' yv
+take t = SigP.lift1 (CutC.take t)
+
+drop :: (RealField.C t, Ring.C t', OccScalar.C t t') =>
+ t' -> SigP.T t t' y y' yv -> SigP.T t t' y y' yv
+drop t = SigP.lift1 (CutC.drop t)
+
+
+propSplit :: (Eq t', Eq y', Eq yv,
+ OccScalar.C t t', Ring.C t', RealField.C t) =>
+ t' -> SigP.T t t' y y' yv -> Bool
+propSplit t x = splitAt t x == (take t x, drop t x)
+
+
+takeUntilPause :: (RealField.C t, Ring.C t', OccScalar.C t t',
+ Field.C y', NormedMax.C y yv, OccScalar.C y y') =>
+ y' -> t' -> SigP.T t t' y y' yv -> SigP.T t t' y y' yv
+takeUntilPause y' t' =
+ SigP.lift1 (CutC.takeUntilPause y' t')
+
+
+unzip ::
+ SigP.T t t' y y' (yv0, yv1) -> (SigP.T t t' y y' yv0, SigP.T t t' y y' yv1)
+unzip = SigP.liftR2 CutC.unzip
+
+unzip3 ::
+ SigP.T t t' y y' (yv0, yv1, yv2)
+ -> (SigP.T t t' y y' yv0, SigP.T t t' y y' yv1, SigP.T t t' y y' yv2)
+unzip3 = SigP.liftR3 CutC.unzip3
+
+
+{- * Glueing -}
+
+
+{- |
+ Similar to @foldr1 append@ but more efficient and accurate,
+ because it reduces the number of amplifications.
+ Does not work for infinite lists,
+ because in this case a maximum amplitude cannot be computed.
+-}
+concat :: (Real.C y', Field.C y', Eq t', OccScalar.C y y',
+ Module.C y yv) =>
+ [SigP.T t t' y y' yv]
+ -> SigP.T t t' y y' yv
+concat = SigP.liftList CutC.concat
+
+{- |
+ Like 'concat', but you have to specify the amplitude of the resulting signal.
+ This way we can process infinite lists, too.
+ The list must contain at least one element for getting a sample rate.
+-}
+concatVolume :: (Field.C y', Eq t', OccScalar.C y y',
+ Module.C y yv) =>
+ y'
+ -> [SigP.T t t' y y' yv]
+ -> SigP.T t t' y y' yv
+concatVolume amp = SigP.liftList (CutC.concatVolume amp)
+
+append :: (Eq t', Real.C y', Field.C y', OccScalar.C y y',
+ Module.C y yv) =>
+ SigP.T t t' y y' yv -> SigP.T t t' y y' yv -> SigP.T t t' y y' yv
+append = SigP.lift2 CutC.append
+
+
+propConcatAppend :: (Eq t', Eq y', Eq yv,
+ Module.C y yv, OccScalar.C y y',
+ Ring.C t', RealField.C y') =>
+ SigP.T t t' y y' yv
+ -> SigP.T t t' y y' yv
+ -> Bool
+propConcatAppend x y = append x y == concat [x,y]
+
+
+propAppendSplit :: (Eq t', Eq y', Eq yv,
+ Module.C y yv, OccScalar.C y y',
+ RealField.C y', OccScalar.C t t',
+ Ring.C t', RealField.C t) =>
+ t' -> SigP.T t t' y y' yv -> Bool
+propAppendSplit t x = uncurry append (splitAt t x) == x
+
+
+
+
+zip :: (Eq t', Real.C y', Field.C y', OccScalar.C y y',
+ Module.C y yv0, Module.C y yv1)
+ => SigP.T t t' y y' yv0
+ -> SigP.T t t' y y' yv1
+ -> SigP.T t t' y y' (yv0, yv1)
+zip = SigP.lift2 CutC.zip
+
+
+zip3 :: (Eq t', Real.C y', Field.C y', OccScalar.C y y',
+ Module.C y yv0, Module.C y yv1, Module.C y yv2)
+ => SigP.T t t' y y' yv0
+ -> SigP.T t t' y y' yv1
+ -> SigP.T t t' y y' yv2
+ -> SigP.T t t' y y' (yv0, yv1, yv2)
+zip3 = SigP.lift3 CutC.zip3
+
+
+propZip :: (Eq t', Eq y', Field.C y', Real.C y',
+ Eq yv0, Eq yv1,
+ Module.C y yv1, Module.C y yv0,
+ OccScalar.C y y') =>
+ SigP.T t t' y y' (yv0, yv1) -> Bool
+propZip x = uncurry zip (unzip x) == x
+
+propZip3 :: (Eq t', Eq y', Field.C y', Real.C y',
+ Eq yv0, Eq yv1, Eq yv2,
+ Module.C y yv2, Module.C y yv1, Module.C y yv0,
+ OccScalar.C y y') =>
+ SigP.T t t' y y' (yv0, yv1, yv2) -> Bool
+propZip3 x = (\(a,b,c) -> zip3 a b c) (unzip3 x) == x
+
+
+splitSampleRateEventList :: (Eq t') =>
+ EventList.T time (SigP.T t t' y y' yv)
+ -> (Rate.T t t', EventList.T time (SigC.T y y' yv))
+splitSampleRateEventList xs =
+ case EventList.getBodies xs of
+ [] -> error "splitSampleRateEventList: empty list"
+ (x:_) ->
+ let sr = fst (SigP.splitSampleRate x)
+ in (sr, EventList.mapBody (SigP.checkSampleRate "splitSampleRateEventList" sr) xs)
+
+
+{- |
+ Given a list of signals with time stamps,
+ mix them into one signal as they occur in time.
+ Ideally for composing music.
+ The amplitude of the output is designed for the worst case
+ (all signals coincide).
+ This is usually too pessimistic.
+ Maybe you prefer 'arrangeVolume'.
+
+ Infinite schedules are not supported,
+ because no maximum amplitude can be computed.
+ If you want infinite schedules,
+ then 'arrangeVolume' is your friend, again.
+-}
+arrange ::
+ (RealFrac t, NonNeg.C t, Eq t', Ring.C t, Ring.C t', OccScalar.C t t',
+ Ord y', Field.C y', OccScalar.C y y',
+ Module.C y yv) =>
+ t' {-^ Unit of the time values in the time ordered list. -}
+ -> EventList.T t (SigP.T t t' y y' yv)
+ {-^ A list of pairs: (relative start time, signal part),
+ The start time is relative
+ to the start time of the previous event. -}
+ -> SigP.T t t' y y' yv
+ {-^ The mixed signal. -}
+arrange unit =
+ uncurry SigP.run .
+ mapSnd (flip (CutC.arrange unit)) .
+ splitSampleRateEventList
+
+
+{- |
+ Similar to 'arrange' but allows for infinite schedules.
+ To this end it needs the amplitude of the resulting signal.
+-}
+arrangeVolume ::
+ (RealFrac t, NonNeg.C t, Eq t', Ring.C t, Ring.C t', OccScalar.C t t',
+ Field.C y', OccScalar.C y y',
+ Module.C y yv) =>
+ y' {-^ Amplitude of output. -}
+ -> t' {-^ Unit of the time values in the time ordered list. -}
+ -> EventList.T t (SigP.T t t' y y' yv)
+ {-^ A list of pairs: (relative start time, signal part),
+ The start time is relative
+ to the start time of the previous event. -}
+ -> SigP.T t t' y y' yv
+ {-^ The mixed signal. -}
+arrangeVolume amp unit =
+ uncurry SigP.run .
+ mapSnd (flip (CutC.arrangeVolume amp unit)) .
+ splitSampleRateEventList
diff --git a/src/Synthesizer/Physical/Displacement.hs b/src/Synthesizer/Physical/Displacement.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/Physical/Displacement.hs
@@ -0,0 +1,45 @@
+module Synthesizer.Physical.Displacement where
+
+import qualified Synthesizer.SampleRateContext.Displacement as MiscC
+
+import qualified Synthesizer.Physical.Signal as SigP
+
+import qualified Algebra.OccasionallyScalar as OccScalar
+import qualified Algebra.Module as Module
+-- import qualified Algebra.Transcendental as Trans
+import qualified Algebra.Field as Field
+import qualified Algebra.Real as Real
+-- import qualified Algebra.Ring as Ring
+-- import qualified Algebra.Additive as Additive
+
+-- import Algebra.Module ((*>))
+
+import PreludeBase
+-- import NumericPrelude
+import Prelude ()
+
+
+{- * Mixing -}
+
+{-| Mix two signals.
+ In opposition to 'zipWith' the result has the length of the longer signal. -}
+mix :: (Eq t', Real.C y', Field.C y', Module.C y yv, OccScalar.C y y') =>
+ SigP.T t t' y y' yv
+ -> SigP.T t t' y y' yv
+ -> SigP.T t t' y y' yv
+mix = SigP.lift2 MiscC.mix
+
+{-| Mix one or more signals. -}
+mixMulti :: (Eq t', Real.C y', Field.C y', Module.C y yv, OccScalar.C y y') =>
+ [SigP.T t t' y y' yv]
+ -> SigP.T t t' y y' yv
+mixMulti = SigP.liftList MiscC.mixMulti
+
+{-| Add a number to all of the signal values.
+ This is useful for adjusting the center of a modulation. -}
+raise :: (Eq t', Field.C y', Module.C y yv, OccScalar.C y y') =>
+ y'
+ -> yv
+ -> SigP.T t t' y y' yv
+ -> SigP.T t t' y y' yv
+raise y' yv = SigP.lift1 (MiscC.raise y' yv)
diff --git a/src/Synthesizer/Physical/File.hs b/src/Synthesizer/Physical/File.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/Physical/File.hs
@@ -0,0 +1,28 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+module Synthesizer.Physical.File where
+
+import qualified Synthesizer.Plain.File as File
+import qualified Synthesizer.Basic.Binary as BinSmp
+
+import qualified Synthesizer.Physical.Signal as SigP
+
+import qualified Algebra.OccasionallyScalar as OccScalar
+import qualified Algebra.VectorSpace as VectorSpace
+import qualified Algebra.RealField as RealField
+import qualified Algebra.Field as Field
+
+import System.Exit(ExitCode)
+
+-- import NumericPrelude
+import PreludeBase
+
+
+
+writeToInt16 ::
+ (RealField.C t, BinSmp.C yv,
+ Field.C t', OccScalar.C t t',
+ Field.C y', OccScalar.C y y',
+ VectorSpace.C y yv) =>
+ t' -> y' -> FilePath -> SigP.T t t' y y' yv -> IO ExitCode
+writeToInt16 freqUnit amp name sig =
+ uncurry (File.writeToInt16 name) (SigP.pureData freqUnit amp sig)
diff --git a/src/Synthesizer/Physical/Filter.hs b/src/Synthesizer/Physical/Filter.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/Physical/Filter.hs
@@ -0,0 +1,51 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+module Synthesizer.Physical.Filter where
+
+import qualified Synthesizer.SampleRateContext.Filter as FiltC
+import qualified Synthesizer.Physical.Signal as SigP
+
+import qualified Algebra.OccasionallyScalar as OccScalar
+import qualified Algebra.Module as Module
+-- import qualified Algebra.Transcendental as Trans
+import qualified Algebra.RealField as RealField
+import qualified Algebra.Field as Field
+import qualified Algebra.Ring as Ring
+import qualified Algebra.Additive as Additive
+
+import PreludeBase
+-- import NumericPrelude
+
+
+{- * Amplification -}
+
+amplify :: (Ring.C y') =>
+ y'
+ -> SigP.T t t' y y' yv
+ -> SigP.T t t' y y' yv
+amplify volume = SigP.lift1 (FiltC.amplify volume)
+
+envelope :: (Eq t', Module.C y0 yv, Ring.C y') =>
+ SigP.T t t' y y' y0 {-^ the envelope -}
+ -> SigP.T t t' y y' yv {-^ the signal to be enveloped -}
+ -> SigP.T t t' y y' yv
+envelope = SigP.lift2 FiltC.envelope
+
+
+
+{- * Filter operators from calculus -}
+
+differentiate :: (Additive.C yv, Ring.C a')
+ => SigP.T t a' y a' yv -> SigP.T t a' y a' yv
+differentiate = SigP.lift1 FiltC.differentiate
+
+integrate :: (Additive.C yv, Field.C a')
+ => SigP.T t a' y a' yv -> SigP.T t a' y a' yv
+integrate = SigP.lift1 FiltC.integrate
+
+
+{- * Echo -}
+
+{- | Infinitely many equi-delayed exponentially decaying echos. -}
+comb :: (RealField.C t, Ring.C t', OccScalar.C t t', Module.C y yv) =>
+ t' -> y -> SigP.T t t' y y' yv -> SigP.T t t' y y' yv
+comb time gain = SigP.lift1 (FiltC.comb time gain)
diff --git a/src/Synthesizer/Physical/Noise.hs b/src/Synthesizer/Physical/Noise.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/Physical/Noise.hs
@@ -0,0 +1,27 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+module Synthesizer.Physical.Noise where
+
+import qualified Synthesizer.SampleRateContext.Noise as NoiseC
+-- import qualified Synthesizer.SampleRateContext.Signal as SigC
+
+import qualified Synthesizer.Physical.Signal as SigP
+
+import System.Random (Random)
+
+import qualified Algebra.Algebraic as Algebraic
+import qualified Algebra.Ring as Ring
+
+-- import PreludeBase
+-- import NumericPrelude
+
+
+{- * Noise -}
+
+white :: (Ring.C yv, Random yv, Algebraic.C q') =>
+ q' {-^ sample rate -}
+ -> q' {-^ width of the frequency band -}
+ -> q' {-^ volume caused by the given frequency band -}
+ -> SigP.T t q' y q' yv
+ {-^ noise -}
+white sampleRate bandWidth volume =
+ SigP.lift0 (NoiseC.white bandWidth volume) sampleRate
diff --git a/src/Synthesizer/Physical/Oscillator.hs b/src/Synthesizer/Physical/Oscillator.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/Physical/Oscillator.hs
@@ -0,0 +1,66 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{- |
+Copyright : (c) Henning Thielemann 2006, 2008
+License : GPL
+
+Maintainer : synthesizer@henning-thielemann.de
+Stability : provisional
+Portability : requires multi-parameter type classes
+
+Tone generators
+
+-}
+module Synthesizer.Physical.Oscillator where
+
+import qualified Synthesizer.SampleRateContext.Oscillator as OsciC
+-- import qualified Synthesizer.Plain.Oscillator as Osci
+import qualified Synthesizer.Basic.Wave as Wave
+import qualified Synthesizer.Physical.Signal as SigP
+
+import qualified Algebra.OccasionallyScalar as OccScalar
+import qualified Algebra.Module as Module
+import qualified Algebra.Transcendental as Trans
+import qualified Algebra.RealField as RealField
+import qualified Algebra.Field as Field
+-- import qualified Algebra.Ring as Ring
+
+-- import PreludeBase
+-- import NumericPrelude
+
+
+
+{- * Oscillators with constant waveforms -}
+
+{- | oscillator with a functional waveform with constant frequency -}
+static :: (RealField.C t, Field.C t', OccScalar.C t t')
+ => Wave.T t yv
+ -> (t' -> y' -> t -> t' -> SigP.T t t' y y' yv)
+static wave sampleRate amplitude phase freq =
+ SigP.lift0 (OsciC.static wave amplitude phase freq) sampleRate
+
+{- | oscillator with a functional waveform with modulated frequency -}
+freqMod :: (RealField.C t, Field.C t', OccScalar.C t t')
+ => Wave.T t yv
+ -> (y' -> t -> SigP.T t t' t t' t -> SigP.T t t' y y' yv)
+freqMod wave amplitude phase =
+ SigP.lift1 (OsciC.freqMod wave amplitude phase)
+
+{- | sine oscillator with static frequency -}
+staticSine :: (RealField.C a, Trans.C a, Field.C t', OccScalar.C a t')
+ => t' -> y' -> a -> t' -> SigP.T a t' a y' a
+staticSine = static Wave.sine
+
+{- | sine oscillator with modulated frequency -}
+freqModSine :: (RealField.C a, Trans.C a, Module.C a a, Field.C t', OccScalar.C a t')
+ => y' -> a -> SigP.T a t' a t' a -> SigP.T a t' a y' a
+freqModSine = freqMod Wave.sine
+
+{- | saw tooth oscillator with modulated frequency -}
+staticSaw :: (RealField.C a, Field.C t', OccScalar.C a t')
+ => t' -> y' -> a -> t' -> SigP.T a t' a y' a
+staticSaw = static Wave.saw
+
+{- | saw tooth oscillator with modulated frequency -}
+freqModSaw :: (RealField.C a, Field.C t', Module.C a a, OccScalar.C a t')
+ => y' -> a -> SigP.T a t' a t' a -> SigP.T a t' a y' a
+freqModSaw = freqMod Wave.saw
diff --git a/src/Synthesizer/Physical/Play.hs b/src/Synthesizer/Physical/Play.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/Physical/Play.hs
@@ -0,0 +1,28 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+module Synthesizer.Physical.Play where
+
+import qualified Synthesizer.Plain.Play as Play
+import qualified Synthesizer.Basic.Binary as BinSmp
+
+import qualified Synthesizer.Physical.Signal as SigP
+
+import qualified Algebra.OccasionallyScalar as OccScalar
+import qualified Algebra.VectorSpace as VectorSpace
+import qualified Algebra.RealField as RealField
+import qualified Algebra.Field as Field
+
+import System.Exit(ExitCode)
+
+-- import NumericPrelude
+import PreludeBase
+
+
+
+toInt16 ::
+ (RealField.C t, BinSmp.C yv,
+ Field.C t', OccScalar.C t t',
+ Field.C y', OccScalar.C y y',
+ VectorSpace.C y yv) =>
+ t' -> y' -> SigP.T t t' y y' yv -> IO ExitCode
+toInt16 freqUnit amp sig =
+ uncurry Play.toInt16 (SigP.pureData freqUnit amp sig)
diff --git a/src/Synthesizer/Physical/Signal.hs b/src/Synthesizer/Physical/Signal.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/Physical/Signal.hs
@@ -0,0 +1,337 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-|
+Copyright : (c) Henning Thielemann 2006, 2008
+License : GPL
+
+Maintainer : synthesizer@henning-thielemann.de
+Stability : provisional
+Portability : requires multi-parameter type classes
+
+ This module equips a list of values
+ with a sampling rate and an amplitude.
+ Since sampling rate and amplitude need not to be of the same type
+ and need not to be of the type of the values
+ one can choose physical quantities for sampling rate and amplitude
+ but low level types like Double and Float for the values.
+ The only thing we need is the conversion to scalar types
+ provided by the 'Algebra.OccasionallyScalar.C' type class.
+ This conversion may fail in which case we encountered a unit error.
+ We can also use this module with plain number types.
+ Then toScalar cannot fail.
+
+ The conversion to scalars is very general
+ and might support applications I can currently not imagine.
+-}
+
+module Synthesizer.Physical.Signal where
+
+import qualified Synthesizer.SampleRateContext.Signal as SigC
+import qualified Synthesizer.SampleRateContext.Rate as Rate
+
+import qualified Algebra.OccasionallyScalar as OccScalar
+import qualified Algebra.VectorSpace as VectorSpace
+import qualified Algebra.Module as Module
+import qualified Algebra.Field as Field
+import qualified Algebra.Ring as Ring
+
+import Algebra.OccasionallyScalar(toScalar)
+import Algebra.Module((*>))
+
+import Data.Tuple.HT (mapSnd, )
+import Synthesizer.Utility (common, )
+
+import PreludeBase
+import NumericPrelude
+
+{-| t and y are plain number types,
+ t' and y' may be physical quantities.
+ yv may be a vector type.
+ It should hold:
+ @(OccScalar.C t t',
+ OccScalar.C y y',
+ Module.C y yv)@
+ There are no values of type t and type y in T
+ but they are essential to computation of intermediate results.
+-}
+data T t t' y y' yv =
+ Cons {
+ fullSampleRate :: Rate.T t t'
+ {-^ how many values per unit are stored -}
+ , content :: SigC.T y y' yv
+ {-^ the signal with a unit-equipped volume -}
+ }
+ deriving (Eq, Show)
+
+{- | Construct a signal. -}
+cons ::
+ t' {- ^ sampling rate, must be positive (unchecked) -}
+ -> y' {- ^ amplitude, must be positive (unchecked) -}
+ -> [yv] {- ^ samples, values should be between -1 and 1 (unchecked) -}
+ -> T t t' y y' yv
+cons sr amp ss =
+ Cons (Rate.fromNumber sr) (SigC.Cons amp ss)
+
+sampleRate :: T t t' y y' yv -> t'
+sampleRate = Rate.toNumber . fullSampleRate
+
+amplitude :: T t t' y y' yv -> y'
+amplitude = SigC.amplitude . content
+
+samples :: T t t' y y' yv -> [yv]
+samples = SigC.samples . content
+
+{- |
+Replace sample rate and amplitude
+with different representations of their values.
+This is needed for internal purposes,
+especially for preserving the phantom types.
+Do not use it for arbitrary changes of sample rate or amplitude!
+-}
+replaceParameters :: t1' -> y1' -> T t t0' y y0' yv -> T t t1' y y1' yv
+replaceParameters sr amp (Cons _ (SigC.Cons _ ss)) = cons sr amp ss
+
+replaceSampleRate :: t1' -> T t t0' y y' yv -> T t t1' y y' yv
+replaceSampleRate sr (Cons _ sig) = Cons (Rate.fromNumber sr) sig
+
+replaceAmplitude :: y1' -> T t t' y y0' yv -> T t t' y y1' yv
+replaceAmplitude amp (Cons sr sig) =
+ Cons sr (SigC.replaceAmplitude amp sig)
+
+replaceSamples :: [yv1] -> T t t' y y' yv0 -> T t t' y y' yv1
+replaceSamples ss (Cons sr sig) =
+ Cons sr (SigC.replaceSamples ss sig)
+
+
+{- |
+Assert a condition before shipping the first sample.
+-}
+assert :: String -> Bool -> T t t' y y' yv -> T t t' y y' yv
+assert msg cond x =
+ replaceSamples (if cond then samples x else error msg) x
+
+{- |
+Assert that the amplitude of the signal matches the given one.
+Otherwise give an error when the first sample is fetched.
+-}
+assertAmplitude :: Eq y' => y' -> T t t' y y' yv -> T t t' y y' yv
+assertAmplitude amp x =
+ replaceSamples
+ (if amp == amplitude x
+ then samples x
+ else error "assertAmplitude: amplitudes differ") x
+
+{- |
+Assert that the sample rate of the signal matches the given one.
+-}
+assertSampleRate :: Eq t' => t' -> T t t' y y' yv -> T t t' y y' yv
+assertSampleRate sr0 (Cons sr sig) =
+ Cons sr $
+ if sr0 == Rate.toNumber sr
+ then sig
+ else error "assertSampleRate: sample rates differ"
+
+{- | Fix the type of a value to the scalar time type of a signal. -}
+asTypeOfTime ::
+ t {- ^ time value, of with a type to be fixed -}
+ -> T t t' y y' yv
+ {- ^ signal, whose time type shall be matched -}
+ -> t {- ^ the time value, again -}
+asTypeOfTime = const
+
+{- | Fix the type of a value to the scalar amplitude type of a signal. -}
+asTypeOfAmplitude :: y -> T t t' y y' yv -> y
+asTypeOfAmplitude = const
+
+{- | Express a time value as a multiple of the sampling period.
+ The multiplicity is returned.
+ It is a checked error,
+ if the units of time value and sampling period mismatch. -}
+toTimeScalar :: (Ring.C t', OccScalar.C t t') =>
+ T t t' y y' yv -> t' -> t
+toTimeScalar x t =
+ toScalar (t * sampleRate x) `asTypeOfTime` x
+
+{- | Express a frequency value as a multiple of the sampling frequency.
+ The multiplicity is returned.
+ In many applications the multiplicity is below 1.
+ It is a checked error,
+ if the units of frequency value and sampling frequency mismatch. -}
+toFrequencyScalar :: (Field.C t', OccScalar.C t t') =>
+ T t t' y y' yv -> t' -> t
+toFrequencyScalar x f =
+ toScalar (f / sampleRate x) `asTypeOfTime` x
+
+{- | Express an amplitude value as a multiple of the signal amplitude.
+ The multiplicity is returned.
+ It is a checked error,
+ if the units of amplitude value and signal amplitude mismatch. -}
+toAmplitudeScalar :: (Field.C y', OccScalar.C y y') =>
+ T t t' y y' yv -> y' -> y
+toAmplitudeScalar x y =
+ toScalar (y / amplitude x) `asTypeOfAmplitude` x
+
+{-| If all signals share the same sampleRate, then return it,
+ otherwise raise an error. -}
+commonSampleRate :: (Eq t') =>
+ T t t' y0 y'0 yv0 -> T t t' y1 y'1 yv1 -> t'
+commonSampleRate x y =
+ commonSampleRate' (sampleRate x) (sampleRate y)
+ -- "The sample rates "++show sr0++" and "++show sr1++" differ."
+
+commonSampleRate' :: (Eq a) => a -> a -> a
+commonSampleRate' x y =
+ common "The sample rates differ." x y
+
+{- | Extract data for further processing that is not aware of physical units,
+ such as playing and creating files. -}
+pureData :: (Field.C t', OccScalar.C t t',
+ Field.C y', OccScalar.C y y',
+ VectorSpace.C y yv) =>
+ t' {- ^ The unit of the sampling frequency, say 'Number.SI.hertz' -}
+ -> y' {- ^ The maximum expected value.
+ The data is normalized to this value,
+ in order to preserve that all output samples
+ are at most 1 in magnitude. -}
+ -> T t t' y y' yv
+ {- ^ The input signal. -}
+ -> (t, [yv])
+ {- ^ The sampling frequency without unit and
+ the list of normalized samples.
+ This information should suffice for playback
+ or writing the signal to a file. -}
+pureData freqUnit amp sig =
+ (toTimeScalar sig (recip freqUnit),
+ recip (toAmplitudeScalar sig amp) *> samples sig)
+
+
+instance Functor (T t t' y y') where
+ fmap f (Cons sr sig) = Cons sr (fmap f sig)
+
+
+
+{- * Conversion from and to signals with sample rate context -}
+
+
+runPlain ::
+ t' -> (Rate.T t t' -> SigC.T y y' yv) -> T t t' y y' yv
+runPlain sr f =
+ addPlainSampleRate sr (f (Rate.fromNumber sr))
+
+addPlainSampleRate ::
+ t' -> SigC.T y y' yv -> T t t' y y' yv
+addPlainSampleRate sr = Cons (Rate.fromNumber sr)
+
+run ::
+ Rate.T t t' -> (Rate.T t t' -> SigC.T y y' yv) -> T t t' y y' yv
+run sr f =
+ addSampleRate sr (f sr)
+
+addSampleRate ::
+ Rate.T t t' -> SigC.T y y' yv -> T t t' y y' yv
+addSampleRate = Cons
+
+splitSampleRate ::
+ T t t' y y' yv -> (Rate.T t t', SigC.T y y' yv)
+splitSampleRate (Cons sr sig) = (sr, sig)
+
+{- |
+If the given sample rate matches the one of the signal,
+then return the core signal, otherwise 'undefined'.
+-}
+checkSampleRate :: (Eq t') =>
+ String ->
+ Rate.T t t' ->
+ T t t' y y' yv -> SigC.T y y' yv
+checkSampleRate funcName sr0 (Cons sr sig) =
+ if sr0 == sr
+ then sig
+ else error ("checkSampleRate for " ++ funcName ++ ": sample rates differ")
+
+splitSampleRateList :: (Eq t') =>
+ [T t t' y y' yv] -> (Rate.T t t', [SigC.T y y' yv])
+splitSampleRateList [] = error "splitSampleRateList: empty list"
+splitSampleRateList xt@(x:_) =
+ let sr = fst (splitSampleRate x)
+ in (sr, map (checkSampleRate "splitSampleRateList" sr) xt)
+
+
+apply ::
+ (Rate.T t t' -> SigC.T y0 y'0 y0v -> SigC.T y1 y'1 y1v)
+ -> T t t' y0 y'0 y0v
+ -> T t t' y1 y'1 y1v
+apply f (Cons sr sig) =
+ run sr (flip f sig)
+
+
+{-
+commonSampleRate :: (Eq t') =>
+ T t t' y0 y'0 yv0 -> T t t' y1 y'1 yv1 -> Rate.T t t'
+commonSampleRate x0 x1 = Rate.fromNumber (SigP.commonSampleRate x0 x1)
+-}
+
+
+lift0 ::
+ (Rate.T t t' -> SigC.T y y' yv)
+ -> t' -> T t t' y y' yv
+lift0 = flip runPlain
+
+lift1 ::
+ (Rate.T t t' -> SigC.T y0 y0' yv0 -> SigC.T y1 y1' yv1)
+ -> (T t t' y0 y0' yv0 -> T t t' y1 y1' yv1)
+lift1 = apply
+
+lift2 :: (Eq t') =>
+ (Rate.T t t' -> SigC.T y0 y'0 yv0 -> SigC.T y1 y'1 yv1 -> SigC.T y2 y'2 yv2)
+ -> (T t t' y0 y'0 yv0 -> T t t' y1 y'1 yv1 -> T t t' y2 y'2 yv2)
+lift2 f x0 x1 =
+ let (_, y0) = splitSampleRate x0
+ (_, y1) = splitSampleRate x1
+ in runPlain (commonSampleRate x0 x1) (\sr -> f sr y0 y1)
+{-
+ let (sr0, y0) = splitSampleRate x0
+ (sr1, y1) = splitSampleRate x1
+ sr = SigP.commonSampleRate' sr0 sr1
+ in addSampleRate sr (f sr y0 y1)
+-}
+
+lift3 :: (Eq t') =>
+ (Rate.T t t' -> SigC.T y0 y'0 yv0 -> SigC.T y1 y'1 yv1 -> SigC.T y2 y'2 yv2 -> SigC.T y3 y'3 yv3)
+ -> (T t t' y0 y'0 yv0 -> T t t' y1 y'1 yv1 -> T t t' y2 y'2 yv2 -> T t t' y3 y'3 yv3)
+lift3 f x0 x1 x2 =
+ let (sr0, y0) = splitSampleRate x0
+ (sr1, y1) = splitSampleRate x1
+ (sr2, y2) = splitSampleRate x2
+ in run
+ (sr0 `commonSampleRate'` sr1 `commonSampleRate'` sr2)
+ (\sr -> f sr y0 y1 y2)
+
+
+liftList :: Eq t' =>
+ (Rate.T t t' -> [SigC.T y1 y'1 yv1] -> SigC.T y y' yv)
+ -> ([T t t' y1 y'1 yv1] -> T t t' y y' yv)
+liftList f =
+ uncurry run .
+ mapSnd (flip f) .
+ splitSampleRateList
+
+
+
+liftR2 ::
+ (Rate.T t t' -> SigC.T y y' yv -> (SigC.T y0 y'0 yv0, SigC.T y1 y'1 yv1))
+ -> T t t' y y' yv
+ -> (T t t' y0 y'0 yv0, T t t' y1 y'1 yv1)
+liftR2 f x0 =
+ let (sr,x1) = splitSampleRate x0
+ (y0,y1) = f sr x1
+ in (addSampleRate sr y0, addSampleRate sr y1)
+
+liftR3 ::
+ (Rate.T t t' -> SigC.T y y' yv -> (SigC.T y0 y'0 yv0, SigC.T y1 y'1 yv1, SigC.T y2 y'2 yv2))
+ -> T t t' y y' yv
+ -> (T t t' y0 y'0 yv0, T t t' y1 y'1 yv1, T t t' y2 y'2 yv2)
+liftR3 f x0 =
+ let (sr,x1) = splitSampleRate x0
+ (y0,y1,y2) = f sr x1
+ in (addSampleRate sr y0, addSampleRate sr y1, addSampleRate sr y2)
+
+
diff --git a/src/Synthesizer/SampleRateContext/Control.hs b/src/Synthesizer/SampleRateContext/Control.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/SampleRateContext/Control.hs
@@ -0,0 +1,202 @@
+{- |
+Copyright : (c) Henning Thielemann 2008
+License : GPL
+
+Maintainer : synthesizer@henning-thielemann.de
+Stability : provisional
+Portability : requires multi-parameter type classes
+
+
+Control curves which can be used
+as envelopes, for controlling filter parameters and so on.
+-}
+module Synthesizer.SampleRateContext.Control
+ ({- * Primitives -}
+ constant, constantVector, linear, line, exponential, exponential2,
+ {- * Piecewise -}
+ piecewise, piecewiseVolume, Control(..), ControlPiece(..),
+ (-|#), ( #|-), (=|#), ( #|=), (|#), ( #|), -- spaces before # for Haddock
+ {- * Preparation -}
+ mapLinear, mapExponential, )
+ where
+
+import Synthesizer.Plain.Control
+ (Control(..), ControlPiece(..), (-|#), ( #|-), (=|#), ( #|=), (|#), ( #|))
+
+import qualified Synthesizer.Amplitude.Control as CtrlV
+import qualified Synthesizer.Plain.Control as Ctrl
+
+import qualified Synthesizer.SampleRateContext.Signal as SigC
+import qualified Synthesizer.SampleRateContext.Rate as Rate
+import Synthesizer.SampleRateContext.Signal
+ (toTimeScalar, toAmplitudeScalar, toGradientScalar)
+
+import qualified Algebra.OccasionallyScalar as OccScalar
+import qualified Algebra.Module as Module
+import qualified Algebra.Transcendental as Trans
+import qualified Algebra.RealField as RealField
+import qualified Algebra.Field as Field
+import qualified Algebra.Real as Real
+import qualified Algebra.Ring as Ring
+import qualified Algebra.Additive as Additive
+
+import NumericPrelude
+import PreludeBase as P
+import Prelude ()
+
+
+constant :: (Field.C y', Real.C y', OccScalar.C y y') =>
+ y' {-^ value -}
+ -> Rate.T t t' -> SigC.T y y' y
+constant y = Rate.pure $ CtrlV.constant y
+
+{- |
+The amplitude must be positive!
+This is not checked.
+-}
+constantVector :: -- (Field.C y', Real.C y', OccScalar.C y y') =>
+ y' {-^ amplitude -}
+ -> yv {-^ value -}
+ -> Rate.T t t' -> SigC.T y y' yv
+constantVector y yv = Rate.pure $ CtrlV.constantVector y yv
+
+{- Using the 'Ctrl.linear' instead of 'Ctrl.linearStable'
+ the type class constraints would be weaker.
+linear :: (Additive.C y, Field.C y', Real.C y', OccScalar.C y y') =>
+-}
+
+{- |
+Caution: This control curve can contain samples
+with an absolute value greater than 1.
+
+Linear curves starting with zero are impossible.
+Maybe you prefer using 'line'.
+-}
+linear ::
+ (Additive.C q, Field.C q',
+ Real.C q', OccScalar.C q q') =>
+ q' {-^ slope of the curve -}
+ -> q' {-^ initial value -}
+ -> Rate.T q q' -> SigC.T q q' q
+linear slope y0 sr =
+ let amp = abs y0
+ steep = toGradientScalar amp sr slope
+ in SigC.Cons amp
+ (Ctrl.linearMultiscale steep (OccScalar.toScalar (signum y0)))
+
+{- |
+Generates a finite ramp.
+-}
+line ::
+ (RealField.C q, Field.C q',
+ Real.C q', OccScalar.C q q') =>
+ q' {-^ duration of the ramp -}
+ -> (q',q') {-^ initial and final value -}
+ -> Rate.T q q' -> SigC.T q q' q
+line dur' (y0',y1') sr =
+ let amp = max (abs y0') (abs y1')
+ dur = toTimeScalar sr dur'
+ y0 = toAmplitudeScalar z y0'
+ y1 = toAmplitudeScalar z y1'
+ z = SigC.Cons amp
+ (take (floor dur)
+ (Ctrl.linearMultiscale ((y1-y0)/dur) y0))
+ in z
+
+exponential :: (Trans.C q, Ring.C q', Real.C q', OccScalar.C q q') =>
+ q' {-^ time where the function reaches 1\/e of the initial value -}
+ -> q' {-^ initial value -}
+ -> Rate.T q q' -> SigC.T q q' q
+exponential time y0 sr =
+ SigC.Cons (abs y0)
+ (Ctrl.exponentialMultiscale
+ (toTimeScalar sr time) (OccScalar.toScalar (signum y0)))
+
+{-
+ take 1000 $ show (run (fixSampleRate 100 (exponential 0.1 1)) :: SigDouble)
+-}
+
+exponential2 :: (Trans.C q, Ring.C q', Real.C q', OccScalar.C q q') =>
+ q' {-^ half life, time where the function reaches 1\/2 of the initial value -}
+ -> q' {-^ initial value -}
+ -> Rate.T q q' -> SigC.T q q' q
+exponential2 time y0 sr =
+ SigC.Cons (abs y0)
+ (Ctrl.exponential2Multiscale
+ (toTimeScalar sr time) (OccScalar.toScalar (signum y0)))
+
+
+
+{- |
+Since this function looks for the maximum node value,
+and since the signal parameter inference phase must be completed before signal processing,
+infinite descriptions cannot be used here.
+-}
+piecewise :: (Trans.C q, RealField.C q,
+ Real.C q', Field.C q', OccScalar.C q q') =>
+ [ControlPiece q']
+ -> Rate.T q q' -> SigC.T q q' q
+piecewise cs =
+ let amplitude = maximum
+ (map (\c -> max (abs (Ctrl.pieceY0 c))
+ (abs (Ctrl.pieceY1 c))) cs)
+ in piecewiseVolume cs amplitude
+
+
+piecewiseVolume ::
+ (Trans.C q, RealField.C q,
+ Real.C q', Field.C q', OccScalar.C q q') =>
+ [ControlPiece q']
+ -> q'
+ -> Rate.T q q' -> SigC.T q q' q
+piecewiseVolume cs amplitude sr =
+ let ps = map (\(Ctrl.ControlPiece typ y0 y1 d) ->
+ Ctrl.ControlPiece
+ {- We cannot provide an default case like "_ -> typ",
+ because the returned constructors
+ have different parameter type. -}
+ (case typ of
+ CtrlStep -> CtrlStep
+ CtrlLin -> CtrlLin
+ -- this may exceed value range (-1,1)
+ CtrlCubic d0 d1 ->
+ CtrlCubic
+ (toGradientScalar amplitude sr d0)
+ (toGradientScalar amplitude sr d1)
+ CtrlExp sat ->
+ CtrlExp
+ (toAmplitudeScalar z sat)
+ CtrlCos -> CtrlCos)
+ (toAmplitudeScalar z y0)
+ (toAmplitudeScalar z y1)
+ (toTimeScalar sr d)) cs
+ z = SigC.Cons amplitude (Ctrl.piecewise ps)
+ in z
+
+
+
+{- |
+Map a control curve without amplitude unit
+by a linear (affine) function with a unit.
+-}
+mapLinear :: (Ring.C y, Field.C y', Real.C y', OccScalar.C y y') =>
+ y' {- ^ range: one is mapped to @center+range@ -}
+ -> y' {- ^ center: zero is mapped to @center@ -}
+ -> Rate.T t t'
+ -> SigC.T y y' y
+ -> SigC.T y y' y
+mapLinear range center =
+ Rate.pure $ CtrlV.mapLinear range center
+
+{- |
+Map a control curve without amplitude unit
+exponentially to one with a unit.
+-}
+mapExponential :: (Field.C y', Trans.C y, Module.C y y') =>
+ y {- ^ range: one is mapped to @center*range@, must be positive -}
+ -> y' {- ^ center: zero is mapped to @center@ -}
+ -> Rate.T t t'
+ -> SigC.T y y y
+ -> SigC.T y y' y
+mapExponential range center =
+ Rate.pure $ CtrlV.mapExponential range center
diff --git a/src/Synthesizer/SampleRateContext/Cut.hs b/src/Synthesizer/SampleRateContext/Cut.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/SampleRateContext/Cut.hs
@@ -0,0 +1,214 @@
+{- |
+Copyright : (c) Henning Thielemann 2008
+License : GPL
+
+Maintainer : synthesizer@henning-thielemann.de
+Stability : provisional
+Portability : requires multi-parameter type classes
+-}
+module Synthesizer.SampleRateContext.Cut (
+ {- * dissection -}
+ splitAt,
+ take,
+ drop,
+ takeUntilPause,
+ unzip,
+ unzip3,
+
+ {- * glueing -}
+ concat, concatVolume,
+ append, appendVolume,
+ zip, zipVolume,
+ zip3, zip3Volume,
+ arrange, arrangeVolume,
+ ) where
+
+import qualified Synthesizer.Amplitude.Cut as CutV
+import qualified Synthesizer.Plain.Cut as CutS
+
+import qualified Synthesizer.SampleRateContext.Signal as SigC
+import qualified Synthesizer.SampleRateContext.Rate as Rate
+-- import Synthesizer.SampleRateContext.Rate (($#))
+import Synthesizer.SampleRateContext.Signal
+ (toTimeScalar, toAmplitudeScalar)
+
+import qualified Data.EventList.Relative.TimeBody as EventList
+import qualified Numeric.NonNegative.Class as NonNeg
+
+import qualified Algebra.NormedSpace.Maximum as NormedMax
+import qualified Algebra.OccasionallyScalar as OccScalar
+import qualified Algebra.Module as Module
+import qualified Algebra.RealField as RealField
+import qualified Algebra.Field as Field
+import qualified Algebra.Ring as Ring
+
+import qualified Data.List as List
+
+import PreludeBase ((.), ($), Ord, (<=), map, fst, snd)
+-- import NumericPrelude
+import Prelude (RealFrac)
+
+
+{- * dissection -}
+
+splitAt :: (RealField.C t, Ring.C t', OccScalar.C t t') =>
+ t' -> Rate.T t t' -> SigC.T y y' yv -> (SigC.T y y' yv, SigC.T y y' yv)
+splitAt t' sr x =
+ let (ss0,ss1) = List.splitAt (RealField.round (toTimeScalar sr t')) (SigC.samples x)
+ in (SigC.replaceSamples ss0 x,
+ SigC.replaceSamples ss1 x)
+
+take :: (RealField.C t, Ring.C t', OccScalar.C t t') =>
+ t' -> Rate.T t t' -> SigC.T y y' yv -> SigC.T y y' yv
+take t sr = fst . splitAt t sr
+
+drop :: (RealField.C t, Ring.C t', OccScalar.C t t') =>
+ t' -> Rate.T t t' -> SigC.T y y' yv -> SigC.T y y' yv
+drop t sr = snd . splitAt t sr
+
+takeUntilPause ::
+ (RealField.C t, Ring.C t', OccScalar.C t t',
+ Field.C y', NormedMax.C y yv, OccScalar.C y y') =>
+ y' -> t' -> Rate.T t t' -> SigC.T y y' yv -> SigC.T y y' yv
+takeUntilPause y' t' sr x =
+ let t = toTimeScalar sr t'
+ y = toAmplitudeScalar x y'
+ in SigC.replaceSamples
+ (CutS.takeUntilInterval ((<=y) . NormedMax.norm)
+ (RealField.ceiling t) (SigC.samples x)) x
+
+
+unzip ::
+ Rate.T t t' ->
+ SigC.T y y' (yv0, yv1) ->
+ (SigC.T y y' yv0, SigC.T y y' yv1)
+unzip = Rate.pure CutV.unzip
+
+unzip3 ::
+ Rate.T t t' ->
+ SigC.T y y' (yv0, yv1, yv2) ->
+ (SigC.T y y' yv0, SigC.T y y' yv1, SigC.T y y' yv2)
+unzip3 = Rate.pure CutV.unzip3
+
+
+
+{- * glueing -}
+
+{- |
+Similar to @foldr1 append@ but more efficient and accurate,
+because it reduces the number of amplifications.
+Does not work for infinite lists,
+because no maximum amplitude can be computed.
+-}
+concat ::
+ (Ord y', Field.C y', OccScalar.C y y',
+ Module.C y yv) =>
+ Rate.T t t' -> [SigC.T y y' yv] -> SigC.T y y' yv
+concat = Rate.pure $ CutV.concat
+
+{- |
+Give the output volume explicitly.
+Does also work for infinite lists.
+-}
+concatVolume ::
+ (Field.C y', OccScalar.C y y',
+ Module.C y yv) =>
+ y' -> Rate.T t t' -> [SigC.T y y' yv] -> SigC.T y y' yv
+concatVolume amp = Rate.pure $ CutV.concatVolume amp
+
+
+append ::
+ (Ord y', Field.C y', OccScalar.C y y',
+ Module.C y yv) =>
+ Rate.T t t' -> SigC.T y y' yv -> SigC.T y y' yv -> SigC.T y y' yv
+append = Rate.pure $ CutV.append
+
+appendVolume ::
+ (Field.C y', OccScalar.C y y',
+ Module.C y yv) =>
+ y' ->
+ Rate.T t t' -> SigC.T y y' yv -> SigC.T y y' yv -> SigC.T y y' yv
+appendVolume amp = Rate.pure $ CutV.appendVolume amp
+
+
+zip ::
+ (Ord y', Field.C y', OccScalar.C y y',
+ Module.C y yv0, Module.C y yv1) =>
+ Rate.T t t' -> SigC.T y y' yv0 -> SigC.T y y' yv1 -> SigC.T y y' (yv0,yv1)
+zip = Rate.pure $ CutV.zip
+
+zipVolume ::
+ (Field.C y', OccScalar.C y y',
+ Module.C y yv0, Module.C y yv1) =>
+ y' ->
+ Rate.T t t' -> SigC.T y y' yv0 -> SigC.T y y' yv1 -> SigC.T y y' (yv0,yv1)
+zipVolume amp = Rate.pure $ CutV.zipVolume amp
+
+
+
+zip3 ::
+ (Ord y', Field.C y', OccScalar.C y y',
+ Module.C y yv0, Module.C y yv1, Module.C y yv2) =>
+ Rate.T t t' -> SigC.T y y' yv0 -> SigC.T y y' yv1 -> SigC.T y y' yv2 ->
+ SigC.T y y' (yv0,yv1,yv2)
+zip3 = Rate.pure $ CutV.zip3
+
+zip3Volume ::
+ (Field.C y', OccScalar.C y y',
+ Module.C y yv0, Module.C y yv1, Module.C y yv2) =>
+ y' ->
+ Rate.T t t' -> SigC.T y y' yv0 -> SigC.T y y' yv1 -> SigC.T y y' yv2 ->
+ SigC.T y y' (yv0,yv1,yv2)
+zip3Volume amp = Rate.pure $ CutV.zip3Volume amp
+
+
+{- |
+Uses maximum input volume as output volume.
+-}
+arrange ::
+ (Ring.C t', OccScalar.C t t',
+ RealFrac t, NonNeg.C t,
+ Ord y', Field.C y', OccScalar.C y y',
+ Module.C y yv) =>
+ t' {-^ Unit of the time values in the time ordered list. -}
+ -> Rate.T t t'
+ -> EventList.T t (SigC.T y y' yv)
+ {- ^ A list of pairs: (relative start time, signal part),
+ The start time is relative
+ to the start time of the previous event. -}
+ -> SigC.T y y' yv
+ {- ^ The mixed signal. -}
+arrange unit' sr sched =
+ let amp = List.maximum (map SigC.amplitude (EventList.getBodies sched))
+ in arrangeVolume amp unit' sr sched
+
+
+{- |
+Given a list of signals with time stamps,
+mix them into one signal as they occur in time.
+Ideally for composing music.
+Infinite schedules are not supported.
+Does not work for infinite lists,
+because no maximum amplitude can be computed.
+-}
+arrangeVolume ::
+ (Ring.C t', OccScalar.C t t',
+ RealFrac t, NonNeg.C t,
+ Field.C y', OccScalar.C y y',
+ Module.C y yv) =>
+ y' {-^ Output volume. -}
+ -> t' {-^ Unit of the time values in the time ordered list. -}
+ -> Rate.T t t'
+ -> EventList.T t (SigC.T y y' yv)
+ {- ^ A list of pairs: (relative start time, signal part),
+ The start time is relative
+ to the start time of the previous event. -}
+ -> SigC.T y y' yv
+ {- ^ The mixed signal. -}
+arrangeVolume amp unit' sr sched' =
+ let unit = toTimeScalar sr unit'
+ sched =
+ EventList.mapBody (SigC.vectorSamples (toAmplitudeScalar z)) sched'
+ z = SigC.Cons amp
+ (CutS.arrange (EventList.resample unit sched))
+ in z
diff --git a/src/Synthesizer/SampleRateContext/Displacement.hs b/src/Synthesizer/SampleRateContext/Displacement.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/SampleRateContext/Displacement.hs
@@ -0,0 +1,83 @@
+{- |
+Copyright : (c) Henning Thielemann 2008
+License : GPL
+
+Maintainer : synthesizer@henning-thielemann.de
+Stability : provisional
+Portability : requires multi-parameter type classes
+-}
+module Synthesizer.SampleRateContext.Displacement (
+ mix, mixVolume,
+ mixMulti, mixMultiVolume,
+ raise,
+ ) where
+
+import qualified Synthesizer.Amplitude.Displacement as MiscV
+
+import qualified Synthesizer.SampleRateContext.Signal as SigC
+import qualified Synthesizer.SampleRateContext.Rate as Rate
+
+-- import Synthesizer.SampleRateContext.Signal (toAmplitudeScalar)
+
+-- import qualified Synthesizer
+
+import qualified Algebra.OccasionallyScalar as OccScalar
+import qualified Algebra.Module as Module
+-- import qualified Algebra.Transcendental as Trans
+import qualified Algebra.Field as Field
+import qualified Algebra.Real as Real
+-- import qualified Algebra.Ring as Ring
+-- import qualified Algebra.Additive as Additive
+
+-- import Algebra.Module ((*>))
+
+import PreludeBase
+-- import NumericPrelude
+import Prelude ()
+
+
+{- * Mixing -}
+
+{-| Mix two signals.
+ In opposition to 'zipWith' the result has the length of the longer signal. -}
+mix :: (Real.C y', Field.C y', Module.C y yv, OccScalar.C y y') =>
+ Rate.T t t'
+ -> SigC.T y y' yv
+ -> SigC.T y y' yv
+ -> SigC.T y y' yv
+mix = Rate.pure MiscV.mix
+
+mixVolume ::
+ (Real.C y', Field.C y', Module.C y yv, OccScalar.C y y') =>
+ y'
+ -> Rate.T t t'
+ -> SigC.T y y' yv
+ -> SigC.T y y' yv
+ -> SigC.T y y' yv
+mixVolume v = Rate.pure $ MiscV.mixVolume v
+
+{-| Mix one or more signals. -}
+mixMulti ::
+ (Real.C y', Field.C y', Module.C y yv, OccScalar.C y y') =>
+ Rate.T t t'
+ -> [SigC.T y y' yv]
+ -> SigC.T y y' yv
+mixMulti = Rate.pure MiscV.mixMulti
+
+mixMultiVolume ::
+ (Real.C y', Field.C y', Module.C y yv, OccScalar.C y y') =>
+ y'
+ -> Rate.T t t'
+ -> [SigC.T y y' yv]
+ -> SigC.T y y' yv
+mixMultiVolume v = Rate.pure $ MiscV.mixMultiVolume v
+
+{-| Add a number to all of the signal values.
+ This is useful for adjusting the center of a modulation. -}
+raise :: (Field.C y', Module.C y yv, OccScalar.C y y') =>
+ y'
+ -> yv
+ -> Rate.T t t'
+ -> SigC.T y y' yv
+ -> SigC.T y y' yv
+raise y' yv = Rate.pure $ MiscV.raise y' yv
diff --git a/src/Synthesizer/SampleRateContext/Filter.hs b/src/Synthesizer/SampleRateContext/Filter.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/SampleRateContext/Filter.hs
@@ -0,0 +1,345 @@
+{- |
+Copyright : (c) Henning Thielemann 2008
+License : GPL
+
+Maintainer : synthesizer@henning-thielemann.de
+Stability : provisional
+Portability : requires multi-parameter type classes
+-}
+module Synthesizer.SampleRateContext.Filter (
+ {- * Non-recursive -}
+
+ {- ** Amplification -}
+ amplify,
+ negate,
+ envelope,
+ {- ** Filter operators from calculus -}
+ differentiate,
+
+{-
+ {- ** Smooth -}
+ mean,
+
+ {- ** Delay -}
+ delay,
+ phaseModulation,
+ phaser,
+ phaserStereo,
+
+
+ {- * Recursive -}
+
+ {- ** Without resonance -}
+ firstOrderLowpass,
+ firstOrderHighpass,
+ butterworthLowpass,
+ butterworthHighpass,
+ chebyshevALowpass,
+ chebyshevAHighpass,
+ chebyshevBLowpass,
+ chebyshevBHighpass,
+ {- ** With resonance -}
+ universal,
+ moogLowpass,
+ {- ** Allpass -}
+ allpassCascade,
+-}
+ {- ** Reverb -}
+ comb,
+
+ {- ** Filter operators from calculus -}
+ integrate,
+) where
+
+
+import qualified Synthesizer.Amplitude.Filter as FiltV
+import qualified Synthesizer.SampleRateContext.Signal as SigC
+import qualified Synthesizer.SampleRateContext.Rate as Rate
+
+import Synthesizer.SampleRateContext.Signal
+ (toTimeScalar, {- toFrequencyScalar, -} )
+
+-- import qualified Synthesizer.Plain.Displacement as Syn
+-- import qualified Synthesizer.Plain.Filter.Recursive as FiltR
+import qualified Synthesizer.Plain.Filter.Recursive.Comb as Comb
+import qualified Synthesizer.Plain.Filter.Recursive.Integration as Integrate
+import qualified Synthesizer.Plain.Filter.NonRecursive as FiltNR
+{-
+import qualified Synthesizer.Plain.Interpolation as Interpolation
+import qualified Synthesizer.Plain.Filter.Delay.Block as Delay
+
+import Data.Ord.HT (limit, )
+-}
+
+import qualified Algebra.OccasionallyScalar as OccScalar
+-- import qualified Algebra.Transcendental as Trans
+import qualified Algebra.RealField as RealField
+import qualified Algebra.Field as Field
+-- import qualified Algebra.Real as Real
+import qualified Algebra.Ring as Ring
+import qualified Algebra.Additive as Additive
+import qualified Algebra.Module as Module
+-- import qualified Algebra.VectorSpace as VectorSpace
+
+-- import Control.Monad(liftM2)
+
+import NumericPrelude hiding (negate)
+import PreludeBase as P
+import Prelude ()
+
+
+{- | The amplification factor must be positive. -}
+amplify :: (Ring.C y') =>
+ y'
+ -> Rate.T t t'
+ -> SigC.T y y' yv
+ -> SigC.T y y' yv
+amplify volume = Rate.pure $ FiltV.amplify volume
+
+negate :: (Additive.C yv) =>
+ Rate.T t t'
+ -> SigC.T y y' yv
+ -> SigC.T y y' yv
+negate = Rate.pure FiltV.negate
+
+envelope :: (Module.C y0 yv, Ring.C y') =>
+ Rate.T t t'
+ -> SigC.T y y' y0 {- the envelope -}
+ -> SigC.T y y' yv {- the signal to be enveloped -}
+ -> SigC.T y y' yv
+envelope = Rate.pure FiltV.envelope
+
+
+
+differentiate :: (Additive.C v, Ring.C q') =>
+ Rate.T t q'
+ -> SigC.T y q' v
+ -> SigC.T y q' v
+differentiate sr x =
+ SigC.Cons
+ (SigC.amplitude x * Rate.toNumber sr)
+ (FiltNR.differentiate (SigC.samples x))
+
+
+{-
+{- | needs a good handling of boundaries, yet -}
+mean :: (Additive.C yv, Field.C y', RealField.C a,
+ Module.C a v, OccScalar.C a q) =>
+ q {- ^ time length of the window -}
+ -> SigC.T y y' yv
+ -> Rate.T t t' -> (SigC.T y y' yv)
+mean time x =
+ do t <- toTimeScalar x (Expr.constant time)
+ let tInt = round ((t-1)/2)
+ let width = tInt*2+1
+ returnModified []
+ ((SigP.asTypeOfAmplitude (recip (fromIntegral width)) x *> ) .
+ Filt.sums width . FiltNR.delay tInt) x
+
+
+delay :: (Additive.C yv, Field.C y', RealField.C a, OccScalar.C a q) =>
+ q
+ -> SigC.T y y' yv
+ -> Rate.T t t' -> (SigC.T y y' yv)
+delay time x =
+ do t <- toTimeScalar x (Expr.constant time)
+ returnModified [] (FiltNR.delay (round t)) x
+
+
+phaseModulation ::
+ (Additive.C yv, Field.C y', RealField.C a, OccScalar.C a q) =>
+ Interpolation.T a v
+ -> q {- ^ minDelay, minimal delay, may be negative -}
+ -> q {- ^ maxDelay, maximal delay, it must be @minDelay <= maxDelay@
+ and the modulation must always be
+ in the range [minDelay,maxDelay]. -}
+ -> SigI.T a q a
+ {- ^ delay control, positive numbers mean delay,
+ negative numbers mean prefetch -}
+ -> SigC.T y y' yv
+ -> Rate.T t t' -> (SigC.T y y' yv)
+phaseModulation ip minDelay maxDelay delays x =
+ do t0 <- toTimeScalar x (Expr.constant minDelay)
+ t1 <- toTimeScalar x (Expr.constant maxDelay)
+ let tInt0 = floor t0
+ let tInt1 = ceiling t1
+ let tInt0Neg = Additive.negate tInt0
+ ds <- SigI.scalarSamples (toTimeScalar delays) delays
+ returnModified [SigP.sampleRate delays]
+ (FiltNR.delay tInt0 .
+ Delay.modulated ip (tInt1-tInt0+1)
+ (FiltNR.delay tInt0Neg
+ (Syn.raise (fromIntegral tInt0Neg)
+ (map (clip t0 t1) ds)))) x
+
+
+{- | symmetric phaser -}
+phaser :: (Additive.C yv, Field.C y', RealField.C a,
+ Module.C a v, OccScalar.C a q) =>
+ Interpolation.T a v
+ -> q {- ^ maxDelay, must be positive -}
+ -> SigI.T a q a
+ {- ^ delay control -}
+ -> SigC.T y y' yv
+ -> Rate.T t t' -> (SigC.T y y' yv)
+phaser ip maxDelay delays x =
+ amplify (asTypeOf 0.5 maxDelay) =<<
+ uncurry SynI.mix =<< phaserCore ip maxDelay delays x
+
+phaserStereo :: (Additive.C yv, Field.C y', Real.C q, RealField.C a,
+ Module.C a v, OccScalar.C a q) =>
+ Interpolation.T a v
+ -> q {- ^ maxDelay, must be positive -}
+ -> SigI.T a q a
+ {- ^ delay control -}
+ -> SigC.T y y' yv
+ -> SigI.Process a q (v,v)
+phaserStereo ip maxDelay delays x =
+ uncurry CutI.zip =<< phaserCore ip maxDelay delays x
+
+phaserCore :: (Additive.C yv, Field.C y', RealField.C a,
+ Module.C a v, OccScalar.C a q) =>
+ Interpolation.T a v
+ -> q {- ^ maxDelay, must be positive -}
+ -> SigI.T a q a
+ {- ^ delay control -}
+ -> SigC.T y y' yv
+ -> Process.T q (SigC.T y y' yv, SigC.T y y' yv)
+phaserCore ip maxDelay delays x =
+ do let minDelay = Additive.negate maxDelay
+ negDelays <- Inference.Signal.Filter.negate delays
+ liftM2 (,)
+ (phaseModulation ip minDelay maxDelay delays x)
+ (phaseModulation ip minDelay maxDelay negDelays x)
+
+
+
+firstOrderLowpass, firstOrderHighpass ::
+ (Trans.C a, Trans.C q, Module.C a v, OccScalar.C a q) =>
+ SigI.T a q a {- ^ Control signal for the cut-off frequency. -}
+ -> SigC.T y y' yv {- ^ Input signal -}
+ -> Rate.T t t' -> (SigC.T y y' yv)
+firstOrderLowpass = firstOrderGen Filt1.lowpass
+firstOrderHighpass = firstOrderGen Filt1.highpass
+
+firstOrderGen :: (Trans.C a, Trans.C q, Module.C a v, OccScalar.C a q) =>
+ ([a] -> [v] -> [v])
+ -> SigI.T a q a
+ -> SigC.T y y' yv
+ -> Rate.T t t' -> (SigC.T y y' yv)
+firstOrderGen filt freq x =
+ do freqs <- SigI.scalarSamples (toFrequencyScalar x) freq
+ returnModified [SigP.sampleRate freq]
+ (filt (map Filt1.parameter freqs)) x
+
+
+butterworthLowpass, butterworthHighpass,
+ chebyshevALowpass, chebyshevAHighpass,
+ chebyshevBLowpass, chebyshevBHighpass ::
+ (Field.C y', Trans.C a, VectorSpace.C a v, OccScalar.C a q) =>
+ Int {- ^ Order of the filter, must be even,
+ the higher the order, the sharper is the separation of frequencies. -}
+ -> a {- ^ The attenuation at the cut-off frequency.
+ Should be between 0 and 1. -}
+ -> SigI.T a q a {- ^ Control signal for the cut-off frequency. -}
+ -> SigC.T y y' yv {- ^ Input signal -}
+ -> Rate.T t t' -> (SigC.T y y' yv)
+
+butterworthLowpass = higherOrderNoResoGen Butter.lowpass
+butterworthHighpass = higherOrderNoResoGen FiltR.butterworthHighpass
+chebyshevALowpass = higherOrderNoResoGen FiltR.chebyshevALowpass
+chebyshevAHighpass = higherOrderNoResoGen FiltR.chebyshevAHighpass
+chebyshevBLowpass = higherOrderNoResoGen FiltR.chebyshevBLowpass
+chebyshevBHighpass = higherOrderNoResoGen FiltR.chebyshevBHighpass
+
+higherOrderNoResoGen ::
+ (Field.C y', Ring.C a, OccScalar.C a q) =>
+ (Int -> a -> [a] -> [v] -> [v])
+ -> Int
+ -> a
+ -> SigI.T a q a
+ -> SigC.T y y' yv
+ -> Rate.T t t' -> (SigC.T y y' yv)
+higherOrderNoResoGen filt order ratio freq x =
+ do freqs <- SigI.scalarSamples (toFrequencyScalar x) freq
+ returnModified [SigP.sampleRate freq]
+ (filt order ratio freqs) x
+
+
+
+universal :: (Trans.C a, Module.C a v, Field.C y', OccScalar.C a q) =>
+ SigI.T a q a {- ^ signal for resonance,
+ i.e. factor of amplification at the resonance frequency
+ relatively to the transition band. -}
+ -> SigI.T a q a {- ^ signal for cut off and band center frequency -}
+ -> SigC.T y y' yv {- ^ input signal -}
+ -> SigI.Process a q (v,v,v) {- ^ highpass, bandpass, lowpass filter -}
+universal reso freq x =
+ do resos <- SigI.scalarSamples (Process.exprToScalar) reso
+ freqs <- SigI.scalarSamples (toFrequencyScalar x) freq
+ let params =
+ map FiltR.uniFilterParam
+ (zipWith FiltR.Pole resos freqs)
+ returnModified [SigP.sampleRate reso, SigP.sampleRate freq]
+ (FiltR.uniFilter params) x
+
+moogLowpass :: (Trans.C a, Module.C a v, Field.C y', OccScalar.C a q) =>
+ Int
+ -> SigI.T a q a {- ^ signal for resonance,
+ i.e. factor of amplification at the resonance frequency
+ relatively to the transition band. -}
+ -> SigI.T a q a {- ^ signal for cut off and band center frequency -}
+ -> SigC.T y y' yv
+ -> Rate.T t t' -> (SigC.T y y' yv)
+moogLowpass order reso freq x =
+ do resos <- SigI.scalarSamples (Process.exprToScalar) reso
+ freqs <- SigI.scalarSamples (toFrequencyScalar x) freq
+ let params =
+ map (Moog.parameter order)
+ (zipWith FiltR.Pole resos freqs)
+ returnModified [SigP.sampleRate reso, SigP.sampleRate freq]
+ (Moog.lowpass order params) x
+
+allpassCascade :: (Trans.C a, Module.C a v, Field.C y', OccScalar.C a q) =>
+ Int {- ^ order, number of filters in the cascade -}
+ -> a {- ^ the phase shift to be achieved for the given frequency -}
+ -> SigI.T a q a {- ^ lowest comb frequency -}
+ -> SigC.T y y' yv
+ -> Rate.T t t' -> (SigC.T y y' yv)
+allpassCascade order phase freq x =
+ do freqs <- SigI.scalarSamples (toFrequencyScalar x) freq
+ let params = map (FiltR.allpassCascadeParam order phase) freqs
+ returnModified [SigP.sampleRate freq]
+ (FiltR.allpassCascade order params) x
+-}
+
+
+
+{- | Infinitely many equi-delayed exponentially decaying echos. -}
+comb :: (RealField.C t, Ring.C t', OccScalar.C t t', Module.C y yv) =>
+ t' -> y -> Rate.T t t' -> SigC.T y y' yv -> SigC.T y y' yv
+comb time gain sr x =
+ SigC.Cons (SigC.amplitude x)
+ (Comb.run (round (toTimeScalar sr time)) gain (SigC.samples x))
+
+
+integrate :: (Additive.C v, Field.C q') =>
+ Rate.T t q'
+ -> SigC.T y q' v
+ -> SigC.T y q' v
+integrate sr x =
+ SigC.Cons
+ (SigC.amplitude x / Rate.toNumber sr)
+ (Integrate.run (SigC.samples x))
+
+
+{-
+returnModified :: (Eq q) =>
+ [Process.Value q] -> ([v] -> [w]) -> SigC.T y y' yv -> SigI.Process a q w
+returnModified sampleRates proc x =
+ do let sampleRate = SigP.sampleRate x
+ mapM_ (Process.equalValue sampleRate) sampleRates
+ SigI.returnCons
+ sampleRate (SigP.amplitude x)
+ (proc (SigP.samples x))
+-}
diff --git a/src/Synthesizer/SampleRateContext/Noise.hs b/src/Synthesizer/SampleRateContext/Noise.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/SampleRateContext/Noise.hs
@@ -0,0 +1,137 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{- |
+Copyright : (c) Henning Thielemann 2008
+License : GPL
+
+Maintainer : synthesizer@henning-thielemann.de
+Stability : provisional
+Portability : requires multi-parameter type classes
+
+-}
+module Synthesizer.SampleRateContext.Noise
+ (white, whiteBandEnergy, randomPeeks,
+ whiteGen, whiteBandEnergyGen, randomPeeksGen,
+ ) where
+
+
+import qualified Synthesizer.Plain.Noise as Noise
+
+import qualified Synthesizer.SampleRateContext.Signal as SigC
+import qualified Synthesizer.SampleRateContext.Rate as Rate
+
+import qualified Algebra.OccasionallyScalar as OccScalar
+import qualified Algebra.Algebraic as Algebraic
+import qualified Algebra.Field as Field
+import qualified Algebra.Ring as Ring
+
+import System.Random (Random, RandomGen, randomRs, mkStdGen)
+
+import NumericPrelude
+import PreludeBase as P
+
+
+
+{- |
+Uniformly distributed white noise.
+The volume is given by two values:
+The width of a frequency band and the volume caused by it.
+The width of a frequency band must be given
+in order to achieve independence from sample rate.
+
+See 'whiteBandEnergy'.
+-}
+white :: (Ring.C yv, Random yv, Algebraic.C q') =>
+ q' {-^ width of the frequency band -}
+ -> q' {-^ volume caused by the given frequency band -}
+ -> Rate.T t q' -> SigC.T y q' yv
+ {-^ noise -}
+white = whiteGen (mkStdGen 6746)
+
+whiteGen :: (Ring.C yv, Random yv, RandomGen g, Algebraic.C q') =>
+ g {-^ random generator, can be used to choose a seed -}
+ -> q' {-^ width of the frequency band -}
+ -> q' {-^ volume caused by the given frequency band -}
+ -> Rate.T t q' -> SigC.T y q' yv
+ {-^ noise -}
+whiteGen gen bandWidth volume sr =
+ SigC.Cons
+ (sqrt (3 * bandWidth / Rate.toNumber sr) * volume)
+ (Noise.whiteGen gen)
+
+
+{-|
+Uniformly distributed white noise.
+Instead of an amplitude you must specify a value
+that is like an energy per frequency band.
+It makes no sense to specify an amplitude
+because if you keep the same signal amplitude
+while increasing the sample rate by a factor of four
+the amplitude of the frequency spectrum halves.
+Thus deep frequencies would be damped
+when higher frequencies enter.
+
+Example:
+If your signal is a function from time to voltage,
+the amplitude must have the unit @volt^2*second@,
+which can be also viewed as @volt^2\/hertz@.
+
+Note that the energy is proportional to the square of the signal amplitude.
+In order to double the noise amplitude,
+you must increase the energy by a factor of four.
+
+Using this notion of amplitude
+the behaviour amongst several frequency filters
+is quite consistent but a problem remains:
+When the noise is quantised
+then noise at low sample rates and noise at high sample rates
+behave considerably different.
+This indicates that quantisation should not just pick values,
+but it should average over the hold periods.
+-}
+whiteBandEnergy :: (Ring.C yv, Random yv, Algebraic.C q') =>
+ q' {-^ energy per frequency band -}
+ -> Rate.T t q' -> SigC.T y q' yv
+ {-^ noise -}
+whiteBandEnergy = whiteBandEnergyGen (mkStdGen 6746)
+
+whiteBandEnergyGen :: (Ring.C yv, Random yv, RandomGen g, Algebraic.C q') =>
+ g {-^ random generator, can be used to choose a seed -}
+ -> q' {-^ energy per frequency band -}
+ -> Rate.T t q' -> SigC.T y q' yv
+ {-^ noise -}
+whiteBandEnergyGen gen energy sr =
+ SigC.Cons (sqrt (3 * Rate.toNumber sr * energy)) (Noise.whiteGen gen)
+
+
+{-
+The Field.C q constraint could be lifted to Ring.C
+if we would use direct division instead of toFrequencyScalar.
+-}
+randomPeeks ::
+ (Field.C q, Random q, Ord q,
+ Field.C q', OccScalar.C q q') =>
+ Rate.T q q'
+ -> SigC.T q q' q {- ^ momentary densities (frequency),
+ @p@ means that there is about one peak
+ in the time range of @1\/p@. -}
+ -> [Bool]
+ {- ^ Every occurence of 'True' represents a peak. -}
+randomPeeks =
+ randomPeeksGen (mkStdGen 876)
+
+randomPeeksGen ::
+ (Field.C q, Random q, Ord q,
+ Field.C q', OccScalar.C q q',
+ RandomGen g) =>
+ g {-^ random generator, can be used to choose a seed -}
+ -> Rate.T q q'
+ -> SigC.T q q' q {- ^ momentary densities (frequency),
+ @p@ means that there is about one peak
+ in the time range of @1\/p@. -}
+ -> [Bool]
+ {- ^ Every occurence of 'True' represents a peak. -}
+randomPeeksGen g sr dens =
+ let amp = SigC.toFrequencyScalar sr (SigC.amplitude dens)
+ in zipWith (<)
+ (randomRs (0, recip amp) g)
+ (SigC.samples dens)
diff --git a/src/Synthesizer/SampleRateContext/Oscillator.hs b/src/Synthesizer/SampleRateContext/Oscillator.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/SampleRateContext/Oscillator.hs
@@ -0,0 +1,89 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{- |
+Copyright : (c) Henning Thielemann 2008
+License : GPL
+
+Maintainer : synthesizer@henning-thielemann.de
+Stability : provisional
+Portability : requires multi-parameter type classes
+
+-}
+module Synthesizer.SampleRateContext.Oscillator (
+ {- * Oscillators with constant waveforms -}
+ static,
+ freqMod,
+ phaseMod,
+ phaseFreqMod,
+) where
+
+import qualified Synthesizer.Plain.Oscillator as Osci
+import qualified Synthesizer.Basic.Wave as Wave
+-- import qualified Synthesizer.Basic.Phase as Phase
+
+import qualified Synthesizer.SampleRateContext.Signal as SigC
+import qualified Synthesizer.SampleRateContext.Rate as Rate
+import Synthesizer.SampleRateContext.Signal (toFrequencyScalar)
+
+import qualified Algebra.OccasionallyScalar as OccScalar
+import qualified Algebra.RealField as RealField
+import qualified Algebra.Field as Field
+
+-- import NumericPrelude
+import PreludeBase as P
+
+
+{- * Oscillators with constant waveforms -}
+
+{- | oscillator with a functional waveform with constant frequency -}
+static :: (RealField.C t, Field.C t', OccScalar.C t t') =>
+ Wave.T t yv {- ^ waveform -}
+ -> y' {- ^ amplitude -}
+ -> t {- ^ start phase from the range [0,1] -}
+ -> t' {- ^ frequency -}
+ -> Rate.T t t'
+ -> SigC.T y y' yv
+static wave amplitude phase freq' sr =
+ let freq = toFrequencyScalar sr freq'
+ in SigC.Cons amplitude (Osci.static wave phase freq)
+
+{- | oscillator with a functional waveform with modulated frequency -}
+freqMod :: (RealField.C t, Field.C t', OccScalar.C t t') =>
+ Wave.T t yv {- ^ waveform -}
+ -> y' {- ^ amplitude -}
+ -> t {- ^ start phase from the range [0,1] -}
+ -> Rate.T t t'
+ -> SigC.T t t' t {- ^ frequency control -}
+ -> SigC.T y y' yv
+freqMod wave amplitude phase sr xs =
+ let freqs = SigC.scalarSamples (toFrequencyScalar sr) xs
+ in SigC.Cons amplitude
+ (Osci.freqMod wave phase freqs)
+
+{- | oscillator with modulated phase -}
+phaseMod :: (RealField.C t, Field.C t', OccScalar.C t t') =>
+ Wave.T t yv {- ^ waveform -}
+ -> y' {- ^ amplitude -}
+ -> t' {- ^ frequency control -}
+ -> Rate.T t t'
+ -> SigC.T t t t {- ^ phase modulation, phases must have no unit and
+ are from range [0,1] -}
+ -> SigC.T y y' yv
+phaseMod wave amplitude freq' sr xs =
+ let freq = toFrequencyScalar sr freq'
+ phases = SigC.scalarSamples id xs
+ in SigC.Cons amplitude
+ (Osci.phaseMod wave freq phases)
+
+{- | oscillator with a functional waveform with modulated phase and frequency -}
+phaseFreqMod :: (RealField.C t, Field.C t', OccScalar.C t t') =>
+ Wave.T t yv {- ^ waveform -}
+ -> y' {- ^ amplitude -}
+ -> Rate.T t t'
+ -> SigC.T t t t {- ^ phase control -}
+ -> SigC.T t t' t {- ^ frequency control -}
+ -> SigC.T y y' yv
+phaseFreqMod wave amplitude sr xs ys =
+ let phases = SigC.scalarSamples id xs
+ freqs = SigC.scalarSamples (toFrequencyScalar sr) ys
+ in SigC.Cons amplitude
+ (Osci.phaseFreqMod wave phases freqs)
diff --git a/src/Synthesizer/SampleRateContext/Play.hs b/src/Synthesizer/SampleRateContext/Play.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/SampleRateContext/Play.hs
@@ -0,0 +1,25 @@
+module Synthesizer.SampleRateContext.Play where
+
+import qualified Synthesizer.Basic.Binary as BinSmp
+
+import qualified Synthesizer.SampleRateContext.Signal as SigC
+import qualified Synthesizer.SampleRateContext.Rate as Rate
+import qualified Synthesizer.Physical.Signal as SigP
+import qualified Synthesizer.Physical.Play as PlayP
+
+import qualified Algebra.OccasionallyScalar as OccScalar
+import qualified Algebra.VectorSpace as VectorSpace
+import qualified Algebra.RealField as RealField
+import qualified Algebra.Field as Field
+
+import System.Exit(ExitCode)
+
+
+toInt16 ::
+ (RealField.C t, BinSmp.C yv,
+ Field.C t', OccScalar.C t t',
+ Field.C y', OccScalar.C y y',
+ VectorSpace.C y yv) =>
+ t' -> y' -> t' -> (Rate.T t t' -> SigC.T y y' yv) -> IO ExitCode
+toInt16 freqUnit amp sampleRate proc =
+ PlayP.toInt16 freqUnit amp (SigP.runPlain sampleRate proc)
diff --git a/src/Synthesizer/SampleRateContext/Rate.hs b/src/Synthesizer/SampleRateContext/Rate.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/SampleRateContext/Rate.hs
@@ -0,0 +1,68 @@
+{- |
+
+Copyright : (c) Henning Thielemann 2008
+License : GPL
+
+Maintainer : synthesizer@henning-thielemann.de
+Stability : provisional
+Portability : requires multi-parameter type classes (OccasionallyScalar)
+
+
+
+Light-weight sample parameter inference which will fit most needs.
+We only do \"poor man's inference\", only for sample rates.
+The sample rate will be provided as an argument of a special type 'T'.
+This argument will almost never be passed explicitly
+but handled operators analogous to '($)' and '(.)'.
+
+In contrast to the run-time inference approach,
+we have the static guarantee that the sample rate is fixed
+before passing a signal to the outside world.
+-}
+module Synthesizer.SampleRateContext.Rate (
+ T(..),
+ fromNumber, toNumber,
+ loop, pure,
+ ($:), ($::), ($^), ($#),
+ (.:), (.^),
+ liftP, liftP2, liftP3, liftP4,
+ ) where
+
+import Synthesizer.ApplicativeUtility
+
+{-
+import NumericPrelude
+import PreludeBase as P
+-}
+
+
+{- |
+This wraps a function which computes a sample rate dependent result.
+Sample rate tells how many values per unit are stored
+for representation of a signal.
+-}
+newtype T t t' = Cons {decons :: t'}
+ deriving (Eq, Ord, Show)
+
+
+fromNumber :: t' -> T t t'
+fromNumber = Cons
+
+toNumber :: T t t' -> t'
+toNumber = decons
+
+
+pure :: a -> T t t' -> a
+pure = const
+
+
+{-
+{- |
+The first argument will be a function like 'Synthesizer.SampleRateContext.Signal.toTimeScalar'.
+If you use this function instead of 'Synthesizer.SampleRateContext.Signal.toTimeScalar' directly,
+the type @t@ can be automatically infered.
+-}
+convertTimeParam :: (t' -> t' -> t) -> t' -> (t -> a) -> T t t' -> a
+convertTimeParam convert t' f = Cons $ \sr ->
+ f (convert sr t')
+-}
diff --git a/src/Synthesizer/SampleRateContext/Signal.hs b/src/Synthesizer/SampleRateContext/Signal.hs
new file mode 100644
--- /dev/null
+++ b/src/Synthesizer/SampleRateContext/Signal.hs
@@ -0,0 +1,72 @@
+{- |
+Copyright : (c) Henning Thielemann 2008
+License : GPL
+
+Maintainer : synthesizer@henning-thielemann.de
+Stability : provisional
+Portability : requires multi-parameter type classes (OccasionallyScalar)
+
+For a description see "Synthesizer.SampleRateContext.Rate".
+-}
+module Synthesizer.SampleRateContext.Signal (
+ T(..),
+ toTimeScalar,
+ toFrequencyScalar,
+ toAmplitudeScalar,
+ toGradientScalar,
+ scalarSamples,
+ vectorSamples,
+ replaceAmplitude,
+ replaceSamples,
+ ($-),
+ ) where
+
+import Synthesizer.SampleRateContext.Rate (($:))
+import qualified Synthesizer.SampleRateContext.Rate as Rate
+
+import Synthesizer.Amplitude.Signal
+import qualified Synthesizer.Amplitude.Control as CtrlV
+
+import qualified Algebra.OccasionallyScalar as OccScalar
+-- import qualified Algebra.Module as Module
+import qualified Algebra.Field as Field
+import qualified Algebra.Real as Real
+import qualified Algebra.Ring as Ring
+
+import Algebra.OccasionallyScalar (toScalar)
+
+import NumericPrelude
+-- import PreludeBase as P
+import Prelude ()
+
+
+{-
+returnCons ::
+ y' -> [yv] -> Rate t t' (T y y' yv)
+returnCons amp sig = Proc.pure (Cons amp sig)
+-}
+
+
+toTimeScalar :: (Ring.C t', OccScalar.C t t') =>
+ Rate.T t t' -> t' -> t
+toTimeScalar sampleRate t =
+ toScalar (t * Rate.toNumber sampleRate)
+
+toFrequencyScalar :: (Field.C t', OccScalar.C t t') =>
+ Rate.T t t' -> t' -> t
+toFrequencyScalar sampleRate f =
+ toScalar (f / Rate.toNumber sampleRate)
+
+toGradientScalar :: (Field.C q', OccScalar.C q q') =>
+ q' -> Rate.T q q' -> q' -> q
+toGradientScalar amp sampleRate steepness =
+ toFrequencyScalar sampleRate (steepness / amp)
+
+
+{- |
+Take a scalar argument where a process expects a signal.
+Only possible for non-negative values so far.
+-}
+($-) :: (Field.C y', Real.C y', OccScalar.C y y') =>
+ (Rate.T t t' -> T y y' y -> a) -> y' -> (Rate.T t t' -> a)
+($-) f x = f $: Rate.pure (CtrlV.constant x)
diff --git a/synthesizer-inference.cabal b/synthesizer-inference.cabal
new file mode 100644
--- /dev/null
+++ b/synthesizer-inference.cabal
@@ -0,0 +1,141 @@
+Name: synthesizer-inference
+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 dynamic physical dimensions
+Description:
+ High-level functions which use physical units.
+ We try to abstract from the sample rate using various approaches.
+ The modules are a bit outdated however,
+ and I think that the package @synthesizer-dimensional@
+ provides the better design.
+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 category
+ description: Check whether Arrow class is split into Arrow and Category.
+
+Flag optimizeAdvanced
+ description: Enable advanced optimizations. They slow down compilation considerably.
+ default: True
+
+Flag buildProfilers
+ description: Build executables for investigating efficiency of code
+ default: False
+
+Flag buildTests
+ description: Build test suite
+ default: False
+
+Flag buildExamples
+ description: Build example executables
+ default: False
+
+
+Source-Repository this
+ Tag: 0.2
+ Type: darcs
+ Location: http://code.haskell.org/synthesizer/inference/
+
+Source-Repository head
+ Type: darcs
+ Location: http://code.haskell.org/synthesizer/inference/
+
+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,
+ -- UniqueLogicNP is needed for InferenceFix
+ UniqueLogicNP >= 0.2 && <0.3,
+ numeric-prelude >=0.1.1 && <0.2,
+ utility-ht >=0.0.5 && <0.1
+
+ If flag(splitBase)
+ Build-Depends:
+ base >= 3 && <5,
+ random >=1.0 && <2.0
+ Else
+ Build-Depends:
+ base >= 1.0 && < 2,
+ special-functors >= 1.0 && <1.1
+
+ GHC-Options: -Wall
+ Hs-source-dirs: src
+ Exposed-modules:
+ Synthesizer.Physical
+ Synthesizer.Physical.Cut
+ Synthesizer.Physical.Control
+ Synthesizer.Physical.File
+ Synthesizer.Physical.Filter
+ Synthesizer.Physical.Noise
+ Synthesizer.Physical.Oscillator
+ Synthesizer.Physical.Play
+ Synthesizer.Physical.Signal
+ Synthesizer.Physical.Displacement
+ Synthesizer.Amplitude.Signal
+ Synthesizer.Amplitude.Cut
+ Synthesizer.Amplitude.Control
+ Synthesizer.Amplitude.Filter
+ Synthesizer.Amplitude.Displacement
+ Synthesizer.SampleRateContext.Rate
+ Synthesizer.SampleRateContext.Signal
+ Synthesizer.SampleRateContext.Oscillator
+ Synthesizer.SampleRateContext.Cut
+ Synthesizer.SampleRateContext.Control
+ Synthesizer.SampleRateContext.Filter
+ Synthesizer.SampleRateContext.Displacement
+ Synthesizer.SampleRateContext.Noise
+ Synthesizer.SampleRateContext.Play
+ Synthesizer.Inference.Fix
+ Synthesizer.Inference.Fix.Cut
+ Synthesizer.Inference.Fix.Filter
+ Synthesizer.Inference.Func.Cut
+ Synthesizer.Inference.Func.Signal
+ Synthesizer.Inference.Monad.File
+ Synthesizer.Inference.Monad.Play
+ Synthesizer.Inference.Monad.Signal
+ Synthesizer.Inference.Monad.Signal.Control
+ Synthesizer.Inference.Monad.Signal.Cut
+ Synthesizer.Inference.Monad.Signal.Filter
+ Synthesizer.Inference.Monad.Signal.Noise
+ Synthesizer.Inference.Monad.Signal.Oscillator
+ Synthesizer.Inference.Monad.Signal.Displacement
+ Synthesizer.Inference.Monad.SignalSeq
+ Synthesizer.Inference.Monad.SignalSeq.Control
+ Synthesizer.Inference.Monad.SignalSeq.Cut
+ Synthesizer.Inference.Monad.SignalSeq.Filter
+ Synthesizer.Inference.Monad.SignalSeq.Noise
+ Synthesizer.Inference.Monad.SignalSeq.Oscillator
+ Synthesizer.Inference.Monad.SignalSeq.Displacement
+ Synthesizer.Inference.Reader.Play
+ Synthesizer.Inference.Reader.Process
+ Synthesizer.Inference.Reader.Signal
+ Synthesizer.Inference.Reader.Control
+ Synthesizer.Inference.Reader.Cut
+ Synthesizer.Inference.Reader.Filter
+ Synthesizer.Inference.Reader.Noise
+ Synthesizer.Inference.Reader.Oscillator
+
+-- Other-Modules:
+
+
+Executable alinea
+ If !flag(buildExamples)
+ Buildable: False
+ GHC-Options: -Wall
+ Hs-Source-Dirs: alinea, src
+ Main-Is: Alinea.hs