From 9290d7ca26479fe27ff781e5b5e3ad3458dd4fa8 Mon Sep 17 00:00:00 2001 From: j-bresson Date: Sun, 23 Dec 2018 00:15:13 +0100 Subject: [PATCH] import --- .gitignore | 14 + LICENSE | 674 +++ OMTristan.lisp | 289 ++ resources/icon/128.bmp | Bin 0 -> 630 bytes resources/icon/130.bmp | Bin 0 -> 630 bytes resources/icon/132.bmp | Bin 0 -> 630 bytes resources/icon/133.bmp | Bin 0 -> 2102 bytes resources/icon/135.bmp | Bin 0 -> 2102 bytes resources/icon/136.bmp | Bin 0 -> 1478 bytes resources/icon/137.bmp | Bin 0 -> 1478 bytes resources/icon/138.bmp | Bin 0 -> 2102 bytes resources/icon/158.bmp | Bin 0 -> 630 bytes resources/icon/160.bmp | Bin 0 -> 2102 bytes resources/icon/164.bmp | Bin 0 -> 2102 bytes sources/Addi-MSP.lisp | 219 + sources/Max-Next.lisp | 444 ++ sources/OM-CS.lisp | 1721 +++++++ sources/OM-functions.lisp | 169 + sources/OMspdata.lisp | 1458 ++++++ sources/TMlibrairie-OM.lisp | 9277 +++++++++++++++++++++++++++++++++++ sources/speartext.lisp | 707 +++ sources/utils.lisp | 272 + 22 files changed, 15244 insertions(+) create mode 100644 .gitignore create mode 100644 LICENSE create mode 100755 OMTristan.lisp create mode 100755 resources/icon/128.bmp create mode 100755 resources/icon/130.bmp create mode 100755 resources/icon/132.bmp create mode 100755 resources/icon/133.bmp create mode 100755 resources/icon/135.bmp create mode 100755 resources/icon/136.bmp create mode 100755 resources/icon/137.bmp create mode 100755 resources/icon/138.bmp create mode 100755 resources/icon/158.bmp create mode 100755 resources/icon/160.bmp create mode 100755 resources/icon/164.bmp create mode 100755 sources/Addi-MSP.lisp create mode 100755 sources/Max-Next.lisp create mode 100755 sources/OM-CS.lisp create mode 100644 sources/OM-functions.lisp create mode 100755 sources/OMspdata.lisp create mode 100755 sources/TMlibrairie-OM.lisp create mode 100755 sources/speartext.lisp create mode 100755 sources/utils.lisp diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..b8ecda1 --- /dev/null +++ b/.gitignore @@ -0,0 +1,14 @@ +*.lisp~ +*.*~ +*.xfasl +*.64xfasl +*.ofasl +*.*ufasl +#*# + +.DS_Store + +# don't track auto-generated html's: +/**/reference/*.* +*.lisp# +*.zip diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..f288702 --- /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/OMTristan.lisp b/OMTristan.lisp new file mode 100755 index 0000000..8f1223a --- /dev/null +++ b/OMTristan.lisp @@ -0,0 +1,289 @@ +;; ==================================================================================== +;; OM-TRISTAN +;; ==================================================================================== + + +(in-package :om) + +;-------------------------------------------------- +;Loading files +;-------------------------------------------------- + +(mapc #'(lambda (file) (compile&load + (make-pathname :directory (append (pathname-directory *load-pathname*) '("sources")) + :name file))) + '("OM-functions" + "utils" + "TMlibrairie-OM" + "OM-CS" + "Max-Next" + "OMspdata" + "Addi-MSP" + "speartext" + )) + + +(om::set-lib-release 3.4) + + +;-------------------------------------------------- +; OM subpackages initialization +; ("sub-pack-name" subpack-lists class-list function-list class-alias-list) +;-------------------------------------------------- + +(om::fill-library + '(("1-SPECTRAL HARMONY" (("HARMONIC SERIES" nil nil(sp-gen + n-sp-gen) nil) + + ("FREQUENCY MODULATION" nil nil (fmo + fm-origin + fm-ratio + fm-arp) nil) + + ("AMPLITUDE MODULATION" nil nil (rmo + rm-gen + rm-approx + rm-intra + ch-rm-sine) nil) + + ("DISTORTION" nil nil (disto + dist-gen + dist-sym + dist-proc) nil) + + ("FREQUENCY SHIFT" nil nil (fsh + fs-proc) nil) + ("VOCODER" nil nil (vocoder + vocod-transp + ch-vocoder + time-vocoder) nil) + + ("OTHER TREATMENTS" nil nil (f-interpol + f-densifier + reharmonizer + diamanter + ch-mixture + f-multiplier + proliferer) nil) + + ("ANALYSIS" nil nil (virtual-fund + virt-fund-step + virt-fund-multi + center-freq + inter-freq + which-harm + closest-harm + deviations + which-dist + match-n-sp + match-dist + match-trans) nil) + + ("PROCESSING SPECTRAL ANALYSIS" nil nil (treat-ampl + midi-ampl) nil)) nil nil nil) + + ("2-INTERVALS" nil nil (closest-trans + oct-trans + chord-multiplier) nil) + + ("3-LISTS" (("EXTRACT" nil nil (atom! + list-pos + organizer + penult) nil) + ("EDIT" nil nil (l-suppress + ll-suppress + ll-remove + ll-replace + ll-insert + guillotine + substit) nil) + ("COMBINATORIAL" nil nil (stairs + sawtooth + go-return + spiral + anaclasis + combining + grouping + remove-dup% + permut-rec + permut-circ) nil) + ("OTHER TREATMENTS" nil nil (list! + densifier + smoothing + inverting + l-associate + l-simplify + l-complete + create-matrix + sort-table) nil) + ("ANALYSIS" nil nil (l-sum + n-occur + positions + length-1) nil)) nil nil nil) + ("4-OBJECTS" (("GENERATE" nil nil (trill + triller + arpeggio + cresc-gen) nil) + ("EXTRACT" nil nil (select-filt + nth-obj + seq-extract) nil) + ("EDIT" nil nil (mixer + chainer + ch-onsets->seq + chords->seq + append-seq + append-mseq + add-chseq + paste-object + copy-paste + paste-in-multi + insert-object + erase-chords + insert-silence + 0start + multi-seq-vide) nil) + ("TREATMENTS" nil nil (ch-modif + lonset-modif + lonset-modif-sel + reverse-obj + slur + slur-stretch + n-slur + ch-distor + ch-interpol + ch-filter + ch-test-filter + ch-remdup + velo + tm-cresc + tm-dur + iso-dur + canal + newport + portchan + synch-fin + ch-trim + accel-ral + stretch + stretch-region + stretch-chunk + seq-stretch-curve + mixtur) nil) + ("MAQUETTE" nil nil (order-maq + sel-maq + maq->mseq) nil) + ("ANALYSIS" nil nil (ch-length + obj-dur + obj-minmax + canaux) nil)) nil nil nil) + ("5-MATHEMATICS" (("SERIES" nil nil (arithm-crible + n-arithm + x-arithm + fibonacci + geom-ser + triangle-ser + puiss/to9-ser + power-ser + sinus-ser) nil) + ("SETS" nil nil (unique-notes + common-notes + notes-union + notes-libres) nil) + ("FUNCTION ON X" nil nil (tree-oper + sample-fun + bpf-transfer + linear-fct + lagrange + power/2 + power/3 + parabole2 + parabole3) nil) + ("FUNCTION ON LIST" nil nil (thales + L*line + L*curb + l-distor/2 + l-distor/3 + deformer + deformer% + ll-deformer% + minmax) nil) + ("CHAOS" nil nil (fractal+ + logistic + henon) nil) + ("ALEATORIC" nil nil (LLalea + tirage + list-tirage + list-alea-filter + random-list + random-from-list) nil) + ("ARITHMETIC" nil nil (tm-average + om-modulo + om-floor + cumul + diff + l-pgcd + ll-scaling + l-scale% + scale-r + om-scale/max + <> + >< + x->dx+ + l-prime? + accumule) nil)) nil nil nil) + ("6-CONVERSIONS etc" (("LIST CONVERSIONS" nil nil (sec->min + min->sec + tm-lin->db + tm-db->lin + addtime + intertime + cumultime + pro-max + pro-max-dur + best-micro + filtre-micro + inter->freq + ratio + ratio->cents + cents->ratio + diff->dist + string->list + midic->canal) nil) + ("OBJECT CONVERSIONS" nil nil (channel->micro + channel->voice + map-channel + seq-part + chord->notes + notes->chord + seq->notes + notes->seq + notes->multi-seq + explosion + implosion + sort-chords) nil) + ("FILES" nil nil (read-file + write-file + ll-write-file) nil)) nil nil nil) + ("7-MIDI" nil nil (all-notes-off) nil) + + ("8-ANALYSIS/SYNTHESIS" (("Addi-MSP" nil nil (addi->coll + addi->tfa + addi->lfa + lfa->coll) nil) + ("OM->spear" nil nil (matching + spear-read + spear-write + spear-read-partials + spear-make-partials + spear-write-partials) nil) + ("SPDATA" nil nil (mask-read + par-spdata + mk-spdata + mk-spdata-seq + intpol-model + filter-spdata + filter-all) nil)) nil nil nil) + + )) + + diff --git a/resources/icon/128.bmp b/resources/icon/128.bmp new file mode 100755 index 0000000000000000000000000000000000000000..a03545f7edc7e4782f071996cbf212078696815c GIT binary patch literal 630 zcmd6iF%H5o3`I?Vi3Pz0svkvSM2@&Xca}=Yj6iS%#LU#0Eh`&$>79ZDO3Ifp8LB zdcNr-==rXVH&xFM4R@@N2Vi021`NG%uFC(@82rsL|00*uxcuCYtQzj$?fr}33A))g A^8f$< literal 0 HcmV?d00001 diff --git a/resources/icon/130.bmp b/resources/icon/130.bmp new file mode 100755 index 0000000000000000000000000000000000000000..a38361539a58f60d9ff55130cd194cf4766a0455 GIT binary patch literal 630 zcmZ?rEn{K;gEAng0mKSW%*en3WB~zCUYHw#1%O--{{R0!gE0dT&z#Bd?%g|vyLaz0 z?B2bbp`)XNAv83U!NtV|q>~ho1_KFTT`WLjARr6}UzC76R5}!w{*G1%gvqD1LLiKf zuAkQG(d`R11_QYJi3fLDI5W%e&xAdo9FK@^wdw~YhC)^?x*&b q3UL2l^RX`TI-Y-_^LWyK>pzzF!NjxR!u$BeOCF!HzqD1jj`;_Xiq9l*Ek*K#HpNXy#r!Bf?A<^LSopd}x8N4sf?H4vX(27RC+{0dhJoDx zx#g4ro=NcyALj@E{_|RjY_C#?U)aS7H)0}iuImxv1|)DkpT+5X62o~A!wDFG^Iq(M z;e?ej0DInV#0J<8Sb_Z>D`Ugo0()pOHh@?Nal~=}cEA?s0UW=-zl*oGH*q{3#o=%e zyWLJ~w_DNoy;v;Z@NM4}_^!a0R3Lp~V)dUXc|A%W@Gt%&-t#FS=_PMRpUZtO*Jf?Z zdbPSI^K-q9lf=Y(<%p>HK~bs_JLSyy$iy#<){3a6P~FXHcCao-Ir6eIt=14&rn;Dw za9C>hzzUg%dS{s@9jl@!`2}r_gah+F5KC~Hj^ z?^oc}OUNeu{hf+IDy!^s?^$1hhCuWZ=B2L`e)$Y)%;R;K?!642EjaHhYLJ9g%s(^@ zJ6MN+f-{O$aGf18pXxe0&{OgXX({jH6ZocXGGCQt$sS9E-ZW$v-g7C~GB4+F;EaNo z;J1 zNe&2a!GJ6IL$Q(h6jNfolvez|5mHWdPETLlHYC`gux@k{evl<3A7Knr7VEl zxV;xX@l3!>l*X!@U3-7!r6jHZ1p4Iiq)}_znB!x4BtApeQ9WmzZ80fNsxp`UXNP%l zd&?S~vpi}RO}gsyjMW8uG}KvmSk9eoiXRSPPBbT_UDtIOmXW^l)Azqi`s7a}{RMf% BezpJr literal 0 HcmV?d00001 diff --git a/resources/icon/135.bmp b/resources/icon/135.bmp new file mode 100755 index 0000000000000000000000000000000000000000..9553202cb9dcb8441d863a63598d32317d6d8002 GIT binary patch literal 2102 zcmeH|-Bp}942I3(Y)BMHhB*8LoCW_#_I!Ic=cIr=-0meUObfI?3)2EE(8AXOEzrW` z@l3XYy~VaZc`RFgUr9dm&%Zy9+^+rf&NXH?zvaOFHn9Fx_TmmOBHQhj$re4k?L4~~ zS*>R0kd;Ftn|b5r&Bkqz^^o<3JsbA0Hm_MSm6SJ+nAkTvraddTQ2 z+`Cuj7JOe{-OJ01dwza)Pft(o@$u0;JUqDj`+IkHcjr<{Zn0Rnd53qLduwkIc#FXQ zjX=sts)(qnm?)F|&@rjSxl~k5%#=RHzA<56Eh*(1E%qL*_iomL_10QsblhRDVm&VV z5_50X!!YxSeTq%$VUp%8E@KQmwm8%{9^-PF0``%--0wl`~y@sHK+Sz>44>ey&#hFF`BKPA|V-meQ06c&>|D|H#DI3+Jt# zpPpV^e6OX81@jX2{zXFNd~D^)K3sgg9R4+^x6o`KpHMjund|W7)0b1J-4wK79{6+B z9aiff2XV4iVkA%S(;&qs(wM+Xlse`GIh#Ug*jr#NfnUmqRVzK59UmXpa!U+}#xi!1 zLucxXEMZiyznvVt|16w0<^E>yOFMqx?^kklc64y_Ug~6npS2O6oV6e38b?}$$0*I7)vfBH}pC>0)rwF$H;+rLqRC3X=_j5!im|7=*vP?kNgrpsZOS8+R|?) z{!fPl2ON;4@q9+nj^=hfjVGHZ*^yuF4?YtRp@ajEZoD%_B|rg4?DKf2W|h*dOeqe^ ri#o3wuv7b3l^9S+*qPvnJo9|L=drkyVOH`eT?l3La@J^L!%9O#&|Eex$qHKIzua@%SuI}xXk$~8-fp()E;m8z05LYrlH z4I&I$DwoEYx%u+CUWZ1Ui;HJ@^w+W#v~>{mT0IMU=X?mu)m7`9RmR-0MF|hkRzaX; ziMUU+(0p3GyfhdH7r=DRn{fEL3^>AEtrnG83;M1& literal 0 HcmV?d00001 diff --git a/resources/icon/137.bmp b/resources/icon/137.bmp new file mode 100755 index 0000000000000000000000000000000000000000..9404d0ea7f2a126783247ff40d7b6f6943a4f311 GIT binary patch literal 1478 zcmeHD!Ic^@3^im)HoF0`>$MHU!fdi*Npqd|Qa~Qp9BE-%paqV(x&>O`p3}5I3$!r# zLsCMH=)G^rvMlNUA3uLj%+j zpc#DWP1kp(>pJ8+1O24!7f`z)gYwr$B~rmRf5~Nkya3I#<~x zAyE}rT~myjS%@WRQq?3Zcv@#tazv#1ifgW-bBYpvMYnn=vz(`*8%geqG9h25TvePa zO|@foj{PQtvA0%iWrc0TJg@#aJdtM+u9&PiV(;gR#|J&iMIIhDRAzJLVKXD>{8t{F!_yKVOBQVdin5Rk1<0z&h z1~CnT7=fwl#0We;KZ7%i3A_=QMm&LG9`Qbk0T|&s0P}!2zz7Tp^8ouGI$#{J2fFk` z{4V9`um`$?sS`*FP6rP5z%XDBfP_ExfS3gAz<@I(JOfX_Bk%y+3-R*uBA%X}#N*?m zczAda_xJbW?(R<9-rj=nx?UA{RUj#lks_t~jEIyE*C7Pv7&x%=6-y8rX`sx4^P;oPY-Yc2>xxqwB&rKJhxo6$MDjT0|()Gduna(`Iyh-YAmf%UGASDUE+`d&jgmgNP^-`jX1m+!}pcCV1B?oNnQA=QTO$m3LB`;<9e) z+7tzH)o#Dnw#dIvSyQ-koUnE zr%|L-xi^28igrh_Na@q0f?`yo28oF&Qg{@h~P5mRO9cR^WZ z)2t``ygU_WXFcW=ujqosRm;+KNte)}BKeCr9IQ=O5}%~YGKIT#yk2O!bJ>S8A%5#E lL{4hPHWZ;ersg~yh(6epgIM&(5>N%!8i|mK(0vs0?mG;1?_~f0 literal 0 HcmV?d00001 diff --git a/resources/icon/158.bmp b/resources/icon/158.bmp new file mode 100755 index 0000000000000000000000000000000000000000..9b7b048fb48b4ad02ab910998d901fc7513d6d6d GIT binary patch literal 630 zcmaJ;F-`+95M025f&xzX0myPei4-ZKyj!i(QARufYn2a>4f`rqvtiFFWI%@s8-W*$3GfO$u(@Q;?K@k#B>s>vj%nD5@Tm8J+oH+yw zht@hb)9ekU>5C?#Q8GH(=B2(rKhPEg-!6()mh5#uap$rOtnwGa%IT-a38&{F-=W literal 0 HcmV?d00001 diff --git a/resources/icon/160.bmp b/resources/icon/160.bmp new file mode 100755 index 0000000000000000000000000000000000000000..e80df639d44b04ba7e186b4b47c78d8e0fb41242 GIT binary patch literal 2102 zcmeHI?RnZr5FUuXaH8EKHe59FP8@^;2wOWV-MN5!{P%vk1zKkx8N3Z z?+WrHf0Ap!123%hop(NV*5;po@6M>VyCb3{R@Vm%=s;lq;^Q7P010$mN8N5mJD}~h z_y)FH+5&C2q0MeXEwJ5U4Ya^+gJ)m^w7{;#Gq3^LxZbw#ZQ|tQcj|--DO8wsO)C+ebIv?t zry6=g1gAMdxgo7oGDL+tETD?8K;}8L4tXo+-GtLgnohp)^+6rLK!JehTSWuJnOMbs zTnBXxHXZXM@*369b1XV`C2DaLf(#bCRdn`8hH65C3ZmY#+S*$){TsaJ2?7{2SX@FI zc`IVQ+RWWVy;ruLE%Rj)Ye5X}HM@xAt-*`L^i$|rzQ!g!4#s&FQ`-u>7AQ2HUkX{A zlK0lv$$5QK+c+a9E-1_+o;XIeid^QLYmMcTFEY)rIcLb3y+dW}rUrby=Rb``BSdD0 zu^^5*FV?WPdfxNP(dp?3k!69&Nyf$`X+J#z|0(t_xkJzFk}LBivWSAe4%ljVK24{?;b6F~ xhJ$r#lFx{5u8#LKJO;-{@yB{^2^>tskFD=i|GoMvHFqYdenG=$aJ>GB{13@n#;^bY literal 0 HcmV?d00001 diff --git a/resources/icon/164.bmp b/resources/icon/164.bmp new file mode 100755 index 0000000000000000000000000000000000000000..43e0e4325c2d43056130348e77ce4934de0ae57e GIT binary patch literal 2102 zcmeH|TXxzo5Qc|bYST0&nBLOHv7rqC$B1CJ;Lu>Gv8AUzvITD;TVM;`Lbi}CcnjG= zwxIsPz`;Cq0ny=;M)S{%qoG1mp@@Md8@Mk15*dPNb@Rgln1#pn>1A-0mEJa)jcS?B*8>GMo zxsN^Y0UXeg1ybOH+{YfIzz3L67pt1p78cPGEIzN|*ABdPfTqn$b8dc!8c`HsZp<6yrpy@YGtRs|=Y5X( zu36TrPQtu|Crk~_IFHKu^a`?4R@t11J-sRd#vBm{3{Q-L@!t95Bnb*6d{rLx&&u_~ z*omFQae58{87@;T>%;^X=cixW>JhB(@o8BPc`!(hkKTO4`RqOjyu-3iG54-2m7_Le zc!tARxUb7W3;M5#5WIgIusxX)Ib!dQPlv%+${>(?`Ff)##og_2B!m=b6YrMt4ZF!E zVuU|)DMe(?yWV{FeTHq?ENGvrfC;NL%vQGWKuD^){Vf8B_P*Y!J9-3>drux!hi J?YjQc{s(FH%A)`P literal 0 HcmV?d00001 diff --git a/sources/Addi-MSP.lisp b/sources/Addi-MSP.lisp new file mode 100755 index 0000000..90a9994 --- /dev/null +++ b/sources/Addi-MSP.lisp @@ -0,0 +1,219 @@ +(in-package :om) + +; ---------------- librairie pour Additive (Diphone) -> Max MSP ------------------ + +; Migth do it in Sdiff lib!!?? + +(defun addicoll (add-file max-file ) +"traduit les fichiers additive dans le format des coll MSP" +(let* ((file-in (if (equal add-file 'nil) (choose-file-dialog ) add-file)) + (file-out (if (equal max-file 'nil) (choose-new-file-dialog ) max-file)) + (window (make-array 163 :adjustable t :fill-pointer 0)) + item ) + + (when file-in + (with-open-file (file file-in :direction :input + :if-does-not-exist nil) + (with-open-file (file2 file-out :direction :output + :if-exists :supersede) + + ; lecture de la 1ere fentre + (do ((n 1 (+ 1 n))) ((= n 163) nil) + (setq item (read file nil :eof)) + (setf (aref window n) item )) + + ; le 1ere fentre est Žcrite deux fois (pour la rampe d'attaque) + (for (j 0 1 1) + (print j) + (princ j file2) + (princ #\, file2) + (for (m 4 4 162 ) + (format file2 "~9,2F" (aref window m)) + (format file2 "~9,4F" (aref window (+ 1 m)))) + (princ #\; file2) + (princ #\newline file2)) + + + ; boucle de lecture des fentres suivantes + (do ((k 2 (+ 1 k))) ((eq item :eof) nil) + + (do ((n 1 (+ 1 n))) ((= n 163) nil) + (setq item (read file nil :eof)) + (setf (aref window n) item )) + + (if (= 0 (mod k 10)) (print k)) + (princ k file2) + (princ #\, file2) + + (if (eq item :eof) + (princ " end" file2) + (for (m 4 4 162 ) + (format file2 "~9,2F" (aref window m)) + (format file2 "~9,4F" (aref window (+ 1 m))))) + + (princ #\; file2) + (princ #\newline file2)) + ))) + )) + + + +(om::defmethod! addi->coll ((add-file symbol) + (max-file symbol)) + + :initvals (list 'nil 'nil) + :indoc '("add-file" "max-file") + :icon 158 + :doc "traduit les fichiers Additive dans le format des coll MSP +ext: fichier = donner noms de fichier avec leur ''path'' - sinon +un dialogue s'ouvre" + + + (addicoll add-file max-file)) + + + +(om::defmethod! addi->tfa ((add-file symbol) (dim number)) + + :initvals (list 'nil 2000) + :indoc '("add-file" "max-file") + :icon 158 + :doc "lit les fichiers additive et en extrait des tableaux de freq et d'amp " + + + (let* ((file-in (if (equal add-file 'nil) (choose-file-dialog ) add-file)) + (dimension (list 40 dim)) + (t-freq (make-array dimension :adjustable t )) + (t-amp (make-array dimension :adjustable t )) + newdim kfen nbpar) + + (when file-in + (with-open-file (file file-in :direction :input + :if-does-not-exist nil) + + ; boucle de lecture des fentres + (do ((k 0 (+ 1 k))) ((eq nbpar :eof) nil) + (setq nbpar (read file nil :eof)) ; nb partiels est lu + + (if (eq nbpar :eof) + () + (progn + + (if (= 0 (mod k 10)) (print k)) + ;(print k) + (read file ) ; time est lu + + (for (rang 0 1 39) + (read file) ; nb rang est lu + (setf (aref t-freq rang k) (read file)) + (setf (aref t-amp rang k) (read file)) + (read file) ; phase est lue + (setq kfen k)) + ) + ) + ) + )) + +(setq newdim (list 40 kfen)) +(print (format nil "nb fentres: ~A " (1+ kfen))) +(list (adjust-array t-freq newdim) (adjust-array t-amp newdim)) +)) + + +; en chantier--------------- + +(om::defmethod! addi->lfa ((add-file symbol)) + :initvals (list 'nil 2000) + :indoc '("add-file" "max-file") + :icon 158 + :doc "lit les fichiers additive et en extrait des listes de freq et d'amp" + + + (let* ((file-in (if (equal add-file 'nil) (choose-file-dialog ) add-file)) + l-freq l-amp kfen nbpar ) + + (when file-in + (with-open-file (file file-in :direction :input + :if-does-not-exist nil) + + ; boucle de lecture des fentres + (do ((k 0 (+ 1 k))) ((eq nbpar :eof) nil) + (setq nbpar (read file nil :eof)) ; nb partiels est lu + (let (fqlist amplist ) + (if (eq nbpar :eof) + () + (progn + (if (= 0 (mod k 10)) (print k)) + ;(print k) + (read file ) ; time est lu + + (for (rang 0 1 39) + (read file) ; nb rang est lu + (push (read file) fqlist) + (push (read file) amplist) + (read file)) ; phase est lue + (setq kfen k)) + ) + (push (reverse fqlist) l-freq) + + (push (reverse amplist) l-amp)) + ))) + +(print (format nil "nb fentres: ~A " (1+ kfen))) +(list (butlast (nreverse l-freq)) (butlast (nreverse l-amp ))) ; butlast filtre un 'nil' final +)) + + +; ----------------------------------- + + + +(om::defmethod! lfa->coll ((l-freqs list) (l-amps list) (file-out string)) + + :initvals (list '(1 2) '(1 2) "name") + :indoc '("l-freqs" "l-amps" "file-out" ) + :icon 158 + :doc "Žcrit un fichier au format coll pour Max MSP ˆ partir de listes de freq et d'amp" + + + (let ((nharm (1- (length l-freqs))) + (nbfen (- (length (first l-freqs)) 1)) + (l-freqs (om-round l-freqs 2)) + (file-out (if (equal file-out "name") (choose-new-file-dialog ) file-out))) + + (with-open-file (file2 file-out :direction :output + :if-exists :supersede) + + ; la 1ere fentre est Žcrite deux fois (pour la rampe d'attaque) + (princ 0 file2) + (princ #\, file2) + (for (h 0 1 nharm) + (format file2 "~9,2F" (l-nth (l-nth l-freqs h) 0)) + (format file2 "~9,4F" (l-nth (l-nth l-amps h) 0))) + (princ #\; file2) + (princ #\newline file2) + + (for (f 0 1 nbfen) + (if (= 0 (mod f 10)) (print f)) + (princ (+ 1 f) file2) + (princ #\, file2) + + (for (h 0 1 nharm) + (format file2 "~9,2F" (l-nth (l-nth l-freqs h) f)) + (format file2 "~9,4F" (l-nth (l-nth l-amps h) f))) + + (princ #\; file2) + (princ #\newline file2)) + + (princ (+ 2 nbfen) file2) + (princ #\, file2) + (princ " end" file2) + (princ #\; file2) + + (format t "~%nb fentres: ~A ~%" (+ 1 nbfen)) + nil + ))) + + + + \ No newline at end of file diff --git a/sources/Max-Next.lisp b/sources/Max-Next.lisp new file mode 100755 index 0000000..88505f4 --- /dev/null +++ b/sources/Max-Next.lisp @@ -0,0 +1,444 @@ +(in-package :om) + +; ------------------- max-next -------------------- + +(om::defmethod! extract-freq ((fichier list) (partiels list)) + + :initvals (list '(1 2) '(1 2)) + :indoc '("fichier" "partiels") + :icon 164 + :doc "extrait les frŽquences d'une q-list" + + + (let ((long (length fichier)) (partiels (carlist! partiels)) res) + (if (atom partiels) + (setq res (extract-one-freq fichier long partiels)) + (progn (dolist (n partiels) (push (extract-one-freq fichier long n) res)) )) + (if (atom partiels) res (nreverse res)))) + + + +(om::defmethod! extract-amp ((fichier list) (partiels list)) + + :initvals (list '(1 2) '(1 2)) + :indoc '("fichier" "partiels") + :icon 164 + :doc "extrait les amplitudes d'une q-list" + + (let ((long (length fichier)) (partiels (carlist! partiels)) res) + (if (atom partiels) + (setq res (extract-one-amp fichier long partiels)) + (progn (dolist (n partiels) (push (extract-one-amp fichier long n) res)) )) + (if (atom partiels) res (nreverse res)))) + + + +(defun extract-one-freq (fichier long partiel) + (l-nth fichier (arithm-ser (+ (* 2 partiel) (* 2 (truncate (1- partiel) 5 ))) long 96 ))) + +(defun extract-one-amp (fichier long partiel) + (l-nth fichier (arithm-ser (1+ (+ (* 2 partiel) (* 2 (truncate (1- partiel) 5 )))) long 96))) + + +(defun extract-one-freq-t (tab long partiel) + (l-aref tab (arithm-ser (+ (* 2 partiel) + (* 2 (truncate (1- partiel) 5 ))) long 96 ))) + +(defun extract-one-amp-t (tab long partiel) + (l-aref tab (arithm-ser (1+ (+ (* 2 partiel) + (* 2 (truncate (1- partiel) 5 )))) long 96 ))) + + + + + +(om::defmethod! ql->freqs ((fichier list)) + + :initvals (list '(1 2)) + :indoc '("fichier" ) + :icon 164 + :doc "extrait les freq de tous les partiels d'une q-list " + + + (let ((long (length fichier)) res) + (for (n 1 1 40) + (print n) + (push (extract-one-freq fichier long n) res)) + (nreverse res) )) + +(om::defmethod! ql->amps ((fichier list)) + :initvals (list '(1 2)) + :indoc '("fichier") + :icon 164 + :doc "extrait les amp de tous les partiels d'une q-list +((amp-partiel1) (amp-partiel2)... ) " + + + (let ((long (length fichier)) res) + (for (n 1 1 40) + (print n) + (push (extract-one-amp fichier long n) res) + ) + (nreverse res))) + + + + + +(om::defmethod! qlt->fqs ((tab t)) + :initvals (list t) + :indoc '("tab") + :icon 164 + :doc "extrait les freq de tous les partiels d'une q-list lue +sous forme de tableau : ((fq-partiel1) (fq-partiel2)... )" + (let ((long (length tab)) res) + (for (n 1 1 40) + (print n) + (push (extract-one-freq-t tab long n) res)) + (nreverse res) )) + + +(om::defmethod! qlt->ams ((tab t)) + + :initvals (list t) + :indoc '("tab") + :icon 164 + :doc "extrait les amp de tous les partiels d'une q-list +((amp-partiel1) (amp-partiel2)... ) " + + (let ((long (length tab)) res) + (for (n 1 1 40) + (print n) + (push (extract-one-amp-t tab long n) res)) + (nreverse res))) + + + +; corrigŽ 14/4/2000 7/6/2003 + +(om::defmethod! analyse-spectre ((freqs list) (amps list) + (deb number) (fin number) + (nharm number)) + :initvals (list '(1 2) '(1 2) 0 1 1) + :indoc '("freqs" "amps" "deb" "fin" "nharm") + :icon 133 + :doc "calcule un spectre moyen d'aprs les premires harmoniques +d'une analyse dynamique freqs-amps au format suivi de partiels +(liste (freqs partiel 1) (freqs partiel 2)...) +Calcule la moyenne sur les fentres situŽes entre deb et fin +Rend une double liste ((freqs) (amps))" + + (let ((freqs (l-nth freqs (arithm-ser 0 (1- nharm) 1 ))) + ( amps (l-nth amps (arithm-ser 0 (1- nharm) 1 ))) + ana-freqs ana-amps) + + (dolist (f freqs) + (push (filtre-liste '= 0 (list-pos f deb fin)) ana-freqs)) + + (dolist (a amps) + (push (list-pos a deb fin) ana-amps)) + + (list (tm-average (nreverse ana-freqs) 1) (tm-average (nreverse ana-amps) 1)))) + +; ancienne version +(om::defmethod! spectre-moyen/a ((freqs list) (amps list) + (deb number) (fin number) + (nharm number) (coupure number) + &optional (minvel 10) (maxvel 127)) + :initvals (list '(1 2) '(1 2) 0 10 20 50 10 127) + :indoc '("freqs" "amps" "deb" "fin" "nharm" "filtre freq" "vel min" "vel max") + :icon 133 + :doc "calcule un spectre d'aprs les premires harmoniques +d'une analyse dynamique par fentre - par ex. masking effects. +(liste (freqs fenetre 1) (freqs fenetre 2)...) +(on obtient le format suivi de partiels utilisŽ dans analyse-spectre par une transposition de matrice) +Ne marche que pour son assez stable. +Calcule la moyenne sur les fentres situŽes entre deb et fin +Filtre frequences basses en hz +Rend objet accord (on peut ajuster ambitus des vŽlocitŽs )" + +(let* ((spfil + (loop for f in freqs + for a in amps + collect (multi-filter '< coupure (list f a) 0))) + + (spanalys (analyse-spectre (mat-trans (mapcar 'first spfil) ) + (mat-trans (mapcar 'second spfil)) deb fin nharm))) + + + (mki 'chord + :LMidic (f->mc (first spanalys)) + :Lvel (om-round (om-scale (tm-lin->db (om-scale/max (second spanalys) 1) 8) minvel maxvel)) + :Loffset '(0) + :Ldur '(1000) + :Lchan '(1)))) + + +; nv version oct 2004 + +(om::defmethod! spectre-moyen ((freqs list) (amps list) + (deb number) (fin number) + (nharm number) (coupure number) + &optional (minvel 10) (maxvel 127)) + :initvals (list '(1 2) '(1 2) 0 10 20 50 10 127) + :indoc '("freqs" "amps" "deb" "fin" "nharm" "filtre freq" "vel min" "vel max") + :icon 133 + :doc "calcule un spectre d'aprs les premires harmoniques +d'une analyse dynamique par fentre - par ex. masking effects. +(liste (freqs fenetre 1) (freqs fenetre 2)...) +(on obtient le format suivi de partiels utilisŽ dans analyse-spectre par une transposition de matrice) +Ne marche que pour son assez stable. +Calcule la moyenne sur les fentres situŽes entre deb et fin +Filtre frequences basses en hz +Rend objet accord (on peut ajuster ambitus des vŽlocitŽs )" + +(let* ((freqs (list-pos freqs deb fin)) + (amps (list-pos amps deb fin)) + (nharm (min nharm (l-min (mapcar 'length freqs)))) + (spfil + (loop for f in freqs + for a in amps + collect (multi-filter '< coupure (list f a) 0))) + + (spanalys (analyse-spectre (mat-trans (mapcar 'first spfil) ) + (mat-trans (mapcar 'second spfil)) 0 (- (length freqs) 1) nharm))) + + + (mki 'chord + :LMidic (f->mc (first spanalys)) + :Lvel (om-round (om-scale (tm-lin->db (om-scale/max (second spanalys) 1) 8) minvel maxvel)) + :Loffset '(0) + :Ldur '(1000) + :Lchan '(1)))) + + + + + + + + + + + +(om::defmethod! melo->env ((rangs list) + (durs list) + (nharm number) + (amp number) + (nbsamp number)) + + :initvals (list '(1 2) '(1 2) 1 1 1) + :indoc '("rangs" "durs" "nharm" "amp" "nbsamp") + :icon 133 + :doc "crŽe une enveloppe o amp sera au max ˆ +chaque fois qu'on trouvera l'harm dans la +mŽlodie rangs , et aussi longtemps que la durŽe +correspondante de +nbsamp = nb de points de l'enveloppe" + + (let ((durs2 (om-round (om-scale/sum durs nbsamp))) lval) + (dolist (i rangs) + (push (if (= i nharm) amp 0) lval)) + (flat (mapcar 'create-list durs2 (nreverse lval))))) + + + + +(om::defmethod! melo->env+pond ((rangs list) + (durs list) + (nharm number) + (env2 list) + (pond% number)) + + :initvals (list '(1 2) '(1 2) 1 '(1 2) 1.0) + :indoc '("rangs" "durs" "nharm" "env2" "pond%") + :icon 133 + :doc "crŽe une enveloppe o amp sera au max ˆ +chaque fois qu'on trouvera l'harm dans la +mŽlodie rangs , et aussi longtemps que la durŽe +correspondante de , le tout Žtant pondŽrŽ par l'env 2, +selon , exprimŽ en pcentage +le nb de points de l'env et son amp max sont sont de env2" + + + (let* ((env2 (flat env2)) (amp2 (list-max env2)) + + (env1 (om-scale/max (om+ (melo->env rangs durs nharm amp2 (length env2)) + (om/ (om* env2 pond%) 100)) amp2))) + + (setq env1 (cond ( (> (length env1) (length env2)) (butlast env1)) + ( (< (length env1) (length env2)) (x-append env1 0)) + (t env1))))) + + + + + +(om::defmethod! env-globale ((l-amps list) + (envglo list) + (type symbol) + (sens symbol)) + + :initvals (list '(1 2) '(1 2) 'abrupt 'normal ) + :indoc '("l-amps" "envglo" "type" "sens") + :menuins '((2 (("abrupt" 'pitch) + ("pentes" 'rotor))) + (3 (("normal" 'midic) + ("renv" 'frq)))) + :icon 133 + :doc " sculpte un son selon l'enveloppe globale envglo ; les env de +chaque partiel sont Žventuellement ramenŽes ˆ 0 ,pour crŽer +les contours d'attaque et d'extinction (du grave ˆ l'aigu) +envglo doit avoir exactement la mme longueur que chaque +liste d'amplitudes +options: +abrupt : les partiels apparaissent ''brusquement'' , en +fct des contours d'envglo +pentes : ils apparaissent doucement, depuis le dŽbut du son, +et atteignent leur max, en fct d'envglo +normal : les hq se dŽploient du grave ˆ l'aigu, selon envglo +renv : ils se dŽploient de l'aigu au grave comme si envglo +Žtait renversŽe" + + (let* ((envglo (om-scale/max envglo 40)) + (type (case type + (abrupt 1) + (pentes 2))) + (sens (case sens + (normal 1) + (renv 2))) + res) + (for (n 0 1 39) + (push (env-un-partiel envglo n type sens) res)) + (om* (nreverse res) l-amps))) + + +(defun env-un-partiel (envglo nharm type sens) + (let ((env (if (= sens 1) (om- envglo nharm) (om- envglo (- 39 nharm))))) + (if (= type 1 ) (mapcar 'test-zero-un env) + (if (< (list-min env) 0) (om-scale (mapcar 'test-un env) 0 1 ) (mapcar 'test-un env) )))) + + +(defun test-zero-un (val) + (cond ( (< val 0) 0) + ( (> val 1) 1) + ( t val))) + +(defun test-un (val) + (if (> val 1) 1 val)) + + + + +(om::defmethod! format-ql ((l-freqs list) (l-amps list)) + + + :initvals (list '(1 2) '(1 2) 'abrupt 'normal ) + :indoc '("l-freqs" "l-amps") + :icon 133 + :doc "" + + (let ((nharm (1- (length l-freqs))) (nbfen (1- (length (first l-freqs)))) + (l-freqs (om-round l-freqs 2)) res) + + (for (h 0 1 nharm) + (if (= 0 (mod h 5)) (push (format () "0 i~A" (1+ h)) res)) + (push (l-nth (l-nth l-freqs h) 0) res) + (push 0 res) + (if (or (= h nharm) (= 4 (mod h 5))) + (progn (push #\; res) (push #\newline res)))) + + (for (f 0 1 nbfen) + (for (h 0 1 nharm) + (if (= 0 (mod h 5)) (push (format () "0 i~A" (1+ h)) res)) + (push (l-nth (l-nth l-freqs h) f) res) + (push (l-nth (l-nth l-amps h) f) res) + (if (or (= h nharm) (= 4 (mod h 5))) + (progn (push #\; res) (push #\newline res))))) + (nreverse res))) + + + + + +;; ---------------------------------------------------------------------------------- +;; modif du format de sortie dans les text-windows (pas de notation exponentielle) +;modifications pour text-window ->> qlist (serge lemouton -- 7/06/93) +;cf file-buffer.lisp + + + +#| +(defpackage "C-PATCH-FILE-BUFFER" + (:use "COMMON-LISP" "CCL") + (:import-from "PATCH-WORK" + "*TARGET-ACTION-OBJECT*" "NEW-MENU" "NEW-LEAFMENU" "MAKE-POPUPBOX" + "PATCH-VALUE" "H" "W" "C-PATCH" "PW-CONTROLS" "INPUT-OBJECTS" "LIST!" + "PW-FUNCTION-STRING" "DEFUNP" "COMPLETE-BOX" "REMOVE-YOURSELF-CONTROL") + (:export "C-PATCH-FILE-BUFFER")) + +(in-package "C-PATCH-FILE-BUFFER") + + +(defvar *lisp-win-option* t) + + +(defclass C-patch-ascii-buffer (C-patch-file-buffer) ()) + + + + +(defmethod add-to-file ((self C-patch-ascii-buffer) list format) + (if *lisp-win-option* + ; (call-next-method) + (let* ((list (list! list)) + (count 0) + (format (if (zerop format) (length list) format)) + (mark (fred-buffer + (if (not (and (fred-win self) (wptr (fred-win self)))) + (get-new self) (fred-win self))))) + (dolist (item list) + (buffer-insert mark (format nil " ~8F" item));modif serge + (if (zerop (rem (incf count) format)) + (buffer-insert mark (format nil ";~A" #\Return))))) + + (let* ((list (list! list)) + (count 0) + (format (if (zerop format) (length list) format)) + (mark (fred-buffer + (if (not (and (fred-win self) (wptr (fred-win self)))) + (get-new self) (fred-win self))))) + (dolist (item list) + (buffer-insert mark (format nil " ~A" item));modif serge + ;(buffer-insert mark (format nil " ~8F" item));modif serge + (if (zerop (rem (incf count) format)) + (buffer-insert mark (format nil "~%"))))))) + +|# + + + + + + + + + + + + +#| +; ------------- sous-menu "Max-Next" + +(in-package epw) + +(defparameter *max-menu* (new-menu "Max-Next")) + +(ccl:add-menu-items patch-work::*pw-menu-patch* + *max-menu* ) + +(PW-addmenu *max-menu* '(extract-freq extract-amp ql->freqs ql->amps + qlt->fqs qlt->ams analyse-spectre + melo->env melo->env+pond env-globale format-ql)) + +|# \ No newline at end of file diff --git a/sources/OM-CS.lisp b/sources/OM-CS.lisp new file mode 100755 index 0000000..2ae1eb8 --- /dev/null +++ b/sources/OM-CS.lisp @@ -0,0 +1,1721 @@ + +; ------------------- OM->CS fonctions personnelles -------------------- +(in-package :om) + + +;------------------------------formant------------------------------------ +;------------------------------------------------------------------------- + +;from TM-librairie +;for compatibility + +(defun seq->list (objet) + "si c'est chseq retourne liste d'accords" + (if (or (typep objet 'chord-seq) (typep objet 'chord)) (lmidic objet) objet)) + + + + +;-------------------------------------------------------------------------- + +(defun formant1 (accord centre bande mulamp mode) + (let* ((res (clone accord)) + (lnotes (lmidic accord)) + (min (- centre (/ bande 2.0))) (max (+ centre (/ bande 2))) + (fctn (parabole/3 1 min 1 centre mulamp max 1))) + + (dolist (n lnotes) + (let ((hauteur (if (equal mode 'freq) (mc->f (lmidic accord)) (lmidic accord)))) + (if (<> hauteur min max '<>) + (set-slot n lvel (round (* (lvel accord) (funcall fctn hauteur))))))) + res)) + + + + + + +;marche aussi pour les liste "numbers?" ds PW c-ˆ-d les deux number et liste + + +(om::defmethod! formant ((accords chord-seq) + (centre t) + (bande t) + (mulamp t) + (mode symbol)) + + + :initvals (list t 6000 75 100 'freq) + :indoc '("accords" "centre" "bande" "amps" "mulamp" "mode") + :menuins '((4 (("freq" 'frq) + ("midic" 'midic)))) + :icon 132 + :doc "centre : fq ou midi central du formant +bande = largeur de bande totale du formant +mulamp = multiplicateur d'intensitŽ" + + + + (let* ( + ;(accords (seq->list accords)) + (long (if (consp accords) (length accords))) res) + + (if (consp accords) + (let ((centre (if (consp centre) centre (create-list long centre))) + (bande (if (consp bande) bande (create-list long bande))) + (mulamp (if (consp mulamp) mulamp (create-list long mulamp)))) + (loop for a in accords + for c in centre + for b in bande + for m in mulamp + do (push (formant1 a c b m mode) res) + finally (return (nreverse res)))) + (formant1 accords centre bande mulamp mode)))) + + + +;Alreday defined in TM library in liste-analyse +;(l-sum l-sum1 positions1 positions nbi-rec nbelem-ident length-1) + + + + + + +;------------------------------------gran-st-sco---------------------------------------------------- + +;gran-st-sco et granf-st-sco modifiŽes (fichier = optional) - le type symbol ne fonctionnait pas. +; Il faudrait changer les autres fct similaires + + +; fct corrigŽe par Laurent Pottier + +(om::defmethod! gran-st-sco ((dates list) + (tuile number) + (frqs list) + (amps list) + (alea number) + (spatia list) + &optional (fichier nil)) + + + :initvals (list '(1 2) 1 '(1 2) '(1 2) 0 '(1 2) 'nil) + :indoc '("dates" "tuile" "frqs" "amps" "alea" "spatia" "fichier" ) + :icon 132 + :doc "" + + (let* ((nom (if (equal fichier 'nil) (choose-new-file-dialog ) fichier)) + (long (1- (length dates))) + (last-ev (- (nth long dates) (nth (1- long) dates))) + (dates (x-append dates (+ (last-elem dates ) last-ev) (+ (last-elem dates ) + (* 2 last-ev)))) + nextDate newDate (fin (+ (last-elem dates) last-ev))) + + (format t "fentres : ") + (when nom + (with-open-file (file nom :direction :output + :if-exists :supersede) + + (format file "f1 0 1024 10 1 ~%~%") + + (for (i 0 1 long) + (if (= (mod i 10) 0) (format t " ~A " i) ) + (for (k 0 1 (1- (length (nth i frqs)))) + + (format file "i1" ) + + (setf nextDate (nth (1+ i) dates) + newDate (+ (nth i dates) (* (/ alea 100.) (om-random 0 (- (nth (1+ i) dates)(nth i dates)))))) + + (format file "~9,4F" newDate) ; dates + (format file "~9,4F" (* tuile (- (nth (+ 2 i) dates) (nth i dates))) ) ; durŽes + (format file "~9,4F" (nth k (nth i amps)) ) ; amps + (format file "~9,2F" (nth k (nth i frqs)) ) ; freqs + (format file "~9,4F" (* tuile (- (nth (+ 2 i) dates) (nth (1+ i) dates))) ) ; pentes + (format file "~8,2F" (nth k (nth i spatia)) file) + (princ #\newline file) )) + + (princ #\e file))) + + (format t "fichier ~A Žcrit - durŽe ~8,3F ~%" nom fin)) + nil) + + +; nouvelle fct - les attaques ˆ l'intŽrieur de chaque fentre sont systŽmatiquement dŽcalŽes +; pour rŽduire le bruit . Le paramtre alea devient inutile. Utiliser avec granArp-st.orc + +(om::defmethod! gran-st-sco-arp ((dates list) + (tuile number) + (frqs list) + (amps list) + (spatia list) + &optional (fichier nil)) + + + :initvals (list '(1 2) 1 '(1 2) '(1 2) 0 '(1 2) 'nil) + :indoc '("dates" "tuile" "frqs" "amps" "spatia" "fichier" ) + :icon 132 + :doc "" + + (let* ((nom (if (equal fichier 'nil) (choose-new-file-dialog ) fichier)) + (long (1- (length dates))) + (last-ev (- (nth long dates) (nth (1- long) dates))) + newDate + (dates (x-append dates (+ (last-elem dates ) last-ev) (+ (last-elem dates ) + (* 2 last-ev)))) + (fin (+ (last-elem dates) last-ev))) + + (format t "fentres : ") + (when nom + (with-open-file (file nom :direction :output + :if-exists :supersede) + + (format file "f1 0 1024 10 1 ~%~%") + (format file "f2 0 1024 -20 2 ~%~%") + + (for (i 0 1 long) + (if (= (mod i 10) 0) (format t " ~A " i) ) + (for (k 0 1 (1- (length (nth i frqs)))) + + (format file "i1" ) + + (setf newDate (+ (nth i dates)(* (/ k (length (nth i frqs))) (- (nth (1+ i) dates)(nth i dates))))) + + (format file "~9,4F" newDate) ; dates + (format file "~9,4F" (* tuile (- (nth (+ 2 i) dates) (nth i dates))) ) ; durŽes + (format file "~9,4F" (nth k (nth i amps)) ) ; amps + (format file "~9,2F" (nth k (nth i frqs)) ) ; freqs + (format file "~9,4F" (* tuile (- (nth (+ 2 i) dates) (nth (1+ i) dates))) ) ; pentes + (format file "~8,2F" (nth k (nth i spatia)) file) + (princ #\newline file) )) + + (princ #\e file))) + + (format t "fichier ~A Žcrit - durŽe ~8,3F ~%" nom fin)) + nil) + + +#| ancienne fonction +(om::defmethod! gran-st-sco ((dates list) + (tuile number) + (frqs list) + (amps list) + (alea number) + (spatia list) + &optional (fichier nil)) + + + :initvals (list '(1 2) 1 '(1 2) '(1 2) 0 '(1 2) 'nil) + :indoc '("dates" "tuile" "frqs" "amps" "alea" "spatia" "fichier" ) + :icon 132 + :doc "" + + (let* ((nom (if (equal fichier 'nil) (choose-new-file-dialog ) fichier)) + (long (1- (length dates))) + (last-ev (- (nth long dates) (nth (1- long) dates))) + (dates (x-append dates (+ (last-elem dates ) last-ev) (+ (last-elem dates ) + (* 2 last-ev)))) + (fin (+ (last-elem dates) last-ev))) + + (format t "fentres : ") + (when nom + (with-open-file (file nom :direction :output + :if-exists :supersede) + + (format file "f1 0 1024 10 1 ~%~%") + + (for (i 0 1 long) + (if (= (mod i 10) 0) (format t " ~A " i) ) + (for (k 0 1 (1- (length (nth i frqs)))) + + (format file "i1" ) + (format file "~8,3F" (* (nth i dates) (+ 1 (/ (om-random (- alea) + (float alea)) 100)) )) ; dates + (format file "~8,3F" (* tuile (- (nth (+ 2 i) dates) (nth i dates))) ) ; durŽes + (format file "~9,4F" (nth k (nth i amps)) ) ; amps + (format file "~9,2F" (nth k (nth i frqs)) ) ; freqs + (format file "~8,3F" (* tuile (- (nth (+ 2 i) dates) (nth (1+ i) dates))) ) ; pentes + (format file "~8,2F" (nth k (nth i spatia)) file) + (princ #\newline file) )) + + (princ #\e file))) + + (format t "fichier ~A Žcrit - durŽe ~8,3F ~%" nom fin)) + nil) + +|# + + + +;------------------------------------granf-st-sco---------------------------------------------------- + +(defun spectre->fct (spectre) + (let* ((rangs (first spectre)) + (last-harm (last-elem rangs)) + (intens (om-round (om-scale/max (second spectre) 1) 3)) + res) + (for (i 1 1 last-harm) + (push (l-nth intens (position i rangs)) res)) + (nreverse (substitute 0 nil res )))) + + +(om::defmethod! granf-st-sco ((dates list) + (tuile number) + (frqs list) + (amps list) + (alea number) + (spatia list) + (spectre list) + &optional (fichier nil) ) + + + :initvals (list '(1 2) 1 '(1 2) '(1 2) 0 '(1 2) '((1) (1) ) 'nil) + :indoc '("dates" "tuile" "frqs" "amps" "alea" "spatia" "fichier" "spectre" ) + :icon 132 + :doc "écriture d'une partition granulaire avec table d'onde; par défaut, onde sinus +format spectre : ( (rangs harm) (intensités))" + + + + (let* ((nom (if (equal fichier 'nil) (choose-new-file-dialog ) fichier)) + (long (1- (length dates))) + (last-ev (- (nth long dates) (nth (1- long) dates))) + (dates (x-append dates (+ (last-elem dates ) last-ev) (+ (last-elem dates ) + (* 2 last-ev)))) + (fin (+ (last-elem dates) last-ev))) + + (when nom + (with-open-file (file nom :direction :output + :if-exists :supersede) + + (format file "f1 0 1024 10 ~{~8,4F~} ~%~%" (spectre->fct spectre) ) + + (for (i 0 1 long) + (for (k 0 1 (1- (length (nth i frqs)))) + + (format file "i1" ) + (format file "~8,3F" (* (nth i dates) (+ 1 (/ (om-random (- alea) + (float alea)) 100)) )) ; dates + (format file "~8,3F" (* tuile (- (nth (+ 2 i) dates) (nth i dates))) ) ; durées + (format file "~9,4F" (nth k (nth i amps)) ) ; amps + (format file "~9,2F" (nth k (nth i frqs)) ) ; freqs + (format file "~8,3F" (* tuile (- (nth (+ 2 i) dates) (nth (1+ i) dates))) ) ; pentes + (format file "~8,2F" (nth k (nth i spatia)) file) + (princ #\newline file) )) + + (princ #\e file))) + + (format t "fichier ~A écrit - durée ~8,3F ~%" nom fin)) + nil) + + + +;------------------------------------seq->gran-sco---------------------------------------------------- + +(om::defmethod! spatia-freq ((freqs list) + (min number) + (max number)) + :initvals (list '(1 2) 0 1) + :indoc '("freqs" "min" "max") + :icon 132 + :doc "spatialise en fct des fréq entre min = gauche et max = droite +Si on entre des midics: répartition plus étale gauche -> droite" + + (om-round (om-scale freqs min max (list-min (list-min freqs)) (list-max (list-max freqs))) 2)) + +(defun spatia-freq1 (freqs) +"spatialise en fct des fréq +Si on entre des midics: répartition plus étale gauche -> droite" + (om-round (om-scale freqs 0 1 (list-min freqs) (list-max freqs)) 2)) + + +(om::defmethod! spatia-rotor ((freqs list) + (min number) + (max number)) + :initvals (list '(1 2) 0 1) + :indoc '("freqs" "min" "max") + :icon 132 + :doc "spatialise en fct des fréq,(entre min et max) et mais ajoute une permutation +circulaire des spatialisations pendant toute la durée du son" + + (let ((freqs (om-round (om-scale freqs min max ) 2)) + (position (arithm-ser 0 1 (/ 1 (length freqs)) )) res) + (loop for f in freqs + for p in position + do (push (rotate f (round (* p (length f)))) res) + finally (return (reverse res) )))) + + +(om::defmethod! spatia-alea ((freqs list) + (gauche number) + (droite number)) + :initvals (list '(1 2) 0 1) + :indoc '("freqs" "gauche" "droite") + :icon 132 + :doc "spatialise aléatoirement entre les valeurs indiquées" + + (let ((res) (sublist)) + (dolist (f freqs) + (repeat (length f) (push (random 100) sublist)) + (push sublist res) + (setq sublist nil)) + (nreverse (om-round (om-scale res gauche droite) 2)))) + +(defun spatia-alea1 (freqs) +"spatialise aléatoirement " + (let ((res) ) + (repeat (length freqs) (push (random 100) res)) + (nreverse (g-round res 2) ))) + + +(om::defmethod! seq->gran-sco ((accords chord-seq) + (tuile number) + (mulamp number) + (mulmin number) + (alea number) + (spatia symbol) + (fichier list ) + (spectre list)) + + + :initvals (list t 1 .5 1 0 "frq" 'nil '((1) (1))) + :indoc '("accords" "tuile" "frqs" "amps" "alea" "spatia" "fichier" "spectre" ) + :menuins '((5 (("frq" 'frq) + ("midic" 'midic) + ("rotor" 'rotor) + ("alea" 'alea)))) + :icon 132 + :doc "écriture d'une partition granulaire ˆ partir d'un chord-seq +mulamp = scaling des amp : si mulamp = 1, somme des amp de chaque accord = 1 +mulmin : redresse la courbe des amp (compresse si mulmin > 1) +table d'onde; par défaut, onde sinus +format spectre : ( (rangs harm) (intensités))" + + + (let* ((nom (if (equal fichier 'nil) (choose-new-file-dialog ) fichier)) + (frqs (mc->f (lmidic accords))) + (amps (lvel accords)) + (amps (om* (om/ amps (list-max (l-sum amps))) mulamp)) ; somme des amps = 1 * mulamp + (maxamp (list-max (list-max amps))) + (minamp (list-min (list-min amps))) + (amps (om-round (om-scale amps (* minamp mulmin) maxamp minamp maxamp) 4)) ; redresser + ; courbe des amp si mulmin <> 1 + (dates (om/ (butlast (lonset accords)) 1000.0)) ;maybe butlast isnot necessary?? + (offsets (om/ (loffset accords) 1000.0)) + (long (1- (length dates))) + (last-ev (- (nth long dates) (nth (1- long) dates))) + (dates (x-append dates (+ (last-elem dates ) last-ev) (+ (last-elem dates ) (* 2 last-ev)))) + ; ajout de deux dates pour le calcul de la dernière pente d'extinction + (offsets (x-append offsets (list (last-elem offsets) (last-elem offsets)))) ; même raison + (attaques (om+ offsets dates)) + (attaques (om- attaques (list-min (list-min attaques)))) ; pour commencer le temps à 0 + (space (case spatia + (frq (spatia-freq frqs 0 1)) + (midic (spatia-freq (lmidic accords) 0 1)) + (rotor (spatia-rotor frqs 0 1)) + (alea (spatia-alea frqs 0 1)))) + (fin (+ (last-elem dates) last-ev))) + + (when nom + (with-open-file (file nom :direction :output + :if-exists :supersede) + + (format file "f1 0 1024 10 ~{~8,4F~} ~%~%" (spectre->fct spectre) ) + + (for (i 0 1 long) + (for (k 0 1 (1- (length (nth i frqs)))) + (format file "i1" ) + (format file "~8,3F" (* (nth k (nth i attaques)) (+ 1 (/ (om-random (- alea) + (float alea)) 100)) )) ; dates + (format file "~8,3F" (* tuile (- (nth (+ 2 i) dates) (nth i dates))) ) ; durées + (format file "~9,4F" (nth k (nth i amps)) ) ; amps + (format file "~9,2F" (nth k (nth i frqs)) ) ; freqs + (format file "~8,3F" (* tuile (- (nth (+ 2 i) dates) (nth (1+ i) dates))) ) ; pentes + (format file "~8,2F" (nth k (nth i space)) file) + (princ #\newline file) )) + + (princ #\e file))) + (format t "fichier ~A écrit - durée ~8,3F ~%" nom fin) ) + nil) + + +;------------------------------------seq->ord-sco---------------------------------------------------- + + +(om::defmethod! seq->ord-sco ((accords chord-seq) + (muldur number) + (mulamp number) + (mulmin number) + (alea number) + (spatia symbol) + (fichier list) + (spectre list)) + + + :initvals (list t 1 .5 1 0 "frq" 'nil '((1) (1))) + :indoc '("accords" "muldur" "mulamp" "mulmin" "alea" "spatia" "fichier" "spectre" ) + :menuins '((5 (("frq" 'frq) + ("midic" 'midic) + ("rotor" 'rotor) + ("alea" 'alea)))) + :icon 132 + :doc "écriture d'une partition ordinaire ˆ partir d'un chord-seq +les durées seront celles du chseq, multipliées par muldur +mulamp = scaling des amp : si mulamp = 1, somme des amp de chaque accord = 1 +mulmin : redresse la courbe des amp (compresse si mulmin > 1) +les offsets sont pris en compte +table d'onde; par défaut, onde sinus +format spectre : ( (rangs harm) (intensités))" + + + (let* ((nom (if (equal fichier 'nil) (choose-new-file-dialog ) fichier)) + (muldur (/ muldur 1000)); might be in milliseconds + (frqs (mc->f (lmidic accords))) + (amps (lvel accords)) + (amps (om* (om/ amps (list-max (l-sum amps))) mulamp)) ; somme des amps = 1 * mulamp + (maxamp (list-max (list-max amps))) + (minamp (list-min (list-min amps))) + (amps (om-round (om-scale amps (* minamp mulmin) maxamp minamp maxamp) 4)) ; redresser + ; courbe des amp si mulmin <> 1 + (dates (om/ (butlast (lonset accords)) 1000.0)) + (offsets (om/ (loffset accords) 1000.0)) + (durées (om* (ldur accords) muldur)) + (long (1- (length dates))) + ;(last-ev (- (nth long dates) (nth (1- long) dates))) + ; (dates (x-append dates (+ (last-elem dates ) last-ev) (+ (last-elem dates ) (* 2 last-ev)))) + ; ; ajout de deux dates pour le calcul de la dernière pente d'extinction + ; (offsets (x-append offsets (list (last-elem offsets) (last-elem offsets)))) ; même raison + (attaques (om+ offsets dates)) + (attaques (om- attaques (list-min (list-min attaques)))) ; pour commencer le temps à 0 + (space (case spatia + (frq (spatia-freq frqs 0 1)) + (midic (spatia-freq (lmidic accords) 0 1)) + (rotor (spatia-rotor frqs 0 1)) + (alea (spatia-alea frqs 0 1)))) + (fin (+ (last-elem dates) (list-max (last-elem durées))))) + + (when nom + (with-open-file (file nom :direction :output + :if-exists :supersede) + + (format file "f1 0 1024 10 ~{~8,4F~} ~%~%" (spectre->fct spectre) ) + + (for (i 0 1 long) + (for (k 0 1 (1- (length (nth i frqs)))) + (format file "i1" ) + (format file "~8,3F" (* (nth k (nth i attaques)) (+ 1 (/ (om-random (- alea) + (float alea)) 100)) )) ; dates + (format file "~8,3F" (nth k (nth i durées)) ) ; durées + (format file "~9,4F" (nth k (nth i amps)) ) ; amps + (format file "~9,2F" (nth k (nth i frqs)) ) ; freqs + ; (format file "~8,3F" (* tuile (- (nth (+ 2 i) dates) (nth (1+ i) dates))) ) ; pentes + (format file "~8,2F" (nth k (nth i space)) ) + (princ #\newline file) )) + + (princ #\e file))) + (format t "fichier ~A écrit - durée ~8,3F ~%" nom fin) ) + nil) + + +;------------------------------------chord->gran-sco---------------------------------------------------- + +(om::defmethod! chord->ord-sco ((accord chord) + (muldur number) + (mulamp number) + (mulmin number) + (alea number) + (spatia symbol) + (fichier list) + (spectre list)) + + + + :initvals (list t 1 .5 1 0 "frq" 'nil '((1) (1))) + :indoc '("accord" "muldur" "mulamp" "mulmin" "alea" "spatia" "fichier" "spectre" ) + :menuins '((5 (("frq" 'frq) + ("midic" 'midic) + ("alea" 'alea)))) + :icon 132 + :doc "écriture d'une partition ordinaire à partir d'un accord +les durées seront celles de l'accord, multipliées par muldur +mulamp = scaling des amp : si mulamp = 1, somme des amp de chaque accord = 1 +(fct ''deformer%'' : si ?amp < 50 : creuse les écarts) +table d'onde; par défaut, onde sinus +format spectre : ( (rangs harm) (intensités))" + + + (let* ((nom (if (equal fichier 'nil) (choose-new-file-dialog ) fichier)) + (muldur (/ muldur 1000)) + (frqs (mc->f (lmidic accord))) + (amps (lvel accord)) + (maxamp (list-max (list-max amps))) + (minamp (list-min (list-min amps))) + (amps (om-round (om-scale amps (* minamp mulmin) maxamp minamp maxamp) 4)) ; redresser + ; courbe des amp si mulmin <> 1 + (amps (om* (om/ amps (list-max (l-sum amps))) mulamp)) ; somme des amps = 1 * mulamp + (offsets (om/ (loffset accord) 1000)) + (durées (om* (ldur accord) muldur)) + (attaques (om- offsets (list-min offsets))) + (fin (list-max (om+ offsets durées))) ; pour commencer le temps à 0 + (space (case spatia + (frq (spatia-freq1 frqs)) + (midic (spatia-freq1 (lmidic accord))) + (alea (spatia-alea1 frqs))))) + + + (when nom + (with-open-file (file nom :direction :output + :if-exists :supersede) + + (format file "f1 0 1024 10 ~{~8,4F~} ~%~%" (spectre->fct spectre) ) + + (for (i 0 1 (1- (length frqs))) + (format file "i1" ) + (format file "~8,3F" (* (nth i attaques) (+ 1 (/ (om-random (- alea) + (float alea)) 100)) )) ; dates + (format file "~8,3F" (nth i durées)) ; durées + (format file "~9,4F" (nth i amps)) ; amps + (format file "~9,2F" (nth i frqs)) ; freqs + (format file "~8,2F" (nth i space) file) + (princ #\newline file) ) + + (princ #\e file))) + (format t "fichier ~A écrit - durée ~8,3F ~%" nom fin) ) + nil) + +;--------------------------------------------STEREO-SCO------------------------------------------ + +(om::defmethod! stereo-sco ((dates list) + (durs number) + (frqs list) + (amps list) + (alea number) + (spatia list) + (fichier symbol) + (spectre list)) + + :initvals (list '(1 2) 1 '(1 2) '(1 2) 0 '(1 2) 'nil '((1) (1) )) + :indoc '("dates" "tuile" "frqs" "amps" "alea" "spatia" "fichier" "spectre") + :icon 132 + :doc "Žcriture d'une partition normale (non granulaire) stereo avec +table d'onde ˆ partir de listes (dates,durs, freqs, amps, spatia) +(il s'agit d'une sŽquence d'accords) +format spectre : ( (rangs harm) (intensitŽs))" + + + (let* ((nom (if (equal fichier 'nil) (choose-new-file-dialog ) fichier)) + (long (1- (length dates))) + (last-ev (- (nth long dates) (nth (1- long) dates))) + (dates (x-append dates (+ (last-elem dates ) last-ev) )) + (accords? (consp (first frqs)))) + + (when nom + (with-open-file (file nom :direction :output + :if-exists :supersede) + + (format file "f1 0 1024 10 ~{~8,4F~} ~%~%" (spectre->fct spectre) ) + + + (if accords? + + (for (i 0 1 long) + (for (k 0 1 (1- (length (nth i frqs)))) + + (format file "i1" ) + (format file "~8,3F" (* (nth i dates) (+ 1 (/ (om-random (- alea) + (float alea)) 100)) )) ; dates + (format file "~8,3F" (nth k (nth i durs)) ) ; durŽes + (format file "~9,4F" (nth k (nth i amps)) ) ; amps + (format file "~9,2F" (nth k (nth i frqs)) ) ; freqs + (format file "~8,2F" (nth k (nth i spatia)) ) + (princ #\newline file) )) + + (for (i 0 1 long) + (format file "i1" ) + (format file "~8,3F" (* (nth i dates) (+ 1 (/ (om-random (- alea) + (float alea)) 100)) )) ; dates + (format file "~8,3F" (nth i durs)) ; durŽes + (format file "~9,4F" (nth i amps)) ; amps + (format file "~9,2F" (nth i frqs)) ; freqs + (format file "~8,2F" (nth i spatia)) + (princ #\newline file) ) + ) + + (princ #\e file))) + + (format t "fichier ~A Žcrit ~%" nom)) + nil) + +;--------------------------------------------granatt-st-sco----------------------------------- + + +; nouvelle fct incluant modif de LP + +(om::defmethod! granatt-st-sco-arp ((dates list) + (tuile number) + (frqs list) + (amps list) + + (spatia list) + (fichier list) + (spectre list)) + + :initvals (list '(1 2) 1 '(1 2) '(1 2) '(1 2) 'nil '((1) (1) )) + :indoc '("dates" "tuile" "frqs" "amps" "spatia" "fichier" "spectre") + :icon 132 + :doc "Žcriture d'une partition granulaire avec attaque +avec table d'onde; par dŽfaut, onde sinus +format spectre : ( (rangs harm) (intensitŽs)) +l'attaque utilise ins1, le reste ins2" + + + (let* ((nom (if (equal fichier 'nil) (choose-new-file-dialog ) fichier)) + (long (1- (length dates))) + (last-ev (- (nth long dates) (nth (1- long) dates))) + (dates (x-append dates (+ (last-elem dates ) last-ev) (+ (last-elem dates ) + (* 2 last-ev)))) + + (dates (om- dates (first dates))) + (dur0 (* tuile (second dates) )) + (fin (+ (last-elem dates) last-ev))) + + + (when nom + (with-open-file (file nom :direction :output + :if-exists :supersede) + + (format file "f1 0 1024 10 ~{~8,4F~} ~%~%" (spectre->fct spectre) ) + +;------- premier Žchantillon (attaque directe) ------- + (format t "fentres : 1 ") + (for (k 0 1 (1- (length (first frqs)))) + (format file "i1" ) + (format file "~8,3F" 0.00) ; date + (format file "~8,3F" dur0) ; durŽe + (format file "~9,4F" (nth k (first amps)) ) ; amps + (format file "~9,2F" (nth k (first frqs)) ) ; freqs + (format file "~8,3F" dur0) ; pente + (format file "~8,2F" (nth k (first spatia)) ) + (princ #\newline file) ) + +;------- suite des Žchantillons ---------- + + (for (i 1 1 long) + (if (= (mod i 10) 0) (format t " ~A " i) ) + + (let* ((dati (nth i dates)) + (nextdati (nth (1+ i) dates)) + (pentedroite (* tuile (- (nth (1+ i) dates) dati))) + (pentegauche (* tuile (- dati (nth (1- i) dates)))) + (nextpentegauche (* tuile (- nextdati dati))) + (pentegauche (min dati pentegauche )) + (nextpentegauche (min nextdati nextpentegauche )) + (duri (+ pentegauche pentedroite)) + (attaque (- dati pentegauche)) + (nextattaque (- nextdati nextpentegauche)) + + + newdate) + + (for (k 0 1 (1- (length (nth i frqs)))) + + (format file "i2" ) + + (setf newDate (+ attaque (* (/ k (length (nth i frqs))) (- nextattaque attaque)))) + (format file "~9,4F" newDate) ; dates + (format file "~9,3F" duri ) ; durŽes + (format file "~9,4F" (nth k (nth i amps)) ) ; amps + (format file "~9,2F" (nth k (nth i frqs)) ) ; freqs + (format file "~9,3F" pentedroite ) + (format file "~8,2F" (nth k (nth i spatia)) ) + (princ #\newline file) ))) + + (princ #\e file))) + + (format t "~% fichier ~A Žcrit - durŽe ~8,3F ~%" nom fin)) + nil) + + + + +(om::defmethod! granatt-st-sco ((dates list) + (tuile number) + (frqs list) + (amps list) + (alea number) + (spatia list) + (fichier list) + (spectre list)) + + :initvals (list '(1 2) 1 '(1 2) '(1 2) 0 '(1 2) 'nil '((1) (1) )) + :indoc '("dates" "tuile" "frqs" "amps" "alea" "spatia" "fichier" "spectre") + :icon 132 + :doc "Žcriture d'une partition granulaire avec attaque +avec table d'onde; par dŽfaut, onde sinus +format spectre : ( (rangs harm) (intensitŽs)) +l'attaque utilise ins1, le reste ins2 +offset: le son peut dŽmarrer aprs un dŽlai" + + + (let* ((nom (if (equal fichier 'nil) (choose-new-file-dialog ) fichier)) + (long (1- (length dates))) + (last-ev (- (nth long dates) (nth (1- long) dates))) + (dates (x-append dates (+ (last-elem dates ) last-ev) (+ (last-elem dates ) + (* 2 last-ev)))) + + (dates (om- dates (first dates))) + (dur0 (* tuile (second dates) )) + (fin (+ (last-elem dates) last-ev)) + ) + + (when nom + (with-open-file (file nom :direction :output + :if-exists :supersede) + + (format file "f1 0 1024 10 ~{~8,4F~} ~%~%" (spectre->fct spectre) ) + +;------- premier Žchantillon (attaque directe) ------- + (format t "fentres : 1 ") + (for (k 0 1 (1- (length (first frqs)))) + (format file "i1" ) + (format file "~8,3F" 0.00) ; date + (format file "~8,3F" dur0) ; durŽe + (format file "~9,4F" (nth k (first amps)) ) ; amps + (format file "~9,2F" (nth k (first frqs)) ) ; freqs + (format file "~8,3F" dur0) ; pente + (format file "~8,2F" (nth k (first spatia)) ) + (princ #\newline file) ) + +;------- suite des Žchantillons ---------- + + (for (i 1 1 long) + (format t " ~A " (1+ i) ) + + (let* ((dati (nth i dates)) + (pentedroite (* tuile (- (nth (1+ i) dates) dati))) + (pentegauche (* tuile (- dati (nth (1- i) dates)))) + (pentegauche (min dati pentegauche )) + (duri (+ pentegauche pentedroite)) + (attaque (- dati pentegauche)) ) + + (for (k 0 1 (1- (length (nth i frqs)))) + + (format file "i2" ) + (format file "~8,3F" (* attaque (+ 1 (/ (om-random (- alea) + (float alea)) 1000)) )) ; dates + (format file "~8,3F" duri ) ; durŽes + (format file "~9,4F" (nth k (nth i amps)) ) ; amps + (format file "~9,2F" (nth k (nth i frqs)) ) ; freqs + (format file "~8,3F" pentedroite ) + (format file "~8,2F" (nth k (nth i spatia)) ) + (princ #\newline file) ))) + + (princ #\e file))) + + (format t "~% fichier ~A Žcrit - durŽe ~8,3F ~%" nom fin)) + nil) + + +;----------------------------------voix-granatt---------------------------------------- + +(om::defmethod! voix-granatt ((dates list) + (tuile number) + (frqs list) + (amps list) + (alea number) + (spatia list) + (offset number)) + + :initvals (list '(1 2) 1 '(1 2) '(1 2) 0 '(1 2) 0) + :indoc '("dates" "tuile" "frqs" "amps" "alea" "spatia" "offset") + :icon 132 + :doc "fabrication d'une voix de partition granulaire avec attaque +permet polyphonie de sons; offset donne le dŽlai d'attaque de la voix +brancher dans poly-granatt-sco" + + + + + (let* ((long (1- (length dates))) + (last-ev (- (nth long dates) (nth (1- long) dates))) + (dates (x-append dates (+ (last-elem dates ) last-ev) (+ (last-elem dates ) + (* 2 last-ev)))) + (dates (om- dates (first dates))) + (dur0 (* tuile (second dates) )) + (fin (+ (last-elem dates) last-ev offset)) + attaques durees pentesdroites ) + + ;------- premier Žchantillon (attaque directe) ------- + + + (push (create-list (length (first frqs)) offset) attaques) + (push dur0 durees) + (push dur0 pentesdroites) + + ;------- suite des Žchantillons ---------- + + (for (i 1 1 long) + (let* ((dati (nth i dates)) + (pentedroite (* tuile (- (nth (1+ i) dates) dati))) + (pentegauche (* tuile (- dati (nth (1- i) dates)))) + (pentegauche (min dati pentegauche )) + (attaque (- dati pentegauche)) + attaqui ) + + (for (k 0 1 (1- (length (nth i frqs)))) + (push (+ offset (* attaque (+ 1 (/ (om-random (- alea) + (float alea)) 1000)) )) attaqui) ; dates soumises ˆ alŽa + ) ; (donc diffŽrentes pour chaque partiel) + + ;(push (nreverse attaqui) attaques) + (push attaqui attaques) ; l'ordre n'a pas d'importance puisque c'est alŽatoire + (push (+ pentegauche pentedroite) durees ) + (push pentedroite pentesdroites ) ) ) + + (list (nreverse attaques) (nreverse durees) amps frqs (nreverse pentesdroites) + spatia fin) + )) ; durees et pentesdroites sont des listes simples (chaque fentre a les mmes + ; valeurs) - les autres sont des listes de listes (chaque partiel est diffŽrent) + +;----------------------------------poly-granatt-sco--------------------------------------- + +(om::defmethod! poly-granatt-sco ((fichier list) + (spectre list) + (son1 list) + (son2 list) + &rest sons) + + :initvals (list nil '((1)(1)) nil nil nil) + :indoc '("fichier" "spectre" "son1" "son2" "sons") + :icon 132 + :doc "Žcriture d'une partition polyphonique granulaire avec attaque +avec table d'onde; par dŽfaut, onde sinus - format spectre : ( (rangs harm) (intensitŽs)) +l'attaque utilise ins1, le reste ins2 +composition des listes ''sons'' : attaques durŽes amps freqs pentesdroites spatias fin +" + + + + (let* ((nom (if (equal fichier 'nil) (choose-new-file-dialog ) fichier)) + + (sons (x-append (if (null son2) son1 (list son1 son2 )) sons)) + (fin (list-max (mapcar 'seventh sons))) + (compte 0)) + + (when nom + (with-open-file (file nom :direction :output :if-exists :supersede) + + (format file "f1 0 1024 10 ~{~8,4F~} ~%~%" (spectre->fct spectre) ) + + ; ====== boucle des sons ====== + + (dolist ( s sons) + (setq compte (1+ compte)) + (let ((long (1- (length (second s))))) + (format t "~%") + (format t "son ~A - fentres: " compte ) + + ; ---- boucle des fentres de chaque son ---- + (for (i 0 1 long) + (let ((instr (if (= i 0) "i1" "i2")) + (longfenetre (1- (length (nth i (fourth s)))))) + (format t "- ~A " i) + + (for (k 0 1 longfenetre) + (format file instr) + (format file "~8,3F" (nth k (nth i (first s)) )) ; date + (format file "~8,3F" (nth i (second s))) ; durŽe + (format file "~9,4F" (nth k (nth i (third s)) )) ; amps + (format file "~9,2F" (nth k (nth i (fourth s)))) ; freqs + (format file "~8,3F" (nth i (fifth s))) ; pente + (format file "~8,2F" (nth k (nth i (sixth s))) ) + (princ #\newline file) ))) ) + + (princ #\newline file) ) + + (princ #\e file))) + + (format t "~% fichier ~A Žcrit - durŽe ~8,3F ~%" nom fin)) + nil) + + + +;----------------------------------voix-granul---------------------------------------------- + +; .............. polyphonie en construisant d'abord une ou plusieurs voix +; .............. puis en les regroupant pour les Žcrire dans poly-granul-sco +; .............. ceci ne marche que pour peu de voix, ou pour des sons courts +; .............. ( crŽe de longues listes intermŽdiaires) + +(om::defmethod! voix-granul ((dates list) + (tuile number) + (frqs list) + (amps list) + (alea number) + (spatia list) + (offset number)) + + :initvals (list '(1 2) 1 '(1 2) '(1 2) 0 '(1 2) 0) + :indoc '("dates" "tuile" "frqs" "amps" "alea" "spatia" "offset") + :icon 132 + :doc "fabrication d'une voix de partition granulaire sans attaque +permet polyphonie de sons; offset donne le dŽlai d'attaque de la voix +brancher dans poly-granul-sco" + + + + (let* ((long (1- (length dates))) + (last-ev (- (nth long dates) (nth (1- long) dates))) + (dates (x-append dates (+ (last-elem dates ) last-ev) (+ (last-elem dates ) + (* 2 last-ev)))) + (dates (om- dates (first dates))) + (dur0 (* tuile (second dates) )) + + (fin (+ (last-elem dates) last-ev offset)) + attaques durees pentesdroites ) + + ;------- premier Žchantillon ------- + + + (push dur0 durees) + (push dur0 pentesdroites) + (let ((dat0 (- offset (* 2 dur0))) attaq0 ) + (for (k 0 1 (1- (length (first frqs)))) + (push (* dat0 (+ 1 (/ (om-random (- alea) (float alea)) 1000)) ) attaq0)) + (push attaq0 attaques)) + + ;------- suite des Žchantillons ---------- + + (for (i 1 1 long) + (let* ((dati (nth i dates)) + (pentedroite (* tuile (- (nth (1+ i) dates) dati))) + (pentegauche (* tuile (- dati (nth (1- i) dates)))) + ;(pentegauche (min dati pentegauche )) + (attaque (- dati pentegauche)) + attaqui ) + + (for (k 0 1 (1- (length (nth i frqs)))) + (push (+ offset (* attaque (+ 1 (/ (om-random (- alea) + (float alea)) 1000)) )) attaqui) ; dates soumises ˆ alŽa + ) ; (donc diffŽrentes pour chaque partiel) + + (push attaqui attaques) + (push (+ pentegauche pentedroite) durees ) + (push pentedroite pentesdroites ) ) ) + + (list (om- (nreverse attaques) (list-min (first attaques))) + (nreverse durees) amps frqs (nreverse pentesdroites) + spatia fin) + )) ; durees et pentesdroites sont des listes simples (chaque fentre a les mmes + ; valeurs) - les autres sont des listes de listes (chaque partiel est diffŽrent) + + + +;-----------------------------poly-granul-sco----------------------------------------------- + + +(om::defmethod! poly-granul-sco ((fichier list) + (spectre list) + (son1 list) + (son2 list) + &rest sons) + + :initvals (list nil '((1)(1)) nil nil nil) + :indoc '("fichier" "spectre" "son1" "son2" "sons") + :icon 132 + :doc "Žcriture d'une partition polyphonique granulaire sans attaque +avec table d'onde; par dŽfaut, onde sinus - format spectre : ( (rangs harm) (intensitŽs)) +composition des listes ''sons'' : attaques durŽes amps freqs pentesdroites spatias fin +" + + + + (let* ((nom (if (equal fichier 'nil) (choose-new-file-dialog ) fichier)) + + (sons (x-append (if (null son2) son1 (list son1 son2 )) sons)) + (fin (list-max (mapcar 'seventh sons))) + ( compte 0)) + + (when nom + (with-open-file (file nom :direction :output :if-exists :supersede) + + (format file "f1 0 1024 10 ~{~8,4F~} ~%~%" (spectre->fct spectre) ) + +; ====== boucle des sons ====== + + (dolist ( s sons) + (setq compte (1+ compte)) + (let ((long (1- (length (second s))))) + (format t "~%") + (format t "son ~A - fenetres: " compte ) + + ; ---- boucle des fentres de chaque son ---- + (for (i 0 1 long) + (let ((longfenetre (1- (length (nth i (fourth s)))))) + (format t "- ~A " i) + + (for (k 0 1 longfenetre) + (format file "i1") + (format file "~8,3F" (nth k (nth i (first s)) )) ; date + (format file "~8,3F" (nth i (second s))) ; durŽe + (format file "~9,4F" (nth k (nth i (third s)) )) ; amps + (format file "~9,2F" (nth k (nth i (fourth s)))) ; freqs + (format file "~8,3F" (nth i (fifth s))) ; pente + (format file "~8,2F" (nth k (nth i (sixth s))) ) + (princ #\newline file) ))) ) + + (princ #\newline file) ) + + (princ #\e file))) + + (format t "~% fichier ~A Žcrit - durŽe ~8,3F ~%" nom fin)) + nil) + + + +; .................................................................................. + + +; crŽation de partitions polyphoniques en Žcrivant directement le fichier +; ˆ partir d'une analyse, et d'un accord qui contient les donnŽes +; (hauteur, durŽe, ampli, offset) + + + +; vŽrifier poly-spatia-rotor + +(defun poly-spatia-rotor (num frq min max ) + (let ((frq (om-round (om-scale frq min max ) 2)) + ) + (permut-circ frq num))) + + + + +(defun poly-spatia-alea (frq gauche droite ) + (let ((res)) + (repeat (length frq) + (push (random 100.0) res)) + (om-round (om-scale res gauche droite) 2))) + + + +(defun poly-spatia (num frq spatia mode minn maxn) + (let* ((frq (if (= 1 mode) frq (f->mc frq))) + (res (cond ((= spatia 1) (spatia-freq frq minn maxn)) + ((= spatia 2) (poly-spatia-rotor num frq minn maxn)) + ((= spatia 3) (poly-spatia-alea frq minn maxn))))) + res)) + +;----------------------------chord->polygranul--------------------------------------------- + +; Note on posn-match: +; In PW the second argument is a list or an atom. +; In OM it is only a list +; There's another way to use it with an atom by using do-posn-match +; So Om team must decide, wether to create a new method +; for posn-match accepting as a second argument an atom. + +(om::defmethod! chord->polygranul ((fichier list) + (accord chord) + (analyse list) + (tuile number) + (alea number) + (fqfond number) + (spatia symbol) + (mode symbol) + (minspa number) + (maxspa number) + (spectre list) + (debut symbol) + (limite number)) + + + :initvals (list nil t '(1 2) 1 0 440 'pitch 'midic 0 1 '((1) (1)) 'doux 22000) + :indoc '("fichier" "chord" "analyse" "tuile" + "alea" "fqfond" "spatia" "mode" + "minspa" "maxspa" "spectre" "dŽbut" "limite") + :menuins '((6 (("pitch" 'pitch) + ("rotor" 'rotor) + ("alea" 'alea))) + (7 (("midic" 'midic) + ("frq" 'frq))) + (11 (("doux" 'doux) + ("percu" 'percu)))) + :icon 132 + :doc " construit une sŽquence de sons resynthŽtisŽs selon les donnŽes d'analyse + (composition des listes : dates freqs amps) + chaque son est transposŽ, dŽcalŽ, et modulŽ en amplitude selon les +hauteurs, offsets et vŽlo. des notes de +fqfond: fond estimŽe de l'analyse +minspa, maxspa : valeurs min et max de spatia (entre 0 et 1) - peuvent tre des +listes (de longueur = ˆ nb fentres) +mode : la spatia peut tre proportionnelle aux midic ou aux freq +spectre; par dŽfaut, onde sinus - format spectre : ( (rangs harm) (intensitŽs)) +dŽbut : le son peut dŽbuter avec pente douce ou tel qu'il est dans l'analyse (percu) +utiliser gran-st ou granatt-st respectivement +limite: fq maximale (pour Žviter repliement) +" + + + (let* ((spatia (case spatia + (pitch 1) + (rotor 2) + (alea 3))) + (mode (case mode + (midic 1) + (frq 2))) + (debut (case debut + (doux 1) + (percu 2))) + + (nom (if (equal fichier 'nil) (choose-new-file-dialog ) fichier)) + (lnotes (inside accord)) ; ATTENTION ici il faut garder les notes en tant qu'objet pour le traitement plutard + (longnotes (1- (length lnotes))) + (datanal (first analyse)) ; liste des dates fentres d'analyse + (datanal (om- datanal (first datanal))) ; pour commencer ˆ 0 + (nbfen (1- (length datanal))) + (last-ev (- (nth nbfen datanal) (nth (1- nbfen) datanal))) + (duranal (+ (last-elem datanal ) last-ev)) ; durŽe analyse (extrapol dernire fen) + (datanal (x-append datanal duranal (+ duranal last-ev))) + + (offsets (om/ (loffset accord) 1000)) + (durees (om/ (ldur accord 3) 1000)) + + ; (first-dur (list-max (do-posn-match (durŽes (positions (offsets (list-min offsets))))))) + ; durŽe de la note qui appara”t en premier (de la + longue si plusieurs + ; apparaissent en mme temps) + ; (first-muldur (/ first-dur duranal)) ; mul durŽe 1e note + ; (first-pentegauche (* tuile (* first-ev first-muldur))) + (offsets (om- offsets (list-min offsets)) ) ; pour commencer ˆ 0 + + (fin (list-max (om+ offsets durees))) + ; estimation grossire durŽe son synthŽtisŽ (sans considŽrer tuilage) + ) + + (when nom + (with-open-file (file nom :direction :output :if-exists :supersede) + + (format file "f1 0 1024 10 ~{~8,4F~} ~%~%" (spectre->fct spectre) ) + +; ====== boucle des notes ====== + + (for (n 0 1 longnotes) + + (format t "~%") + (format t "note ~A - fentres: " (1+ n) ) + + (let* ((muldur (/ (nth n durees) duranal)) + (multuile (* muldur tuile)) ; rapport durŽe voulue/durŽe analy * tuilage + (offn (nth n offsets)) + (note (nth n lnotes)) + (transpo (/ (mc->f (midic note)) fqfond)) + (mulamp (/ (vel note) 100)) ; vel 100 considere comme val moyenne + ) + + ; ---- boucle des fenetres de chaque note ---- + + ;------- premier echantillon ------- + + (let* ((longfenetre (1- (length (first (second analyse))))) + (instrument (if (= debut 1) 2 1)) ;si dŽbut sans attaque i2 sinon i1 + (datedeb (if (= debut 1) offn (+ offn (* muldur (second datanal))))) + ; date : si le 1er echantillon est percussif + ; il debute en meme temps que le 2nd + (pente0 (* multuile (second datanal))) + (dur0 (if (= debut 1) (* 2 pente0) pente0)) + ; si dŽbut sans attaque il y a une pentegauche + ; (et on estime penteg = pented) sinon durŽe=pente + (mulampcorr (if (= debut 2) (* mulamp tuile) mulamp)) + ; nouveau !!! si dŽbut percussif, il faut renforcer le premier + ; Žchantillon proportionnellement au tuilage + (coefspa (poly-spatia 0 (first (second analyse)) spatia mode + (if (atom minspa) minspa (nth n minspa)) + (if (atom minspa) maxspa (nth n maxspa))))) + + (for (k 0 1 longfenetre) + (let ((partiel (* transpo (nth k (first (second analyse)))))) + (if (< partiel limite) + (progn + (format file "i~A" instrument) + (format file "~8,3F" datedeb ) + (format file "~8,3F" dur0) + (format file "~9,4F" (* mulampcorr (nth k (first (third analyse))))) ; amps + (format file "~9,2F" partiel) ; freqs + (format file "~8,3F" pente0 ) + (format file "~8,2F" (nth k coefspa) ) + (princ #\newline file) ))))) + + + ;------- suite des Žchantillons ---------- + + (for (i 1 1 nbfen) + (if (= (mod i 10) 0) (format t " ~A " i)) + + (let* ((longfenetre (1- (length (nth i (second analyse))))) + (dati (nth i datanal)) + (pentedroite (* multuile (- (nth (1+ i) datanal) dati))) + (pentegauche (* multuile (- dati (nth (1- i) datanal)))) + (duri (+ pentedroite pentegauche)) + (coefspa (poly-spatia i (nth i (second analyse)) spatia mode + (if (atom minspa) minspa (nth n minspa)) + (if (atom minspa) maxspa (nth n maxspa))))) + + (for (k 0 1 longfenetre) + (let ((partiel (* transpo (nth k (nth i (second analyse)))))) + (if (< partiel limite) + (progn + (format file "i2") + (format file "~8,3F" (+ offn (* muldur dati (+ 1 (/ (om-random (- alea) + (float alea)) 1000)) ))) ; date + (format file "~8,3F" duri) ; durŽe + (format file "~9,4F" (* mulamp (nth k (nth i (third analyse)) ))) ; amps + (format file "~9,2F" partiel) ; freqs + (format file "~8,3F" pentedroite) ; pente + (format file "~8,2F" (nth k coefspa) ) + (princ #\newline file) ))) ) )) ) + + (princ #\newline file) ) + + (princ #\e file))) + + (format t "~% fichier ~A Žcrit - durŽe ~8,3F ~%" nom fin)) + nil) + + + + + +; -------------------------------gran-st-sco-tab-------------------------------------- +; essai utilisation de tableaux + +(defun ll->tab (liste larg) + (let ((liste (complete-lliste liste larg nil)) (dim (list (length liste) larg))) + (make-array dim :initial-contents liste))) + +;A Verifier +(om::defmethod! gran-st-sco-tab ((dates list) + (tuile number) + (freqs list) + (amps list) + (alea number) + (spatia list) + (fichier list)) + + :initvals (list '(1 2) 1 '(1 2) '(1 2) 0 '(1 2) nil) + :indoc '("dates" "tuile" "frqs" "amps" "alea" "spatia" "fichier") + :icon 132 + :doc "" + + (let* ((nom (if (equal fichier 'nil) (choose-new-file-dialog ) fichier)) + (long (1- (length dates))) + (larg (list-max (mapcar 'length freqs))) + (last-ev (- (nth long dates) (nth (1- long) dates ))) + (dates (x-append dates (+ (last-elem dates ) last-ev) (+ (last-elem dates ) + (* 2 last-ev)))) + + (tdates (make-array (+ 3 long) :initial-contents dates)) + (tfreqs (ll->tab freqs larg)) + (tamps (ll->tab amps larg)) + (tspatia (ll->tab spatia larg))) + + (when nom + (with-open-file (file nom :direction :output + :if-exists :supersede) + + (format file "f1 0 1024 10 1 ~%~%") + + (for (i 0 1 long) + (for (k 0 1 (1- larg)) + (if (not (null (aref tfreqs i k))) + (progn + (format file "i1" ) + (format file "~8,3F" (* (aref tdates i) (+ 1 (/ (om-random (- alea) + (float alea)) 1000)) )) ; dates + (format file "~8,3F" (* tuile (- (aref tdates (+ 2 i)) (aref tdates i))) ) ; durŽes + (format file "~9,4F" (aref tamps i k)) ; amps + (format file "~9,2F" (aref tfreqs i k)) ; freqs + (format file "~8,3F" (* tuile (- (aref tdates (+ 2 i)) (aref tdates (1+ i))))) ; pentes + (format file "~8,2F" (aref tspatia i k) file) + (princ #\newline file) )))) + + (princ #\e file))) + + (format t "fichier ~A Žcrit ~%" nom)) + nil) + + +; ================================================================================================ + + + + +; ---------------------------------------------------------------------------------------------- + +(om::defmethod! format-suivi ((l-dates list) + (l-freqs list) + (l-amps list) + (tuilage number) + (extinct number) + (spectre list)) + + :initvals (list '(1 2) '(1 2) '(1 2) 1 1 '((1) (1))) + :indoc '("l-dates" "l-freqs" "l-amps" "tuilage" "extinct" "spectre") + :icon 132 + :doc "crŽe fichier pour text-win ; score pour instrument SUIVI " + + + + (let* ((nbcomp (1- (length (first l-freqs))) ) ; nb partiels + (nbechant (1- (length l-dates))) + (l-durs (om+ (x-append (x->dx l-dates) extinct) tuilage)) + (l-freqs (x-append l-freqs (list (last-elem l-freqs) ))) + (zeros (list (create-list (1+ nbcomp) 0))) + (l-amps (x-append l-amps zeros )) + (spectre (list! spectre)) + res) + + (push (format () "f1 0 1024 10 ~{ ~4F~} ~% ~%" spectre) res) + + + ;(push #\newline res) + + (for (i 0 1 nbechant) + (for (k 0 1 nbcomp) + (push + (format () "i1 ~6F ~6F ~6F ~6F ~6F ~6F ~6F" + (l-nth l-dates i) (l-nth l-durs i) + (l-nth (l-nth l-amps i) k) (l-nth (l-nth l-amps (1+ i)) k) + (l-nth (l-nth l-freqs i) k) (l-nth (l-nth l-freqs (1+ i)) k) + tuilage) res) + (push #\newline res)) + (push #\newline res)) + + (push #\e res) + + (nreverse res))) + + +(om::defmethod! write-suivi ((l-dates list) + (l-freqs list) + (l-amps list) + (tuilage number) + (extinct number) + (spectre list) + (fichier list)) + :initvals (list '(1 2) '(1 2) '(1 2) 1 1 '((1) (1)) nil) + :indoc '("l-dates" "l-freqs" "l-amps" "tuilage" "extinct" "spectre" "fichier") + :icon 132 + :doc "crŽe fichier sur disque ; score pour instrument SUIVI " + + + + + (let* ((nbcomp (1- (length (first l-freqs))) ) ; nb partiels + (nbechant (1- (length l-dates))) + (l-durs (om+ (x-append (x->dx l-dates) extinct) tuilage)) + (l-freqs (x-append l-freqs (list (last-elem l-freqs) ))) + (zeros (list (create-list (1+ nbcomp) 0))) + (l-amps (x-append l-amps zeros )) + (spectre (list! spectre)) + (nom (if (equal fichier 'nil) (choose-new-file-dialog ) fichier))) + + (when nom + (with-open-file (file nom :direction :output :if-exists :supersede) + + (format file "f1 0 1024 10 ~{ ~4F~} ~% ~%" spectre) + + (for (i 0 1 nbechant) + (for (k 0 1 nbcomp) + (format file "i1 ~6F ~6F ~6F ~6F ~6F ~6F ~6F ~%" + (l-nth l-dates i) (l-nth l-durs i) + (l-nth (l-nth l-amps i) k) (l-nth (l-nth l-amps (1+ i)) k) + (l-nth (l-nth l-freqs i) k) (l-nth (l-nth l-freqs (1+ i)) k) + tuilage)) + (princ #\newline file)) + + (princ #\e file)))) + (print "fichier Žcrit ")) + + +; ------ tentative de crŽer des suivis de partiels ˆ partir d'une liste d'accords qcq --- + + + + +(om::defmethod! wr-cree-suivi ((l-dates list) + (l-midics list) + (l-amps list) + (toler number) + (tuilage number) + (extinct number) + (spectre t) ; normalement list! + (fichier list)) + + :initvals (list '(1 2) '(1 2) '(1 2) 25 0.05 1.0 1 nil) + :indoc '("l-dates" "l-midics" "l-amps" "tolerance" "tuilage" "extinct" "spectre" "fichier") + :icon 132 + :doc "crŽe fichier sur disque ; score pour instrument SUIVI +crŽe un pseudo suivi de partiels ˆ partir d'une liste d'accords qcq + (cents) indique la dŽviation en freq en + ou - acceptŽe pour chaque partiel +ATTENTION : entrŽe en Midics " + + + (let* ((nbechant (1- (length l-dates))) + (l-durs (om+ (x-append (x->dx l-dates) extinct) (* 2 tuilage))) + (l-midics (x-append l-midics (list (last-elem l-midics) ))) ; crŽation donnŽes + (zeros (list (create-list (length (last-elem l-midics)) 0))) ; midi et amp pour + (l-amps (x-append l-amps zeros )) ; extinction + (resul (suivi-partiels l-midics l-amps nbechant toler)) + (l-freqs-fin (first resul)) + (l-amps-fin (second resul)) + (spectre (list! spectre)) + (nom (if (equal fichier 'nil) (choose-new-file-dialog ) fichier)) ) + + (when nom + (with-open-file (file nom :direction :output :if-exists :supersede) + + (format file "f1 0 1024 10 ~{ ~4F~} ~% ~%" spectre) + + (for (i 0 1 nbechant) + (for (k 0 1 (1- (length (l-nth l-midics i)))) + (format file "i1 ~6F ~6F ~6F ~6F ~6F ~6F ~6F ~%" + (l-nth l-dates i) (l-nth l-durs i) + (l-nth (l-nth l-amps i) k) (l-nth (l-nth l-amps-fin i) k) + (l-nth (l-nth (mc->f l-midics) i) k) (l-nth (l-nth l-freqs-fin i) k) + tuilage)) + (princ #\newline file)) + + (princ #\e file)))) + + (print "fichier Žcrit ")) + + + +; ------2e tentative de crŽer des suivis de partiels ˆ partir d'une liste d'accords qcq --- + + + +(om::defmethod! cree-suivi ((l-dates list) + (l-midics list) + (l-amps list) + (toler number) + (fade number) + (tuilage number) + (attaque number) + (extinct number) + (spectre t)) + + :initvals (list '(1 2) '(1 2) '(1 2) 25 .2 .05 0 1.0 1) + :indoc '("l-dates" "l-midics" "l-amps" "tolerance" "fade" "tuilage" "attaque" "extinct" "spectre") + :icon 132 + :doc "crŽe fichier pour text-win ; score pour instrument SUIVI +crŽe un pseudo suivi de partiels ˆ partir d'une liste d'accords qcq + (cents) indique la dŽviation en freq en + ou - acceptŽe pour chaque partiel + durŽe d'extinction des partiels non suivis ou d'apparition des partiels +nouveaux (pourcentage de la durŽe de l'Žchantillon de gauche) + tuilage des partiels suivis (durŽe fixe en sec) + durŽe d'extinction du dernier Žchantillon (sec) +ATTENTION : entrŽe en Midics " + + + + (let* ((nbechant (1- (length l-dates))) + (l-durs (x-append (x->dx l-dates) extinct) ) + (l-dates (om+ l-dates attaque)) + (l-midics (x-append l-midics (list (last-elem l-midics) ))) ; crŽation donnŽes + (zeros (list (create-list (length (last-elem l-midics)) 0))) ; midi et amp pour + (l-amps (x-append l-amps zeros )) ; extinction + (toler (* 2 toler)) + (spectre (list! spectre)) + res) + + (push (format () "f1 0 1024 10 ~{ ~4F~} ~% ~%" spectre) res) + +; ------- premier accord --------- + (let ((accord (first l-midics )) + (prochacc (second l-midics )) + (ampli (first l-amps)) (prochampli (second l-amps )) + (fadefin (* (first l-durs) fade))) + + (for (k 0 1 (1- (length accord))) ;---- boucle des notes --------- + (let* ((resul (suivi? (l-nth accord k) (l-nth ampli k) prochacc prochampli toler)) + (suiv (first resul )) + (dur (+ (if suiv (+ (first l-durs ) tuilage) (first l-durs )) attaque)) + (tuilfin (if suiv tuilage fadefin )) + (notefin (second resul)) + (ampfin (third resul))) + + (push (format () "i1 ~6F ~6F ~6F ~6F ~6F ~6F ~6F ~6F ~%" + 0 dur + (l-nth ampli k) ampfin + (mc->f (l-nth accord k) ) (mc->f notefin) + attaque tuilfin) res) ))) + (push #\newline res) + + (for (i 1 1 nbechant) ;=============== boucle des accords =================== + (let ((accord (l-nth l-midics i)) (precedacc (l-nth l-midics (1- i))) + (prochacc (l-nth l-midics (1+ i))) + (ampli (l-nth l-amps i)) (prochampli (l-nth l-amps (1+ i))) + (fadedeb (* (l-nth l-durs (1- i)) fade)) + (fadefin (* (l-nth l-durs i) fade))) + + (for (k 0 1 (1- (length accord))) ;---- boucle des notes --------- + (let* ((resul (suivi? (l-nth accord k) (l-nth ampli k) prochacc prochampli toler)) + (suiv (first resul )) + (nouv (nouvel? (l-nth accord k) precedacc toler)) + (date (if nouv (- (l-nth l-dates i) fadedeb) (l-nth l-dates i))) + (dur (if suiv (+ (l-nth l-durs i) tuilage) (l-nth l-durs i))) + (dur (if nouv (+ dur fadedeb) dur)) + (tuildeb (if nouv fadedeb tuilage)) + (tuilfin (if suiv tuilage fadefin )) + (notefin (second resul)) + (ampfin (third resul))) + + (push + (format () "i1 ~6F ~6F ~6F ~6F ~6F ~6F ~6F ~6F~%" + date dur + (l-nth ampli k) ampfin + (mc->f (l-nth accord k) ) (mc->f notefin) + tuildeb tuilfin) res) ) + ) + ) ;-------------------------------------------------- + (push #\newline res)) ; ========================================================= + + (push #\e res) + (nreverse res))) + + + + +(defun suivi? (note amp prochacc prochampli toler) + + (let* ((ecarts (om-abs (om- prochacc note))) + (ecartmin (list-min ecarts)) + (numcible (position ecartmin ecarts)) + (suivi? (< ecartmin toler)) + (notefin (if suivi? (l-nth prochacc numcible) note)) + (ampfin (if suivi? (l-nth prochampli numcible) amp))) + (list suivi? notefin ampfin))) + + +(defun nouvel? (note precedacc toler) + + (let ((ecartmin (list-min (om-abs (om- precedacc note))))) + (> ecartmin toler))) + + + + + + +; lecture d'un fichier d'analyse .chseq (markers) + +(om::defmethod! as-markers ((analyse list) + (fqmin number) + (fqmax number) + (*amp number)) + + :initvals (list '(1 2) 60 440 .5) + :indoc '("analyse" "fqmin" "fqmax" "*amp") + :icon 132 + :doc "convertit fichier d'analyse type markers-chseq +sortie : liste ((dates ) ((listes fq)) ((listes amps))) +les amps sont mises ˆ l'Žchelle - somme des amps=1 " + + + + (let* ((analyse (cddr (car analyse)) ) + (dates (mapcar 'third analyse)) + (fqs (mapcar 'fourth analyse)) + (amps (mapcar 'fifth analyse)) + + (res (band-multi-filter (list dates fqs amps) 1 fqmin fqmax 1)) + + (dates (om- (car res) (car (car res)))) + (datesdiff (unique-1 dates '= ) ) + + (lgdate (x->dx (x-append (car-mapcar 'position datesdiff dates) (length dates)))) + + ;(amps (om-scale (group-list (third res) lgdate 'linear) 0.001 1)) + ;(ampmax (list-max (l-sum amps))) + ;(amps (om-round (om* (om/ amps ampmax) *amp) 4))) + + (amps (om-scale (third res) 0.00 1)) + (amps (om* amps (g-exp (om* 2 amps))))) + + (list datesdiff (group-list (second res) lgdate 'linear) + (group-list amps lgdate 'linear)))) + + + + + + + +#| + +A Carlos a faire, car celˆ touche l'interface + + +;; ---------------------------------------------------------------------------------- + +;; ---------------------------------------------------------------------------------- + +;; ---------------------------------------------------------------------------------- +;; modif du format de sortie dans les text-windows (pas de notation exponentielle) +; pas de guillemets Žcrits dans text-window quand on utilise (format .....) +;modifications pour text-window ->> qlist (serge lemouton -- 7/06/93) +;cf file-buffer.lisp + + + +(defpackage "C-PATCH-FILE-BUFFER" + (:use "COMMON-LISP" "CCL") + (:import-from "PATCH-WORK" + "*TARGET-ACTION-OBJECT*" "NEW-MENU" "NEW-LEAFMENU" "MAKE-POPUPBOX" + "PATCH-VALUE" "H" "W" "C-PATCH" "PW-CONTROLS" "INPUT-OBJECTS" "LIST!" + "PW-FUNCTION-STRING" "DEFUNP" "COMPLETE-BOX" "REMOVE-YOURSELF-CONTROL") + (:export "C-PATCH-FILE-BUFFER")) + +(in-package "C-PATCH-FILE-BUFFER") + + +(defvar *lisp-win-option* t) + + +(defclass C-patch-ascii-buffer (C-patch-file-buffer) ()) + + + + +(defmethod add-to-file ((self C-patch-ascii-buffer) list format) + (if *lisp-win-option* + ; (call-next-method) + (let* ((list (list! list)) + (count 0) + (format (if (zerop format) (length list) format)) + (mark (fred-buffer + (if (not (and (fred-win self) (wptr (fred-win self)))) + (get-new self) (fred-win self))))) + (dolist (item list) + (buffer-insert mark (format nil " ~8F" item));modif serge + (if (zerop (rem (incf count) format)) + (buffer-insert mark (format nil ";~A" #\Return))))) + + (let* ((list (list! list)) + (count 0) + (format (if (zerop format) (length list) format)) + (mark (fred-buffer + (if (not (and (fred-win self) (wptr (fred-win self)))) + (get-new self) (fred-win self))))) + (dolist (item list) + (buffer-insert mark (format nil " ~A" item));modif serge + ;(buffer-insert mark (format nil " ~8F" item));modif serge + (if (zerop (rem (incf count) format)) + (buffer-insert mark (format nil "~%")))))) + ) +|# + + + diff --git a/sources/OM-functions.lisp b/sources/OM-functions.lisp new file mode 100644 index 0000000..43506e0 --- /dev/null +++ b/sources/OM-functions.lisp @@ -0,0 +1,169 @@ + +;;;=================== +;;; OM-Tristan +;;;=================== + +; new methods for existing OM functions +; !! compatibility + +(in-package :om) + +(defmethod* approx-m ((self chord) (approx number) &optional (ref-midic 0)) + (ch-modif self '= (approx-m (lmidic self) approx) 'lmidic) ) + +(defmethod* approx-m ((self chord-seq) (approx number) &optional (ref-midic 0)) + (ch-modif self '= (approx-m (lmidic self) approx) 'lmidic) ) + +(defmethod* approx-m ((self multi-seq) (approx number) &optional (ref-midic 0)) + (mki 'multi-seq + :chord-seqs (approx-m (chord-seqs self) approx))) + + +(defmethod* approx-m ((self multi-seq) (approx list) &optional (ref-midic 0)) + (mki 'multi-seq + :chord-seqs (double-mapcar 'approx-m (chord-seqs self) approx))) + + + +; pour multiseq - voir si ce n'est pas dangereux !!! +(defmethod ldur ((self multi-seq)) + (mapcar 'ldur (chord-seqs self))) + +(defmethod lvel ((self multi-seq)) + (mapcar 'lvel (chord-seqs self))) + +(defmethod lmidic ((self multi-seq)) + (mapcar 'lmidic (chord-seqs self))) + +(defmethod loffset ((self multi-seq)) + (mapcar 'loffset (chord-seqs self))) + +(defmethod lchan ((self multi-seq)) + (mapcar 'lchan (chord-seqs self))) + +(defmethod lonset ((self multi-seq)) + (mapcar 'lonset (chord-seqs self))) + +(defmethod lport ((self multi-seq)) + (mapcar 'lport (chord-seqs self))) + +(defmethod chords ((self multi-seq)) + (flat (mapcar 'chords (chord-seqs self)))) + + + +; om+ se comporte comme un transpositeur de midics +(defmethod om+ ((self container) (num number)) + (ch-modif self '+ num 'lmidic)) + + +; om* se comporte comme stretch +(defmethod om* ((self chord-seq) (num t)) + (seq-stretch self num )) + +(defmethod om* ((self multi-seq) (num number)) + (seq-stretch self num )) + +(defmethod om* ((self chord) (num t)) + (chord-stretch self num )) + + +(defmethod om* ((self multi-seq) (num list)) + (seq-stretch self num )) + + +; permet de crŽer des listes structurŽes +(defmethod create-list ((count list) (elem t)) + (loop for c in count + collect (create-list c elem))) + + + +; ajout des ports 2-10-03 - ajout de port-modif.pfsl dans dossier patches +; attention: +; arithm-ser (ordre paramtres changŽ) +;list-filter (param. differents), table-filter (fct differente) utiliser filtre-liste, multi-filter +; om-mean (n'accepte pas trees) utiliser tm-average + +; -------------------------------------------------------------------------------------- +; pour Žviter approximation au demi-ton dans align-chords +; pour Žviter que legato soit mis ˆ 100 dans align-chords et merger + + +#| + +(defun tm-make-quanti-chords (note-list delta) + (loop while note-list + for note = (car note-list) + with pitch-list and dur-list and offset-list and chan-list and vel-list + with base-time = (second (first note-list)) + if (<= (- (second (first note-list)) base-time) delta) + do + + (push (first note) pitch-list) + (push (third note) dur-list) + (push (fifth note) chan-list) + (push (fourth note) vel-list) + (push (- (second note) base-time) offset-list) + (pop note-list) + else + collect (mk-chord-at base-time pitch-list dur-list offset-list chan-list vel-list ) into result + and do (setf base-time (second note) pitch-list () dur-list () offset-list () chan-list () vel-list () ) + finally (return (append result (list (mk-chord-at base-time pitch-list dur-list offset-list chan-list vel-list )))))) + +(defmethod tm-chord-seq->mf-info ((self chord-seq)) + (loop for lpitch in (lmidic self) + for onset in (lonset self) + for ldur in (ldur self) + for lvel in (lvel self) + for loffset in (loffset self) + for lchan in (lchan self) + for lport in (lport self) + append (loop for pitch in lpitch + for dur in ldur + for vel in lvel + for offset in loffset + for chan in lchan + for port in lport + collect (list pitch (+ onset offset) dur vel chan port)) + )) + +(defmethod tm-mf-info->chord-seq ((self list)) + (let* ((chords (tm-make-quanti-chords self *global-deltachords*)) + (lonset (mapcar 'offset chords)) + (last-note (first (inside (first (last chords)))))) + (setf lonset (append lonset (list (+ (extent->ms last-note) (first (last lonset)))))) + (make-instance 'chord-seq + :lmidic chords + :lonset lonset + :legato 0 + ))) + +(defmethod tm-align-chordseq-chords ((self chord-seq)) + (align-offsets (tm-mf-info->chord-seq (tm-chord-seq->mf-info self)))) + + +;;; aligne les accords d'un chord-seq + +(defmethod! align-chords ((self chord-seq) (delta integer)) + :initvals (list (make-instance 'chord-seq) 100) + :indoc '("a chord-seq" "an integer") + :icon 230 + :doc "Transforms so that notes falling in a small time interval are grouped into a chord. + gives the time interval in ms +If delta = nil , align-chords does not act" + (let ((*global-deltachords* delta)) + (tm-align-chordseq-chords self))) + +|# + + +#| +(defmethod* merger ((chs1 chord-seq) (chs2 chord-seq)) + (let* ((mf (sort (nconc (tm-chord-seq->mf-info chs1) (tm-chord-seq->mf-info chs2)) + #'< :key #'second))) + (tm-mf-info->chord-seq mf))) +|# + + + diff --git a/sources/OMspdata.lisp b/sources/OMspdata.lisp new file mode 100755 index 0000000..c54f0b7 --- /dev/null +++ b/sources/OMspdata.lisp @@ -0,0 +1,1458 @@ +(in-package :om) +;---------------------------------------------------------------------- +;----------------------Primitives Le lisp removed from Om-------------- +;---------------------------------------------------------------------- +(defmacro rassq (item list) `(rassoc ,item ,list :test #'eq)) +;;;(defmacro cassq (item list) `(cdr (assq ,item ,list))) +(defmacro newl (lst elem) `(push ,elem ,lst)) + +(defmacro nextl (lst &optional symb) + (if symb + `(setq ,symb (pop ,lst)) + `(pop ,lst) )) + +(defmacro vref (vect index) `(svref ,vect ,index)) +(defmacro vset (vect index val) `(setf (svref ,vect ,index) ,val)) + +;; =============================================================================-====== + +(defmacro tell (outlet fun &rest args) + (let ((args-var (gensym "ARGS-")) (fun-var (gensym "FUN-"))) + (if args + `(let ((,args-var (list ,@args)) (,fun-var ,fun)) + (mapc #'(lambda (x) (apply ,fun-var x ,args-var)) ,outlet)) + `(mapc ,fun ,outlet)))) + +(defmacro ask (outlet fun &rest args) + (let ((args-var (gensym "ARGS-")) (fun-var (gensym "FUN-")) + (out-var (gensym "OUT-")) (result-var (gensym "RESULT-"))) + `(let ((,args-var (list ,@args)) (,fun-var ,fun) (,result-var nil)) + (dolist (,out-var ,outlet) + (when (setq ,result-var (apply ,fun-var ,out-var ,args-var)) + (return))) + ,result-var))) + +(defmacro ask-all (outlet fun &rest args) + (let ((args-var (gensym "ARGS-")) (fun-var (gensym "FUN-"))) + (if args + `(let ((,args-var (list ,@args)) (,fun-var ,fun)) + (mapcar #'(lambda (x) (apply ,fun-var x ,args-var)) ,outlet)) + `(mapcar ,fun ,outlet)))) + +;; =============================================================================-====== +;; The syntax is different from the Le_Lisp "with" + +(defmacro with (l-place-value &body body) + "Changes locally the value of \"setf-able\" places (like a \"let\" where places +would not be restricted to variables)." + (let ((places (mapcar #'first l-place-value)) + (values (mapcar #'second l-place-value)) + (vars (mapcar #'(lambda (pv) (declare (ignore pv)) (gensym "WITH-")) + l-place-value))) + `(let ,(mapcar #'list vars places) + (unwind-protect + (progn + ,.(mapcar #'(lambda (place value) `(setf ,place ,value)) places values) + ,.body) + ,.(mapcar #'(lambda (place var) `(setf ,place ,var)) places vars))))) + +;(let ((l '(a . b))) (with (((car l) 1) ((cdr l) 2)) (print l))) + +;; =============================================================================-====== +;;********************************************************************************************************** + +;; root class for spdata and spdata-seq +(defclass C-spd () + ((typ :initform () :initarg :typ :accessor typ) ; typ is addsyn, modres, iana + (file :initform () :initarg :file :accessor file) + (last-loaded-file :initform "root:" :accessor last-loaded-file :allocation :class) + (spd-debug :initform () :accessor spd-debug :allocation :class) + )) + + + +(defclass* C-spdata (C-spd) + ((size :initform 0 :initarg :size :accessor size) + (frame :initform 0 :initarg :frame :accessor frame) + (partials :initform () :initarg :partials :accessor partials) + (freqs :initform () :initarg :freqs :accessor freqs) + (amps :initform () :initarg :amps :accessor amps) + (normalized-amps :initform () :accessor normalized-amps) + (bws :initform () :initarg :bws :accessor bws) + (phases :initform () :initarg :phases :accessor phases) + (weights :initform () :initarg :weights :accessor weights) + (resfact :initform () :accessor resfact) + (patch :initform () :accessor patch) ; max patch modules; used by write-msgbox + ) + (:icon 139) + (:documentation "erer")) + + +(defmethod copy-spdata ((self C-spdata)) + (make-instance 'C-spdata :size (size self) :frame (frame self) + :partials (partials self) :freqs (freqs self) :amps (amps self) + :bws (bws self) :phases (phases self) :weights (weights self) + :typ (typ self) :file (file self)) +) + +(defclass* C-spdata-seq (C-spd) + ((duration :initform 0 :initarg :duration :accessor duration) + (spdata :initform () :initarg :spdata :accessor spdata) ;; list of time-tagged spectra + ) + (:icon 139) + (:documentation "erer")) + + + + +;from PW's kernel code +(defmacro until (condition &body body) + `(while (not ,condition) ,.body)) + + +(defvar *lastspfile* "root") + +;xxxxxxxxxxxxxxxxxxxxxxxxxxxxxwhats neededxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +;; =============================================================================-====== + +(defun synonym (new-fun old-fun) + "make symbol a synonym function of symbol " + (setf (symbol-function new-fun) (symbol-function old-fun)) + (setf (documentation new-fun 'function) (documentation old-fun 'function)) + new-fun ) + +(defun vector-to-list (vector) + "Takes the elements of a linear vector and collects them into a list." + (do ((list () (cons (aref vector index) list)) + (index (1- (length vector)) (1- index))) + ((< index 0) list))) + +#| +(defun vector-to-list1 (vector &aux (length (length vector)) (list ())) + "Takes the elements of a simple vector and collects them into a list." + (dotimes (index length) + (push (svref vector (decf length)) list)) + list ) + +(time (dotimes (i 10000) (vector-to-list #(a b c d)))) +(dotimes (i 10000) (vector-to-list #(a b c d))) took 205 ticks (3.417 seconds) to run. + +(time (dotimes (i 10000) (vector-to-list1 #(a b c d)))) +(dotimes (i 10000) (vector-to-list1 #(a b c d))) took 218 ticks (3.633 seconds) to run. +|# +;; =============================================================================-====== + +(defun compile-file? (file) + "Compiles only if needed." + (let* ((infile (merge-pathnames file "*.Lisp")) + (outfile (compile-file-pathname infile))) + (unless (and (probe-file outfile) + (> (file-write-date outfile) (file-write-date infile))) + (compile-file infile :output-file outfile :verbose t) ))) + +;; =============================================================================-====== + +(defun file-compareE () + (let* + ((file1 (oa::om-choose-file-dialog :button-string "Read 1st")) + (file2 (oa::om-choose-file-dialog :button-string "Read 2nd")) + (diffname (format () "~A/~A" (pathname-name file1) (pathname-name file2))) + (outfile + (oa::om-choose-new-file-dialog + :directory + (merge-pathnames (make-pathname :name diffname :type "diff") file2) + :prompt "Save difference as:" + :button-string "Save diff" ))) + (file-compare file1 file2 outfile))) + +(defun file-compare (file1 file2 outfile) + (with-open-file (output-stream outfile :direction :output :if-exists :supersede) + (let ((*package* *package*) l1 p1 l2 p2) + (multiple-value-setq (l1 p1) (read-lists-from file1)) + (multiple-value-setq (l2 p2) (read-lists-from file2)) + (cond + ((and (consp p1) (not (consp (cdr p1))) + (consp p2) (not (consp (cdr p2))) + (eq (first p1) (first p2))) + (setf *package* (first p1)) + (print `(in-package ,(package-name (first p1))) output-stream)) + (t (warn "~S has packages ~S, while~%~S has packages ~S." file1 p1 file2 p2))) + (list-compare l1 l2 output-stream)))) + +(defun read-lists-from (infile) + (with-open-file (input-stream infile :direction :input) + (let ((*package* *package*) (lists ()) (packages ()) read) + (until (eq :eof (setq read (read input-stream nil :eof))) + (when (and (listp read) (eq (first read) 'in-package)) + (newl packages (eval read))) + (newl lists read)) + (values (nreverse lists) (nreverse packages))))) + +(defun similar-exprs? (l1 l2) + (and (listp l1) (listp l2) (eq (first l1) (first l2)) + (listp (cdr l1)) (listp (cdr l2)) (eq (second l1) (second l2)))) + +(defun list-compare (l1 l2 &optional (out *standard-output*)) + (let (pl1 expr1 pl2) + (setq l1 (delete nil l1) + l2 (delete nil l2) + pl1 l1) + (format out "~%~%;; Equal expressions") + (while pl1 + (if (or (null (setq expr1 (first pl1))) + (not (setq pl2 (member expr1 l2 :test #'equal)))) + (pop pl1) + (progn + (print expr1 out) + (setf (car pl1) (cadr pl1) + (cdr pl1) (cddr pl1) + (car pl2) (cadr pl2) + (cdr pl2) (cddr pl2))))) + (format out "~%~%;; Similar expressions with differences") + (setq l1 (delete nil l1) + l2 (delete nil l2) + pl1 l1) + (while pl1 + (if (or (null (setq expr1 (first pl1))) + (not (setq pl2 (member expr1 l2 :test #'similar-exprs?)))) + (pop pl1) + (progn + (format out "~%~%;; - ~S" (second expr1)) + (print expr1 out) + (print (first pl2) out) + (setf (car pl1) (cadr pl1) + (cdr pl1) (cddr pl1) + (car pl2) (cadr pl2) + (cdr pl2) (cddr pl2))))) + (setq l1 (delete nil l1) + l2 (delete nil l2)) + (format out "~%~%;; Expressions of 1st list") + (mapc #'(lambda (e) (print e out)) l1) + (format out "~%~%;; Expressions of 2nd list") + (mapc #'(lambda (e) (print e out)) l2) + out)) + +;; =============================================================================-====== +;; Expression prefixer +;; See tests at the end + +;; ==== operation level ==== + +(defstruct + (level + (:print-function + (lambda (me stream depth) + (declare (ignore depth)) + (format + stream + "#" + (level-ops me) + (level-associative? me) + (level-dop me) + (level-iop me) + (level-l-op.tr me))))) + dop ;default operators + iop ;inverse operators + tr-default ;default operator translation + tr-inverse ;inverse operator translation + ops ;all operators + l-op.tr ;translations + associative?) + +(defun create-level (dop iop l-op.tr associative? &aux me ops) + "Create a level object from the specification of the default and inverse operators +and the associativity." + (unless (listp dop) (setq dop (list dop))) + (unless (listp iop) (setq iop (list iop))) + (setq me + (make-level + :dop dop + :iop iop + :ops (setq ops (remove-duplicates (append dop iop (mapcar #'car l-op.tr)))) + :l-op.tr l-op.tr + :associative? associative?)) + (setf (level-tr-default me) (level-translate me (car (level-dop me))) + (level-tr-inverse me) (level-translate me (car (level-iop me)))) + (mapc + #'(lambda (op) + (check-type op symbol) + (unless (eq (symbol-package op) #.(find-package "KEYWORD")) + (import op "COMMON-LISP") + (export op "COMMON-LISP"))) + ops) + me) + +(defun level-has? (me op) (memq op (level-ops me))) +(defun level-default? (me op) (memq op (level-dop me))) +(defun level-inverse? (me op) (memq op (level-iop me))) +(defun level-default (me) (first (level-dop me))) +(defun level-translate (me op) (or (cassq op (level-l-op.tr me)) op)) + +;; ==== globals and macros ==== + +(progn + (defvar *levels*) + (defvar *all-ops*) + + (setf *levels* + (list + (create-level '\; () '((\; . progn)) t) + (create-level ':= () '((:= . setq)) nil) + (create-level '(==) () '((== . =)) t) + (create-level '(!=) () '((!= . /=)) t) + (create-level '(>) () () t) + (create-level '(<) () () t) + (create-level '(>=) () () t) + (create-level '(<=) () () t) + (create-level '+ '- () t) + (create-level '* '/ () t) + (create-level '(** ) () '((** . expt) ) nil))) + + (setf *all-ops* (apply #'append (mapcar #'level-ops *levels*)))) + +(defvar *default-operation* '*) + +(eval-when (eval compile) + (defmacro operation? (op) `(memq ,op *all-ops*))) + +;; ==== help, user function and sharp macro character ==== + +(defun prefix-help () + "Describes the current levels of operations." + (format t "~&The current levels of operations are:") + (mapc 'print *levels*) + (values)) + +(defun prefix-expr (expr) + "Converts an (usually infixed) expression into a lisp (prefixed) expression. +Help on available operations can be obtained with (prefix-help)." + (cond + ((not (consp expr)) expr) + ((and (symbolp (first expr)) (fboundp (first expr))) + `(,(first expr) ,.(mapcar #'prefix-expr (rest expr)))) + (t (prefix-iexpr (test-syntax expr) *levels*)))) + +(set-dispatch-macro-character + #\# #\i + #'(lambda (stream char count) + (declare (ignore char count)) + (prefix-expr (read stream t nil t)))) ; maybe (CLtLII p548) + +;; ==== internals ==== +(defun sp-simplify (exprs ops level) + ;; (length exprs) = (length ops) + 1 + (cond + ;; only 1 elt + ((null ops) (first exprs)) + ;; not associative (** ^): left to right + ((not (level-associative? level)) + (let ((result (nextl exprs))) + (mapc + #'(lambda (op expr) + (setq result (list (level-translate level op) result expr))) + ops exprs) + result)) + ;; associative and only inverse (- /) + ((every #'(lambda (op) (level-inverse? level op)) ops) + `(,(level-tr-inverse level) ,.exprs)) + ;; associative operator (+ - * /): skip default operators (+ *) + ;; could use commutativity too... + (t `(,(level-tr-default level) + ,(nextl exprs) + ,.(mapcar + #'(lambda (op expr) + (if (level-default? level op) expr + (list (level-translate level op) expr))) + ops exprs))))) + + + +(defun prefix-iexpr (iexpr levels) + ;; iexpr == (expr op expr op ... expr) + (if (endp (rest iexpr)) + (prefix-expr (first iexpr)) + (let* ((exprs ()) + (ops ()) + (level (first levels)) + sub-iexpr) + (while iexpr + (setq sub-iexpr (list (nextl iexpr))) + (while (and iexpr (not (level-has? level (first iexpr)))) + (newl sub-iexpr (nextl iexpr)) + (newl sub-iexpr (nextl iexpr))) + (newl exprs (prefix-iexpr (nreverse sub-iexpr) (cdr levels))) + (when iexpr (newl ops (nextl iexpr)))) + (sp-simplify (nreverse exprs) (nreverse ops) level)))) + + + +(defun test-syntax (expr) + "1st level syntax test and completion with * when omitted." + (let ((orig-expr expr) + (result ()) + (operation? nil) + elt) + (while expr + (setq elt (first expr)) + (newl + result + (if operation? + (if (operation? elt) (nextl expr) *default-operation*) + (if (operation? elt) + (if (eq orig-expr expr) + (error + "Syntax: the infixed expression should not begin with an operation:~%~S" + orig-expr) + (error + "Syntax: The operations ~S and ~S should not be consecutive ~ + in the infixed expression:~%~S" + (first result) elt orig-expr)) + (nextl expr)))) + (setq operation? (not operation?))) + (unless operation? + (error "Syntax: the infixed expression should not end with an operation:~%~S" + orig-expr)) + (nreverse result))) + +;; ==== global and user function ==== + +(defvar *compile-num-lambda* t) + +;; (make-num-fun '(y := z - x \; y * z + y) nil ) +;; => '(lambda (x z) (let (y) (progn (setq y (- z x)) (+ (* y z) y)))) +;; but +;; (make-num-fun '(f(z x)= y := z - x \; y * z + y) nil) +;; => '(lambda (z x) (let (y) (progn (setq y (- z x)) (+ (* y z) y)))) + +(defun make-num-fun (fexpr) + "Creates a lisp function object from the \"functional\" expr which is +basically an infixed expression (see prefix-expr and prefix-help). +When begins with something like (f(x)= ...), the formal arguments are taken +from the given list, otherwise they are deduced from the body of and collected +in the order they appear in it. +Local variables are automatically handled. +The resulting function is compiled when the value of *compile-num-lambda* is T (default)." + ;; fexpr == || ( = . ) + (multiple-value-bind (lambda name) (make-num-lambda fexpr) + (if *compile-num-lambda* + (compile name lambda) + lambda))) + +(defun make-num-lambda (fexpr) + "Creates a lisp function object from the \"functional\" expr which is +basically an infixed expression (see prefix-expr and prefix-help). +When begins with something like (f(x)= ...), the formal arguments are taken +from the given list, otherwise they are deduced from the body of and collected +in the order they appear in it. +Local variables are automatically handled. +The resulting function is a lambda list not compiled." + ;; fexpr == || ( = . ) + (let ((=? (and (consp fexpr) (consp (cdr fexpr)) (consp (cddr fexpr)) + (symbolp (first fexpr)) + (listp (second fexpr)) + (eq '= (third fexpr)))) + (name ()) args expr rvars wvars) + (when =? + (setq name (nextl fexpr) args (nextl fexpr)) + (nextl fexpr)) + (setq expr (prefix-expr fexpr)) + (multiple-value-setq (rvars wvars) + (if =? (rw-vars expr args) (rw-vars expr))) + (values + `(lambda ,rvars ,(if wvars `(let ,wvars ,expr) expr)) + name))) + +;; ==== internals ==== + +(defun rw-vars (expr &optional (args () args-p)) + (let ((*rvars* (reverse args)) (*wvars* ())) + (declare (special *rvars* *wvars*)) + (rw-vars-expr expr) + (setq *rvars* (nreverse *rvars*)) + (when (and args-p (not (equal args *rvars*))) + (warn "Found other free variables ~S not in ~S~%in expression ~S." + (set-difference *rvars* args) args expr) + (setq *rvars* args)) + (values *rvars* *wvars*))) + +(defun rw-vars-expr (expr) + (declare (special *rvars* *wvars*)) + (cond + ((null expr)) + ((and (symbolp expr) (not (constantp expr))) + (unless (or (memq expr *rvars*) (memq expr *wvars*)) + (newl *rvars* expr))) + ((not (consp expr))) + ((eq 'setq (car expr)) + (mapc #'rw-vars-expr (cddr expr)) + (unless (or (memq (second expr) *rvars*) (memq (second expr) *wvars*)) + (newl *wvars* (second expr)))) + (t (mapc #'rw-vars-expr (cdr expr))))) + +;; =============================================================================-====== + + + +(defmethod filter-aux ((self C-spdata) condexpr slot) + (when (spd-debug self) (format t "expr ~D~%" condexpr)) + (let ( condflags tmp) + (setf condflags (mapcar (eval `(function ,condexpr)) (funcall slot self))) ;; apply filter to slot and collect in flag list + (when (spd-debug self) (format t "result ~D~%" condflags)) + (dolist (varslot '(freqs amps bws phases weights partials)) + ;(format t "varslot ~D data ~D~%" varslot (funcall varslot self)) + (when (slot-value self varslot) ;; if slot is not empty, then it must have length = size + (setf tmp (slot-value self varslot)) + (setf (slot-value self varslot) ()) + (mapc #'(lambda (flag x) + (when flag (setf (slot-value self varslot) (push x (slot-value self varslot)))) ;; if filter test was t, put parameter in slot + ) condflags tmp) + (setf (slot-value self varslot) (reverse (slot-value self varslot)))) + ) + self) + ) + + + + + +(defmethod filter ((self C-spdata) fct val slot) + (assert (> (size self) 0) () "filter: cannot filter a spdata of null size") + (when (spd-debug self) (format t "~4Fs: test ~D with val ~D on slot ~D~%" (frame self) fct val slot)) + (let ( (to-spdata (copy-spdata self)) condexpr (msgbp "for band-pass filter input value must be a pair (inf sup) or a list of pairs ((inf1 sup1) (inf2 sup2) ..)")) + (ecase fct ;; building filtering expression + (band-pass (assert (listp val) (val) msgbp) + (cond ((member-if #'listp val) (assert (and (not (member-if-not #'listp val)) + (not (member-if-not #'(lambda(x) (if (= (length x) 2) t ())) val))) (val) + msgbp) + + (setf condexpr ()) + ; construct expression (or (and (x >= min) (x <= max)) (and ....)) for all band-pass values + (dolist (bp val) (setf condexpr (append condexpr `((and (>= x ,(car bp)) (<= x ,(cadr bp))))))) + (setf condexpr (make-num-lambda (cons 'or condexpr))) + (filter-aux to-spdata condexpr slot)) + (t (setf condexpr (make-num-lambda `(and (>= x ,(car val)) (<= x ,(cadr val))))) + (filter-aux to-spdata condexpr slot)))) + (low-pass (assert (numberp val) (val) "value for low pass must be a number") + (setf condexpr (make-num-lambda `(<= x ,val))) + (filter-aux to-spdata condexpr slot)) + (high-pass (assert (numberp val) (val) "value for low pass must be a number") + (setf condexpr (make-num-lambda `(> x ,val))) + (filter-aux to-spdata condexpr slot)) + (reject-band (assert (listp val) (val) msgbp) + (cond ((member-if #'listp val) (assert (and (not (member-if-not #'listp val)) + (not (member-if-not #'(lambda(x) (if (= (length x) 2) t ())) val))) (val) + msgbp) + + (dolist (bp val) (setf condexpr (make-num-lambda `(or (<= x ,(car bp)) (>= x ,(cadr bp))))) + (filter-aux to-spdata condexpr slot))) + (t (setf condexpr (make-num-lambda `(and (<= x ,(car val)) (>= x ,(cadr val))))) + (filter-aux self condexpr val slot)))) + (eq (cond ((listp val) + (setf condexpr (make-num-lambda `(when (member x ',val) t))) + (filter-aux to-spdata condexpr slot )) + (t (setf condexpr (make-num-lambda `(= x ,val))) + (filter-aux to-spdata condexpr slot)) + )) + (neq (cond ((listp val) + (setf condexpr (make-num-lambda `(when (not (member x ',val)) t))) + (filter-aux to-spdata condexpr slot)) + (t (setf condexpr (make-num-lambda `(/= x ,val))) + (filter-aux to-spdata condexpr slot)) + )) + ) + (setf (frame to-spdata) (frame self)) + (setf (typ to-spdata) (typ self)) + (print (freqs to-spdata)) + (setf (size to-spdata) (length (freqs to-spdata))) + (setf (file to-spdata) (concatenate 'string (file self) " filtered")) + (when (<= (size to-spdata) 0) (ccl::beep) (warn "filter: output spdata of null size")) + to-spdata) + ) + + +(defmethod filter ((self C-spdata-seq) fct val slot) + (make-instance 'C-spdata-seq :duration (duration self) + :typ (typ self) :file (file self) + :spdata (mapcar #'(lambda (x) (filter x fct val slot)) + (spdata self))) +) + + +(defmethod tm-scale ((self C-spdata-seq) fct val slot) + (make-instance 'C-spdata-seq :duration (duration self) + :typ (typ self) :file (file self) + :spdata (mapcar #'(lambda (x) (tm-scale x fct val slot)) + (spdata self))) +) + + + + +(defmethod setup ((self C-spdata) freqs amps bws phases partials weights typ file) + (setf (freqs self) freqs) + (setf (amps self) amps) + (setf (bws self) bws) + (setf (size self) (length (freqs self))) + (setf (phases self) phases) + (setf (partials self) partials) + (setf (weights self) weights) + (setf (typ self) typ) + (setf (file self) file) +self) + +(defmethod reset ((self C-spdata)) + (setup self () () () () () () 'empty ()) +self) + +(om::defmethod! filter-spdata ((spdata t) + (fct symbol) + (val t) + (slot symbol)) +:initvals (list '() "band-pass" '() "amps") + :indoc '("object" "filter" "val" "slot") + :icon 160 +:menuins '((1 (("band-pass" 'band-pass) + ("low-pass" 'low-pass) + ("high-pass" 'high-pass) + ("reject-band" 'reject-band) + ("neq" 'neq))) + (3 (("amps" 'amps) + ("freqs" 'freqs) + ("partials" 'partials) + ("weights" 'weights) + ("bws" 'bws) + ("size" 'size)))) + :doc "creates a new spdata object with only partials data satisfying the test" + + + + (when spdata + (cond ((listp spdata) (mapcar #'(lambda(x) (filter-spdata x fct val slot)) spdata)) ;; recursive call in case val is list + ;;((listp val) (mapcar #'(lambda(x) (filter spdata fct x slot)) val)) + (t (filter spdata fct val slot))) ;; spdata is spdata or spdata-seq + ) +) + + + +;;;*******************************mask-read****************************************** + +(defun arith0 (dep pas n) + (let ((L ())) + (dotimes (i n (reverse L)) + (push (+ (* pas i) dep) L)))) + +(defmethod read-mask-data ((self C-spdata-seq) filename beg end &optional nmax) + (cond ((and beg end) (assert (> end beg) () "mask-read: beg must be > end")) + (beg (assert (>= beg 0) () "mask-read: beg must be >= 0")) + (end (assert (> end 0) () "mask-read: end must be > 0")) + ) + (with-open-file (in filename :direction :input) + (let (curline readframe cursize curmask-frame (continueflag t) (calculeflag ())) + (while (and continueflag (setf cursize (read in nil nil))) + + (setf cursize (round (if nmax (min nmax cursize) cursize))) ;si limitation du nombre de pics (sera peut-tre modifiŽ par les developpeurs) + + (setf readframe (read in)) + ;;;;;(format t "readfdrame : ~a~%" readframe) + (cond ((and (not end) (not beg)) ;; if beg and end nil, read it all + (setf calculeflag t) + ) + ((and end (not beg)) ;; start from 0 until specified end in ms + (setf calculeflag (<= readframe end))) + ((and beg end) + (setf calculeflag (cond ((< readframe beg) ()) + ((<= readframe end ) t) + (t ()))) + ) + ((and (not end) beg) + (setf calculeflag (>= readframe beg))) + ) + (when (and calculeflag (> cursize 0.0)) + (setf curmask-frame (make-instance 'C-spdata)) + (format t "~Ds : ~D partials~%" readframe cursize) + ) + (dotimes (i cursize) + (cond (calculeflag ;; when partial to read, push items in lists, if not, read all line and dump + ;;; (setf (partials curmask-frame) (cons (read in) (partials curmask-frame))) + (setf (freqs curmask-frame) (cons (read in) (freqs curmask-frame))) + (setf (amps curmask-frame) (cons (read in) (amps curmask-frame))) + (setf (weights curmask-frame) (cons (read in) (weights curmask-frame)))) + (t (setf curline (read-line in))) ;; dump because out of interval beg-end + ) + ) + (when (and calculeflag (> cursize 0)) + curline ;for no more warnings + (setf (frame curmask-frame) readframe) + (setf (size curmask-frame) cursize) + (setf (partials curmask-frame) (arith0 1 1 cursize)) + (setf (freqs curmask-frame) (reverse (freqs curmask-frame))) + (setf (amps curmask-frame) (reverse (amps curmask-frame))) + (setf (weights curmask-frame) (reverse (weights curmask-frame))) + (setf (bws curmask-frame) (make-list (length (amps curmask-frame)) :initial-element 1)) ; lp 20/8/94 + ;(setf normalized-amps (normalize-amp amps)) + ;(setf (phases curmask-frame) (reverse (phases curmask-frame))) + (setf (spdata self) (cons curmask-frame (spdata self))) + ) + ) + (setf (spdata self) (reverse (spdata self))) + + (when beg ;; if begin time was specified, adjust all time frame values + (when (= beg (frame (first (spdata self)))) + (setf beg (- beg (- (first (spdata self)) (second (spdata self)))))) + (mapc #'(lambda (x) (setf (frame x) (- (frame x) beg))) (spdata self)) + ) + + (setf (file self) (mac-namestring filename)) + (setf (typ self) 'mask) + (setf (duration self) (- (frame (car (last (spdata self)))) (frame (first (spdata self))))) + (format t "finished reading additive synthesis file ~D from time ~5F to ~5F duration ~5F ~%" filename + (if beg beg 0) (if end end readframe) (duration self)) + )) + self) + + +(om::defmethod! mask-read ((filename t) + &optional (beg '()) (end '()) + (nmax '())) + + + + :initvals (list '() '() '() '()) + :indoc '("filename" "beg" "end" "nmax") + :icon 135 + :doc "reads mask analysis data and returns a spdata object (c-spdata-seq class)" + (let ((spdata-seq (make-instance 'C-spdata-seq ))) + (unless filename + (setf filename (om-choose-file-dialog :directory *lastspfile* + :button-string "mask file"))) + (when filename + (setf *lastspfile* filename) + (read-mask-data spdata-seq filename beg end nmax) + ) + ) + ) + + +;;*************************************par-spdata****************************************** + + + + + + + + (om::defmethod! par-spdata ((spdata t) + (menu symbol)) + + + :initvals (list '() "freqs") + :indoc '("spdata" "menu" ) + :icon 160 + :menuins '((1 (("freqs" 'freqs) + ("amps" 'amps) + ("bws" 'bws) + ("partials" 'partials) + ("weights" 'weights) + ("phases" 'phases) + ("size" 'size)))) + :doc "get data in spdata object from the specified slot" + + (when (or (and (atom spdata) (spd-debug spdata)) + (and (listp spdata) (spd-debug (first spdata)))) (format t "values for menu ~D~%" menu)) + (let (ret-list) + (cond ((listp spdata) (setf ret-list (remove nil (mapcar #'(lambda(x) (funcall menu x)) spdata)))) + ((typep spdata 'C-spdata-seq) + (setf ret-list (remove nil (mapcar #'(lambda(x) (list (frame x) (funcall menu x))) (spdata spdata)) :key 'cadr)) + (when ret-list (setf ret-list (mat-trans ret-list)))) + (t (setf ret-list (funcall menu spdata)))) + ret-list)) + + + + +;*****************************FILTER ALL********************************************** + + +(defun filtre-position (list poslist) + (reverse (set-difference list (loop for i in poslist collect (nth i list))))) + +;(filtre-position '(1 2 3 4 5 6 7) '(1 3)) + + + +(defmethod* losfiltre ((self c-spdata) par test) + (let (rejected newspdata) + (loop for i from 0 to (- (size self) 1 ) do + (unless (funcall test (nth i (par-spdata self par))) + (push i rejected))) + (setf newspdata (make-instance 'c-spdata + :size (- (size self) (length rejected)) + :frame (frame self) + :partials (filtre-position (partials self) rejected) + :freqs (filtre-position (freqs self) rejected) + :amps (filtre-position (amps self) rejected) + :bws (filtre-position (bws self) rejected) + :phases (filtre-position (phases self) rejected) + :weights (filtre-position (weights self) rejected) + )) + (setf (normalized-amps newspdata) (filtre-position (normalized-amps self) rejected)) + newspdata)) + +(defmethod* losfiltre ((self list) par test) + (loop for item in self collect (losfiltre item par test))) + +(defmethod* losfiltre ((self c-spdata-seq) par test) + (make-instance 'c-spdata-seq + :spdata (losfiltre (spdata self) par test) + :duration 0 )) + + + +(om::defmethod! filter-all (self par test format) + + :initvals (list '() "freqs" '() "list") + :indoc '("spdata" "menu" "test" "format") + :icon 160 + :menuins '((1 (("freqs" 'freqs) + ("amps" 'amps) + ("bws" 'bws) + ("partials" 'partials) + ("weights" 'weights) + ("phases" 'phases) + ("size" 'size))) + (3 (("list" 'list) + ("object" 'object)))) + :doc "blabla" + +(ecase format +(list (par-spdata (losfiltre self par test) par)) +(object (losfiltre self par test)))) + + + ;*********************************************************************************************** + +; additions 4/10/04 + +(om::defmethod! mk-spdata ((freqs t ) + (amps t ) + (phases t ) + (partials t ) + (weights t ) + (bws t)) + +:initvals '( 0 0 0 0 60 1) +:icon 160 +:doc "creates a new spdata object or a list of spdata objects. Inputs are simple list to create +a single object or a list of lists to create a series of spdata objects. See sp-data-seq" + + (let (spdata llsizes) + ; looking for double lists (list of lists) in order : freqs, amps, bws, phases + ; collecting list of sublist sizes if double list, () otherwise + (setf llsizes (or (ll-length freqs) + (ll-length amps) + (ll-length bws) + ( ll-length phases) + )) + + (cond (llsizes ;; at least one list of lists --> sequence of spectra + ;; preparing data lists; in order freqs, amps, bws, phases, partials, weights + (setf freqs (fill-if-not-ll "freqs" freqs llsizes)) + (setf amps (fill-if-not-ll "amps" amps llsizes)) + (setf bws (fill-if-not-ll "bws" bws llsizes)) + (setf phases (fill-if-not-ll "phases" phases llsizes)) + (setf weights (fill-if-not-ll "weights" weights llsizes)) + (setf partials (fill-partials-ll partials llsizes)) + ; loop to create list of spdata +;(format t "llflag ~D bw ~D~%" llflag bws) + (dotimes (i (length llsizes)) + (setf spdata (cons (make-instance 'C-spdata :freqs (nth i freqs) + :amps (nth i amps) + :phases (nth i phases) + :partials (nth i partials) + :bws (nth i bws) + :weights (nth i weights) + :size (length (nth i freqs)) + ) + spdata))) + (setf spdata (reverse spdata))) + (t ;; all inputs are numbers or simple lists --> only one spectrum + (setf llsizes (or (listp-size freqs) (listp-size amps) ; set size to list size if any + (listp-size bws) (listp-size phases) + (listp-size weights))) + (when (not llsizes) (error "mk-spdata: all inputs are numbers. At least one list is needed")) + (setf spdata (make-instance 'C-spdata :freqs (fill-if-not-l freqs llsizes) + :amps (fill-if-not-l amps llsizes) + :phases (fill-if-not-l phases llsizes) + :partials (fill-if-not-l partials llsizes) + :bws (fill-if-not-l bws llsizes) + :weights (fill-if-not-l weights llsizes) + :size llsizes + )) + )) + spdata) +) + + + + +(om::defmethod! mk-spdata-seq ((frames list ) + (spdata list)) + + +:initvals '( '() '()) +:icon 160 +:doc "creates a spdata-seq object with a list of spdata objects and a list of frames" + + (when spdata + (unless (listp spdata) (setf spdata (list spdata))) + (when (< (length frames) (length spdata)) ;;when frames list is too short + ;(setf frames (append frames (make-list (- (length spdata) (length frames)) + ; :initial-element (car (last frames))))) + (warn "frames list is too short") ; lp 20/8/94 + ) + ; ;; converts in seconds, cumulate for absolute time and store in frame slot + ; (let (atimes (cumtime 0)) + ; (setf atimes (cons 0 (mapcar #'(lambda( time ) (setf cumtime (+ (/ time 100.) cumtime))) frames))) + ;; write frame slot in spdata + (mapcar #'(lambda (spd time) (setf (frame spd) time)) spdata frames) ; lp 20/8/94 + + (make-instance 'C-spdata-seq :duration (car (last frames)) + :spdata spdata :typ (typ (first spdata)) + :file (file (first spdata))) + ) +) + + + +; ===================== interpolations de spectres ================================= + + +; --------- fct utiles de pw:apparier-clos-sp ----------- + +(defclass liste-double () + ((LdeP :initform () :initarg :LdeP :accessor LdeP) + (lg :initform () :initarg :lg :accessor lg) + (ld :initform () :initarg :ld :accessor ld) + (nbre-P :initform 1 :initarg :nbre-P :accessor nbre-P))) + +;(defclass liste-multiple (liste-double) +; ((nbre-instts :initform 2 :accessor nbre-instts))) + +(defun make-ldouble (L1 L2) + (make-instance 'liste-double :Lg L1 + :Ld L2)) + +;(defun make-lmultiple (L1 L2) +; (make-instance 'liste-multiple :Lg L1 +; :Ld L2)) + +;(defun make-LdeP (LdeP) +; (make-instance 'liste-double :LdeP LdeP +; :nbre-P (length LdeP))) + +;(defun xmake-LdeP (LdeP) +; (make-instance 'liste-multiple :LdeP LdeP + ; :nbre-P (length LdeP))) + +(defmethod optim1-l ((self liste-double) i) ;;((10 8) (10 9) (10 12) (10 0)) + (let ((liste (nth i (LdeP self)))) + (do* ((n 0 (1+ n)) + (ind 0 )) + ((eq n (length liste))(nth ind liste)) + (setf ind (if (< (diff-de-P (nth n liste)) + (diff-de-P (nth ind liste))) + n ind))))) + +(defmethod apari ((self liste-double) seuil) + (let ((L1 (lg self))(L2 (ld self))(L ())) + (dolist (elt L1 (setf (LdeP self)(reverse L))) + (if (find-elt-seuil elt l2 seuil) + (push (find-elt-seuil elt l2 seuil) L))))) + +(defmethod appariement ((self liste-double) seuil) + (apari self seuil) + (optim1-apari self) + (optim2-apari self) + (recup-elts self) +(LdeP self)) + +(defmethod optim1-apari ((self liste-double)) ;et multiple + (do ((n 0 (1+ n)) L) + ((eq n (length (LdeP self))) (setf (LdeP self) (reverse L))) + (push (optim1-l self n) L))) + +(defmethod optim2-apari ((self liste-double)) + (let ((L ()) + (P ()) + (D ())) + (while (setq P (pop (LdeP self))) + (setf D (car (LdeP self))) + (if (equal (max 1 (second P)) + (second D)) ;->deux pareils consŽcutifs + (if (< (diff-de-P P) + (diff-de-P D)) ;si le premier Žcart est + faible + (and (pop (LdeP self)) (push P (LdeP self)))()) + (push P L))) (setf (LdeP self) (reverse L)))) + +(defmethod appariement2 ((self liste-double) seuil type) + "type = type du seuil puis type de la liste" + (let ((l1 (lg self)) + (l2 (ld self))) + (cond ((equal type '("midic" "midic")) + (setf (LdeP self) + (f->mc2 + (appariement + (make-ldouble (mc->f2 L1) + (mc->f2 L2)) + seuil)))) + ((equal type '("Hz" "midic")) + (setf (LdeP self) + (f->mc2 + (appariement + (make-ldouble (mc->f2 L1) + (mc->f2 L2)) + (- 0 seuil))))) + ((equal type '("Hz" "Hz")) + (appariement self (- 0 seuil))) + (t + (appariement self seuil))) + (LdeP self))) + +(defmethod compar-apari ((objf liste-double) (obj2 liste-double)) + (let* (( LdeP2 ()) + (L1 (lg obj2)) + (L2 (ld obj2)) + (n1 (taille (car L1))) + (n2 (taille (car L2)))) + (dolist (Paire (LdeP objf) (setf (LdeP obj2) (reverse LdeP2))) + (cond ((zerop (moy-dt-x (car Paire))) + (push (cons-x-elt (pop L2) 1 n1) LdeP2)) + ((zerop (moy-dt-x (second Paire))) + (push (cons-x-elt (pop L1) 0 n2) LdeP2)) + (t + (push (list (pop L1)(pop L2)) LdeP2)))))) + + +(defmethod insert-si-absent ((self liste-double) numero rang n) + (declare (ignore n)) + (let ((elt (nth numero (if (eq rang 0) (lg self)(ld self)))) + (Lelt ()) stockage) + (push elt Lelt) + (while Lelt + (let ((Paire (pop (LdeP self)))) + (cond ((null Paire) (push (cons-x-paire (pop Lelt) rang) stockage)) + ((equal (nth rang Paire) elt) + (and (pop Lelt)(push Paire stockage))) + ((> (moy-dt-x Paire) elt) + (and (push (cons-x-paire (pop Lelt) rang) stockage) + (push Paire stockage))) + (t (push Paire stockage))))) + (setf (LdeP self) (append (reverse stockage) (LdeP self))))) + + +(defmethod recup-elts ((self liste-double)) + (do ((n 0 (1+ n))) + ((eq n (length (Lg self))) ()) (insert-si-absent self n 0 1)) + (do ((n 0 (1+ n))) + ((eq n (length (Ld self))) ()) (insert-si-absent self n 1 1))) + + +(defmethod intpola1 ((self liste-double) scaler) + (let (Lamps + (Lamps1 (Lg self)) + (Lamps2 (Ld self))) + (dolist (P (LdeP self) (reverse Lamps)) + (if (< (length (flat P)) 3) + (push (scal-Pair-dtx P scaler) Lamps) + (cond ((zerop (moy-dt-x (car P))) + (push (* scaler (pop Lamps2)) Lamps)) + ((zerop (moy-dt-x (second P))) + (push (* (- 1 scaler) (pop Lamps1)) Lamps)) + (t + (push (abs (+ (* (- 1 scaler)(pop Lamps1)) + (* scaler (pop Lamps2)))) Lamps))))))) + +(defmethod intersecta ((self liste-double) scaler) + (let (Lamps + (Lamps1 (Lg self)) + (Lamps2 (Ld self))) + (dolist (P (LdeP self) (reverse Lamps)) + (cond ((zerop (moy-dt-x (car P)))(pop Lamps2)) + ((zerop (moy-dt-x (second P)))(pop Lamps1)) + (t + (push (abs (+ + (* (- 1 scaler) (pop Lamps1)) + (* scaler (pop Lamps2)))) Lamps)))))) + +(defmethod intpolamps ((self liste-double) scaler flag) + (let ((scalspec (cond + ((< scaler 0.25) 0) + ((< scaler 0.5)(- (* 4 scaler) 1)) + ((< scaler 0.75) 1) + (t (- 4 (* 4 scaler)))))) + (cond ((= flag 0) ;elt gauche seult + (lg self)) + ((or (= flag 1) (= flag 4)); intersec + mixage + (intpola1 self scaler)) + ((or (= flag 2)(= flag 5)) ; mixage (pas d'appariements) + (append (rescale (lg self)(- 1 scaler)) + (rescale (ld self) scaler))) + ((= flag 3) ; intersec seult (pas de freq isolŽes) + (intersecta self scaler)) + ((= flag 6) ; = scaler <0.5 instg sinon instd pour freqs + (if (< scaler 0.5) (lg self)(ld self))) + ((= flag 7) ; double interpol pour les freqs + (intpola1 self scalspec))))) + +(defmethod intpolf1 ((self liste-double) scaler) + (let (L) + (dolist (P (LdeP self) (reverse L)) + (push (if (zerop (min (moy-dt-x(car P))(moy-dt-x(cadr P)))) + (max (moy-dt-x(car P))(moy-dt-x(cadr P))) + (+ (* (- 1 scaler) (car P))(* scaler (cadr P)))) L )))) + +(defmethod intersect ((self liste-double) scaler) + (let (L) + (dolist (P (LdeP self) (reverse L)) + (if (zerop (min (moy-dt-x(car P))(moy-dt-x(cadr P)))) + () + (push (+ (* (- 1 scaler) (car P))(* scaler (cadr P))) L))))) + +(defmethod intpolfreqs ((self liste-double) scaler flag) + (let ((scalspec (cond + ((< scaler 0.25) 0) + ((< scaler 0.5)(- (* 4 scaler) 1)) + ((< scaler 0.75) 1) + (t (- 4 (* 4 scaler)))))) + (cond ((= flag 0) ;elt gauche seult + (lg self)) + ((or (= flag 1)(= flag 4)) ; intersec + mixage + (intpolf1 self scaler)) + ((or (= flag 2)(= flag 5)) ; mixage (pas d'appariements) + (append (lg self) (ld self))) + ((= flag 3) ; intersec seult (pas de freq isolŽes) + (intersect self scaler)) + ((= flag 6) ; = scaler <0.5 instg sinon instd pour freqs + (if (< scaler 0.5) (lg self) (ld self))) + ((= flag 7) ; double interpol pour les freqs + (intpolf1 self scalspec))))) + + +(defmethod intpolbw1 ((self liste-double) scaler) + (let (Lbws + (Lbws1 (Lg self)) + (Lbws2 (Ld self))) + (dolist (P (LdeP self) (reverse Lbws)) + (cond ((zerop (moy-dt-x (car P))) (push (pop Lbws2) Lbws)) + ((zerop (moy-dt-x (second P))) (push (pop Lbws1) Lbws)) + (t (push (scalbw (pop Lbws1)(pop Lbws2) scaler) Lbws)))))) + + +(defmethod intersectbw ((self liste-double) scaler) + (let (Lbws + (Lbws1 (Lg self)) + (Lbws2 (Ld self))) + (dolist (P (LdeP self) (reverse Lbws)) + (cond ((zerop (moy-dt-x (car P)))(pop Lbws2)) + ((zerop (moy-dt-x (second P)))(pop Lbws1)) + (t (push (scalbw (pop Lbws1)(pop Lbws2) scaler) Lbws)))))) + +(defmethod intpolbwres + ((self liste-double) scaler resmoy1/2) ;-->les freq appariŽes restent interpolŽes + (let (Lbws + (Lbws1 (Lg self)) + (Lbws2 (Ld self))) + (dolist (P (LdeP self) (reverse Lbws)) + (cond ((zerop (moy-dt-x (car P)))(push (* (pop Lbws2) + (expt resmoy1/2 (- scaler 1))) Lbws)) + ((zerop (moy-dt-x (second P))) (push (* (pop Lbws1) + (expt resmoy1/2 scaler)) Lbws)) + (t (push (scalbw (pop Lbws1)(pop Lbws2) scaler) Lbws)))))) + + +(defmethod intpolbws + ((self liste-double) scaler flag resmoy1/2) + (let ((scalspec (cond + ((< scaler 0.25) (* 4 scaler)) + ((< scaler 0.5) 1) + ((< scaler 0.75)(- 3 (* 4 scaler))) + (t 0)))) + (cond ((= flag 0) ;elt gauche seult + (lg self)) + ((= flag 1) ; intersec + mixage + (intpolbw1 self scaler)) + ((= flag 2) ; mixage (pas d'appariements) + (append (lg self)(ld self))) + ((= flag 3) ; intersec seult (pas de freq isolŽes) + (intersectbw self scaler)) + ((= flag 4) ; = resmoy ! + (intpolbwres self scaler resmoy1/2)) + ((= flag 5) ; = type2 pour les freq + (append (rescale (lg self) (expt resmoy1/2 scaler)) + (rescale (ld self) (expt resmoy1/2 (- scaler 1))))) + ((= flag 6) ; = scaler <0.5 instg sinon instd pour freqs + (if (< scaler 0.5) (rescale (lg self) (expt resmoy1/2 (* 2 scaler))) + (rescale (ld self) (expt resmoy1/2 (- 1 (* 2 scaler)))))) ;-->ˆ vŽrifier + ((= flag 7) ; double interpol pour les freqs + (intpolbwres self scalspec resmoy1/2))))) + + + +; --------- fct utiles de pw:sp-fonctions ----------- + +(defun f->mc2 (LorA) + (cond ((null LorA) + ()) + ((atom LorA) + (if (numberp LorA) (round (f->mf LorA)) LorA)) + (t + (cons (f->mc2 (car LorA))(f->mc2 (cdr LorA)))))) + + + +(defun mc->f2 (LorA) + (cond ((null LorA) + ()) + ((atom LorA) + (if (numberp LorA) (mc->f LorA) LorA)) + (t + (cons (mc->f2 (car LorA))(mc->f2 (cdr LorA)))))) + + + + +(defun flat2 (lorx) + (if (atom lorx) lorx (flat lorx))) + + +(defun taille (LorA) + (if (atom LorA) 1 (length LorA))) + +(defun rescale (Lamps scaler) + (let ((l () )) + (dolist (elt Lamps (reverse L)) + (push (* elt scaler) L)))) + +(defun scal-Pair-dtx (Paire scaler) + (let ((A (car Paire)) + (B (second Paire))) + (setf A (if (numberp A) A 0) + B (if (numberp B) B 0)) + (abs (+ (* (- 1 scaler) A)(* scaler B))))) + +(defun scalbw (bw1 bw2 scaler) +"donne la largeur de bande moyenne (inverse) entre bw1 et bw2 pondŽrŽ par scal" + (/ (* bw1 bw2)(+ (* (- 1 scaler) bw2)(* scaler bw1)))) + +(defun find-elt-seuilmc (elt l2 seuil) + (let ((L ()) + (elt1 (f->mc2 elt))) + (dolist (elt2 l2 (reverse L)) + (if (<= (abs (- elt1 (f->mc2 elt2))) seuil) + (setf L (cons (list elt elt2) L)) + ())))) + + +(defun find-elt-seuilf (elt l2 seuil) + (let ((L ())) + (dolist (elt2 l2 (reverse L)) + (if (<= (abs (- elt elt2)) seuil) + (setf L (cons (list elt elt2) L)) + ())))) + +(defun find-elt-seuil (elt l2 seuil) + (if (> 0 seuil) (find-elt-seuilf elt l2 (- seuil)) + (find-elt-seuilmc elt l2 seuil))) + +(defun diff-de-P (Paire) + (abs (- (car Paire)(cadr Paire)))) + +(defun cons-x-elt (elt rang n) +(cond ((null elt )()) + ((eq rang 0) + (if (eq n 1)(cons elt '(x)) + (cons elt (list (make-list n :initial-element 'x))))) + (t (if (eq n 1)(cons 'x (cons elt ())) + (list (make-list n :initial-element 'x) + elt))))) + +(defun cons-x-paire (elt rang) + (if (null elt)() + (if (eq rang 0)(cons elt (cons 'x ())) + (cons 'x (cons elt ()))))) + +(defun som-dt-x (l) + (if l (+ (if (equal (car l) 'x) 0 (car l))(som-dt-x (cdr l))) 0)) + +(defun moy-dt-x (l) + (if (atom l) (if (numberp l) l 0) + (let ((l (remove 0 (remove 'x (flat l))))) + (/ (som-dt-x l)(length l))))) + + +(defun res-moy (Lamps Lbws) + (do* ((n 0 (1+ n)) + (sumres (* (car Lamps)(expt (/ 1 (car Lbws)) 2)) + (+ sumres (* (nth n Lamps) (expt (/ 1 (nth n Lbws)) 2)))) + (sumamp (car Lamps)(+ sumamp (nth n Lamps)))) + ((eq n (1- (length Lamps)))(expt (/ sumres sumamp) 0.5)))) + + +; --------- interpolation de spectres ------------------------------------------ + + + + +(om::defmethod! intpol-model ((spd1 t) + (spd2 t) + (seuil number) ; 100 + (scaler number) ; 0 + (flag integer) ;(:value 1 :min-val 0 :max-val 7)) + &optional + (th-type 'midic) ; (:menu-box-list (("midic" . "midic") ("Hz" . "Hz")) + (mod-type 'midic )) ; menu-box-list (("midic" . "midic") ("Hz" . "Hz")))) + :initvals '( '() '() 100 0 1 'midic 'midic) + :menuins '((5 (("midic" 'midic) ("hz" 'hz) )) (6 (("midic" 'midic) ("hz" 'hz) ))) + :icon 160 + :doc "donne un nouveau modle interpolŽ ˆ partir de deux modles de dŽpart, +les frames sont calculŽes sur le modle gauche (1) +flag : entier, entre 1 et 7" + (let* (Lfg Lfd Lag Lad Lbwg Lbwd resmoy1/2 + objetf objeta objetbw) + (setf Lfg (freqs spd1)) + (setf Lag (amps spd1 )) + (if (zerop (apply '+ Lag))(setf Lag (arith0 0.00001 0 (length Lfg)))) ;;new lp 28/9/94 + (setf Lbwg (bws spd1)) + (setf Lfd (freqs spd2)) + (setf Lad (amps spd2 )) + (if (zerop (apply '+ Lad))(setf Lad (arith0 0.00001 0 (length Lfd)))) ;;new lp 28/9/94 + (setf Lbwd (bws spd2)) + (setf objetf (make-ldouble Lfg Lfd)) + (setf objeta (make-ldouble Lag Lad)) + (setf objetbw (make-ldouble Lbwg Lbwd)) + (progn + (setf resmoy1/2 (/ (res-moy (lg objeta) (lg objetbw)) + (if (zerop (res-moy (ld objeta) (ld objetbw))) 1 + (res-moy (ld objeta) (ld objetbw))))) ;; a ameliorer si amps = 0 + (appariement2 objetf seuil (list th-type mod-type) ) ;; --> old 31/11/93 lp + ;(appariement3 objetf seuil (list th-type mod-type) flag) -> modif bof + (compar-apari objetf objeta) + (compar-apari objetf objetbw) + ;(list (intpolfreqs objetf scaler flag) --> old 19/8/93 lp + ; (intpolamps objeta scaler flag) + ; (intpolbws objetbw scaler flag resmoy1/2)) + (when (and objetf objeta objetbw) + (let ((modele (make-instance 'C-spdata ))(liste-ref (intpolfreqs objetf scaler flag))) + (setup modele liste-ref (intpolamps objeta scaler flag) + (intpolbws objetbw scaler flag resmoy1/2) + (make-list (length liste-ref) :initial-element 0) + (arith0 1 1 (length liste-ref)) (make-list (length liste-ref) :initial-element 0) + 'empty ()) + (setf (frame modele) (frame spd1)) + modele) + )))) + + + + + + + + + +;;------------------------- list utilities ------------------------------------------- + + +(defun fill-if-not-l ( obj size) + (cond ((not obj) (error "null input in mk-spdata (fill-if-not-l )")) + ((listp obj) + (cond ((= (length obj) size) obj) + ((< (length obj) size) + (append obj (make-list (- size (length obj)) :initial-element (car (last obj))))) + ((> (length obj) size) (subseq obj 0 size)) + )) + (t ;; should be number + (make-list size :initial-element obj))) +) + +;; test if list of list. returns list of sublists length if list of lists, length if simple length +(defun ll-length (obj) + (cond ((not obj) ()) ;; null object + ((and (listp obj) (not (member-if-not #'listp obj))) (mapcar #'length obj)) ;; list of lists + ((listp obj) ()) ;; simple list + ((numberp obj) ()) + (t ())) +) + +;; if not list of list, make a list repeating element +(defun fill-if-not-ll (varname obj sizes) + (let ((lle (ll-length obj))) + (cond (lle (unless (equal lle sizes) (error "bad format for ~D: ~D instead of ~D~%" varname lle sizes)) + obj) + ((listp obj) (check-parlist (make-list (length sizes) :initial-element obj) sizes)) + (t (mapcar #'(lambda(x) (make-list x :initial-element obj)) sizes)) + ) + ) +) + +;; adjust list of lists; obj is a list of lists and sizes is a list of sizes +(defun check-parlist (obj sizes) + (when (or (not (listp obj)) (not (listp sizes)) (not (= (length obj) (length sizes)))) + (error "check-parlist: bad formats for ~D and ~D~%" obj sizes)) + (let (curemt result cursize curlength) + (dotimes (i (length obj)) + (setf curemt (pop obj)) + (setf cursize (nth i sizes)) + (setf curlength (length curemt)) + (setf curemt (cond ((< curlength cursize) ;; list in list of lists is too short + (append curemt (make-list (- cursize curlength) :initial-element (car (last curemt))))) + ((> curlength cursize) (subseq curemt 0 cursize)) ;; current element too long + (t curemt))) + (setf result (cons curemt result))) + (setf result (reverse result)) + result) +) + + +(defun fill-partials-ll ( obj sizes) + (let ((lle (ll-length obj))) + (cond (lle (unless (equal lle sizes) (error "bad format for ~D: ~D instead of ~D~%" "partials" lle sizes)) + obj) + ((listp obj) (check-partial-list (make-list (length sizes) :initial-element obj) sizes)) + (t (mapcar #'(lambda(x) (arithm-ser 1 1 x)) sizes)) + ) + ) +) + +;; adjust list of lists; obj is a list of lists and sizes is a list of sizes +(defun check-partial-list (obj sizes) + (when (or (not (listp obj)) (not (listp sizes)) (not (= (length obj) (length sizes)))) + (error "check-parlist: bad formats for ~D and ~D~%" obj sizes)) + (let (curemt result cursize curlength) + (dotimes (i (length obj)) + (setf curemt (pop obj)) + (setf cursize (nth i sizes)) + (setf curlength (length curemt)) + (setf curemt (cond ((< curlength cursize) ;; list in list of lists is too short + (append curemt (arithm-ser (car (last curemt)) 1 (+ (car (last curemt)) (- cursize curlength) )))) + ((> curlength cursize) (subseq curemt 0 cursize)) ;; current element too long + (t curemt))) + (setf result (cons curemt result))) + (setf result (reverse result)) + result) +) + + + +;; returns list size is a list +(defun listp-size (obj) + (cond ((listp obj) (length obj)) + (t ()) + ) +) + + + + diff --git a/sources/TMlibrairie-OM.lisp b/sources/TMlibrairie-OM.lisp new file mode 100755 index 0000000..440e56d --- /dev/null +++ b/sources/TMlibrairie-OM.lisp @@ -0,0 +1,9277 @@ +(in-package :om) + + +; =================== frequentiel ====================================== + +; ----------------------------harm-series provenant d'Esquisse------------------------------ + +(defun rankcalc (numer denom begin end ) + (let ((cdeb (mod begin denom)) (pas (if (< end begin) -1 1)) res) + (for (n begin pas end) + (if (not (>= (mod (- n cdeb) denom) numer)) (push n res)) ) + (nreverse (remove 0 (if (and (not (null (find 1 res))) (not (null (find -1 res)))) + (remove -1 res) res))))) + +(defun hrmcalc1 ( listharm fond) + (let (res) + (dolist ( n listharm) + (cond ( ( > n 0 ) (push (* fond n ) res)) + ( ( < n 0 ) (push (/ fond (abs n)) res)) + ( t () ) )) + (nreverse res))) + +(defun hrmcalc (fond listharm ) + (less-deep-mapcar #'hrmcalc1 listharm fond)) + +(defun sercalc (fund numer denom begin end ) + (hrmcalc fund (rankcalc numer denom begin end) )) + +(defun one-nth (fund nth type) + (let ((res (deep-mapcar/1 'hrmcalc fund nth))) + (if (equal type 'chord) (flat-once res) res))) + + +(defun duo-nth (fund nth type) + (if (equal type 'chord) (flat-once (one-nth fund nth type)) + (mapcar #'(lambda (x) (flat (one-nth fund x type))) nth))) + +(defun seqf-nth (fund nth type listnth) + (cond ((not listnth) (mapcar #'(lambda (x) (one-nth x nth 2)) fund)) + ((equal type 'chord) (flat-once (mapcar #'(lambda (x) (duo-nth x nth 2)) fund))) + ((equal type 'chordseq) (mapcar #'(lambda (x) (flat (one-nth x nth type))) fund) ))) + + +;====Removed from menu 22-11-2006================================================== +; redŽfini , types changŽs (= harm-series) +(om::defmethod! harm-ser ((fund t) (numer integer) + (denom integer) (begin integer) + (end integer) + &optional (unit 'midic) (type 'chord)) + :initvals '(3600 1 1 1 7 'midic 'chord) + :indoc '("Fundamental" "Numerator" "Denominator" "Begin" "End" "Unit" "Type") + :menuins '((5 (("Midics" 'midic) ("Freqs" 'freq))) (6 (("Chord" 'chord) ("ChordSeq" 'chordseq)))) + :icon 137 + :doc "Builds the harmonic and/or sub-harmonic series on fundamental . The arguments and determine what sample (/) of the partials is taken. (e.g. 1/1 = all; 1/2 = every other; 2/5 = the first two of each group of five). + +The arguments and determine the lowest and highest partials generated. The fundamental is represented by '1' or '-1'. Sub-harmonics are represented by negative numbers, overtones by positive. (e.g. partial number 7 is 7 times the fundamental frequency; partial -7 is the fundamental frequency divided by 7; thus to go from the seventh undertone to the seventh overtone would equal '-7' and would equal '7') + +Options: The menu argument determines whether the is entered in midicents, ('midic'), or in Hertz ('freq'). If 'midic' is selected the value will be converted to frequency inside the function and then the output is reconverted to midicents. If 'freq' is selected the entry, both calculation and output are done in Hertz. + +When is a list, the menu argument is used to determine the format of the output. The value 'seq' returns a list of chords +representing the partials requested for each successive fundamental. The value 'chord' returns a single chord containing all the partials for all fundamentals." + (let* ((fund (if (equal unit 'freq) fund (mc->f fund))) + (res (car-mapcar 'sercalc fund numer denom begin end))) + (setq res (if (equal unit 'freq) res (f->mc res) )) + (if (equal type 'chord) (flat res) res))) + + +;====Removed from menu 22-11-2006================================================== +(defmethod! n-harm ((fund t) (nth t) &optional (unit 'midic) (type 'chord)) + :initvals '(3600 '(1 2 3 4 5) 'midic 'chord) + :indoc '("Fundamental" "Partial-numbers" "Unit" "Type") + :menuins '((2 (("Midics" 'midic) ("Freqs" 'freq))) (3 (("Chord" 'chord) ("ChordSeq" 'chordseq)))) + :icon 137 + :doc + "Receives a fundamental , or list of fundamentals, and returns a list of partials with rank . can be a number or a list of number. Negative numbers indicate subharmonics. Floating point numbers mean non-harmonic partials. + +Options: The menu argument determines whether the is entered in midicents, ('midic') or Hertz ('freq'). If 'midic' is selected the value will be converted to frequency inside the function and then the output is reconverted to midicents. If 'freq' is selected the entry, both calculation and output are done in Hertz. + +When is a list, the menu argument is used to determine the format of the output. The value 'ChordSeq' returns a list of chords representing the partials requested for each successive fundamental. The value 'chord' returns a single chord containing the merged partials for all fundamentals." + + (let* ((nth (list! nth)) (fund (list! fund)) + (listfund (not (one-elem fund))) + (listnth (not (atom (car nth)))) + (listchord (not (atom (car fund)))) + (fund (if (equal unit 'freq) fund (mc->f fund))) + res) + (cond (listchord (setq res (seqf-nth fund nth type listnth))) + ((and listfund listnth) (setq res (duo-nth fund nth type))) + ((not listfund) (setq res (flat-once (one-nth fund nth type)))) + (t (setq res (one-nth fund nth type)))) + (if (one-elem res) (setq res (first res))) + (if (equal unit 'freq) res (f->mc res)))) + +; ----------------------------harm-series------------------------------ + + +; revoir pb de liste de fondamentales + +(defun hqm (fund n) +"harm sup ou inf (midic) de fund (midic)" + (f->mc (hqf fund n ))) + +(defun hqf (fund n) +"harm sup ou inf (freq) de fund (midic)" + (if (> n 0) (* (mc->f fund) n) (/ (mc->f fund) (abs n)))) + + + +(defun rangcalc (numer denom begin end ) + (let ((cdeb (mod begin denom)) (pas (if (< end begin) -1 1)) res) + (for (n begin pas end) + (if (not (>= (mod (- n cdeb) denom) numer)) (push n res)) ) + (nreverse (remove 0 (if (and (not (null (find 1 res))) (not (null (find -1 res)))) + (remove -1 res) res))))) + + + +(defun hcalc (fond listharm dist% offset approx) + (let ( (d (+ 1 (/ dist% 100))) res ) + (dolist ( n listharm) + (cond ( ( > n 0 ) (push (f->mc (+ (* fond (expt n d)) offset)) res)) + ( ( < n 0 ) (push (f->mc (+ (/ fond (expt (abs n) d)) offset)) res)) + ( t () ) )) + (if (eq approx nil) (nreverse res) (approx-m (nreverse res) approx)))) + +(defun polycalc (fund dist% numer denom begin end offset approx) + (hcalc fund (rangcalc numer denom begin end) dist% offset approx)) + + + + +; ajout methodes pour objets 11-10-04 + +(om::defmethod! polysp ((fund number) (dist% number) + (numer integer) (denom integer) (begin integer) (end integer) + &optional (offset 0) (approx nil)) + + :initvals '(3600 0 1 1 1 7 0 nil) + :indoc '("Fundamental" "Dist" "Numerator" "Denominator" "Begin" "End" "Offset" "Approx") + :menuins '((7 (("nil" nil) ("1/2" '1/2) ("1/4" '1/4) ("1/8" '1/8)))) + :icon 137 + :doc "tous les sur partiels de depuis ˆ + selon algorithme : p = f * r ^ d + offset +d = 1 + dist%/100 (dist% = distorsion exprimŽe en %) +offset = freq shift" + (let ((approx + (cond ((null approx) nil) + ((equal approx '1/2) 2) + ((equal approx '1/4) 4) + ((equal approx '1/8) 8)))) +(polycalc (mc->f (carlist! fund)) dist% numer denom begin end offset approx))) + + + +(om::defmethod! polysp ((fund list) (dist% number) + (numer integer) (denom integer) (begin integer) (end integer) + &optional (offset 0) (approx nil)) + + (if (one-elem fund) (polysp (car fund) dist% numer denom begin end offset approx) + (loop for f in fund + collect (polysp f dist% numer denom begin end offset approx)))) + + + + +(om::defmethod! polysp ((fund chord) (dist% number) + (numer integer) (denom integer) (begin integer) (end integer) + &optional (offset 0) (approx nil)) + (if (one-elem (lmidic fund)) + (make-instance 'chord + :LMidic (polysp (lmidic fund) dist% numer denom begin end offset approx) + :Lvel (lvel fund) + :Loffset (loffset fund) + :Ldur (ldur fund) + :Lchan (lchan fund) + :lport (lport fund)) + + (polysp (explosion fund) dist% numer denom begin end offset approx))) + + + +(om::defmethod! polysp ((fund chord-seq) (dist% number) + (numer integer) (denom integer) (begin integer) (end integer) + &optional (offset 0) (approx nil)) + (make-instance 'chord-seq + :lmidic + (loop for c in (chords (explosion fund)) + collect (polysp c dist% numer denom begin end offset approx)) + :lonset (lonset (explosion fund)) + :legato (legato fund))) + + +(om::defmethod! polysp ((fund note) (dist% number) + (numer integer) (denom integer) (begin integer) (end integer) + &optional (offset 0) (approx nil)) + (make-instance 'chord + :LMidic (polysp (midic fund) dist% numer denom begin end offset approx) + :Lvel (list (vel fund)) + :Loffset (list(offset fund)) + :Ldur (list(dur fund)) + :Lchan (list(chan fund)) + :lport (list(port fund)))) + + + +;====Rename polysp as sp-gen 22-11-2006================================================== + +(om::defmethod! sp-gen ((fund number) (dist% number) + (numer integer) (denom integer) (begin integer) (end integer) + &optional (offset 0) (approx nil)) + :initvals '(3600 0 1 1 1 7 0 nil) + :indoc '("Fundamental" "Dist" "Numerator" "Denominator" "Begin" "End" "Offset" "Approx") + :menuins '((7 (("nil" nil) ("1/2" '1/2) ("1/4" '1/4) ("1/8" '1/8)))) + :icon 137 + :doc "Returns all partials of fundamental determined by a numerator and a denominator from beginning to end . + +The following algorithm is used: p = f * r ^ d + offset. +Here, d = 1 + dist%/100 (dist% = distortion percentage). +In case d = 1, there is no distortion (dist% = 0) and the series is harmonic. +In case d < 1, we have a distorted (i.e. inharmonic) spectrum which is compressed. +In case of d > 1 we have a distorted (i.e. inharmonic) spectrum which is expanded. + +Optional: With ÔOffsetÕ a frequency shift may be added to the function." + (polysp fund dist% numer denom begin end offset approx)) + +(om::defmethod! sp-gen ((fund list) (dist% number) + (numer integer) (denom integer) (begin integer) (end integer) + &optional (offset 0) (approx nil)) + + (polysp fund dist% numer denom begin end offset approx)) + + +(om::defmethod! sp-gen ((fund chord) (dist% number) + (numer integer) (denom integer) (begin integer) (end integer) + &optional (offset 0) (approx nil)) + (polysp fund dist% numer denom begin end offset approx)) + + + +(om::defmethod! sp-gen ((fund chord-seq) (dist% number) + (numer integer) (denom integer) (begin integer) (end integer) + &optional (offset 0) (approx nil)) + (polysp fund dist% numer denom begin end offset approx)) + + +(om::defmethod! sp-gen ((fund note) (dist% number) + (numer integer) (denom integer) (begin integer) (end integer) + &optional (offset 0) (approx nil)) + (polysp fund dist% numer denom begin end offset approx)) + +;======================================================================================== + + +; a faire : crŽer des objets quand fund = objet + +(om::defmethod! nth-polysp ((fund t) (nth t ) + (dist% number) + &optional (offset 0) (approx nil)) + + :initvals '(3600 '(1 2 3 4 5) 0 0 nil) + :indoc '("Fundamental" "Ranks" "Distor" "Offset" "Approx") + :menuins '((4 (("nil" nil) ("1/2" '1/2) ("1/4" '1/4) ("1/8" '1/8)))) + :icon 137 + + :doc "Returns the harmonic(s) of the fundamental . can be atom, +or a list any depth ; can be atom or list ; may be non integer +dist% et offset optionnels +algorithme : p = f * r ^ d + offset +d = 1 + dist%/100 (dist% = distorsion exprimŽe en %) +offset = freq shift" +(let* ((approx + (cond ((null approx) nil) + ((equal approx '1/2) 2) + ((equal approx '1/4) 4) + ((equal approx '1/8) 8))) + (res (deep-mapcar/1 'hcalc (mc->f (carlist! fund)) (list! nth) dist% offset approx))) + (if (one-elem res) (first res) res))) + + +(om::defmethod! nth-polysp ((fund chord) (nth t ) + (dist% number) + &optional (offset 0) (approx nil)) +(make-instance 'chord + :LMidic (flat (nth-polysp (lmidic fund) nth dist% offset approx)) + :Lvel (lvel fund) + :Loffset (loffset fund) + :Ldur (ldur fund) + :Lchan (lchan fund) + :lport (lport fund))) + +(om::defmethod! nth-polysp ((fund chord-seq) (nth t ) + (dist% number) + &optional (offset 0) (approx nil)) + (make-instance 'chord-seq + :lmidic + (loop for c in (chords fund) + collect (flat (nth-polysp (lmidic c) nth dist% offset approx))) + :lonset (lonset fund) + :legato (legato fund))) + + +;====Rename nth-polysp as N-SP-GEN 22-11-2006================================================== + +(om::defmethod! n-sp-gen ((fund t) (nth t ) + (dist% number) + &optional (offset 0) (approx nil)) + + :initvals '(3600 '(1 2 3 4 5) 0 0 nil) + :indoc '("Fundamental" "Ranks" "Distor" "Offset" "Approx") + :menuins '((4 (("nil" nil) ("1/2" '1/2) ("1/4" '1/4) ("1/8" '1/8)))) + :icon 137 + + :doc "Returns the partial(s) of fundamental . can be an atom or a list any depth ; can be an atom or a list ; may be a non-integer. ÔdÕ allows to input a distortion factor immediately. + +The following algorithm is used: p = f * r ^ d + offset. +Here, d = 1 + dist%/100 (dist% = distortion percentage). +In case d = 1, there is no distortion (dist% = 0) and the series is harmonic. +In case d < 1, we have a distorted (i.e. inharmonic) spectrum which is compressed. +In case of d > 1 we have a distorted (i.e. inharmonic) spectrum which is expanded. + +Optional: With ÔoffsetÕ a frequency shift may be added to the function. ÔapproxÕ allows to specify the desired approximation of the pitches to the nearest 1/2 th, 1/4 th, or 1/8th tone." + + (nth-polysp fund nth dist% offset approx)) + + +(om::defmethod! n-sp-gen ((fund chord) (nth t ) + (dist% number) + &optional (offset 0) (approx nil)) + (nth-polysp fund nth dist% offset approx)) + + + +(om::defmethod! n-sp-gen ((fund chord-seq) (nth t ) + (dist% number) + &optional (offset 0) (approx nil)) + (nth-polysp fund nth dist% offset approx)) + +;======================================================================================== + + + + + + + +; --------------------- modulation de frŽquence --------------------- + + + +(defun fmnthtm (p m lindex output) + (let ((res (if (equal output 'exclus) () (list p)))) + (while lindex + (let ((i (pop lindex))) + (push (+ p (* i m)) res) + (push (- p (* i m)) res))) + (reverse res))) + + + +(defmethod! fm/origin ((diff number) (add number)) + :initvals '(7200 4800) + :indoc '("Differential" "Additional") + :icon 136 + :doc "rend liste (porteuse modulante) en fct diffŽrentiel et +additionnel (d'indice 1) " +(let ((d (mc->f (car! diff))) (a (mc->f (car! add))) port modul) + ;(if (> d a) (setq a (mc->f (car! diff)) d (mc->f (car! add)))) + (setq port (/ (+ a d) 2) modul (abs (/ (- a d) 2))) + (format t "porteuse = ~S ; modulante = ~S ; ratio = ~S / " + (om-round port 3) (om-round modul 3) (om-round (/ modul port) 3)) + (f->mc (list port modul)))) + + +;====Rename fm/origin as fm-origin 22-11-2006================================================== + +(om::defmethod! fm-origin ((diff number) (add number)) + :initvals '(7200 4800) + :indoc '("Differential" "Additional") + :icon 136 + :doc "Returns a list (carrier, modulator) after input of given difference and addition tones (with i=1)." + + (fm/origin diff add)) + +;============================================================================================== +; verifier pour carrier = liste (les options chord - chordseq ne marchent pas) + +;====<>================================================== + +(defmethod! fm/freq ((fcarrier t) (fmod t) (index t) + (format symbol) &optional (output t)) + :initvals '(261 440 5 'Chord 'inclus) + :indoc '("Carrier" "Modulator" "Index" "Format" "Output") + :menuins '((3 (("Chord" 'Chord) ("Chordseq" 'Chordseq) )) (4 (("Inclus" 'inclus) ("Exclus" 'exclus) ))) + :icon 137 + :doc "Input = freq ; output = object + fcarrier fmod and index may be lists" + +(let* (ll (x (one-elem fcarrier)) (fcarrier (list! fcarrier)) (fmod (list! fmod)) + (index (if (atom index) (arithm-ser 1 index 1) index )) + ; (lindex (append '(0) (list-fill index (* 2 (length index))))) + res) + (while fcarrier + (let ((a (pop fcarrier))) + (push (unique (flat (mapcar #'(lambda (x) (f->mc (fmnthtm a x index output))) fmod))) ll) )) + + (if (equal format 'Chord) + (if x + (setq res (make-instance 'chord + :lmidic (flat (nreverse ll) ))) + (dolist (n ll) + (push (make-instance 'chord + :lmidic n ) res))) + (setq res (if x (flat (nreverse ll)) (nreverse ll)))) + res)) + + + +(om::defmethod! fm/midic ((mcarrier t) (mmod t) (index t ) + (format symbol ) &optional (output t)) + :initvals '(6000 6600 5 'Chord 'inclus) + :indoc '("Carrier" "Modulator" "Index" "Format" "Output") + :menuins '((3 (("Chord" 'Chord) ("Chordseq" 'Chordseq) )) (4 (("Inclus" 'inclus) ("Exclus" 'exclus) ))) + :icon 137 + :doc "MF en midics, si index=atome, MF classique, si index=liste, MF calculŽe +seulement pour les valeurs de cette liste" + (fm/freq (mc->f mcarrier) (mc->f mmod) index format output)) + + + +(om::defmethod! fm/ratio ((carrier t) (ratio t) (index t ) + (format symbol) &optional (output t)) + + :initvals '(6000 1.42 5 'Chord) + :indoc '("Carrier" "Modulator" "Index" "Format" "Output") + :menuins '((3 (("Chord" 'Chord) ("Chordseq" 'Chordseq) )) (4 (("Inclus" 'inclus) ("Exclus" 'exclus) ))) + :icon 136 + :doc "porteuse=midic sortie=objet ou liste" + + (fm/freq (mc->f carrier) (om* ratio (mc->f carrier)) index format output)) + + + +;====Rename fm/ratio as FM-ratio 22-11-2006================================================== + +(om::defmethod! fm-ratio ((carrier t) (ratio t) (index t ) + (format symbol) &optional (output t)) + + :initvals '(6000 1.42 5 'Chord) + :indoc '("Carrier" "Modulator" "Index" "Format" "Output") + :menuins '((3 (("Chord" 'Chord) ("Chordseq" 'Chordseq) )) (4 (("Inclus" 'inclus) ("Exclus" 'exclus) ))) + :icon 136 + :doc "porteuse=midic sortie=objet ou liste" + + (fm/ratio carrier ratio index format output)) + +;============================================================================================= + + + + +(om::defmethod! fm/fan ((carrier number) (ratio number) (index t) + (del1 number) (deltot number) (durs t) (dyns t) &optional (output t)) + + :initvals '(6000 1.42 5 200 2000 200 80 'inclus) + :indoc '("Carrier" "Ratio" "Index" "First delay" "Total delay" "Durs" "Dyns" "Output") + :menuins '((7 (("Inclus" 'inclus) ("Exclus" 'exclus) ))) + :icon 136 + :doc "deltot : temps entre index 0 et index + del1 : temps entre index 0 et index 1" + +(let* ((index (if (atom index) (arithm-ser 1 index 1 ) index)) + (lg (length index)) + (hauteurs (f->mc (fmnthtm (mc->f carrier) (om* ratio (mc->f carrier)) index output))) + ; (lindex (append '(0) (list-fill index (* 2 lg)))) + + (offs (if (> lg 1) + (x-append 0 + (list-fill (om-round + (power/3 (arithm-ser 1 lg 1) 0 0 1 del1 lg deltot ) 1) + (* 2 lg))) + (list 0 deltot deltot)))) + + (make-instance 'chord + :lmidic hauteurs + :lvel (list! dyns) + :ldur (list! durs) + :loffset (om-round offs) ))) + + +;====Rename fm/fan as fm-arp 22-11-2006================================================== + +(defmethod! fm-arp ((carrier number) (ratio number) (index t) + (del1 number) (deltot number) (durs t) (dyns t) &optional (output t)) + + :initvals '(6000 1.42 5 200 2000 200 80 'inclus) + :indoc '("Carrier" "Ratio" "Index" "First delay" "Total delay" "Durs" "Dyns" "Output") + :menuins '((7 (("Inclus" 'inclus) ("Exclus" 'exclus) ))) + :icon 136 + :doc +"Returns an arpeggio of the frequency modulation sound. The component of the sound with the higher index starts later than those with a lower indices. + +deltot: time between index 0 and index . +del1: time between index 0 and index 1" + + (fm/fan carrier ratio index del1 deltot durs dyns output)) + +;============================================================================================= + + + + + + + + + +;======================= from Esquisse ================================== + +(om::defmethod! freq-mod ((carrier number) (modul number) (index number) (unit symbol) (type symbol)) + :initvals '(3600 4000 1 'midic 'chord) + :indoc '("Carrier" "Moduler" "Index" "Unit" "Type") + :menuins '((3 (("Midics" 'midic) ("Freqs" 'freq)))(4 (("Chord" 'chord) ("ChordSeq" 'chordseq)))) + :icon 136 + :doc + "Computes a FM spectrum from , and . + and may be expressed in midics (the default) or in freqs. In that case +the menu must be set to 'Freq'. +, the modulation index is a positive integer between 1 and 25. +Outputs a chord object. +, and may also be lists. In that case, the 1st item in +is modulated by the 1st item in , with the 1st index in , and so on. +The results are then merged into a chord object. +When using lists, you may also have the result as a series of chords in a +chord-seq object by selecting 'chordseq' in the menu " + + (when (eq unit 'midic) + (setf carrier (mc->f carrier) modul (mc->f modul))) + (let* ((spec (fmspec carrier modul index)) + (vel (mapcar #'(lambda (x) (round (* (/ 127 3.0) (if (<= (cdr x) 0.0) 0 (log (cdr x) 10))))) spec)) + (spec (band-filter (mapcar #'car spec) '((15.0 20000.0)) 'pass)) ) + (make-instance 'chord + :lmidic (f->mc spec) + :lvel vel) )) + + +(defmethod! freq-mod ((carrier list) (modul list) (index list) (unit symbol) (type symbol)) + (let ((fmlist (loop while (or carrier modul index) + for car = (pop carrier) then (if carrier (pop carrier) car) + for mod = (pop modul) then (if modul (pop modul) mod) + for ind = (pop index) then (if index (pop index) ind) + collect (freq-mod car mod ind unit type)))) + (if (eq type 'chordseq) + (make-instance 'chord-seq :lmidic fmlist) + (make-instance 'chord :lmidic (flat (mapcar 'lmidic fmlist)) :lvel (flat (mapcar 'lvel fmlist)))))) + +(defmethod! freq-mod ((carrier t) (modul t) (index t) (unit symbol) (type symbol)) + (freq-mod (list! carrier) (list! modul) (list! index) unit type)) + +(defmethod! freq-mod ((carrier chord) (modul t) (index t) (unit symbol) (type symbol)) + (freq-mod (lmidic carrier) modul index 'midic type)) + + +;====Rename freq-mod as fmo 22-11-2006================================================== + +(defmethod! fmo ((carrier number) (modul number) (index number) (unit symbol) (type symbol)) + :initvals '(3600 4000 1 'midic 'chord) + :indoc '("Carrier" "Moduler" "Index" "Unit" "Type") + :menuins '((3 (("Midics" 'midic) ("Freqs" 'freq)))(4 (("Chord" 'chord) ("ChordSeq" 'chordseq)))) + :icon 136 + :doc + "Computes a frequency modulation spectrum, returning a chord object. The carrier frequency C is modulated by the modulating frequency M with modulation index I . + + and may be expressed in midics (the default) or in freqs. In that case the menu must be set to 'Freq'. , the modulation index, is a positive integer between 1 and 25. + +The inputs , and may also be lists. In that case, the nth element in is modulated by the nth element in using the nth element in , and so on. The results are then merged into a chord object (by default) or a chord-seq object by selecting 'chordseq' in the menu . + +A short explanation of FM (Curtis Roads, the computer music tutorial, MIT press, Massachusetts, p. 227-230): In case the inputs are atoms, we have Simple FM or Chowning FM (Chowning 1973). FM between two sinusoids generates a series of sidebands around C. Each sideband is located at a distance equal to a multiple of M. When the ratio between C and M (the C:M ratio) is a simple integer ratio such as, for example, 3:2 or 4:1, FM generates harmonic spectra. This means that the sidebands are integer multiples of both M and C. When C:M is not a simple integer ratio, FM creates inharmonic spectra. The number of sidebands the bandwidth) of the FM spectrum is controlled by the modulation index I, etc." + + (freq-mod carrier modul index unit type)) + +(defmethod! fmo ((carrier list) (modul list) (index list) (unit symbol) (type symbol)) + (let ((fmlist (loop while (or carrier modul index) + for car = (pop carrier) then (if carrier (pop carrier) car) + for mod = (pop modul) then (if modul (pop modul) mod) + for ind = (pop index) then (if index (pop index) ind) + collect (freq-mod car mod ind unit type)))) + (if (eq type 'chordseq) + (make-instance 'chord-seq :lmidic fmlist) + (make-instance 'chord :lmidic (flat (mapcar 'lmidic fmlist)) :lvel (flat (mapcar 'lvel fmlist)))))) + +(defmethod! fmo ((carrier t) (modul t) (index t) (unit symbol) (type symbol)) + (freq-mod carrier modul index unit type)) + +(defmethod! fmo ((carrier chord) (modul t) (index t) (unit symbol) (type symbol)) + (freq-mod carrier modul index unit type)) + +;====================================================================================== + + + +; ------ freq modulation fcts ------------- + +(defvar *maxorder* 25) +(defvar *bessel* + (make-array '(26 25) + :initial-contents + '( + ( 1000 765 223 -260 -397 -177 150 300 171 -90 -245 -171 47 206 171 -14 -174 -169 -13 + 146 167 36 -120 -162 -56) + ( 0 440 576 339 -66 -327 -276 -4 234 245 43 -176 -223 -70 133 205 90 -97 -187 -105 66 + 171 117 -39 -154) + ( 0 114 352 436 364 46 -242 -301 -112 144 254 139 -84 -217 -152 41 186 158 -7 -157 -160 + -20 131 158 43) + ( 0 19 128 309 430 364 114 -167 -291 -180 58 227 195 3 -176 -194 -43 134 186 72 -98 -174 + -93 67 161) + ( 0 2 33 132 281 391 357 157 -105 -265 -219 -15 182 219 76 -119 -202 -110 69 180 130 -29 + -156 -141 -3) + ( 0 0 7 43 132 261 362 347 185 -55 -234 -238 -73 131 220 130 -57 -187 -155 3 151 163 36 + -116 -162) + ( 0 0 1 11 49 131 245 339 337 204 -14 -201 -243 -118 81 206 166 0 -155 -178 -55 107 173 90 + -64) + (0 0 0 2 15 53 129 233 320 327 216 18 -170 -240 -150 34 182 187 51 -116 -184 -102 58 163 130) + (0 0 0 0 4 18 56 127 223 305 317 224 45 -141 -231 -173 -7 153 195 92 -73 -175 -136 8 140) + (0 0 0 0 0 5 21 58 126 214 291 308 230 66 -114 -220 -189 -42 122 194 125 -31 -157 -157 -36) + (0 0 0 0 0 1 6 23 60 124 207 280 300 233 85 -90 -206 -199 -73 91 186 148 7 -132 -167) + (0 0 0 0 0 0 2 8 25 62 123 201 270 292 235 99 -68 -191 -204 -98 61 173 164 42 -103) + (0 0 0 0 0 0 0 2 9 27 63 121 195 261 285 236 112 -48 -176 -205 -118 32 156 173 72) + (0 0 0 0 0 0 0 0 3 10 28 64 120 190 253 278 236 122 -30 -161 -204 -135 6 137 176) + (0 0 0 0 0 0 0 0 1 3 11 30 65 118 185 246 272 236 131 -15 -146 -200 -148 -17 118) + (0 0 0 0 0 0 0 0 0 1 4 13 31 65 117 181 239 266 235 138 0 -132 -195 -158 -38) + (0 0 0 0 0 0 0 0 0 0 1 5 13 32 66 116 177 234 261 234 145 12 -118 -189 -166) + (0 0 0 0 0 0 0 0 0 0 0 1 5 14 33 66 114 173 228 255 233 150 23 -105 -183) + (0 0 0 0 0 0 0 0 0 0 0 0 2 6 15 34 66 113 170 223 251 231 154 34 -93) + (0 0 0 0 0 0 0 0 0 0 0 0 0 2 6 16 35 67 112 167 218 246 229 158 43) + (0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 7 17 36 67 111 164 214 242 228 161) + (0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 3 7 18 36 67 110 162 210 238 226) + (0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 3 8 18 37 67 109 159 206 234) + (0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 3 8 19 38 67 108 157 203) + (0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 3 9 19 38 67 107 155) + (0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 4 9 20 39 67 106) + ) + ) + ) + +(defun fix (x) (truncate x)) +(defun ceil (x) (ceiling x)) +(defun fixp (x) (integerp x)) +(defun add1 (x) (1+ x)) + +(defun fmSpec (c m imod &optional order) + (let ((spec) s p MI) + (setq MI imod) + (if (floatp imod) (setq imod (ceil imod)) (setq imod (fix imod))) + (if (null order) + ;(setq order (car order)) + (setq order (add1 imod)) ) + (setq order (min order *maxorder*)) + (setq spec `((, c . 0 ))) + (for (i 1 1 order) + (newl spec (cons (- c (* i m)) (- i))) + (setq spec (nconc spec (list (cons (+ c (* i m)) i)))) + (when (and (null p) (< (caar spec) 0)) + (setq p spec))) + (setq s spec) + (while s + ;(when (and (null p) (>= (caar s) 0)) + ; (setq p q)) + (cond + ( (< (cdar s) 0) + (if (oddp (cdar s)) + (rplacd (car s) (- (bessel MI (abs (cdar s))))) + (rplacd (car s) (bessel MI (abs (cdar s))))) + (when (< (caar s) 0) + (rplaca (car s) (- (caar s))) + (rplacd (car s) (- (cdar s))))) + ( t + (rplacd (car s) (bessel MI (cdar s))))) + ;(setq q s) + (nextl s)) + (setq spec + (if (not p) + spec + (fmMerge (cdr p) + (progn (rplacd p ()) (nreverse spec))))) + (mapc #'(lambda (comp) + (rplacd comp (abs (cdr comp)))) + spec) + (when (<= (caar spec) 0) (nextl spec)) + (fmNormalize spec) + spec +)) + + +(defun fmNormalize (spec) + (let ((etot 0) ratio) + (mapc #'(lambda (x) (setf etot (+ etot (cdr x)))) + spec) + (setq ratio (/ 1000.0 etot)) + (mapc #'(lambda (x) + (rplacd x (fix (* (cdr x) ratio)))) + spec) + spec)) + + + +(defun bessel (imod i) + (if (fixp imod) + (aref *bessel* i imod) + (let ((i1 (aref *bessel* i (fix imod))) (i2 (aref *bessel* i (ceil imod)))) + (fix (+ i1 (* (- imod (fix imod)) (- i2 i1))))))) + +(defun fmMerge (f1 f2) + (let ((r (list ()))) + (fmMerge2 r f1 f2) + (cdr r))) + + +(defun fmMerge2 (r f1 f2) + (cond + ((null f1) (rplacd r f2)) + ((null f2) (rplacd r f1)) + ((< (caar f1) (caar f2)) + (rplacd r f1) + (fmMerge2 f1 (cdr f1) f2)) + ((= (caar f1) (caar f2)) + (rplaca f1 (cons (caar f1) (+ (cdar f1) (cdar f2)))) + (rplacd r f1) + (fmMerge2 f1 (cdr f1) (cdr f2))) + (t (rplacd r f2) + (fmMerge2 f2 f1 (cdr f2))))) + + +(defun fm (c m i) + (let ((spec (fmspec c m i))) + (cons (mapcar #'car spec) + (mapcar #'(lambda (x) (round (* (/ 127 3.0) (log (cdr x) 10)))) spec)))) + + + + +; ----------------------ring modulation--------------------------- + +; from Esquisse (ring-mod) - optional ajoutŽ - type et unit intervertis + +(defun ring/freq (freqs1 freqs2 ) +"Rend une liste de listes de frŽquences contenant la modulation en anneau +de chaque frŽquence de la liste par la liste " + (let* (ll (freqs1 (list! freqs1)) (freqs2 (list! freqs2)) + (x (one-elem freqs1))) + (while freqs1 + (let ((a (pop freqs1))) + (push (append (om+ a freqs2) (om- a freqs2)) ll) )) + (if x (flat (nreverse ll)) (nreverse ll)))) + +(defmethod! ring-modulation ((ch1 number) (ch2 number) &optional (type 'chord) (unit 'midic) ) + :initvals '(6000 6200 'chord 'midic) + :indoc '("Chord" "Chord" "Type" "Unit") + :menuins '((3 (("Midics" 'midic) ("Freqs" 'freq))) (2 (("Chord" 'chord) ("ChordSeq" 'chordseq))) ) + :icon 137 + :doc + "Simulates the ring modulation of each note of by all the notes of +. The frequency of each note of is added to and subtracted +from the frequency of each note of ; thus, all the possible +additive and subtractive combinations are produced. + + and may be midics, list of midics, list of lists of midics or chord objects. + +The optional argument determines whether and are +entered in midicents, ('midic'), or in hertz ('freq'). If 'midic' is +selected the values will be converted to frequencies inside the function +and then the output is reconverted to midicents. If 'freq' is selected the +entries, calculations and output are all in hertz. (note: Ring-modulation +can produce negative frequencies; conversion to midicents will +automatically reflect these notes back into the positive domain.) + +When contains multiple notes, the optional argument is used +to determine the format of the output. The value 'seq' returns a list of +chords representing the modulation of each successive note of by +all the notes of . The value 'chord' returns a single chord +containing all the notes of all the modulations. + +The output is always list of midics or list of list of midics. + and may be chord objects in which case the unit is set to 'midic internally. + +Certain combinations may produce too many levels of parentheses: use after +" + + + (let ((res (if (eq unit 'freq) + (ring/freq ch1 ch2) + (f->mc (ring/freq (mc->f ch1) (mc->f ch2)))))) + (setq res (push (x-append ch1 ch2) res)) + (setq res (band-filter res '((100 12000)) 'pass)) + (if (or (eq type 'chord) (one-elem ch1) ) (flat res) res ))) + + +(defmethod! ring-modulation ((ch1 t) (ch2 t) &optional (type nil) (unit nil)) + + (let ((ring (remove-dup + (loop for note in (list! ch1) + collect (loop for mod in (list! ch2) append (ring-modulation note mod type unit ))) + 'eq + 2))) + (if (eq type 'chord) + (remove-dup (flat ring) 'eq 1) + ring )) ) + + +(defmethod! ring-modulation ((ch1 CHORD) (ch2 CHORD) &optional (type nil) (unit nil)) + (ring-modulation (lmidic ch1) (lmidic ch2) type 'midic )) + +;====Rename ring-modulation as rmo 22-11-2006================================================== + +(defmethod! rmo ((ch1 number) (ch2 number) &optional (type 'chord) (unit 'midic)) + :initvals '(6000 6200 'chord 'midic) + :indoc '("Chord" "Chord" "Type" "Unit") + :menuins '((2 (("Chord" 'chord) ("ChordSeq" 'chordseq))) (3 (("Midics" 'midic) ("Freqs" 'freq)))) + :icon 137 + :doc + "Simulates the ring modulation of each note of by all the notes of . The frequency of each note of is added to and subtracted from the frequency of each note of ; thus, all the possible additive and subtractive combinations are produced. + + and may be midics, list of midics, list of lists of midics or chord objects. + +The optional argument determines whether and are entered in midicents, ('midic'), or in hertz ('freq'). If 'midic' is +selected the values will be converted to frequencies inside the function and then the output is reconverted to midicents. If 'freq' is selected the entries, calculations and output are all in hertz. (note: Ring-modulation can produce negative frequencies; conversion to midicents will automatically reflect these notes back into the positive domain.) + +When contains multiple notes, the optional argument is used to determine the format of the output. The value 'seq' returns a list of chords representing the modulation of each successive note of by all the notes of . The value 'chord' returns a single chord containing all the notes of all the modulations. + +The output is always list of midics or list of list of midics. and may be chord objects in which case the unit is set to 'midic internally. + +Certain combinations may produce too many levels of parentheses: In that case use after ." + (ring-modulation ch1 ch2 type unit)) + +(defmethod! rmo ((ch1 t) (ch2 t) &optional (type nil) (unit nil)) + (ring-modulation ch1 ch2 type unit)) + + +(defmethod! rmo ((ch1 CHORD) (ch2 CHORD) &optional (type 'chord) (unit 'midic)) + ; should compute the resulting velocities sometime + (case type + (chord (mki 'chord :lmidic (ring-modulation ch1 ch2 type unit))) + (chordseq (loop for chord in (ring-modulation ch1 ch2 type unit) + collect (mki 'chord :lmidic chord))))) + + + +(defmethod! rmo ((s1 chord) (s2 chord-seq) &optional (type 'chord) (unit 'midic) ) + (mki 'chord-seq + :lmidic + (flat-once (loop for chord in (chords s2) + collect (rmo s1 chord type unit))))) + +(defmethod! rmo ((s1 chord-seq) (s2 chord) &optional (type 'chord) (unit 'midic) ) + (mki 'chord-seq + :lmidic + (flat-once (loop for chord in (chords s1) + collect (rmo chord s2 type unit))))) + + + +(defmethod! rmo ((s1 chord-seq) (s2 chord-seq) &optional (type 'chord) (unit 'midic) ) + (mki 'multi-seq + :chord-seqs + (loop for chord1 in (chords s1) + collect + (mki 'chord-seq + :lmidic + (flat-once (loop for chord2 in (chords s2) + collect (rmo chord1 chord2 type unit))))))) + + + +;============================================================================================== + + +(defun ringlist (fonda fondb hqa hqb ) + (let ((lfonda (om* fonda hqa)) (lfondb (list!(om* fondb hqb)))) + (flat-once (mapcar #'(lambda (x) (ring-mod lfonda x 2 1 1)) lfondb)))) + +(defun ringharm/f/struc (fond1 fond2 hqa hqb ) +"" +(setq fond1 (car! fond1) fond2 (car! fond2)) +(if (and (atom hqa) (atom hqb)) + (let ( (mx (max hqa hqb)) (res ()) (resinter ()) ) + (for (m 1 1 mx) + (for (ia 1 1 (min m hqa)) + (for (ib 1 1 (min m hqb)) + (if (and (< ia m) (< ib m)) () + (progn (push (+ (* ia fond1) (* ib fond2)) resinter) + (if (/= (- (* ia fond1) (* ib fond2)) 0) + (push (- (* ia fond1) (* ib fond2)) resinter)))) + )) + (push (reverse resinter) res) + (setq resinter () )) + (reverse res)) + (ringlist fond1 fond2 hqa hqb))) + + + + + +(defmethod! ring-harm ((funda number) (fundb number) + (hqa t) (hqb t) + &optional (type nil) (output nil) (unit nil)) + :initvals '(4800 5400 2 3 'chord 'excluded 'midic) + :indoc '("Fundam a" "Fundam b" "Harm a" "Harm b" "Type" "Output" "Unit" ) + :menuins '((4 (("chord" 'chord) ("chord list" 'chlist))) + (5 (("excluded" 'excluded) ("included" 'included))) + (6 (("midic" 'midic) ("hz" 'hz) ))) + :icon 137 + :doc "Simulates the ring-modulation between the harmonic series (see box +'harm-series') built on and the harmonic series on . The +arguments and determine the number of partials present for +each fundamental. The frequencies of each partial of the harmonic series +on is added to and subtracted from the frequency of each partial +of the harmonic series on ; thus, all the possible additive and +subtractive combinations are produced. + +If the arguments or are a list, rather then including all the +partials up to and including the number given: only the listed partials +for both fundamentals will included in the calculations. + +The optional argument determines whether and are +given in midicents, ('midic'), or in hertz ('freq'). If 'freq' is selected +entries and output are all in hertz. + +The optional argument is used to determine the format of the +output. The value 'seq' returns a list of chords in which each successive +chord represents the notes involving the next partial or partials. +Thus the first chord contains: funda ± fundb; the second: 2*funda ± fundb, +funda ± 2*fundb and 2*funda ± 2*fundb; etc. The value 'chord' returns a +single chord containing all the notes of all the combinations and +differences. + +The optional argument determines whether the notes and + are included ('inclu') or excluded ('exclu') from the output list +or lists." + +(let ((res (if (equal unit 'hz) (ringharm/f/struc funda fundb hqa hqb) + (f->mc (ringharm/f/struc (mc->f funda) (mc->f fundb) hqa hqb))))) + (if (eq output 'included) (setq res (push (list funda fundb) res)) res) + (if (eq type 'chord) (flat res) res))) + + + +;====Rename ring-harm as rm-gen 22-11-2006================================================= + +(defmethod! rm-gen ((funda number) (fundb number) + (hqa t) (hqb t) + &optional (type nil) (output nil) (unit nil)) + :initvals '(4800 5400 2 3 'chord 'excluded 'midic) + :indoc '("Fundam a" "Fundam b" "Harm a" "Harm b" "Type" "Output" "Unit" ) + :menuins '((4 (("chord" 'chord) ("chord list" 'chlist))) + (5 (("excluded" 'excluded) ("included" 'included))) + (6 (("midic" 'midic) ("hz" 'hz) ))) + :icon 137 + :doc "Simulates the ring-modulation between the harmonic series on and the harmonic series on . The arguments and determine the number of partials present for each fundamental. The frequencies of each partial of the harmonic series on is added to and subtracted from the frequency of each partial of the harmonic series on ; thus, all possible addition and difference tones are calculated. + +If the arguments or are lists, only the listed partials will be included in the calculations. + +The optional argument determines whether and are given in midicents, ('midic'), or in hertz ('freq'). If 'freq' is selected entries and output are all in hertz. + +The optional argument is used to determine the format of the output. The value 'seq' returns a list of chords in which each successive chord represents the notes involving the next partial or partials. Thus the first chord contains: funda ± fundb; the second: 2*funda ± fundb, funda ± 2*fundb and 2*funda ± 2*fundb; etc. The value 'chord' returns a single chord containing all the notes of all the combinations and differences. + +The optional argument determines whether the notes and are included ('inclu') or excluded ('exclu') from the output list or lists." + + (ring-harm funda fundb hqa hqb type output unit)) + +;========================================================================================== + + +(defun +- (a b) + (list (+ a b) (- a b))) + +(defun +&- (a b) + (append (om+ a b) (om- a b))) + +(defmethod! intermod ((accord list) (resul symbol ) (approx integer)) + + :initvals '('(6000 6600) 'ring 4) + :indoc '("List Midics" "Calcul" "Approx" ) + :menuins '((1 (("add" 'add) ("diff" 'diff) ("ring" 'ring)))) + :icon 136 + :doc "modulations entre les sons de l'accord, diff, add ou les deux (ring) +Toutes les combinaisons 2 ˆ 2 sont envisagŽes. +Les rŽpŽtitions sont enlevŽes, en fct de approx" + + (let ((couples (posn-match (mc->f accord) + (combinaisons (arithm-ser 0 (1- (length accord)) 1)))) + (fct (case resul (add '+) (diff '-) (ring '+-))) + res) + (dolist (c couples) + (push (apply fct c) res)) + (unique-notes (flat (f->mc res)) approx))) + +;====Rename intermod as rm-intra 22-11-2006================================================= + +(defmethod! rm-intra ((accord list) (resul symbol ) (approx integer)) + + :initvals '('(6000 6600) 'ring 4) + :indoc '("List Midics" "Calcul" "Approx" ) + :menuins '((1 (("add" 'add) ("diff" 'diff) ("ring" 'ring)))) + :icon 136 + :doc "Returns a choice of difference tones, addition tones or both within one chord. All possible combinations are calculated. Repetitions are omitted after approximation to the nearest 1/2, 1/4th or 1/8th tone." + + (intermod accord resul approx)) + + +;============================================================================================ + + +(om::defmethod! resultants ((ch1 list) (ch2 list ) (resul symbol ) (approx integer)) + + :initvals '('(6000 6600) '(4700 5300) 'ring 4) + :indoc '("accord1" "accord2" "Calcul" "Approx" ) + :menuins '((2 (("add" 'add) ("diff" 'diff) ("ring" 'ring)))) + :icon 136 + :doc +"sons resultants additionnels ou diffŽrentiels entre les deux accords, +sans rŽpŽtition (en fct de approx) " + (let (ll (freqs1 (mc->f (list! ch1))) (freqs2 (mc->f (list! ch2))) + (fct (case resul (add 'om+) (diff 'om-) (ring '+&-)))) + (while freqs1 + (let ((a (pop freqs1))) + (push (funcall fct a freqs2) ll) )) + (f->mc ll) + (unique-notes (flat (f->mc ll)) approx))) + + +;====Rename resultants as rm-approx 22-11-2006================================================= +;====<>============================== + +(om::defmethod! rm-approx ((ch1 list) (ch2 list ) (resul symbol) (approx integer)) + + :initvals '('(6000 6600) '(4700 5300) 'ring 4) + :indoc '("accord1" "accord2" "Calcul" "Approx" ) + :menuins '((2 (("add" 'add) ("diff" 'diff) ("ring" 'ring)))) + :icon 136 + :doc +"Returns all possible difference tones and addition tones between two chords. Repetitions are omitted after approximation to the nearest 1/2, 1/4th or 1/8th tone." + + (x-diff (resultants ch1 ch2 resul approx) '(-1272300))) + +;============================================================================================ + + + +(om::defmethod! ch-rm-sine ((object chord) (sine t) (%amp t) (type t) +(mode t) (inclus t) + &optional (channel nil) (port nil)) + + + :initvals '(nil 440 100 'freq 'RM 'inclus nil nil ) + :menuins '((3 (("freq" 'freq) ("midic" 'midic))) (4 (("add" 'add) + ("diff" 'diff) ("RM" 'RM))) + (5 (("inclus" 'inclus) ("exclus" 'exclus)))) + :icon 137 + :doc "Simulation of the ring modulation of an object (chord, chord-seq or multi-seq) by a sine-wave. +%amp : scales amplitude of the resulting sounds (according to a given percentage of the original amplitudes). +Choices : input of sine wave tone either as frequency or in midicents ; computation of the additional or the differential tone or both (RM); initial object can be included or not. +Options : it is possible to asign a different channel and port to the resulting sounds. +In order to calculate ring modulation of the harmonics of the object, use 'mixtur' before ch-RM-sine." + +(let* ((sine (list! (if (eq type 'freq) sine (mc->f sine)))) + (nbsine (length sine)) + (lcanal (if (atom channel) (create-list nbsine channel) channel)) + (lport (if (atom port) (create-list nbsine port) port)) + (lamp (if (atom %amp) (create-list nbsine %amp) %amp )) + + (resultchord (loop for s in sine + for a in lamp + for c in lcanal + for p in lport + collect (simpleRM object s a mode c p) )) + + (finalresult (if (one-elem resultchord) (first resultchord) (mixer + resultchord nil)))) + +(if (eq inclus 'inclus) (mixer object finalresult) finalresult))) + + +(defun simpleRM (object sine %amp mode channel port ) +(print + (if (eq mode 'RM) (mixer (simpleresul object sine %amp 'add channel port) + (simpleresul object sine %amp 'diff channel port)) + (simpleresul object sine %amp mode channel port)))) + + +(defun simpleresul (object sine %amp mode channel port) + (let* ((gener (mc->f (lmidic object)))) + (mki 'chord + :LMidic (f->mc (if (eq mode 'add ) (om+ gener sine) (om- gener sine))) + :Ldur (ldur object) + :LOffset (loffset object) + :Lchan (if (null channel) (lchan object ) (list! channel)) + :Lvel (om// (om* (lvel object ) %amp) 100) + ; :Lport (if (null port) (lport object ) (list! port)))) toujours ce pb avec Lport... + :Lport (if (null port) (lport object ) (create-list (ch-length object) port)) + ))) + +(om::defmethod! ch-rm-sine ((object chord-seq) (sine t) (%amp t) (type t) (mode t) (inclus t) + &optional (channel nil) (port nil)) + (mki 'chord-seq + :lmidic (loop for ch in (chords object) + collect (ch-RM-sine ch sine %amp type mode inclus channel port)) + :lonset (lonset object))) + +(om::defmethod! ch-RM-sine ((object multi-seq) (sine t) (%amp t) (type t) (mode t) (inclus t) + &optional (channel nil) (port nil)) + (mki 'multi-seq + :chord-seqs (loop for cs in (chord-seqs object) + collect (ch-RM-sine cs sine %amp type mode inclus channel port)))) + + +(om::defmethod! ring-sine ((accord chord) (sine t) + &optional (unit 'midic) + (type 'chord) + (output 'exclus)) + :initvals '(nil 6600 'midic 'chord 'exclus) + :indoc '("accord" "sine" "unit" "type" "output") + :menuins '((2 (("midic" 'midic) ("freq" 'freq) )) + (3 (("chord" 'chord) ("seq" 'seq) )) + (4 (("exclus" 'exclus) ("inclus" 'inclus)))) + :icon 137 + :doc + "Simulates the ring modulation of each note of by one or several sine-waves. +The optional argument determines whether sine is +entered in midicents, ('midic'), or in hertz ('freq'). +When contains multiple pitches, the optional argument is used +to determine the format of the output ('seq' or 'chord') +The optional argument determines whether the original notes of + are included ('inclus') or excluded ('exclus') from the +output chord or chords" + (print unit) + (let* ((l-freqs (mc->f (lmidic accord))) + (l-vels (lvel accord)) + (l-durs (ldur accord)) + (l-offs (loffset accord)) + (modul (list! (if (equal unit 'midic) (mc->f sine) sine))) + (nbcomp (1- (length l-freqs))) + (nbmodul (1- (length modul))) + (rm-freqs (if (and (equal output 'inclus) (equal type 'seq)) l-freqs nil)) + (rm-vels (if (and (equal output 'inclus) (equal type 'seq)) l-vels nil)) + (rm-durs (if (and (equal output 'inclus) (equal type 'seq)) l-durs nil)) + (rm-offs (if (and (equal output 'inclus) (equal type 'seq)) l-offs nil)) + lrm-freqs lrm-vels lrm-durs lrm-offs res) + + (for (m 0 1 nbmodul) + (if (or (equal output 'exclus) (and (equal output 'inclus) (equal type 'seq) (> m 0))) + (progn (setq rm-freqs nil) + (setq rm-vels nil ) + (setq rm-durs nil) + (setq rm-offs nil))) + (if (and (equal output 'inclus) (equal type 'chord)) + (progn (setq rm-freqs l-freqs) + (setq rm-vels l-vels ) + (setq rm-durs l-durs) + (setq rm-offs l-offs))) + + (for (i 0 1 nbcomp) + (push (list (+ (nth i l-freqs) (nth m modul)) (- (nth i l-freqs) (nth m modul))) rm-freqs) + (push (create-list 2 (nth i l-durs)) rm-durs) + (push (create-list 2 (nth i l-offs)) rm-offs) + (push (create-list 2 (nth i l-vels)) rm-vels)) + (push (nreverse (flat rm-freqs)) lrm-freqs) + (push (nreverse (flat rm-durs)) lrm-durs) + (push (nreverse (flat rm-offs)) lrm-offs) + (push (nreverse (flat rm-vels)) lrm-vels)) + + (setq lrm-freqs (if (or (one-elem sine) (equal type 'seq)) (flat (nreverse lrm-freqs)) + (nreverse lrm-freqs) )) + (setq lrm-vels (if (or (one-elem sine) (equal type 'seq)) (flat (nreverse lrm-vels)) + (nreverse lrm-vels) )) + (setq lrm-durs (if (or (one-elem sine) (equal type 'seq)) (flat (nreverse lrm-durs)) + (nreverse lrm-durs) )) + (setq lrm-offs (if (or (one-elem sine) (equal type 'seq)) (flat (nreverse lrm-offs)) + (nreverse lrm-offs) )) + + (if (or (one-elem sine) (equal type 'seq)) + + (setf res (make-instance 'chord + :lmidic (f->mc (flat lrm-freqs)) + :ldur (flat lrm-durs) + :loffset (flat lrm-offs) + :lvel (flat lrm-vels))) + + + (for (m nbmodul -1 0) + (push (make-instance 'chord + :lmidic (f->mc (nth m lrm-freqs)) + :ldur (nth m lrm-durs) + :loffset (nth m lrm-offs) + :lvel (nth m lrm-vels)) res) + )) + + (ch-test-filter res '< 100 'lmidic))) + + +(om::defmethod! ring-sine ((accord chord-seq) (sine t) + &optional (unit 'midic) + (type 'chord) + (output 'exclus)) + +(mki 'chord-seq + :lmidic (loop for ch in (chords accord) + + do (print ch) + collect (ring-sine ch sine unit 'chord output)) + :lonset (lonset accord))) + + + + + + + + +; .................. frequency shifting ..................... + +; revoir - eventuellement prendre les fct esquisse + +(defun simple-shift (fchord dfreq output) + (let ((res (om+ dfreq fchord))) + (if (equal output 'included) (x-append fchord res) res))) + +(defun lcshift (fchord dfreq type output) + (let ((res (deep-mapcar/1 #'om+ dfreq fchord ))) + (if (eq output 'included) (setq res (mapcar #'x-append fchord res)) res) + (if (eq type 'chord) (flat-once res) res))) + +(defun lfshift (fchord dfreq type output) + (let ((res (deep-mapcar/1 #'om+ dfreq fchord ))) + (cond ((and (eq output 'included) (eq type 'chord)) + (mapcar #'(lambda (x) (x-append x fchord)) res)) + ((and (eq output 'included) (eq type 'chlist)) + (x-append fchord (flat-once res))) + (t (if (eq type 'chord) (flat-once res) res))))) + + +(defun doubleshift (fchord dfreq type output) + (cond ((eq type 'chord) + (mapcar #'(lambda (x) (lfshift x dfreq type output)) fchord)) + ((and (eq output 'excluded) (eq type 'chlist)) + (flat-once (mapcar #'(lambda (x) (lfshift fchord x type output)) dfreq))) + ((and (eq output 'included) (eq type 'chlist)) + (flat-once + (mapcar #'(lambda (x) (lcshift fchord x type output)) dfreq))))) + + + +; semblable ˆ fshift d'Esquisse (mais "output" manque dans Esquisse + +(defmethod! freq-shift ((chord t) (dfreq t) &optional + (type 'chord) (output 'excluded) (unit 'midic)) + + :initvals '('(4800 5250 5800) 100 'chord 'excluded 'midic) + :indoc '("Chord" "D-freq" "Type" "Output" "Unit") + :menuins '((2 (("chord" 'chord) ("chord list" 'chlist))) + (3 (("excluded" 'excluded) ("included" 'included))) + (4 (("midic" 'midic) ("hz" 'hz) ))) + :icon 137 + :doc "Shifts the frequency of each note of by a frequency +(positive or negative, but always in hertz). + +The optional argument determines whether is entered in +midicents, ('midic'), or in hertz ('freq'). If 'midic' is selected the +values will be converted to frequencies inside the function and then the +output is reconverted to midicents. If 'freq' is selected the entry, +calculations and output are all in hertz. + +If is a list of chords the optional argument is used to +determine whether the output will be a list of chords ('seq'), each one +shifted by or a single chord combining the notes of all the +shifted chords ('chord'). If is a list the same argument is used +to choose between a list of chords shifted by each successive or a +single chord combining the different distortions. If both and + are lists the position 'seq' will return a list of chords +containing each chord shifted by each frequency; the position 'chord' +will return a list of chords containing each chord shifted by all the +listed frequencies. + +The optional argument determines whether the original is +included or excluded from the output list." + +(let ((listchord (not (atom (car chord)))) + (listfreq (not (atom dfreq))) + (fchord (if (eq unit 'hz) chord (mc->f chord))) res) + (cond ((and listchord listfreq) + (setq res (doubleshift fchord dfreq type output))) + (listchord (setq res (lcshift fchord dfreq type output))) + (listfreq (setq res (lfshift fchord dfreq type output))) + (t (setq res (simple-shift fchord dfreq output)))) + (if (eq unit 'hz) res (f->mc res)))) + + + +;==========Rename freq-shift as fsh 22-11-2006============================== + +(defmethod! fsh ((chord t) (dfreq t) &optional + (type 'chord) (output 'excluded) (unit 'midic)) + + :initvals '('(4800 5250 5800) 100 'chord 'excluded 'midic) + :indoc '("Chord" "D-freq" "Type" "Output" "Unit") + :menuins '((2 (("chord" 'chord) ("chord list" 'chlist))) + (3 (("excluded" 'excluded) ("included" 'included))) + (4 (("midic" 'midic) ("hz" 'hz) ))) + :icon 137 + :doc + "Shifts the frequency of each note of by a frequency (positive or negative, but always in hertz). + +The optional argument determines whether is entered in midicents, ('midic'), or in hertz ('freq'). If 'midic' is selected the values will be converted to frequencies inside the function and then the output is reconverted to midicents. If 'freq' is selected the entry, calculations and output are all in hertz. + +If is a list of chords the optional argument is used to determine whether the output will be a list of chords ('seq'), each one shifted by or a single chord combining the notes of all the shifted chords ('chord'). If is a list the same argument is used to choose between a list of chords shifted by each successive or a single chord combining the different distortions. If both and are lists the position 'seq' will return a list of chords containing each chord shifted by each frequency; the position 'chord' will return a list of chords containing each chord shifted by all the listed frequencies. + +The optional argument determines whether the original is included or excluded from the output list." + + (freq-shift chord dfreq type output unit)) + +;========================================================================= + + + + +(defmethod! fshift-proc ((chord t) (dfreq number) (steps integer) + &optional (output 'excluded) (unit 'midic)) + + :initvals '('(4800 5250 5400) 400 3 'excluded 'midic) + :indoc '("Chord" "D-freq" "Nb steps" "Output" "Unit") + :menuins '((3 (("excluded" 'excluded) ("included" 'included))) + (4 (("midic" 'midic) ("hz" 'hz) ))) + :icon 137 + :doc "Progressively shifts until the final chord which is shifted by + (positive or negative, but always in hertz). The argument +determines the number of intermediate distortions to be produced between +the unaltered and the chord shifted by . + +The argument may be a list, in which case the same process of +shifting is carried out for each successive chord. + + and may not be lists. + +The optional argument determines whether is entered in +midicents, ('midic'), or in hertz ('freq'). If 'midic' is selected the +values will be converted to frequencies inside the function and then the +output is reconverted to midicents. If 'freq' is selected the entry, +calculations and output are all in hertz. + +The optional argument determines whether the non-shifted +is included or excluded from the output list of +chords." + +(let* ((ldfreq (n-arithm 0 dfreq steps)) + (ldfreq (if (equal output 'excluded) (cdr ldfreq) ldfreq)) + (res (freq-shift chord ldfreq output unit))) +(if (not (atom (car chord))) (flat-once res) res))) + + + +;==========Rename fshift-proc as fs-proc 22-11-2006======================= + +(defmethod! fs-proc ((chord t) (dfreq number) (steps integer) + &optional (output 'excluded) (unit 'midic)) + + :initvals '('(4800 5250 5400) 400 3 'excluded 'midic) + :indoc '("Chord" "D-freq" "Nb steps" "Output" "Unit") + :menuins '((3 (("excluded" 'excluded) ("included" 'included))) + (4 (("midic" 'midic) ("hz" 'hz) ))) + :icon 137 + :doc + "Progressively shifts until the final chord which is shifted by (positive or negative, but always in hertz). The argument determines the number of intermediate distortions to be produced between the unaltered and the chord shifted by . + +The argument may be a list, in which case the same process of shifting is carried out for each successive chord. + + and may not be lists. + +The optional argument determines whether is entered in midicents, ('midic'), or in hertz ('freq'). If 'midic' is selected the values will be converted to frequencies inside the function and then the output is reconverted to midicents. If 'freq' is selected the entry, calculations and output are all in hertz. + +The optional argument determines whether the non-shifted is included or excluded from the output list of chords." + + (fshift-proc chord dfreq steps output unit)) + +;========================================================================= + + + + + +; ................. distorsions selon module "scaling" .................... + +(defun dist-midi (accord fund nhq1 nhq2 dint1 dint2) + (let* ((minin (hqm fund nhq1)) + (maxin (hqm fund nhq2)) + (minout (+ minin dint1)) + (maxout (+ maxin dint2))) + (om-round (om-scale accord minout maxout minin maxin )))) + +(defun dist-freq (accord fund nhq1 nhq2 dfq1 dfq2) + (let* ((minin (hqf fund nhq1)) + (maxin (hqf fund nhq2)) + (minout (+ minin dfq1)) + (maxout (+ maxin dfq2))) + (f->mc/tm (om-scale (mc->f accord) minout maxout minin maxin ) ))) + + + (defun f->mc/tm (midics) + (f->mc midics)) + + + +(defmethod! d-harm/m ((fund number) (numer integer) (denom integer) + (begin integer) (end integer) (nhq1 integer) (dint1 number) + (nhq2 integer) + (dint2 number)) + + :initvals '(3600 1 1 1 7 1 0 7 0) + :indoc '("Fundamental" "Numerator" "Denominator" "Begin" "End" "N-harm1" "D-interv1" "N-harm2" "D-interv2") + :icon 136 + :doc "rend une sŽrie harmonique distordue selon module 'scale' +On donne comme rŽfŽrence basse et haute 2 numŽros d'harmoniques +et les intervalles midic de distorsion correspondants (dint1, dint2)" + + (dist-midi (harm-ser fund numer denom begin end ) fund nhq1 nhq2 dint1 dint2)) + + + + +(defmethod! d-harm/f ((fund number) (numer integer) (denom integer) + (begin integer) (end integer) (nhq1 integer) + (dfq1 number) (nhq2 integer) + (dfq2 number)) + + :initvals '(3600 1 1 1 7 1 0 7 0) + :indoc '("Fundamental" "Numerator" "Denominator" "Begin" "End" "N-harm1" "D-freq1" "N-harm2" "D-freq2") + :icon 136 + :doc "rend une sŽrie harmonique distordue selon module 'scale' +On donne comme rŽfŽrence basse et haute 2 numŽros d'harmoniques +et les distorsions correspondantes en hz (dfq1, dfq2)" + + (dist-freq (harm-ser fund numer denom begin end ) fund nhq1 nhq2 dfq1 dfq2)) + + + +;====Rename d-harm/f and d-harm/m as dist-gen 22-11-2006================================= +;====<>========================== + +(defmethod! dist-gen ((fund number) (numer integer) (denom integer) + (begin integer) (end integer) (nhq1 integer) + (d1 number) (nhq2 integer) + (d2 number) (mc-or-f string)) + + :initvals '(3600 1 1 1 7 1 0 7 0 "mc") + :indoc '("Fundamental" "Numerator" "Denominator" "Begin" "End" "N-harm1" "Distance1" "N-harm2" "Distance2" "midicents or frequency") + :icon 136 + :doc "Returns a distorted (i.e. inharmonic) spectrum obtained through scaling of a harmonic series. Reference pitches are two partials and the two midicent intervals between the original harmonic pitches and the corresponding distorted pitch obtained after scaling. Input of the intervals occurs in midicents or frequency. + +N.B. Definition of the harmonic series (which partials are present of a given fundamental?) occurs by numerator and denominator. Distortion is the result of scaling the harmonic series." + + (if (string-equal mc-or-f "mc") + (d-harm/m fund numer denom begin end nhq1 d1 nhq2 d2) + (d-harm/f fund numer denom begin end nhq1 d1 nhq2 d2))) + +;======================================================================================= + + + +#| +;====Removed from menu 22-11-2006==================================================== + +;There seems to be a problem with double-float/2 division by zero?? +; And with hqm, nth-overtones, and nth-harm (from esquisse lib) + +(defmethod! d-nth/m ((fund number) (nth list) (nhq1 integer) (dint1 number) (nhq2 integer) (dint2 number)) + + :initvals '(3600 '(1 3 5 7 9) 1 0 9 0) + :indoc '("Fundamental" "Ranks" "N-harm1" "D-interv1" "N-harm2" "D-interv2") + :icon 136 + :doc "rend une sŽrie harmonique distordue selon module 'scale' +On donne comme rŽfŽrence basse et haute 2 numŽros d'harmoniques +et les intervalles midic de distorsion correspondants (dint1, dint2)" + + (dist-midi (nth-overtones fund nth) fund nhq1 nhq2 dint1 dint2)) + + + +(defmethod! d-nth/f ((fund number) (nth list) + (nhq1 integer) (dfq1 number) (nhq2 integer) (dfq2 number)) + + :initvals '(3600 '(1 3 5 7 9) 1 0 9 0) + :indoc '("Fundamental" "Ranks" "N-harm1" "D-freq1" "N-harm2" "D-freq2") + :icon 136 + :doc "rend une sŽrie harmonique distordue selon module 'scale' +On donne comme rŽfŽrence basse et haute 2 numŽros d'harmoniques +et les intervalles midic de distorsion correspondants (dint1, dint2)" + + (dist-freq (nth-overtones fund nth) fund nhq1 nhq2 dfq1 dfq2)) +|# + + +;=================================================================================== + +(defmethod! distsym ((fund number ) (axe integer) (numer integer) (denom integer) + (begin integer) (end integer) + (nhq integer) (dfq number)) + + :initvals '(3600 5 1 1 1 9 9 0) + :indoc '("Fundamental" "Axis" "Numerator" "Denominator" "Begin" "End" "N-harm" "D-freq") + :icon 136 + :doc "sŽrie harmonique distordue selon module 'distor', autour d'un axe de symŽtrie +'axe' et une harm. de rŽfŽrence. Le crible numer/denom respecte l'axe de symŽtrie" + + (let* ((ecart (abs(- nhq axe))) + (nhqhaut (+ axe ecart)) + (nhqbas (- axe ecart)) + (nhqbas (if (> nhqbas 0) nhqbas (- nhqbas 2))) ; test hq inf + (dfmul (/ (+ dfq (hqf fund nhq)) (hqf fund nhq))) + (dfhaut (- (* (hqf fund nhqhaut) dfmul) (hqf fund nhqhaut))) + (dfbas (- (hqf fund nhqbas) (* (hqf fund nhqbas) dfmul) )) + ) + (print (list nhqbas dfbas nhqhaut dfhaut )) + (x-union (dist-freq (harm-ser fund numer denom axe begin) fund axe nhqbas 0 dfbas) + (dist-freq (harm-ser fund numer denom axe end) fund axe nhqhaut 0 dfhaut) + ))) + + +;====Rename distsym as dist-sym 22-11-2006============================================== + +(defmethod! dist-sym ((fund number ) (axe integer) (numer integer) (denom integer) + (begin integer) (end integer) + (nhq integer) (dfq number)) + + :initvals '(3600 5 1 1 1 9 9 0) + :indoc '("Fundamental" "Axis" "Numerator" "Denominator" "Begin" "End" "N-harm" "D-freq") + :icon 136 + :doc "Distortion of a harmonic series according to a symmetry axis and one reference partial . + +N.B. Definition of the harmonic series occurs by numerator and denominator. Distortion is the result of transforming the harmonic series around a symmetry axis. The employed numerator/denominator ratio is in accordance with the symmetry axis." + + (distsym fund axe numer denom begin end nhq dfq)) + +;======================================================================================= + + + + + + +;====All TO9 algorithms related functions removed from menu 22-11-2006=================== +; ............. distorsions selon "algorithme TO9" (cf "AllŽgories") ................ + +(defun fdist-to9 (accord fqmin qdist1 incrdist) + (let ((ncomp (length accord)) fq res ) + (dotimes (n ncomp) + (setq fq (mc->f (nextl accord ))) + (setq fq (* fq (+ qdist1 (* incrdist (- fq fqmin))))) + (push (f->mc fq) res)) + (reverse res))) + +(defun h-dist (accord fund nhq1 nhq2 dint1 dint2) + (let* ((minin (hqf fund nhq1)) + (maxin (hqf fund nhq2)) + (minout (* minin (cents->ratio dint1))) + (maxout (* maxin (cents->ratio dint2))) + (qdist1 (/ minout minin)) + (qdist2 (/ maxout maxin)) + (incrdist (/ (- qdist2 qdist1) (- maxin minin)))) + (format t "minin = ~S maxin = ~S minout = ~S maxout = ~S ~%" minin maxin minout maxout) + (fdist-to9 accord minin qdist1 incrdist))) + + +(defun fdist/hz (accord minref maxref dmin dmax ) +"distord les frŽquences de l'accord selon l'algorithme TO9. +On donne les notes de rŽfŽrence basse et haute (minref, maxref) +et les distorsions en hz correspondantes (dmin , dmax)" +(let* ((qdist1 (1+ (/ dmin (mc->f minref)))) + (qdist2 (1+ (/ dmax (mc->f maxref)))) + (incrdist (/ (- qdist2 qdist1) (- (mc->f maxref) (mc->f minref))))) + (fdist-to9 accord (mc->f minref) qdist1 incrdist))) + + + +(om::defmethod! dist-overtones ((fund t) (numer integer) (denom integer) + (begin integer) (end integer) (nhq1 integer) (nhq2 integer) + (dint1 number) (dint2 number)) + :initvals '(2400 1 1 1 7 1 0 7 0) + :indoc '("Fundamental" "Numerator" "Denominator" "Begin" "End" "nhq1" "nhq2" + "dint1" "dint2") + :icon 136 + :doc +"rend une sŽrie harmonique distordue selon l'algorithme TO9. +On donne comme rŽfŽrence basse et haute 2 numŽros d'harmoniques +et les intervalles midic de distorsion correspondants (dint1, dint2)" + + (let* ((accord (harm-series fund numer denom begin end 1 2)) + (minin (hqf fund nhq1)) + (maxin (hqf fund nhq2)) + (minout (* minin (cents->coef dint1))) + (maxout (* maxin (cents->coef dint2))) + (qdist1 (/ minout minin)) + (qdist2 (/ maxout maxin)) + (incrdist (/ (- qdist2 qdist1) (- maxin minin)))) + (format t "minin = ~S maxin = ~S minout = ~S maxout = ~S ~%" minin maxin minout maxout) + (fdist-to9 accord minin qdist1 incrdist))) + + + +(om::defmethod! dist-to9 ((fund number) (numer integer) (denom integer) + (begin integer) (end integer) (nhq1 integer) (dint1 number) + (nhq2 integer) + (dint2 number)) + :initvals '(3600 1 1 1 7 1 0 7 0) + :indoc '("Fundamental" "Numerator" "Denominator" "Begin" "End" "N-harm1" "D-freq1" + "N-harm2" "D-freq2") + :icon 136 + :doc "rend une sŽrie harmonique distordue selon l'algorithme TO9. +On donne comme rŽfŽrence basse et haute 2 numŽros d'harmoniques +et les intervalles midic de distorsion correspondants (dint1, dint2)" + (let* ((accord (polysp fund 0 numer denom begin end 0 nil)) + (minin (hqf fund nhq1)) + (maxin (hqf fund nhq2)) + (minout (* minin (cents->ratio dint1))) + (maxout (* maxin (cents->ratio dint2))) + (qdist1 (/ minout minin)) + (qdist2 (/ maxout maxin)) + (incrdist (/ (- qdist2 qdist1) (- maxin minin)))) + (format t "minin = ~S maxin = ~S minout = ~S maxout = ~S ~%" minin maxin minout maxout) + (fdist-to9 accord minin qdist1 incrdist))) + + + +(om::defmethod! disto9-nth/m ((fund number) (nth list) + (nhq1 integer) (dint1 number) (nhq2 integer) (dint2 number)) + + :initvals '(3600 '(1 3 5 7 9) 1 0 9 0) + :indoc '("Fundamental" "Ranks" "N-harm1" "D-interv1" "N-harm2" "D-interv2") + :icon 136 + :doc "rend une sŽrie harmonique distordue selon l'algorithme TO9. +On entre une liste d'harmoniques +On donne comme rŽfŽrence basse et haute 2 numŽros d'harmoniques +et les intervalles midic de distorsion correspondants (dint1, dint2)" + + (h-dist (n-harm fund nth) fund nhq1 nhq2 dint1 dint2)) + + + +(om::defmethod! disto9-nth/f ((fund number) (nth list) + (nhq1 integer) (dfq1 number) (nhq2 integer) (dfq2 number)) + :initvals '(3600 '(1 3 5 7 9) 1 0 9 0) + :indoc '("Fundamental" "Ranks" "N-harm1" "D-freq1" "N-harm2" "D-freq2") + :icon 136 + :doc "rend une sŽrie harmonique distordue selon l'algorithme TO9. +On entre une liste d'harmoniques +On donne comme rŽfŽrence basse et haute 2 numŽros d'harmoniques +et les distorsions correspondantes en hz (dfq1, dfq2)" + + (fdist/hz (n-harm fund nth) (hqm fund nhq1) (hqm fund nhq2 ) + dfq1 dfq2) ) + +;=============================================================================== + + + + + + + + + + + + +; ............... distorsion des frŽquences .................... + + +; semblable ˆ fdistor d'Esquisse (mais "output" manque dans Esquisse) + +(defmethod! freq-distor ((chord t) (minout number) (maxout number) + &optional (minin nil) (maxin nil) + (output 'excluded ) (unit 'midic )) + + :initvals '('(4800 5250 5400) 5700 6300 () () 'excluded 'midic) + :indoc '("Chord" "minout" "maxout" "minin" "maxin" "output" "unit") + :menuins '((5 (("excluded" 'excluded) ("included" 'included))) + (6 (("midic" 'midic) ("hz" 'hz) ))) + :icon 137 + :doc "Distorts the frequencies of so that the lowest note is changed to + and the highest note to . Interior notes are rescaled so +as to preserve the relative positions of their frequencies. + +The optional inputs and allow the scaling to be done +relative to two selected reference notes rather than the highest and +lowest notes of the chord. The note entered as will be moved to +, and to the rest of the chord is then +rescaled accordingly. + +If is a list of chords, output will be a corresponding list of +distorted chords. + +The optional argument determines whether is entered in +midicents, ('midic'), or in hertz ('freq'). If 'midic' is selected the +values will be converted to frequencies inside the function and then the +output is reconverted to midicents. If 'freq' is selected the entry, +calculations and output are all in hertz. + +The optional argument determines whether the non-distorted + is included ('inclu') or excluded ('exclu') from the output list. +If included the non-distorted notes will be mixed with the distorted into +a single chord." + + (let ((minin (if (null minin) (list-min chord) (car! minin))) + (maxin (if (null maxin) (list-max chord) (car! maxin)))) + + (if (equal unit 'midic) (setq chord (mc->f chord) minout (mc->f minout) maxout (mc->f maxout) + minin (mc->f minin) + maxin (mc->f maxin))) + + (let ((res (om-scale chord (car! minout) (car! maxout) minin maxin))) + (setq res (if (equal output 'included) (if (atom (car chord)) (x-append chord res) + (mapcar #'x-append chord res)) res)) + (if (equal unit 'hz) res (f->mc res) )))) + +;===============Rename freq-distor as disto 22-11-2006=================================== + +(defmethod! disto ((chord t) (minout number) (maxout number) + &optional (minin nil) (maxin nil) + (output 'excluded ) (unit 'midic )) + + :initvals '('(4800 5250 5400) 5700 6300 () () 'excluded 'midic) + :indoc '("Chord" "minout" "maxout" "minin" "maxin" "output" "unit") + :menuins '((5 (("excluded" 'excluded) ("included" 'included))) + (6 (("midic" 'midic) ("hz" 'hz) ))) + :icon 137 + :doc "Distorts the frequencies of so that the lowest note is changed to + and the highest note to . Interior notes are rescaled so +as to preserve the relative positions of their frequencies. + +The optional inputs and allow the scaling to be done +relative to two selected reference notes rather than the highest and +lowest notes of the chord. The note entered as will be moved to +, and to the rest of the chord is then +rescaled accordingly. + +If is a list of chords, output will be a corresponding list of +distorted chords. + +The optional argument determines whether is entered in +midicents, ('midic'), or in hertz ('freq'). If 'midic' is selected the +values will be converted to frequencies inside the function and then the +output is reconverted to midicents. If 'freq' is selected the entry, +calculations and output are all in hertz. + +The optional argument determines whether the non-distorted + is included ('inclu') or excluded ('exclu') from the output list. +If included the non-distorted notes will be mixed with the distorted into +a single chord." + + (freq-distor chord minout maxout minin maxin output unit)) + +;========================================================================================== + + + +(defmethod! fdistor-proc ((chord t) (steps integer) (minout number) (maxout number) + &optional (minin nil) + (maxin nil) (output 'excluded ) (unit 'midic )) + + :initvals '('(4800 5250 5400) 3 5700 8500 () () 'excluded 'midic) + :indoc '("Chord" "steps" "minout" "maxout" "minin" "maxin" "output" "unit") + :menuins '((6 (("excluded" 'excluded) ("included" 'included))) + (7 (("midic" 'midic) ("hz" 'hz) ))) + :icon 137 + :doc "Progressively distorts until the distortion specified by +and is reached. The argument determines the number of +intermediate distortions to be produced between the unaltered and +the final distortion. (For explanation of frequency distortion, as well as +the use of ,, and see the box 'fdistor') + + may not be a list of chords. + +The optional argument determines whether is entered in +midicents, ('midic'), or in hertz ('freq'). If 'midic' is selected the +values will be converted to frequencies inside the function and then the +output is reconverted to midicents. If 'freq' is selected the entry, +calculations and output are all in hertz. + +The optional argument determines whether the non-distorted + is included ('inclu') or excluded ('exclu') from the output list +of chords." +(let* ((valmin (if (null minin) (list-min (list! chord)) (car! minin))) + (valmax (if (null maxin) (list-max (list! chord)) (car! maxin))) + (stepmin (if (/= steps 0) (/ (- (car! minout) valmin) steps) 0)) + (stepmax (if (/= steps 0) (/ (- (car! maxout) valmax) steps) 0)) + (deb (if (equal output 'included) 0 1 )) + res) + (for (n deb 1 steps) + (newl res (freq-distor chord (round (+ valmin (* n stepmin))) (round (+ valmax (* n stepmax))) + (car! minin) (car! maxin) 1 unit))) + (nreverse res))) + +;================Rename fdistor-proc as dist-proc 22-11-2006==================================== + +(defmethod! dist-proc ((chord t) (steps integer) (minout number) (maxout number) + &optional (minin nil) + (maxin nil) (output 'excluded ) (unit 'midic )) + + :initvals '('(4800 5250 5400) 3 5700 8500 () () 'excluded 'midic) + :indoc '("Chord" "steps" "minout" "maxout" "minin" "maxin" "output" "unit") + :menuins '((6 (("excluded" 'excluded) ("included" 'included))) + (7 (("midic" 'midic) ("hz" 'hz) ))) + :icon 137 + :doc + "Progressively distorts until the distortion specified by and is reached. The argument determines the number of intermediate distortions to be produced between the unaltered and +the final distortion (For explanation of frequency distortion, as well as the use of , , and see the box 'fdistor'). + + may not be a list of chords. + +The optional argument determines whether is entered in midicents, ('midic'), or in hertz ('freq'). If 'midic' is selected the values will be converted to frequencies inside the function and then the output is reconverted to midicents. If 'freq' is selected the entry, calculations and output are all in hertz. + +The optional argument determines whether the non-distorted is included ('inclu') or excluded ('exclu') from the output list of chords." + (fdistor-proc chord steps minout maxout minin maxin output unit)) + +;======================================================================================= + + + + + + + + + +;====All TO9 algorithms related functions removed from menu 22-11-2006=================== + +; distorsions selon algo TO9 + +(om::defmethod! fdisto9/hz ((accord list) (minref number) (maxref number) + (dmin number) (dmax number)) + + :initvals '('(4800 5250 5400) 4800 5400 100 250) + :indoc '("accord" "minref" "maxref" "dmin" "dmax") + :icon 136 + :doc "distord les frŽquences de l'accord selon l'algorithme TO9. +On donne les notes de rŽfŽrence basse et haute (minref, maxref) +et les distorsions en hz correspondantes (dmin , dmax)" + (fdist/hz accord minref maxref dmin dmax )) + + + +(om::defmethod! fdisto9/note ((accord list) (minin number) (maxin number) + (minout number) (maxout number)) + :initvals '('(4800 5250 5400) 4800 5400 3200 7000) + :indoc '("accord" "minin" "maxin" "minout" "maxout") + :icon 136 + :doc "distord les frŽquences de l'accord selon l'algorithme TO9. +On donne les notes de rŽfŽrence basse et haute (minin, maxin) +et les notes distordues correspondantes (minout , maxout)" +(let* ((qdist1 (/ (mc->f minout) (mc->f minin))) + (qdist2 (/ (mc->f maxout) (mc->f maxin))) + (incrdist (/ (- qdist2 qdist1) (- (mc->f maxin) (mc->f minin))))) + (fdist-to9 accord (mc->f minin) qdist1 incrdist))) + + +(om::defmethod! fdisto9/interv ((accord list) (ncomp1 integer) (ncomp2 integer) + (dint1 number) (dint2 number)) + :initvals '('(4800 5250 5400) 0 2 100 300) + :indoc '("accord" "ncomp1" "ncomp2" "dint1" "dint2") + :icon 136 + :doc "distord les frŽquences de l'accord selon l'algorithme TO9. +On donne comme rŽfŽrence basse et haute 2 numŽros de composantes (ˆ partir de 0) +et les intervalles midic de distorsion correspondants (dint1, dint2)" + (let* ((minin (nth ncomp1 accord)) + (maxin (if (or (= ncomp2 0) (> ncomp2 (1- (length accord)))) (car (last accord)) + (nth ncomp2 accord))) + (minout (+ dint1 minin)) + (maxout (+ dint2 maxin)) + (qdist1 (/ (mc->f minout) (mc->f minin))) + (qdist2 (/ (mc->f maxout) (mc->f maxin))) + (incrdist (/ (- qdist2 qdist1) (- (mc->f maxin) (mc->f minin))))) + (fdist-to9 accord (mc->f minin) qdist1 incrdist))) + + +;=============================================================================== + + + +;---------------------------Other Treatments------------------------------------ + +(om::defmethod! fq-interpol ((begin t) (end t) (steps integer) (curve number)) + :initvals '(4800 6000 5 1.0) + :indoc '("begin" "end" "steps" "curve") + :icon 136 + :doc "interpolation calculŽe sur les frŽquences. EntrŽe et sortie en midics" + (f->mc (interpolation (mc->f begin) (mc->f end) steps (float curve)))) + + + +;====Rename fq-interpol as f-interpol 23-06-2007================================ + +(om::defmethod! f-interpol ((begin t) (end t) (steps integer) (curve number)) + :initvals '(4800 6000 5 1.0) + :indoc '("begin" "end" "steps" "curve") + :icon 136 + :doc "Interpolation calculated between frequencies. Input and output are in midicents." + + (fq-interpol begin end steps curve)) + +;=============================================================================== + + + + + +(om::defmethod! densif/f ((accord list) (density integer) (mmin number) (mmax number)) + :initvals '((4800 5300 5900) 1 4800 5900) + :indoc '("accord" "density" "mmin" "mmax") + :icon 136 + :doc "ajoute partiels entre chaque composante du spectre comprise +entre mmin et mmax (midics). Les partiels crŽŽs divisent les intervalles +de l'accord en intervalles Žgaux en frŽquence" + (f->mc (densifier (mc->f accord) density 0 (mc->f mmin) (mc->f mmax)))) + + +;====Rename densif/f as f-densifier 23-06-2007=================================== +;====full function in definition in order to avoid "/"in name==================== + +(om::defmethod! f-densifier ((accord list) (density integer) (mmin number) (mmax number)) + :initvals '((4800 5300 5900) 1 4800 5900) + :indoc '("accord" "density" "mmin" "mmax") + :icon 136 + :doc "Adds partials between every component pair of the spectrum within a given range defined by and . The created partials divide each frequency interval of the original spectrum into intervals of equal lengths." + + (f->mc (densifier (mc->f accord) density 0 (mc->f mmin) (mc->f mmax)))) + + +;================================================================================ + + +(defun reharm-fct (accord toler) + (let ((vf (virt-fund accord toler 'midic)) + (rgh (closest-harm accord (virt-fund accord toler 'midic) 'ranks 'midic))) + (print (list vf (mc->n (approx-m vf 8)))) + (print rgh) + (n-harm vf rgh))) + +(om::defmethod! reharmoniser ((accords list) (toler number )) + :initvals '('(4800 5340 5987 6250) 25 ) + :indoc '("accords" "toler" ) + :icon 136 + :doc "rend les accords plus harmoniques ; effet plus ou moins grand selon " + (less-deep-mapcar #'reharm-fct accords toler)) + + +;====Rename reharmoniser as reharmonizer 23-06-2007============================== +;====added object compatibility================================================== + +(om::defmethod! reharmonizer ((accords list) (toler number)) + :initvals '('(4800 5340 5987 6250) 25 ) + :indoc '("accords" "toler" ) + :icon 136 + :doc +"Returns a more harmonic chord, a chord more related to a harmonic series. +The amount of increase in harmonicity is determined by . +The reharmonizer function first determines the virtual fundamental of the chord and replaces the original pitches by the closest harmonic partials on the obtained virtual fundamental. Accepts list of midicents and list of lists of midicents, and objects (chords, chord-seq and multi-seq)." + +(reharmoniser accords toler)) + + +(om::defmethod! reharmonizer ((self chord) (toler number)) + (make-instance 'chord + :lmidic + (reharmonizer (lmidic self) toler) + :ldur (ldur self) + :lvel (lvel self) + :loffset (loffset self) + :lchan (lchan self))) + + +(om::defmethod! reharmonizer ((self chord-seq) (toler number)) + (make-instance 'chord-seq + :lmidic + (reharmonizer (mapcar 'lmidic (chords self)) toler) + :lonset (lonset self) + :ldur (ldur self) + :lvel (lvel self) + :loffset (loffset self) + :lchan (lchan self) + :legato (legato self))) + + + +(om::defmethod! reharmonizer ((self multi-seq) (toler number)) + (make-instance 'multi-seq + :chord-seqs + (loop for chord-seq in (chord-seqs self) + collect + (reharmonizer chord-seq toler)))) + + + +;============================================================================= + + + +(om::defmethod! mul-freq ((ch1 list ) (ch2 list ) (type symbol )) + + :initvals '('(4800 5300 6000) '(6200 6700 7000) 'chlist) + :indoc '("ch1" "ch2" "type" ) + :menuins '((2 (("chlist" 'chlist) ("chord" 'chord)))) + :icon 136 + :doc "Like mul-chord, but calculations are made with frequencies. +The optional argument allows the choice of whether the output is +a list of chords ('seq') or a single chord ('chord') containing all the +transpositions combined." + (let ((ch1 (list! (mc->f ch1))) + (addfq (dx->x 0 (inter->freq ch2 ))) + res) + (dolist (n ch1 ) + (push (om+ n addfq) res)) + (setq res (nreverse (f->mc res))) + (if (equal type 'chord) (flat res) res ))) + + +;====Rename mul-freq as f-multiplier 24-06-2007============================== + +(om::defmethod! f-multiplier ((ch1 list ) (ch2 list ) (type symbol )) + + :initvals '('(4800 5300 6000) '(6200 6700 7000) 'chlist) + :indoc '("ch1" "ch2" "type" ) + :menuins '((2 (("chlist" 'chlist) ("chord" 'chord)))) + :icon 136 + :doc "Like mul-chord, but calculations are made with frequencies. The optional argument allows the choice of whether the output is a list of chords ('seq') or a single chord ('chord') containing all the transpositions combined." + + (mul-freq ch1 ch2 type)) + +;============================================================================= + + + + +; ---------------------- analyse ---------------------- + +(defun best-freq1 (freqs) + (let ((sum 0) (nb-freq (length freqs))) + (while freqs (incf sum (log (nextl freqs)))) + (exp (/ sum nb-freq)))) + + +(defmethod! best-freq ((chord list) (unit symbol)) + :initvals '('(6000) 'midic) + :indoc '("pitches" "unit" ) + :menuins '((1 (("Midics" 'midic) ("Freqs" 'freq))) ) + :icon 136 + :doc + + "Returns the note which is at the minimum possible distance from the +frequencies of all the notes of . (minimum sum of the squares of +the distances) This note can be thought of as a sort of center of gravity +for (it is not usually a member of the chord). + +If is a list of chords the box returns a list of best frequencies. + +The optional argument determines whether is entered in +midicents, ('midic'), or in hertz ('freq'). If 'midic' is selected the +values will be converted to frequencies inside the function and then the +output is reconverted to midicents. If 'freq' is selected the entry, +calculations and output are all in hertz." + (if (eq unit 'freq) + (less-deep-mapcar 'best-freq1 chord) + (f->mc (less-deep-mapcar 'best-freq1 (mc->f chord))))) + + +(defmethod! best-freq ((chord chord) (unit symbol)) + (best-freq (lmidic chord) 'lmidic)) + +(defmethod! best-freq ((chord chord-seq) (unit symbol)) + (best-freq (lmidic chord) 'lmidic)) + + +;====Rename best-freq as center-freq 25-06-2007========= + +(defmethod! center-freq ((chord list) (unit symbol)) + :initvals '('(6000) 'midic) + :indoc '("pitches" "unit" ) + :menuins '((1 (("Midics" 'midic) ("Freqs" 'freq))) ) + :icon 136 + :doc + + "Returns the note which is at the minimum possible distance from the +frequencies of all the notes of (minimum sum of the squares of +the distances). This note can be thought of as a sort of center of gravity +for (it is usually not a member of the chord). + +If is a list of chords the box returns a list of center frequencies. + +The optional argument determines whether is entered in +midicents, ('midic'), or in hertz ('freq'). If 'midic' is selected the +values will be converted to frequencies inside the function and then the +output is reconverted to midicents. If 'freq' is selected the entry, +calculations and output are all in hertz." + + (best-freq chord unit)) + + +(defmethod! center-freq ((chord chord) (unit symbol)) + + (best-freq chord unit)) + + +(defmethod! center-freq ((chord chord-seq) (unit symbol)) + (best-freq chord unit)) + + +;======================================================== + + + +(defun closest-harm-f (f0 freq ) + "" + (if (<= freq f0) (/ f0 freq) + (let* ((ratio (/ freq f0)) + (n-partial (floor ratio)) + (d1 (/ ratio n-partial)) + (d2 (/ (1+ n-partial) ratio))) + (if (< d1 d2) n-partial (1+ n-partial) )))) + + +(om::defmethod! closest-harm ((chord list) (fund number) (type symbol) + &optional (unit 'midic)) + + + :initvals '('(4800 5250 5580) 2400 'notes 'midic) + :indoc '("chord" "fund" "type" "unit") + :menuins '((2 ( ("notes" 'notes) ("ranks" 'ranks))) + (3 (("midic" 'midic) ("hz" 'hz)))) + :icon 137 + :doc + "Calculates the closest partial of the harmonic series built on to each note of (For explanations on building harmonic series, see the object 'n-sp-gen'). + +If is a list of chords the result will contain the analyses of each successive chord. + +The optional argument determines whether is entered in midicents, or in hertz. If 'midic' is selected the values will be converted to frequencies inside the function and then the output (if appropriate) is reconverted to midicents. If 'hz' is selected the entry, calculations and output (if appropriate) are all in hertz. + +The optional argument determines whether the output is a list of partial numbers/ranks or the actual notes corresponding to those partials." + +(let* ((ffund (car! (if (equal unit 'midic) (mc->f fund) fund))) + (fchord (if (equal unit 'midic) (mc->f chord) chord)) + (res (deep-mapcar/1 #'(lambda (x) (closest-harm-f ffund x)) fchord))) + (if (equal type 'notes) (n-harm fund res ) res))) + + +(om::defmethod! deviations ((accord list) (fond number) (numer integer) (denom integer) + (begin integer) (end integer) (m/f symbol)) + + :initvals '('(4800 5250 5580) 3200 1 1 1 1 'm) + :indoc '("chord" "fundamental" "numerator" "denominator" "begin" "end" "m/f") + :icon 136 + :doc "Deviations of the pitches/frequencies of a distorted chord when compared to its harmonic counterpart; m for midicents and f for frequencies." + + (if (equal m/f 'm) (om- accord (nth-harm fond numer denom begin end)) + (om- (mc->f accord) (mc->f (nth-harm fond numer denom begin end))))) + + +;====Removed from menu 22-11-2006======================== + +(om::defmethod! l-interfreq ((midics t)) + :initvals '('(4800 5250 5580)) + :indoc '("midics" ) + :icon 136 + :doc "liste des intervalles en freq entre les notes successives +d'une liste de midics" + + (carlist! (x->dx (mc->f midics)))) + +;========================================================= + +(om::defmethod! quelle-harm ((accord list) (fond number) (approx integer)) + :initvals '('(4800 5250 5580) 2400 4) + :indoc '("accord" "fond" "approx") + :icon 136 + :doc "donne le rang harm par rapport ˆ une fond. et une approx" +(om-round (om/ (mc->f (approx-m accord approx)) (car! (mc->f fond))) 2)) + + +;===Rename quelle-harm as which-harm 25-06-2007============ + +(om::defmethod! which-harm ((chord list) (fund number) (approx integer)) + :initvals '('(4800 5250 5580) 2400 4) + :indoc '("chord" "fund" "approx") + :icon 136 + :doc "Returns the partial number for a given fundamental and approximation." + + (quelle-harm chord fund approx)) + +;========================================================== + +(om::defmethod! interfreq ((midics list) (nbdec integer)) + :initvals '('(4800 5250 5580) 2) + :indoc '("midics" "nbdec") + :icon 136 + :doc "liste des intervalles en freq entre les notes successives +d'une liste de midics" + (om-round (carlist! (x->dx (mc->f midics))) nbdec)) + + +(defun calc-distor (rang accord) + (/ (log (/ (mc->f (nth (1- rang) accord )) (mc->f (list-min accord)))) (log rang))) + +(defun calc-distor1 (rang accord ) + (print rang) + (/ (log (/ (mc->f (list-max accord )) (mc->f (list-min accord)))) (log rang))) + +(defun quelle-dist-1 (accord rang mode) + (om-round (- (* 100 + (cond ((equal mode 'all) + (om-mean (car-mapcar 'calc-distor (arithm-ser 2 (length accord) 1) accord) 1)) + ((equal mode 'spectrum) (calc-distor rang accord )) + ((equal mode 'one-harm) (calc-distor1 rang accord )))) + 100) 4)) + +;===Rename interfreq as inter-freq 25-06-2007============ + +(om::defmethod! inter-freq ((midics list) (nbdec integer)) + :initvals '('(4800 5250 5580) 2) + :indoc '("midics" "nbdec") + :icon 136 + :doc "Returns a list of frequency intervals between successive notes defined by a midicents list and rounds off the values to a specified amount of decimals ." + + (interfreq midics nbdec)) + +;========================================================== + +(om::defmethod! quelle-dist ((accords list) (rang integer) (mode symbol)) + :initvals '('(2400 3636 4360 4872 5270 5596 5870) 2 'one-harm) + :indoc '("accords" "rang" "mode") + :icon 136 + :menuins '((2 (("une-harm" 'one-harm) ("spectre" 'spectrum) ("toutes" 'all)))) + :doc "rend la valeur de la distorsion harmonique (en %) d'un agrŽgat. +La note la plus grave est censŽe être la fondamentale; +on effectue le calcul par rapport ˆ un partiel dont on donne le rang. +On choisissant l'option on obtient la moyenne des distorsions calculŽes ˆ partir de chaque +partiel - accepte une liste d'accords" + (less-deep-mapcar 'quelle-dist-1 accords rang mode)) + + +;===Rename quelle-dist as which-dist 25-06-2007============ + +(om::defmethod! which-dist ((chords list) (rank integer) (mode symbol)) + :initvals '('(2400 3636 4360 4872 5270 5596 5870) 2 'one-harm) + :indoc '("chords" "rang" "mode") + :icon 136 + :menuins '((2 (("one-harm" 'one-harm) ("spectrum" 'spectrum) ("all" 'all)))) + :doc "Returns the distortion percentage of a chord (or a list of chords). The lowest note of the chord is assumed to be the fundamental; the calculation is based on one partial and its assigned number/rank. When choosing the option , the mean of the distortions for all partials is obtained." + + (quelle-dist chords rank mode)) + +;========================================================== + + + + +; ------- fondamentales virtuelles -------------- + +(defun cents->coef (nb-cents) + "coef> takes an interval expressed in midi-cents and returns the ratio +between two frequencies separated by that interval; i.e., the value: (freq + ) / freq." + (expt 2.0 (/ nb-cents 1200.0))) + +(defun virt-fund1 (chord cents) + (car-mapcar #'(lambda (c) (fond-virt-f chord (1- (cents->coef c)) ;;(round (/ 100 c)) + )) cents)) + +(defun fond-virt-f (freqs approx) + (tolerant-gcd freqs approx)) + +;;From Gerard Assayag [93 07 16] + +(defun tolerant-gcd (values grid-ratio) + "floating gcd with tolerance grid-ratio around the values." + (labels ((grid-above (val) (* val (1+ grid-ratio))) + (grid-below (val) (/ val (1+ grid-ratio))) + (gcd-try (values gcd-min gcd-max) + (when (<= gcd-min gcd-max) + (ifnot values + (/ (+ gcd-min gcd-max) 2.0) + (let* ((val-below (grid-below (first values))) + (val-above (grid-above (first values))) + (quo-min (ceiling (/ val-below gcd-max))) + (quo-max (floor (/ val-above gcd-min)))) + (do* ((quotient quo-min (1+ quotient)) (gcd-interval)) + ((> quotient quo-max) nil) + (setf gcd-interval + (gcd-try (rest values) + (max gcd-min (/ val-below quotient)) + (min gcd-max (/ val-above quotient)))) + (when gcd-interval + (return-from gcd-try gcd-interval)))))))) + (gcd-try values .1 (grid-above (apply 'min values))))) + +(defmethod! virt-fund ((chord list) (cents integer) (unit symbol)) + + :initvals '('(6000) 50 'midic) + :indoc '("pitches""approx" "unit" ) + :menuins '((2 (("Midics" 'midic) ("Freqs" 'freq))) ) + :icon 136 + :doc + + "Returns the highest fundamental for which the notes of could be +thought of as harmonic partials. In general, the lower the virtual +fundamental, the more dissonant the chord. + + may be a list of midics, a list of list of midics, a chord object or a chord-seq objest. + +The argument determines the precision of the analysis (a value of +'0' would return the real fundamental; the larger the value the more +approximate the result). + +If is a sequence of chords the box returns a list of virtual +fundamentals. + +The optional argument determines whether is entered and the +result returned in midicents, ('midic'), or in hertz ('freq'). The argument +, however, remains unchanged." + + (if (eq unit 'freq) + (less-deep-mapcar 'virt-fund1 chord cents) + (f->mc (less-deep-mapcar 'virt-fund1 (mc->f chord) cents)))) + +(defmethod! virt-fund ((chord chord) (cents integer) (unit symbol)) + (virt-fund (lmidic chord) cents 'midic)) + +(defmethod! virt-fund ((chord chord-seq) (cents integer) (unit symbol)) + (virt-fund (lmidic chord) cents 'midic)) + + +;===Rename virt-fund as virtual-fund in order to avoid clashes with Esquisse 26-06-2007=== + +(defmethod! virtual-fund ((chord list) (cents integer) (unit symbol)) + + :initvals '('(6000) 50 'midic) + :indoc '("pitches""approx" "unit" ) + :menuins '((2 (("Midics" 'midic) ("Freqs" 'freq))) ) + :icon 136 + :doc + "Returns the highest fundamental for which the notes of could be thought of as harmonic partials. In general, the lower the virtual fundamental, the more dissonant the chord. + + may be a list of midics, a list of list of midics, a chord object, a list of chord objects or a chord-seq object. If is a sequence of chords the box returns a list of virtual fundamentals. + +The argument determines the precision of the analysis (A value of '0' would return the real fundamental; the larger the value the more approximate the result). The optional argument determines whether is entered and the result returned in midicents ('midic'), or in hertz ('freq')." + + (virt-fund chord cents unit)) + +(defmethod! virtual-fund ((chord chord) (cents integer) (unit symbol)) + + (virt-fund chord cents unit)) + +(defmethod! virtual-fund ((chord chord-seq) (cents integer) (unit symbol)) + + (virt-fund chord cents unit)) + +;================================================================== + +(om::defmethod! fonds-virts ((accord list ) (pmin number ) (pmax number ) + (pstep number ) (approx integer )) + :initvals '('(2400 3636 4360 4872 5270 5596 5870) 5 100 5 4) + :indoc '("accord" "pmin" "pmax" "pstep" "approx") + :icon 136 + :doc "liste des fond virt obtenues en faisant varier la prŽcision de pmin ˆ pmax +avec un pas pstep. Les valeurs redondantes ˆ près sont ŽliminŽes +de la liste" + (let (res) + (for (i pmin pstep pmax) + (push (virt-fund accord i 'midic) res)) + (unique-notes (nreverse res) approx))) + +(om::defmethod! fonds-virts ((accord chord ) (pmin number ) (pmax number ) + (pstep number ) (approx integer )) +(fonds-virts (lmidic accord) pmin pmax pstep approx)) + + +;====Rename fonds-virts as virt-fund-step 25-06-2007================ + +(om::defmethod! virt-fund-step ((accord list) (pmin number) (pmax number) + (pstep number) (approx integer)) + :initvals '('(2400 3636 4360 4872 5270 5596 5870) 5 100 5 4) + :indoc '("accord" "pmin" "pmax" "pstep" "approx") + :icon 136 + :doc "Returns a list of virtual fundamentals obtained after varying the precision of the calculation from to by steps with size . After approximation redundant pitches are removed." + + (fonds-virts accord pmin pmax pstep approx)) + +(om::defmethod! virt-fund-step ((accord chord) (pmin number ) (pmax number ) + (pstep number ) (approx integer )) + + (fonds-virts accord pmin pmax pstep approx)) + +;====================================================================== + + + +;;; Fondamentales virtuelles multiples. Algorithme par Olivier Delerue. + +(defmethod! multi-virt-fun ((chord list) (approx integer) (thresh number) (unit symbol)) + :initvals '('(6000 6400 6700) 50 1200 'midic) + :indoc '("Chord" "Approx" "MinFund" "Unit") + :menuins '((3 (("Midics" 'midic) ("Freqs" 'freq)))) + :icon 242 + :doc + "Computes a series of possible virtual fundamentals from (a list of pitches) and (in midicents). +The result is a list of chord-sequences that can be fed to the 'chord-seq'input of a 'multi-seq'. Each chord-seq is a possible solution, sorted from the least significant to the most significant. Each chord-seq is a series of chords where the lowest note is a virtual fundamental and the remaining notes are a subset +of the original chord. + is a minimum pitch/frequency value for the virtual fundamentals. If the menu is 'freq' then and must be given in Hz, otherwise in Midics." + + (setf chord (sort (copy-list chord) '<)) + (when (eq unit 'midic) (setf chord (mc->f chord) thresh (mc->f thresh))) + (let ((classement (make-classement chord (cents->coef approx) thresh)) ) + (loop while (iteration classement ) ) + (loop for regroupement in (rest (regroupements classement)) + collect + (make-instance 'chord-seq :lmidic + (loop for spectre in (spectres regroupement) + collect + (f->mc (join-fund-to-spec (first (fondamentales spectre)) + (mapcar 'frequence (partiels spectre))))))))) + + + +(defmethod! multi-virt-fun ((chord chord) (approx integer) (thresh number) (unit symbol)) + (m-vir-fun (lmidic chord) approx thresh 'midic)) + +(defun make-classement (liste-partiels tolerance freq-min) + (make-instance 'classement + :regroupements (list (make-instance 'regroupement + :spectres (cree-liste-spectres liste-partiels tolerance freq-min))))) + + +;====Rename multi-virt-fun as virt-fund-multi 25-06-2007======================== + +(defmethod! virt-fund-multi ((chord list) (approx integer) (thresh number) (unit symbol)) + :initvals '('(6000 6400 6700) 50 1200 'midic) + :indoc '("Chord" "Approx" "MinFund" "Unit") + :menuins '((3 (("Midics" 'midic) ("Freqs" 'freq)))) + :icon 136 + :doc + "Computes a series of possible virtual fundamentals from (a list of pitches) and (in midicents). +The result is a list of chord-sequences that can be fed into the 'chord-seq'input of a multi-sequence object. Each chord-seq is a possible solution, sorted from the least significant to the most significant. Each chord-seq is a series of chords where the lowest note is a virtual fundamental and the remaining notes are a subset +of the original chord. + is a minimum pitch/frequency value for the virtual fundamentals. If the menu is 'freq' then and must be given in Hz, otherwise in Midics." + + (multi-virt-fun chord approx thresh unit)) + +(defmethod! virt-fund-multi ((chord chord) (approx integer) (thresh number) (unit symbol)) + + (multi-virt-fun chord approx thresh unit)) + +;================================================================================ + + +; --------------------- traitement de spectres (spectra menu)--------------------- + + +(om::defmethod! traite-ampl ((spectre list) (max number) (filtre% number)) + :initvals '('((1 2 3 4 5) (10 9 5 3.5 1.7)) 100 20) + :indoc '("Spectrum (ranks ampl)" "New max ampl" "Ampl low limit") + :icon 136 + :doc "met les intensitŽs du spectre ˆ l'Žchelle donnŽe par et retire les composantes +dont l'amplitude est < ˆ % donnŽ par filtre%" + (let ((res (multi-fil #'< (* (list-max (nth 1 spectre)) (/ filtre% 100.0)) spectre 1))) + (list (nth 0 res) (scaling/max (nth 1 res) max)))) + + +;====Rename traite-ampl as treat-amplitude 25-06-2007=================== + +(om::defmethod! treat-ampl ((spectre list) (max number) (filtre% number)) + :initvals '('((1 2 3 4 5) (10 9 5 3.5 1.7)) 100 20) + :indoc '("Spectrum (ranks ampl)" "New max ampl" "Ampl low limit") + :icon 136 + :doc "Scales the intensities (obtained after the spectral analysis) with respect to the maximum value and removes those components with an amplitude below a the percetage specified at ." + + (traite-ampl spectre max filtre%)) + +;====================================================================== + +(om::defmethod! midi-ampl ((spectre list) (velmin number)) + :initvals '('((1 2 3 4 5) (10 9 5 3.5 1.7)) 70) + :indoc '("Spectrum (ranks ampl)" "Ampl low limit") + :icon 136 + :doc + "Scales the intensities (obtained after the spectral analysis) with respect to the maximum value equal to 127, adjusts for a MIDI transfer through function (14.044 * x ^ 0455) and removes those components with a velocity below the specified ." + (let (resul) + (setq resul (om-round (mapcar #'(lambda (x) (* (expt x .455) 14.044)) + (scaling/max (nth 1 spectre) 127)) 1) ) + (multi-fil #'< velmin (list (nth 0 spectre) resul ) 1))) + +; =================== conversions ====================================== + + + +;---------------------conversions temporelles-------------------- + +(defun sec->min1 (sec nbdec format) +(let ((min (truncate sec 60))) + (if (and (equal format 'abbrev )(= 0 min)) (list(om-round sec nbdec)) + (list min 'min (om-round (mod sec 60) nbdec))))) + + +(om::defmethod! sec->min ((lsec t ) &optional (nbdec 2 ) (format 'normal)) + :initvals '(68 2 'normal) + :indoc '("lsec" "nbdec" "format" ) + :menuins '((2 (("normal" 'normal) ("abbrev"'abbrev)))) + :icon 137 + :doc "Converts values in seconds ()to values in minutes and seconds. The +optional argument determines the number of decimals in the +seconds column of the output. +The output is in the format '1 min 15' for an equal to '75'. If the +number of seconds is less than sixty the output will be in the form +'0 min 32'. The optional argument , if set to the position +'abbrev', will eliminate the minutes column if it has a value of '0'. +(The first example would remain '1 min 15' while the second would become '32')" + (deep-mapcar/1 'sec->min1 lsec nbdec format)) + + + +(defun min->sec1 (minutage) + (let ((sec 0) (minutes 0) (minutage (list! minutage))) + (cond ((= (length minutage) 1) (setq sec (car minutage))) + (( or (numberp (second minutage)) (= (length minutage) 3)) + (setq minutes (car minutage)) (setq sec (car (last minutage)))) + (t (setq minutes (car minutage)))) + (om-round (+ sec (* minutes 60)) 2))) + + +(om::defmethod! min->sec ((minutes list )) + :initvals '('(1 min 30) ) + :indoc '("minutes" ) + :icon 136 + :doc "Converts values in minutes into values in seconds. The value in minutes +may be entered as a list in any of the following formats: (3 min), or +(3 0); (3 min 30), or (3 30), or (3.5 min); (3 min 30.2), or (3 30.2). +(the letters 'min' may be replaced by simply 'm' or any other non-numeric +character or characters) " + (less-deep-mapcar 'min->sec1 (list! minutes))) + + + +(om::defmethod! addtime ((temps list) ) + :initvals '('((1 min 30) (2 min 12) )) + :indoc '("temps" ) + :icon 136 + :doc "additionne des minutages donnŽs sous forme de liste de liste +Minutages nŽgatifs possibles; orthographe : (-1 m 5)" + (sec->min (apply #'+ (min->sec temps)) 0)) + + +(om::defmethod! intertime ((temps list) ) + :initvals '('((1 min 30) (2 min 12) )) + :indoc '("temps" ) + :icon 136 + :doc "donne intervalles entre minutages donnŽs sous forme de liste de liste" + (sec->min (x->dx (min->sec temps)) 0 )) + + +(om::defmethod! cumultime ((tdeb list) (durs list )) + :initvals '('(0 min 45) '( 30 12) ) + :indoc '("tdeb" "durs" ) + :icon 136 + :doc "cumuls successifs d'une liste de durŽes (en secondes), ˆ partir +d'un temps de dŽpart 'tdeb' (en minutes-secondes) " + (rest (sec->min (dx->x (min->sec tdeb) durs) 2))) + + + +(om::defmethod! pro-max ((accord chord) (approx integer ) (canal integer)) + :initvals '(t 4 1) + :indoc '("chord" "approx" "canal") + :icon 136 + :doc "construit une liste au format max note vel canal " + + + (let ((hauteurs (lmidic accord)) + (velos (lvel accord ))) + (while hauteurs (let ((hauteur (approx-m (nextl hauteurs) approx))) + (format t "~A ~A ~A \," (truncate hauteur 100) (nextl velos) + (+ canal (/ (mod hauteur 100) 25))))) + (format t "~%") + nil)) + + + +(om::defmethod! pro-max-dur ((accord chord) (approx integer ) (canal integer)) + :initvals '(t 4 1) + :indoc '("chord" "approx" "canal") + :icon 136 + :doc "construit une liste au format max note vel canal off dur " + + (let ((hauteurs (lmidic accord )) + (velos (lvel accord)) + (durees (ldur accord)) + (offsets (loffset accord))) + (while hauteurs (let ((hauteur (approx-m (nextl hauteurs) approx))) + (format t "~A ~A ~A ~A ~A \," (truncate hauteur 100) (nextl velos) + (+ canal (/ (mod hauteur 100) 25)) + (* 10 (nextl offsets)) (* 10 (nextl durees))))) + (format t "~%") + nil)) +; ------------ approximations + + +(defun best-micro/1 (accord nbmicro approx) + (let* ( (ldist (om-modulo accord 100)) (app (/ 200 approx)) + (ldistapp nil) (ldist2 (copy-list ldist)) res ) + + (while ldist2 (let ((item (nextl ldist2))) + (if (< item app) (push (- app item) ldistapp) + (push (- item app) ldistapp)))) + + (setq ldistapp (reverse ldistapp)) + (setq ldist2 (sort-list (copy-list ldistapp))) + + (let ((mini (l-nth ldist2 (1- nbmicro)))) + + (while ldistapp (let ((item (nextl ldistapp))) + (if (<= item mini) + (progn (push app res) (nextl ldist)) + (push (om* (* app 2) (ll/round (nextl ldist) (* app 2))) res ))))) + + (om+ (nreverse res) (om* 100 (om-floor accord 100))))) + + + + + + +(om::defmethod! best-micro ((accords list) (nbmicro integer) (approx integer)) + :initvals '('(6000 6345 6625) 1 4) + :indoc '("accords" "nbmicro" "approx" ) + :icon 136 + :doc "ne rend l'approx que pour les hauteurs les mieux placŽes +Si = 0, rend l'accord approximŽ normalement" + (if (or (< approx 3) (= nbmicro 0)) (approx-m accords approx) + (less-deep-mapcar #'best-micro/1 accords nbmicro approx))) + + + +(defun filtre-micro/1 (accord approx crible ) + (let ((modulo (/ 200 crible)) (accord (approx-m accord approx)) res) + (dolist (n accord) + (if (= (mod n modulo) 0) (push n res))) + (nreverse res))) + +(om::defmethod! filtre-micro ((accords list) (approx integer) (crible integer)) + :initvals '('(6000 6345 6625 6987) 4 2) + :indoc '("accords" "approx" "crible") + :icon 136 + :doc "approxime l'accord, puis enlève les sons n'appartenant pas ˆ l'ensemble +des sons en 1/2 ou 1/4, selon " + (less-deep-mapcar #'filtre-micro/1 accords approx crible)) + + +;; ---- midic -> symbol ---- + +(om::defmethod! ratio->cents ((coef number)) + :initvals '(1.05946) + :indoc '("Freq ratio") + :icon 136 + :doc "cents> takes a frequency ratio f1/f2 and returns the interval, +expressed in midi-cents, between f1 and f2." + + (round (log coef) #.(/ (log 2) 1200))) + + +(om::defmethod! cents->ratio ((nb-cents number)) + :initvals '(100) + :indoc '("Cents") + :icon 136 + :doc "coef> takes an interval expressed in midi-cents and returns the ratio +between two frequencies separated by that interval; i.e., the value: (freq + ) / freq." + + (expt 2.0 (/ nb-cents 1200.0))) + + + +(om::defmethod! inter->freq ((accord list)) + :initvals '('(2400 3100 4050)) + :indoc '("accord") + :icon 136 + :doc "intervalles en frŽquence entre chaque note de l'accord" + (om-abs (x->dx (mc->f accord)))) + + +(om::defmethod! diff->dist ((fond number) (rang number) (diff number) ) + :initvals '(2400 5 235) + :indoc '("fond" "rang" "diff") + :icon 136 + :doc "convertit une distorsion exprimŽe en midic par rapport ˆ un rang en +distorsion exprimŽe en %" + (let ((f (mc->f fond)) (d (mc->f diff))) + (/ (log (/ (+ d (* f rang)) f)) (log rang)))) + + +(defun lin->db1 (amp) + (if (zerop amp) -3.63224978306E9 + (* 20.0 (log amp 10)))) + + +(om::defmethod! tm-lin->db ((amps list) &optional (nbdec 2)) + :initvals '('(1024 2048) 2) + :indoc '("Amplitudes" "Nb decimals") + :icon 136 + :doc "db> takes a number and returns the corresponding value +expressed in decibels. The input can be a list of numbers. In this case a list of +db values is returned." + + (om-round (deep-mapcar/1 'lin->db1 amps) nbdec)) + + + +(defun dB->lin1 (amp) (expt 10.0 (/ amp 20.0))) + + +(om::defmethod! tm-db->lin ((amps list) &optional (nbdec 0)) + :initvals '('(60 66) 0) + :indoc '("Decibels" "Nb decimals") + :icon 136 + :doc "lin> takes a number in decibels and converts it +to linear. The input can be a list of numbers. In this case a list of +linear values is returned." + + (om-round (deep-mapcar/1 'db->lin1 amps) nbdec)) + + +(defun choisir-separateurs (texte separateurs ) + (let ((lchar (coerce texte 'list)) (separateurs (list! separateurs))) + (dolist (sep separateurs) + (setq lchar (ll-replace lchar sep #\Space) )) + (coerce lchar 'string))) + +(defun m->can1 (chord approx) + (let* ((res (clone chord)) + (l-midics (approx-m (lmidic) approx)) + (l-canaux (lchan res))) + (setf (lchan res) (om+ l-canaux (om/ (second (multiple-value-list (om// l-midics 100))) 25))) + (setf (lmidic res) (om* 100 (first (multiple-value-list (om// (om/ l-midics 100) 1))))) + res)) + + +(om::defmethod! midic->canal ((chords t) (approx integer)) + :initvals '(t 4 ) + :indoc '("chords" "approx") + :icon 136 + :doc "rend chord approximŽ o l'indication de 1/4 de ton ou de 1/8 ton est fournie +par le canal (+ 1 2 3 selon micro-int)" + (car-mapcar #'m->can1 (lmidic chords) approx)) + + + +; changement de port et de canal + +(om::defmethod! map-channel ((obj chord) (mapping list)) + :initvals '(nil (((0 1) (1 3)))) + :indoc '("chord" "mapping list") + :icon 136 + :doc "gives new port and channel numbers . Format of mapping list : +(((oldport oldchannel) (newport newchannel)) ((oldport oldchannel) (newport newchannel))...) +ex : ( ((0 1) (3 5)) ((1 3) (1 7)) ((1 9) (2 11)) ) +if one change only, don't forget outer brackets : ( ((0 1) (3 5)) ) " + + (let ((ports (lport obj)) (chans (lchan obj)) ) + (for (i 0 1 (length-1 ports)) + (loop for m in mapping + + do (if (and (= (nth i ports) (car (car m))) (= (nth i chans) (second (car m)))) + (progn (setf (nth i ports)(car (second m))) + (setf (nth i chans)(second (second m))))))) + (mki 'chord + :LMidic (lmidic obj) + :Lvel (lvel obj) + :Loffset (loffset obj) + :Ldur (ldur obj) + :Lchan chans + :Lport ports))) + + + +(om::defmethod! map-channel ((obj chord-seq) (mapping list)) +(mki 'chord-seq + :lmidic (loop for ch in (chords obj) + collect (map-channel ch mapping)) + :lonset (lonset obj) + :legato (legato obj))) + + + +(om::defmethod! map-channel ((obj multi-seq) (mapping list)) + (mki 'multi-seq + :chord-seqs (loop for chseq in (chord-seqs obj) + collect (map-channel chseq mapping)))) + + + + + + +;=============================CONTROL================================== + + + +(om::defmethod! aiguillage ((num integer) (pat1 list) + (pat2 list) + &rest patches) + :initvals '(1 '() '() '()) + :indoc '("num" "pat1" "pat2" "patches") + :icon 137 + :doc "dŽclenche le patch branchŽ ˆ l'entrŽe indiquŽe par " + + (let ((lpatches (x-append (list pat1 pat2 ) patches))) + (posn-match lpatches (1- num)))) + + + +(om::defmethod! lambda-mapcar ((fct t ) (liste list) (arg t)) + :initvals '('+ '() '()) + :indoc '("fct" "liste" "arg") + :icon 136 + :doc "" + + (mapcar #'(lambda (x) (funcall fct x arg) ) liste)) + + + + +; ================= ensembles ======================================= + + +(om::defmethod! unique-notes ((acc1 t) (approx integer) &rest accords ) + + :initvals '('(6000 6600 6615) 4 () ) + :indoc '("Midics" "Approx" "Midics") + :icon 137 + :doc "retire notes redoublŽes, après approximation. +Accepte listes d'accords sur l'entrŽe acc1, ou avec extensions, diffŽrents +accords sur chaque entrŽe" + (remove 0 (less-deep-mapcar 'unique (append (approx-m acc1 approx) + (flat (deep-mapcar/1 'approx-m accords approx )))))) + + +(om::defmethod! common-notes ((accord1 list) (approx integer) (accord2 list) &rest accords ) + + :initvals '('(6000 6600) 4 '(6200 6600) () ) + :indoc '("Midics" "Approx" "Midics" "Midics") + :icon 137 + :doc "notes communes, après approximation" + (let ((ll (intersection (approx-m accord1 approx) (approx-m accord2 approx)))) + (while accords + (setq ll (intersection (approx-m (pop accords) approx) ll)) ) + ll)) + + +(om::defmethod! notes-union ((accord1 list) (approx integer) (accord2 list) &rest accords ) + + :initvals '('(6000 6600) 4 '(6200 7000) () ) + :indoc '("Midics" "Approx" "Midics" "Midics") + :icon 137 + :doc "union des notes des deux accords, sans rŽpŽtition, selon approx. +L'accord rendu est approximŽ" + (let ((ll (x-union (approx-m accord1 approx) (approx-m accord2 approx)))) + (while accords + (setq ll (x-union ll (approx-m (pop accords) approx)) )) + (sort-list ll '<))) + + +(om::defmethod! notes-libres ((accord list) (approx integer) &rest accords ) + :initvals '('(6000 6600 7300 8850) 4 () ) + :indoc '("Midics" "Approx" "Midics" ) + :icon 137 + :doc "degrŽs non utilisŽs par un accord ou une sŽrie d'accords, selon approx" + (let ((gamme (arithm-ser 6000 7199 (/ 200 approx))) + (ll (transpoct (approx-m accord approx) 6000 7199))) + (while accords + (setq ll (x-union ll (transpoct (approx-m (pop accords) approx) 6000 7199) ))) + (x-diff gamme ll))) + + + +(om::defmethod! notes-libres ((accord chord) (approx integer) &rest accords ) + (notes-libres (lmidic accord) approx)) + + + + + + +; ======================= intervals ========================== + + + +(defun max-abs-idt (ch1 ch2) + "Uses as intervalic distance the maximum of the absolute intervals (in cents) +between the corresponding notes of the two chords and . +Returns the minimum intervalic distance between and the best transposition +of and returns this transposition as second value." + (let* ((ints (mapcar #'- ch1 ch2)) + (int-min (apply #'min ints)) + (int-max (apply #'max ints))) + (values (/ (- int-max int-min) 2) (/ (+ int-max int-min) 2)))) + +;;so that user extended box works with max-abs-idt as default value...!!! +(defun CL-USER::max-abs-idt (ch1 ch2) (max-abs-idt ch1 ch2)) + +(defun ma-best-transp (ch1 ch2) + "Uses as intervalic distance the maximum of the absolute intervals (in cents) +between the corresponding notes of the two chords and . +Computes the minimum intervalic distance between and the best transposition +of and returns this transposition." + (multiple-value-bind (dist ch) (max-abs-idt ch1 ch2) + (declare (ignore dist)) + ch)) + + +;; - the best transposition "Tbest" is the middle point of the list: +;; (cond ((oddp (length ints)) (nth (/ n 2) ints)) +;; ((evenp (length ints)) (/ (+ (nth (floor n 2) ints) +;; (nth (floor (1+ n) 2) ints)) 2))) +;; - the corresponding distance is: +;; D = (Sum (i 0 n/2) |Tbest-INTi|) + (Sum (i n/2 n+1/2) |INTi-Tbest|) +;; D = (Sum (i n/2 n+1/2) INTi) - (Sum (i 0 n/2) INTi) + +(defun sum-abs-idt (ch1 ch2) + "Uses as intervalic distance the arevage of the absolute intervals (in cents) +between the corresponding notes of the two chords and . +Returns the minimum intervalic distance between and the best transposition +of and returns this transposition as second value." + (let* ((ints (sort (mapcar #'- ch1 ch2) #'<)) + (1-length (1- (length ints))) + (summin 0) (summax 0) + transpos) + (repeat (floor 1-length 2) + (incf summin (nextl ints))) + (if (evenp 1-length) + (nextl ints transpos) + (progn + (incf summin (nextl ints transpos)) + (setq transpos (/ (+ transpos (car ints)) 2)))) + (while ints (incf summax (nextl ints))) + (values (- summax summin) transpos))) + +(defun sa-best-transp (ch1 ch2) + "Uses as intervalic distance the arevage of the absolute intervals (in cents) +between the corresponding notes of the two chords and . +Computes the minimum intervalic distance between and the best transposition +of and returns this transposition." + (multiple-value-bind (dist ch) (sum-abs-idt ch1 ch2) + (declare (ignore dist)) + ch)) + +(defmethod! besttransp ((ch1 list) (ch2 list) (fct symbol)) + :initvals '('(6000) '(6000) 'sum) + :indoc '("chord" "chord" "fct") + :menuins '((2 (("Sum" 'sum) ("Max" 'max))) ) + :icon 136 + :doc + +"Transposes the chord (a single chord in midicents) so that its +intervallic distance to (also a single chord in midicents) is as +small as possible. Thus the distance between each note of and each +note of becomes as small as possible.This is essentially the same +as the box 'best-inv' except the ordering of is preserved. + +The optional argument allows the choice between two different +algorithms for calculating this function,'sum' and 'max'. The default +is sum because 'max' may produce quarter-tones from semi-tone input. For +best results one should experiment with both and chose according to the +context." + +(om+ ch2 (if (eq fct 'max) (ma-best-transp ch1 ch2) (sa-best-transp ch1 ch2)))) + + +(defmethod! besttransp ((ch1 t) (ch2 list) (fct symbol)) + (besttransp (lmidic ch1) ch2 fct)) + +(defmethod! besttransp ((ch1 list) (ch2 chord) (fct symbol)) + (besttransp ch1 (lmidic ch2) fct)) + +(defmethod! besttransp ((ch1 chord) (ch2 chord) (fct symbol)) + (besttransp (lmidic ch1) (lmidic ch2) fct)) + +;===Rename besttransp as closest-trans 25-06-2007========== + +(defmethod! closest-trans ((ch1 list) (ch2 list) (fct symbol)) + :initvals '('(6000) '(6000) 'sum) + :indoc '("chord" "chord" "fct") + :menuins '((2 (("Sum" 'sum) ("Max" 'max))) ) + :icon 136 + :doc + "Transposes the chord (a single chord in midicents) so that its +intervallic distance to (also a single chord in midicents) is as +small as possible. Thus the distance between each note of and each +note of will become as small as possible. This is essentially the same +as the box 'best-inv' except the ordering of is preserved. + +The optional argument allows the choice between two different +algorithms for calculating this function,'sum' and 'max'. The default +is sum because 'max' may produce quarter-tones from semi-tone input. For +best results one should experiment with both and chose according to the +context." + + (besttransp ch1 ch2 fct)) + +(om::defmethod! closest-trans ((ch1 list) (ch2 chord) (fct symbol)) + (make-instance 'chord + :lmidic + (closest-trans ch1 (lmidic ch2) fct) + :ldur (ldur ch2) + :lvel (lvel ch2) + :loffset (loffset ch2) + :lchan (lchan ch2))) + +(om::defmethod! closest-trans ((ch1 chord) (ch2 list) (fct symbol)) + (make-instance 'chord + :lmidic + (closest-trans (lmidic ch1) ch2 fct) + :ldur (ldur ch1) + :lvel (lvel ch1) + :loffset (loffset ch1) + :lchan (lchan ch1))) + +(om::defmethod! closest-trans ((ch1 chord) (ch2 chord) (fct symbol)) + (make-instance 'chord + :lmidic + (closest-trans (lmidic ch1) (lmidic ch2) fct) + :ldur (ldur ch2) + :lvel (lvel ch2) + :loffset (loffset ch2) + :lchan (lchan ch2))) + +;=============================================================== + + + +(defun transpoct-prox1 (midics min max pivot ) + "" + (let ((mmin (max min (- pivot 1200))) + (mmax (min max (+ pivot 1200)))) + (cond + ((> mmin mmax) + (error "The intervals [~S ~S] [~S-1200 ~S+1200] don't intersect." + min max pivot pivot)) + ((< (- mmax mmin) 1200) + (error "The intersection between [~S ~S] and [~S-1200 ~S+1200] is smaller than one octave." + min max pivot pivot))) + (transpoct midics mmin mmax))) + + + +(defun transpoct-prox (chord min max pivot) + "Transposes (midics) by octaves to fit into the interval [ ] +while making with an interval smaller than one octave. + may be a list of chords" + (less-deep-mapcar 'transpoct-prox1 chord min max pivot)) + +(defun transpoct1 (midics min max) + "" + (let ((result (mapcar #'(lambda (midic) + (while (< midic min) (incf midic 1200)) + (while (> midic max) (decf midic 1200)) + midic) (list! midics)))) + (if (cdr result) result (car result)))) + + +(om::defmethod! transpoct ((chord list) (min integer) (max integer) &optional (pivot 0)) + + :initvals '('(5500 6600 7850) 6000 7200 0 ) + :indoc '("Midics" "Min" "Max" "Pivot") + :icon 137 + :doc "Transposes notes of a chord or list of chords by octaves such +that all its notes will be contained within the range between and +, given in midicents. + +The optional argument (a note, in midicents) forces all notes +to be transposed so that they will be within one octave of that note. + must be within the specified range, or an error will be +produced." + (if (< max min) (rotatef max min)) + (if (zerop pivot) + (less-deep-mapcar 'transpoct1 (list! chord) min max) + (less-deep-mapcar 'transpoct-prox1 (list! chord) min max pivot))) + + +;===Rename transpoct as oct-trans 25-06-2007===================== + +(om::defmethod! oct-trans ((chord list) (min integer) (max integer) &optional (pivot 0)) + + :initvals '('(5500 6600 7850) 6000 7200 0 ) + :indoc '("Midics" "Min" "Max" "Pivot") + :icon 137 + :doc "Transposes notes of a chord or list of chords by octaves so all its notes will be contained within the range between and , given in midicents. + +The optional argument (a note, in midicents) forces all notes to be transposed to the same octave as the pivot. The must be within the specified range, or an error will occur." + + (transpoct chord min max pivot)) + + +(om::defmethod! oct-trans ((self chord) (min integer) (max integer) &optional (pivot 0)) + (make-instance 'chord + :lmidic + (oct-trans (lmidic self) min max) + :ldur (ldur self) + :lvel (lvel self) + :loffset (loffset self) + :lchan (lchan self))) + + +(om::defmethod! oct-trans ((self chord-seq) (min integer) (max integer) &optional (pivot 0)) + (make-instance 'chord-seq + :lmidic + (oct-trans (mapcar 'lmidic (chords self)) min max) + :lonset (lonset self) + :ldur (ldur self) + :lvel (lvel self) + :loffset (loffset self) + :lchan (lchan self) + :legato (legato self))) + + + +(om::defmethod! oct-trans ((self multi-seq) (min integer) (max integer) &optional (pivot 0)) + (make-instance 'multi-seq + :chord-seqs + (loop for chord-seq in (chord-seqs self) + collect + (oct-trans chord-seq toler)))) + + +;================================================================= + + +(om::defmethod! mul-chord ((ch1 list) (ch2 list) &optional (type 'chord)) + + :initvals '('(6000 6300) '(6400 6700) 'chord ) + :icon 137 + :doc "Generates a list of chords in which the intervallic structure of +(a single chord in midicents) is reproduced beginning on each successive +note of (also a single chord in midicents). +The optional argument allows the choice of whether the output is +a list of chords ('seq') or a single chord ('chord') containing all the +transpositions combined." + + (let ((ch1 (list! ch1)) (int2 ()) (base-note-2 (apply 'min ch2)) res) + (while ch2 (newl int2 (- (nextl ch2) base-note-2))) + (setq int2 (nreverse int2)) + (setq res (mapcar + #'(lambda (midic) (mapcar #'(lambda (iv) (+ iv midic)) int2)) + ch1 )) + (if (eq type 'chord) (flat res) res ))) + + +;=========Rename mul-chord as chord-multiplier 24-06-2007========================= + +(om::defmethod! chord-multiplier ((ch1 list) (ch2 list) &optional (type 'chord)) + + :initvals '('(6000 6300) '(6400 6700) 'chord ) + :icon 137 + :doc "Generates a list of chords in which the intervallic structure of (a single chord of pitches as a list in midicents) is reproduced beginning on each successive note of (also a single chord in midicents). The optional argument allows the choice of whether the output is a list of chords ('seq') or a single chord ('chord') containing all the transpositions combined." + + (mul-chord ch1 ch2 type)) + + +; ================================ traitement de listes =========================== + +; ............ utilitaires + +(defun nnth (arg list ) + (nth arg (flat list))) + +(defun aplatit (list listmem) + (cond ((atom list) list) + ((atom (car list)) list) + ((atom (car (car list))) (flat-once listmem)) + (t (aplatit (car list) listmem)))) + +(defun supprimelem (liste elem ) + (let ((long (1- (length liste))) result) + (for (i 0 1 long) + (if (= i elem) (progn (pop liste) (push () result)) + (push (pop liste) result))) + (remove () (nreverse result)))) + +;-------------------------------------------------------- + +(om::defmethod! lister ((list1 t) (list2 t) &rest lst?) + :initvals '('(1 2) '(1 2) '(1 2)) + :indoc '("list1" "list2" "lst?") + :icon 137 + :doc "puts lists together" + (x-append (list list1 list2) lst?)) + + +(om::defmethod! lister4 ((list1 t) (list2 t) (list3 t) (list4 t) + &rest lst?) + :initvals '('(1 2) '(1 2) '(1 2) '(1 2) '(1 2) ) + :indoc '("list1" "list2" "list3" "list4" "lst?") + :icon 137 + :doc "puts lists together" + (x-append (list list1 list2 list3 list4) lst?)) + + + + +;-------------------------- extraction ------------------------------ + + +(om::defmethod! atom! ((data t)) + :initvals '('(1 2 3 4 5) ) + :indoc '("data") + :icon 136 + :doc "Works similarly as 'first', but also accepts an atom at the input." + + (if (atom data) data (first data))) + +(defun deuxieme (liste) "" + (second liste)) + +(defun troisieme (liste) "" + (third liste)) + + +(om::defmethod! list-pos ((liste list) (deb number) (fin number) + &optional (niveau 'high)) + + :initvals (list '(1 2) 0 1 'haut) + :indoc '("liste" "deb" "fin" "niveau" ) + :icon 137 + :menuins '((3 (("high" 'high) ("med" 'med) ("low" 'low) ))) + :doc "Extracts at the specified positions between beginning and end. Options: 'high' means operation occurs hierarchically at the highest sublists.'med' means operation occurs at the second level. 'low' means the operation takes place at the lowest sublists." + + + (let* ((indi (if (< fin deb) -1 1)) ) + (remove nil + (cond ((equal niveau 'high) (l-nth liste (arithm-ser deb fin indi) )) + ((equal niveau 'med) (car-mapcar #'l-nth liste (arithm-ser deb fin indi))) + ((equal niveau 'low) (less-deep-mapcar #'l-nth liste (arithm-ser deb fin indi))) + )))) + +#| +; pour compatibilitŽ +(defunp liste-pos ((liste list) (deb fix) (fin fix)) list + "" + (list-pos liste deb fin 2)) +|# + +(om::defmethod! guillotine ((liste list)) + :initvals '( '((1 2 3 4 5) (1 6 7 8 9))) + :indoc '("List of lists") + :icon 136 + :doc "Returns the first elemement of every sublist. The input may be a list or a list of lists." + +(let ((end (length liste)) listinter sousliste) + (dotimes (n end) + (setq sousliste (cdr (nth n liste))) + (push sousliste listinter)) + (setq liste (reverse listinter)))) + +(om::defmethod! l-extract ((texte t) (ncol integer) (select t)) + :initvals '( '(1 100 3.0 2 200 5.0 3 300 2.7 ) 3 '(1 2)) + :indoc '("Raw text" "Number of columns" "Choice of columns (list)") + :icon 136 + :doc "Organizes a raw data list (for example a spectral analysis file). Applies a list-modulo in columns. Selects the columns indicated by and returns a list of lists." + + (l-extract text ncol select)) + +;========================================================== + +(om::defmethod! penult ((liste list)) + :initvals '( 1 2 3 4 5) + :indoc '("List") + :icon 136 + :doc "Extracts the 'butlast' element from a list. For example from the list (0 1 (2 10) 3 (4 1) 5 6 7) it returns 6." + +(last-elem (butlast liste))) + +;-------------------------- liste-analyse ------------------------------ + +(defun l-sum1 (liste) + (apply #'+ liste)) + +(om::defmethod! l-sum ((liste list)) + :initvals '( '(1 2 3 4 5 6 7 ) ) + :indoc '("liste") + :icon 136 + :doc "Returns the total sum of all elements of a list." + (less-deep-mapcar #'l-sum1 liste)) + +(defun positions1 (list elem ) + (let ((index 0) res) + (dolist (n list) + (if (eq elem n ) (push index res)) + (setq index (1+ index))) + (nreverse res))) + +(om::defmethod! positions ((list list) (elem t)) + :initvals '( '(1 2 3 1 5 1 7 ) 1 ) + :indoc '("list" "elem") + :icon 136 + :doc "Returns all positions of a certain element within a list." + (less-deep-mapcar 'positions1 list elem)) + +(defun nbi-rec (liste res) + (let ((sublist ())) + (push (length (positions liste (first liste))) sublist) + (push (first liste) sublist) + (push sublist res) + (setq liste (remove (first liste) liste)) + (if (not (null liste)) (nbi-rec liste res) res))) + +(om::defmethod! nbelem-ident ((liste list)) + :initvals '( '(a b a c b a d e ) ) + :indoc '("liste") + :icon 136 + :doc "donne le nombre d'ŽlŽments identiques d'une liste, rangŽs par +ordre de frŽquence dŽcroissante +sortie: liste elems, liste frequences " + (let ((res (sort-table (mat-trans (nbi-rec liste () )) 1))) + (list (nreverse (first res)) (nreverse (second res))))) + +;====Rename nbelem-ident as n-occur 28-06-2007================== + +(om::defmethod! n-occur ((liste list)) + :initvals '('(a b a c b a d e)) + :indoc '("liste") + :icon 136 + :doc "Returns the number of indentical elements within a list, ordered by decreasing frequency (i.e. number of occurences). + +Output: list of identical elements, list of frequencies." + + (nbelem-ident liste)) + +;=============================================================== + +(om::defmethod! length-1 ((list list)) + :initvals '('(1 2 3 4 5 6 7)) + :indoc '("list") + :icon 136 + (1- (length list))) + + +;-------------------------- substit/insert ------------------------------ + + +(defun rec-suppress (liste elem) + (while elem + (setq liste (rec-suppress (suppress-one liste (pop elem)) (cdr elem)))) + liste) + +(defun suppress-one (liste elem ) + (let ((long (1- (length liste))) result) + (for (i 0 1 long) + (if (= i elem) (progn (pop liste) (push () result)) + (push (pop liste) result))) + (nreverse result))) + +(om::defmethod! l-suppress ((liste list) (elem t)) + :initvals '( '((1 2 3 4 5) 0) 0) + :indoc '("List of lists" "elem") + :icon 136 + :doc " retire les ŽlŽments de numŽro (peut tre une liste) de la liste" + (remove () (rec-suppress liste (list! elem)))) + +;(l-suppress '(1 2 3 4 5) '(0 2)) + + +(defun remove-all (list nums) + (let ((count 0)) + (dolist (item nums list) + (setf (nthcdr (- item count) list) (nthcdr (+ item 1 (- count)) list)) + (incf count)))) + +(defun get-useful-nums (nums length) + (let ((elems (unique (list! nums))) list) + (dolist (a-num elems (nreverse list)) + (cond ((minusp a-num) ) + ((< a-num length) (push a-num list)) + (t (return (nreverse list))))))) + +; corr. 8-6-03 +(defun multi-fil (test val list numcol ) +"retire de chacune des sous-listes de les ŽlŽments dont le numŽro d'ordre +correspond ˆ chaque ŽlŽment de la sous-liste de numŽro qui satisfait +ˆ la condition " + (if (atom (car list)) (filtre-liste test val list) + (let ((longueur (length (nth numcol list))) + (ncol (1- (length list))) res) + (dotimes (n longueur) + (if (funcall test (car (nth numcol list)) val) + () + (for (i 0 1 ncol) + (push (car (nth i list)) res))) + (setq list (ll-suppress list 0)) ) + (if (null res) () (list-modulo (reverse res) (1+ ncol))) ))) + +(defun l-delete (list elem ) +"deletes the elemth (can be a list) element from list. If is a list of +numbers, these have to be ordered " + (let ((numbers (get-useful-nums elem (length list)))) + (if numbers + (let ((save-l (copy-list list))) + (if (zerop (car numbers)) + (cdr (remove-all save-l (cdr numbers))) + (remove-all save-l numbers))) + list))) + + +(om::defmethod! ll-suppress ((lliste list) (elem t )) + :initvals '( '((1 2 3 4 5) (1 6 7 8 9)) '(0 3)) + :indoc '("List of lists" "Num of elements") + :icon 136 + :doc " retire les ŽlŽments de numŽro de chaque sous-liste de la liste" + (mapcar #'(lambda (x) (l-delete x elem)) lliste)) + + + + +(om::defmethod! ll-remove ((list list) (item t)) + :initvals '( '((1 2 3 4 5) (3 3 7 8 9)) 3) + :indoc '("List of lists" "Element") + :icon 136 + :doc "remove sur listes de listes " + (less-deep-mapcar #'(lambda (x) (remove item x)) list )) + + +(om::defmethod! ll-replace ((list list) (old t) (new t)) + :initvals '( '((1 2 3 4 5) (3 3 7 8 9)) 3 'b) + :indoc '("List of lists" "Element to replace" "New element") + :icon 136 + :doc "replace on list of lists " + (less-deep-mapcar #'(lambda (x) (substitute new old x)) list )) + + + +(defun insert1 (liste insert pos ) + (let ((long (1- (length liste))) res ) + (if (> pos 0) + (dolist (d (list-pos liste 0 (1- pos))) + (push d res))) + (if (consp insert) + (dolist (d insert) (push d res)) + (push insert res)) + (if (<= pos long) + (dolist (d (list-pos liste pos long)) + (push d res))) + (nreverse res))) + +(defun insert-rec (liste insert pos ) + (while (not (null pos)) + (setf liste (insert1 liste (pop insert) (pop pos) )) + (insert-rec liste insert pos )) + liste) + +(om::defmethod! ll-insert ((liste list) (insert t ) (pos integer)) + :initvals '( '(1 2 3 4 5) 'f 2) + :indoc '( "liste" "insert" "pos") + :icon 136 + :doc " insère une liste ou un ŽlŽment au sein de la liste ˆ partir de la position +On peut insŽrer une liste d'insertions, avec les positions correspondantes dans pos +Jouer avec les parenthèses pour obtenir l'effet de niveau dŽsirŽ +Nouvelle version 28/7/96" + (if (one-elem pos) + (insert1 liste insert pos) + (insert-rec liste insert pos))) + + +; gardŽ pour compatibilitŽ +(defun l-insert (liste insert pos ) +" insŽre une liste ou un ŽlŽment au sein d'un autre ˆ partir +de la position pos" + (x-append (liste-pos liste 0 (1- pos)) insert (liste-pos liste pos (1- (length liste))))) + + +(defun substit-one (liste elem val fct) + (let ((long (1- (length liste) )) (val (list val))) + (x-append (l-nth liste (arithm-ser 0 (1- elem) 1)) + (if (equal fct '=) val (funcall fct (l-nth liste elem) val )) + (l-nth liste (arithm-ser (1+ elem) long 1)) ))) + +(om::defmethod! substit ((liste list) (elem t) (val t) &optional (fct '=)) + :initvals '( '(1 2 3 4 5) '(0 3) '(12 10) '=) + :indoc '( "liste" "elem" "val" "fonction") + :icon 137 + :doc "remplace les ŽlŽments de n° par les valeurs +extension: = fonction ; si diffŽrent de ''='', +on remplace alors par ( )" + (let* ((elem (list! elem)) (lg (1- (length elem))) + (val (if (and (consp val) (one-elem elem)) (list val) (list! val)))) + (print elem) + (print (posn-match elem '(1) )) + (for (n 0 1 lg) + (setq liste (substit-one liste (l-nth elem n) (l-nth val n) fct))) + liste)) + + +;-------------------------- filtres ------------------------------ + +#| + +; Same as in kernel but modified keep it??? + +(om::defmethod! band-filter ((list list) (bounds list) (mode symbol)) + :initvals '('(1 2 3 4 5) '((0 2) (5 10)) 'pass) + :indoc '("list" "bounds" "mode" ) + :menuins '((2 (("Reject" 'reject) ("Pass" 'pass)))) + :icon 235 + :doc "filters out (a list or a tree of numbers) using . + is a list of pairs (min-value max-value). Elts in list are selected if they stay between the bounds. + is a menu input. 'Reject' means reject elts that are selected. +'Pass' means retain only elts that are selected." + (let ((bounds (if (atom (first bounds)) (list bounds) bounds))) + (list-filter + #'(lambda (item) + (some #'(lambda (bound) (and (>= item (first bound)) (<= item (second bound)))) bounds)) + list + mode))) +|# + +; band-pass band-reject sont dŽfinis dans fichier pw-list-functions + +#| +(defunp b-pass ((list list) (min fix/float) (max fix/float)) list + "garde les valeurs comprises entre min et max, bornes comprises" + (filtre-liste '< min (filtre-liste '> max list))) + +(defunp b-reject ((list list) (min fix/float) (max fix/float)) list + "rejette les valeurs comprises entre min et max, bornes comprises" + (append (filtre-liste '>= min list) (filtre-liste '<= max list))) +|# + + + + + +; ajout de filtre-liste (= list-filter de PW) - plus facile d'emploi que OM:list-filter + +(defun filtre-liste1 (liste fct val ) +"retire de la liste toutes les valeurs rŽpondant ˆ la condition " + (let ((res)) + (dolist (num liste (nreverse res)) + (unless (funcall fct num val) (push num res))))) + +(om::defmethod! filtre-liste ((test symbol) (val number) (list list)) + :initvals '( '= 5 '(1 2 3 4 5 6 7 8 9)) + :indoc '("Test" "Valeur" "Liste") + :icon 136 + :doc "filtre-liste removes elements from a according to a predicate . If the +predicate is 'eq', all instances of are removed from the list, regardless of +their level. If, for example, the predicate is >, all elements of list which are +greater than are removed. Note that can be a string, but only if the +predicate can handle a string. " + (less-deep-mapcar 'filtre-liste1 list test val )) + + + + + + + +(om::defmethod! multi-filter ((test symbol) (val number) (list list) (numcol integer)) + :initvals '( '= 7 '((1 2 3 4 5) (1 6 7 8 9)) 1) + :indoc '("Test" "Value" "List of lists" "Num of column starting at 0") + :icon 136 + :doc +" +Correspond ˆ l'ancien table-filter de PW +retire de chacune des sous-listes de les ŽlŽments dont le numŽro d'ordre +correspond ˆ chaque ŽlŽment de la sous-liste de numŽro qui satisfait +ˆ la condition " + (multi-fil test val list numcol)) + + + + +(om::defmethod! band-multi-filter ((list list) (min number) (max number) (numcol integer) (test symbol) ) + :initvals '('((1 3 15) (a b c)) 0.5 8 0 '<> ) + :indoc '("list" "Value" "min" "max" "numcol" "test") + :icon 136 + :menuins '((4 (("<>" '<> ) ("<>=" '<>=) ("><" '>< ) ("><=" '><= )))) + :doc "ne garde de chacune des sous-listes de que les ŽlŽments dont le numŽro d'ordre +correspond ˆ chaque ŽlŽment de la sous-liste de numŽro qui satisfait +ˆ la condition " + + (let ((fct (cond ((equal test '<>) 'compris ) + ((equal test '<>=) 'compris= ) + ((equal test '><) 'exclus ) + ((equal test '><=) 'exclus= ))) + + (longueur (length (nth numcol list))) + (ncol (1- (length list))) res) + + (dotimes (n longueur) + (if (funcall fct (car (nth numcol list)) min max) + + (for (i 0 1 ncol) + (push (car (nth i list)) res)) + () ) + (setq list (ll-suppress list 0)) ) + + (list-part (reverse res) (1+ ncol))) ) + + + + +(om::defmethod! filtrenx ((liste list) (nbval integer) (fct symbol)) + :initvals '( '(1 3 7 2 15) 3 '> ) + :indoc '( "liste" "nbval" "fct") + :icon 136 + :doc "laisse les + grands ( > ) ou plus petits ( < ) d'une liste" + (let ((fct (if (equal fct '>) 'list-max 'list-min)) (copie liste) val) + (for (i 1 1 nbval) + (setq val (funcall fct liste)) + (setq liste (remove val liste))) + + (setq liste (x-diff copie liste)) + (setq nbval (length liste)) + (print (format nil "valeur limite = ~D - nb ŽlŽments retenus = ~D " val nbval)) + liste)) + + +(om::defmethod! multi-filtrenx ((liste list) (nbval integer) (fct symbol) (numcol integer)) + + :initvals '( '((1 3 7 2 15) (a b v f r)) 3 '> 0) + :indoc '( "liste" "nbval" "fct" "numcol") + :icon 136 + :doc "laisse les + grands ( > ) ou plus petits ( < ) ŽlŽments +de la sous-liste , et les ŽlŽments de numŽro correspondant +des autres sous-listes +Il y des problèmes lorsque la liste comporte des valeurs Žgales proches de +la valeur limite - consulter les messages du listener" + (let ( (fct (if (equal fct '>) 'list-max 'list-min)) + (fct2 (if (equal fct '>) '< '>)) + (testcol (nth numcol liste)) val res) + + (if (>= nbval (length (first liste))) (setq res liste) + (progn + (for (k 1 1 nbval) + (setq val (funcall fct testcol)) + (setq testcol (remove val testcol))) + (setq res (multi-fil fct2 val liste numcol)))) + + (setq nbval (length (first res))) + (print (format nil "valeur limite = ~D - nb ŽlŽments retenus = ~D ~%" val nbval )) + res)) + + + +;-------------------------- traite-listes ------------------------------ + + +; densifier et monnayage sont Žgalement dŽfinis dans Esquisse (fichier Freq-Harmony) +; seule diff: le commentaire + +(defun monnayage (list density) + (let* ((interv (/ (- (second list) (car list)) (1+ density))) res) + (for (n 1 1 density) + (push (+ (car list) (* n interv)) res)) + res)) + +(om::defmethod! densifier ((list list) (density integer) (nbdec integer) + &optional (min nil) (max nil)) + :initvals '('(1 5 9 20) 2 2 () () ) + :indoc '("List" "Density factor" "Nb decimals" "Low limit" "High limit") + :icon 137 + :doc "ajoute valeurs entre chaque ŽlŽment de la liste compris +entre min et max (optionnel). Les valeurs crŽŽes divisent les intervalles +de la liste en intervalles Žgaux. Attention: ce module n'ordonne +ni la liste d'entrŽe, ni la liste rendue +Extensions: min et max: l'opŽration n'aura lieu que pour tout +intervalle dont les valeurs seront comprises entre min et max" + (setq min (if min min (list-min list))) + (setq max (if max max (list-max list))) + (let ((long (1- (length list))) res) + (dotimes (n long) + (push (car list) res) + (if (and (>= (min (car list) (second list)) min) + (<= (max (car list) (second list)) max) + (> density 0)) + (push (monnayage list density) res)) + (setq list (cdr list))) + (om-round (nreverse (flat (push (last-elem list) res))) nbdec ))) + + + +(om::defmethod! l-assoc ((format symbol) + (list1 list) (list2 list) + &rest lst?) + + :initvals '('flat '(1 2) '(1 2) nil) + :indoc '("format" "list1" "list2" "add list") + :icon 137 + :menuins '((0 (("flat" 'flat) ("struct" 'struct) ("flat-low" 'flat-low)))) + :doc "couple les listes : (1 2 3) (10 11 12) --> (1 10 2 11 3 12)" + + + (let* ((listgen (append (list list1 list2) lst?)) + (long (1- (l-max (mapcar #'length listgen)))) res) + (for (i 0 1 long) + (push (car-mapcar #'l-nth listgen i) res)) + (cond ((eq format 'flat) (flat (nreverse res))) + ((eq format 'struct) (nreverse res)) + ((eq format 'flat-low) (flat-low (nreverse res)))))) + + +;===Rename l-assoc as l-associate 27-06-2007=================== + +(om::defmethod! l-associate ((format symbol) + (list1 list) (list2 list) + &rest lst?) + + :initvals '('flat '(1 2) '(1 2) nil) + :indoc '("format" "list1" "list2" "add list") + :icon 137 + :menuins '((0 (("flat" 'flat) ("struct" 'struct) ("flat-low" 'flat-low)))) + :doc "Associates two lists. For example, (1 2 3) and (10 11 12) are associated into (1 10 2 11 3 12)." + + (l-assoc format list1 list2)) + +;============================================================= + +(om::defmethod! create-matrix ((repeat integer) (liste list)) + :initvals '(3 '( 1 2 3 )) + :indoc '("number of repeats" "initial list") + :icon 136 + :doc "Duplicates items in a list . If repeat = 3 and liste = '( 1 2 3 ), +returns ((1 1 1) (2 2 2) (3 3 3)). Repeat can be a list of equal length than liste" + (let ((res)) + (dolist (l liste) + (push (create-list repeat l) res)) + (nreverse res))) + + +(om::defmethod! create-matrix ((repeat list) (liste list)) + + (loop for l in liste + for n in repeat + collect (create-list n l))) + + + + +; gardŽ pour anciens patches + +(defun l-couple (list1 list2) +"couple les listes : (1 2 3) (10 11 12) --> (1 10 2 11 3 12)" + (flat (mapcar #'x-append list1 list2))) + + + +(om::defmethod! inverseur ((liste list)) + :initvals '('(1 2) ) + :indoc '( "liste" ) + :icon 136 + :doc "renverse les valeurs, en gardant min et max" + + (om-scale liste (list-max liste) (list-min liste))) + + + +;====Rename inverseur as inverting 27-06-2007========= + +(om::defmethod! inverting ((liste list)) + :initvals '('(1 2) ) + :indoc '( "liste" ) + :icon 136 + :doc "Returns the inverted list while maintaining minimum and maximum values." + + (inverseur liste)) + +;===================================================== + + + + +(defun simplifie-rec (liste a-retirer nbmin vallim nbenleve fct) + (let* ((nbelem (length liste)) + (elemvise (if (eq fct '<) (list-min liste) (list-max liste))) + (position (position elemvise liste))) + (cond + ((and (funcall fct elemvise vallim) (> nbelem nbmin) (< nbenleve a-retirer)) + (simplifie-rec (supprimelem liste position) a-retirer nbmin vallim (1+ nbenleve) fct)) + (t liste)))) + +(defun simplifie-1 (liste pcent% nbmin vallim fct) + (let ((a-retirer (round (/ (* (length liste) pcent%) 100)))) + (simplifie-rec liste a-retirer nbmin vallim 0 fct))) + + +(om::defmethod! simpli-liste ((liste list ) + (pcent% number) (nbmin integer) + (vallim integer) + (fct symbol)) + + + + :initvals '( '(1 2) 50 10 20 '<) + :indoc '("liste" "pcent%" "nbmin" "vallim" "fct") + :icon 136 + :menuins '((0 ((">" '>)("<" '<) ))) + :doc "retire d'une liste un % d' ŽlŽments en partant des plus petits ou des +plus grands (selon la fct choisie) +On limite cependant la procŽdure avec nbmin = nb d'ŽlŽments qui doit rester +au minimum et vallim = valeur limite en-dessus ou en dessous de quoi +on agit" + + (less-deep-mapcar #'simplifie-1 liste pcent% nbmin vallim fct)) + + +;===Rename simpli-liste as l-simplify 27-06-2007================== + +(om::defmethod! l-simplify ((liste list ) (pcent% number) (nbmin integer) (vallim integer) (fct symbol)) + + :initvals '( '(1 2) 50 10 20 '<) + :indoc '("list" "pcentage" "nbmin" "vallim" "function") + :icon 136 + :menuins '((0 ((">" '>)("<" '<) ))) + :doc "Removes from a list a certain percentage of the elements. Depending on the option chosen, either the smallest or the biggest values are removed from the list. With the minimum number of remaining elements can be chosen." + + (simpli-liste liste pcent% nbmin vallim fct)) + +;=================================================================== + + + + +(om::defmethod! compl-list ((liste list) (long integer)) + :initvals '('((1 5 9 20) (4 3 2 1)) 1) + :icon 136 + :indoc '("liste" "length") + :doc " complŽte la liste pour obtenir la longueur voulue en rŽpŽtant le dernier ŽlŽment +Marche aussi si est un atome" + + + (let* ((liste (list! liste)) + (lgliste (length liste))) + (x-append liste (repeat-n (last-elem liste) (- long lgliste))))) + + +;====Rename compl-list as l-complete 27-06-2007======================== + +(om::defmethod! l-complete ((liste list) (long integer)) + :initvals '('((1 5 9 20) (4 3 2 1)) 1) + :icon 136 + :indoc '("liste" "length") + :doc "Returns a list completed to a desired length. This length is obtained by repetition of the last element. Also works for atoms at the input of ." + + (compl-list list long)) + +;===================================================================== + + + +(defun posmax (llist col) + (let ((nl (nth col llist))) + (position (list-max nl) nl))) + +(defun sort-table-rec (table col long res) + (cond ((null (car table) ) res) + (t (for (i 0 1 long) + (push (nth (posmax table col) (nth i table)) (nth i res))) + (sort-table-rec (ll-suppress table (posmax table col)) col long res)))) + +(om::defmethod! sort-table ((table list) (col integer)) + :initvals '('((1 5 9 20) (4 3 2 1)) 1) + :icon 136 + :indoc '("table" "col") + :doc "trie en ordre croissant selon la colonne indiquŽe" + (let* ((long (length table)) + (res (create-list long '()))) + (sort-table-rec table col (1- long) res))) + + + + +;============================ combinatoire ============================ + + + +(om::defmethod! escalier ((liste list) (pas integer)) + :initvals '('(1 2 3 4 5 6) 2) + :indoc '("List" "Step") + :icon 136 + :doc "permute en escalier : si pas = 2 ,(1 2 3 4 5 6) devient (1 3 2 4 3 5 4 6)" + (let ((res)) + (dotimes (i (- (length liste) pas)) + (push (nth i liste) res) + (push (nth (+ i pas) liste) res)) + (nreverse res))) + +;===Rename escalier as stairs 26-06-2007=================== + +(om::defmethod! stairs ((liste list) (step integer)) + :initvals '('(1 2 3 4 5 6) 2) + :indoc '("List" "Step") + :icon 136 + :doc "Returns a permutation according to a stairs model. For example, with a stepsize equal to 2, the list (1 2 3 4 5 6) will become (1 3 2 4 3 5 4 6)." + + (escalier liste step)) + +;========================================================== + +(om::defmethod! scie ((liste list) (aller integer) (retour integer) (pas integer)) + :initvals '('(1 2 3 4 5 6 7) 4 2 1) + :indoc '("List" "Aller" "Retour" "Step") + :icon 136 + :doc "permute en ''dents de scie'' : si aller = 4, retour = 2 , pas = 1: +(1 2 3 4 5 6 7) devient (1 2 3 4 5 4 3 2 3 4 5 6 5 4 3 4 5 6 7 6 5)" + + (let ((res)) + (for (i 0 pas (- (length liste) 1 aller)) + (for (n i 1 (+ i aller)) + (push (nth n liste) res)) + (for (n (1- (+ i aller)) -1 (- (+ i aller) retour)) + (push (nth n liste) res))) + (nreverse res))) + +;===Rename scie as sawtooth 26-06-2007==================== + +(om::defmethod! sawtooth ((liste list) (go integer) (return integer) (step integer)) + :initvals '('(1 2 3 4 5 6 7) 4 2 1) + :indoc '("List" "Aller" "Retour" "Step") + :icon 136 + :doc "Returns a permutation according to a sawtooth model. For example, when =4, =2 and =1, the list (1 2 3 4 5 6 7) will become (1 2 3 4 5 4 3 2 3 4 5 6 5 4 3 4 5 6 7 6 5)." + + (scie liste go return step)) + + +;========================================================== + +(om::defmethod! aller-retour ((liste list) (modulo integer)) + :initvals '('(1 2 3 4 5 6) 2 ) + :indoc '("List" "modulo") + :icon 136 + :doc "(1 2 3 4 5 6) devient (1 3 5 6 4 2) avec modulo=2" + (let* ((listmodulo (list-modulo liste modulo)) (res (first listmodulo))) + (for (i 1 1 (1- modulo)) + (setf res (x-append res + (if (= 0 (mod i 2)) (nth i listmodulo) + (reverse (nth i listmodulo)))))) + res)) + +;===Rename aller-retour as go-return 26-06-2007==================== + +(om::defmethod! go-return ((liste list) (modulo integer)) + :initvals '('(1 2 3 4 5 6) 2 ) + :indoc '("List" "modulo") + :icon 136 + :doc "Returns a permutation going forth and back through a list. When modulo is set to 2, the list (1 2 3 4 5 6) will become (1 3 5 6 4 2)." + + (aller-retour liste modulo)) + +;================================================================== + + +(defun spire-rec (liste res) + (push (car liste) res) + (push (last-elem liste) res) + (setq liste (cdr (butlast liste))) + (if (null liste) res (spire-rec liste res))) + + +(om::defmethod! spirale ((liste list) (sens symbol ) ) + :initvals '('(1 2 3 4 5 6) 'cfug ) + :indoc '("List" "Direction") + :menuins '((1 (("Centripetal" 'cpet) ("Centrifugal" 'cfug) ))) + :icon 136 + :doc " (1 2 3 4 5 6) devient : centripète -> (1 6 2 5 3 4) +centrifuge -> 4 3 5 2 6 1" + + (let ((res () )) + (if (equal sens 'cpet) (nreverse (spire-rec liste res)) (spire-rec liste res)))) + + +;================================================================= + + +(om::defmethod! anaclase ((liste list) (pas integer)) + :initvals '('(1 2 3 4 5 6) 2 ) + :indoc '("List" "Step") + :icon 136 + :doc +"permutations de proximitŽ : si pas = 2 ,(1 2 3 4 5 6) devient (1 3 2 5 4 6), +si pas = 3 ,(1 2 3 4 5 6 7) devient (1 4 2 3 7 5 6) etc..." + (let ((res (list (first liste)))) + (for (i 1 pas (1- (length liste) )) + (push (nth (+ i (1- pas)) liste) res) + (for (n i 1 (+ i (- pas 2))) + (push (nth n liste) res))) + (nreverse (remove nil res)))) + +;===Rename anaclase as anaclasis 26-06-2007===================== + +(om::defmethod! anaclasis ((liste list) (step integer)) + :initvals '('(1 2 3 4 5 6) 2 ) + :indoc '("List" "Step") + :icon 136 + :doc "Permutations of proximity. For example, if the =2 the list (1 2 3 4 5 6) will become (1 3 2 5 4 6). When =3 the list (1 2 3 4 5 6) will become (1 4 2 3 7 5 6)." + (anaclase list step)) + +;=============================================================== + +(om::defmethod! combinaisons ((liste list)) + :initvals '('(1 2 3 4 5 6) ) + :indoc '("List" ) + :icon 136 + :doc "combinaisons 2 ˆ 2 des ŽlŽments d'une liste, sans rŽpŽtition" + (let ((ll (butlast liste)) (lm (cdr liste)) res) + (while lm + (dolist (l ll) + (dolist (m lm) + (push (list l m) res)) + (pop lm))) + (reverse res))) + +;====Rename combinaisions as combining 26-06-2007============ + +(om::defmethod! combining ((liste list)) + :initvals '('(1 2 3 4 5 6) ) + :indoc '("List" ) + :icon 136 + :doc "Combines all elements of a list into pairs without repetitions." + + (combinaisons liste)) + +;============================================================== + +(om::defmethod! unique% ((liste list) (pourcent number)) + :initvals '('(1 2) 0) + :indoc '("List" "pourcent") + :icon 136 + :doc "retire certaines valeurs en double, selon un taux de hasard " + + (let ((res) ) + (dotimes (i (length liste)) + (if (not (and (< (random 100) pourcent) (member (nth i liste) res))) + (push (nth i liste) res))) + (nreverse res))) + +;====Rename unique% as remove-dup% 26-06-2007================== + +(om::defmethod! remove-dup% ((liste list) (percentage number)) + :initvals '('(1 2) 0) + :indoc '("List" "percentage") + :icon 136 + :doc "Removes duplicates from a according to a specified probability ." + + (unique% liste percentage)) + +;============================================================== + +(defun sedim-1 (liste test val fonct) + (let ((res (copy-list (groupe-tete liste test val fonct)))) + (for ( i (1- (length res)) -1 1) + (if (funcall test (nth i res) val) + (progn (setf (nth (1- i) res) (funcall fonct (nth (1- i) res) (nth i res)) ) + (setf (nth i res) nil)) ) ) + (remove nil res))) + +(defun attire-1 (liste test val fonct) + (let ((res (copy-list (groupe-tete liste test val fonct)))) + (do (( i 1 (1+ i))) ((null (nth i res))) + (if (funcall test (nth i res) val) + (progn (setf (nth (1- i) res) (funcall fonct (nth (1- i) res) (nth i res)) ) + (setq res (l-suppress res i )) + (setq i (1- i)) )) ) + res)) + +(defun groupe-tete (liste test val fonct) + (if (funcall test (car liste) val) + (groupe-tete + (setq liste (cons (funcall fonct (second liste) (car liste)) (cddr liste))) + test val fonct) + liste)) + +(om::defmethod! grouper ((test symbol) (val number) (liste list) + (fonct symbol) (format integer)) + :initvals '("<" 0 '(1 2) "+" 1) + :indoc '("test" "val" "liste" "fonct" "format") + :icon 136 + :doc " regroupe valeurs: si ( n+1 ) est vrai alors on fait n = ( n n+1 ) +Ceci ˆ l'intŽrieur de chaque sous-liste. +Format=1 : lit la liste ˆ l'endroit: les petites valeurs sont ''aspirŽes'' +par la grande valeur la plus ˆ gauche +Format=0 : lit la liste ˆ l'envers: les petites valeurs peuvent se regrouper jusqu'ˆ former +une valeur longue" + + (if (= format 1) (less-deep-mapcar 'attire-1 liste test val fonct) + (less-deep-mapcar 'sedim-1 liste test val fonct))) + + +;====Rename grouper as grouping 26-06-2007=========================== + +(om::defmethod! grouping ((test symbol)(val number)(liste list)(fonct symbol)(format integer)) + :initvals '("<" 0 '(1 2) "+" 1) + :indoc '("test" "val" "liste" "fonct" "format") + :icon 136 + :doc "Regroups values inside a list following a predicate. When ( n+1 ) is true, then values are regrouped according to n = ( n n+1) inside every sublist. +In case =1, the list is read forward: the small values are absorbed by the bigger value at their left. +In case =0, the list is read backwards: the small values are regrouped (added to each other) to form one longer value." + + (grouper test val liste fonct format)) + +;===================================================================== + +(defun perrec (liste) + (if (equal (car liste) (last-elem liste)) liste + (append liste (list (l-nth (last-elem liste) (om- (last-elem liste) 1)))))) + +(om::defmethod! permut-rec ((liste list)) + :initvals '('(5 3 4 1 2)) + :indoc '("List") + :icon 136 + :doc "Recursive permutation (Messiaen): The list is read in the order given by its elements until the initial list is obtained (the list can only contain integers 1, 2, 3,...n)." + + ( perrec (list liste (l-nth liste (om- liste 1))))) + + +(om::defmethod! permut-circ ((list list) (nth integer)) + :icon 136 + :doc "Returns a circular permutation of starting from its element (=0 means the 1st element of the list). + + may be a list. If this is the case, the operation will lead to a list of permutations." + + (permut-circn/tm (copy-list list) nth)) + + +(om::defmethod! permut-circ ((list list) (nth list)) + (loop for n in nth + collect (permut-circ list n))) + + + +(defun permut-circn/tm (list nth ) + "Returns a destructive circular permutation of starting from its (which +defaults to 1) element, (n=0 means the \"car\", n=1 means the \"cadr\")." + (when list + (let ((length (length list)) n-1thcdr) + (setq nth (mod nth length)) + (if (zerop nth) list + (prog1 + (cdr (nconc (setq n-1thcdr (nthcdr (1- nth) list)) list)) + (rplacd n-1thcdr ())))))) + + + + + + + + + + +(defun tm-proche (liste item) + "recherche l'ŽlŽment de le plus proche de " + + (let ((listdif (om-abs (om- liste item)))) + (l-nth liste (position (list-min listdif) listdif) ))) + +(defun vocod1 (struct reservoir mode ) + + (let* ((struct (if (equal mode 'freq) (mc->f struct) struct)) + (reservoir (if (equal mode 'freq) (mc->f reservoir) reservoir)) + (res)) + (dolist (a struct) + + (push (tm-proche reservoir a) res)) + (nreverse (if (equal mode 'freq) (f->mc res) res)))) + +(om::defmethod! vocoder ((struct list) (reservoir list) + &optional (mode 'midic)) + + :initvals '('(1 2) '(1 2) 'midic) + :menuins '((2 (("Midics" 'midic) ("Freqs" 'freqs)))) + :indoc '("struct" "reservoir" "mode") + :icon 137 + :doc + "Applies the structure of a list to a reservoir . It chooses those values from the reservoir which match the values in the structure most closely. may be a list of lists. is one single reservoir. For instance, may be a list of midicents, may be a another list of midicents which acts as a harmonic field, to which the is applied." + + (let ((struct (if (atom (car struct)) (list struct) struct))) + (car-mapcar 'vocod1 struct reservoir mode))) + + + + + + + + +(defun max-abs-idt (ch1 ch2) + "Uses as intervalic distance the maximum of the absolute intervals (in cents) +between the corresponding notes of the two chords and . +Returns the minimum intervalic distance between and the best transposition +of and returns this transposition as second value." + (let* ((ints (mapcar #'- ch1 ch2)) + (int-min (apply #'min ints)) + (int-max (apply #'max ints))) + (values (/ (- int-max int-min) 2) (/ (+ int-max int-min) 2)))) + + +(defun ma-min-interv (ch1 ch2) + "Uses as intervalic distance the maximum of the absolute intervals (in cents) +between the corresponding notes of the two chords and . +Returns the minimum intervalic distance between and the best transposition +of ." + (multiple-value-bind (dist ch) (max-abs-idt ch1 ch2) + (declare (ignore ch)) + dist)) + + + +(om::defmethod! vocod-transp1 ((struct list) (reservoir list) (pas number) + &optional (mode 'midic)) + :initvals '('(1 2) '(1 2) 50 'midic) + :menuins '((3 (("Midics" 'midic) ("Freqs" 'freqs)))) + :indoc '("struct" "resrvoir" "pas" "mode") + :icon 137 + :doc "comme ''vocoder'', mais cherche dans toute l'Žchelle de ; i.e. +comme si on cherchait la transposition de s'appliquant le mieux" + + (let* ((debut (- (list-max struct) (list-min reservoir))) + (fin (- (list-min struct) (list-max reservoir))) + (pas (if (< fin debut) (* pas -1) pas)) + listacc listdif) + (for (transp debut pas fin) + (let ((accres (vocoder (om- struct transp) reservoir mode)) ) + (push accres listacc) + (push (ma-min-interv accres (om- struct transp)) listdif))) + (l-nth listacc (position (list-min listdif) listdif) ))) + +(om::defmethod! vocod-transp ((struct list) (reservoir list) (step number) + &optional (mode 'midic)) + + :initvals '('(1 2) '(1 2) 50 'midic) + :menuins '((3 (("Midics" 'midic) ("Freqs" 'freqs)))) + :indoc '("struct" "reservoir" "step" "mode") + :icon 137 + :doc + "Applies the structure of a chord or its transpositon to a harmonic field or reservoir . It chooses those values from the harmonic reservoir which match the structure of the chord or one of its transpositions most closely. may be a list of chords. can only be one harmonic field, i.e. one chord." + + + (let ((struct (if (atom (car struct)) (list struct) struct))) + (car-mapcar 'vocod-transp1 struct reservoir step mode))) + + +(om::defmethod! diff-sim ((fonda t) (nth list) + (disto list) (orig list) + (approx integer ) (compa symbol)) + + :initvals '('(1 2) '(1 2) '(1 2) '(6000) 8 'diff) + :menuins '((5 (("diff" 'diff) ("sim"'sim)))) + :indoc '("fonda" "nth" "disto" "orig" "approx" "compa") + :icon 136 + :doc "cherche un spectre fabriquŽ par 'n-sp-gen' qui soit +le plus semblable ou le plus diffŽrent de l'accord donnŽ +dans . Test effectuŽ par 'common-notes' +arguments : +fonda = fondamentale donnŽe ou liste de fondas +disto = distorsion donnŽe ou liste de distos +approx = approx choisie pour la comparaison +compa : choisir 'diff' ou 'sim'" + + (let* ((orig (chord->list! orig)) + (fonda (list! fonda)) (disto (list! disto)) (longd (length disto)) + notescom posi valm ftrouve dtrouve ) + (dolist (f fonda) + (dolist (d disto) + (push (length (common-notes (nth-polysp f nth d) approx orig)) notescom))) + (setq notescom (nreverse notescom)) + (setq valm (if (equal compa 'sim) (list-max notescom ) (list-min notescom))) + (format t "nb max ou min d'ŽlŽments communs: ~S ~%" valm) + (setq posi (positions notescom valm)) + (setq ftrouve (posn-match fonda (first (multiple-value-list (om// posi longd))))) + (setq dtrouve (posn-match disto (second (multiple-value-list (om// posi longd))))) + (cond ((one-elem fonda) (format t "liste des distorsions: ~%") (om-round dtrouve 2)) + ((one-elem disto) (format t "liste des fondamentales: ~%") ftrouve) + (t (format t "couples fondamentales/distorsions: ~%") + (list-explode (l-couple ftrouve (om-round dtrouve 2)) (length ftrouve)))) + )) + +;====Rename diff-sim as match-n-sp 25-06-2007=================== + +(om::defmethod! match-n-sp ((fonda t) (nth list) (disto list) (orig list) (approx integer ) (compa symbol)) + + :initvals '('(1 2) '(1 2) '(1 2) '(6000) 8 'diff) + :menuins '((5 (("diff" 'diff) ("sim" 'sim)))) + :indoc '("fundamental" "nth" "distortion" "original" "approximation" "comparison") + :icon 136 + :doc "Looks for a spectrum made by Ôn-sp-genÕ that either resembles the chord most closely or differs from it most. Effectively tests with Ôcommon-notesÕ. +Arguments: + = given fundamental or list of fundamentals + = given distortion or list of distortions + = the desired approximation (to 1/2 tone, 1/4 tone or 1/8th tone) before the common-note comparison is applied + = mode of comparison, either resulting in the most similar chord through or the most different ." + + (diff-sim fonda nth disto orig approx compa)) + +;============================================================== + + +(om::defmethod! diff-sim-scaling ((minout t) + (accord t) + (maxout t) + (orig t) + (approx integer) + (compa symbol )) + + + :initvals '('(1 2) '(6000) '(1 2) '(6000) 8 'diff) + :menuins '((5 (("diff" 'diff) ("sim" 'sim)))) + :indoc '("minout" "accord" "maxout" "orig" "approx" "compa") + :icon 136 + :doc "cherche une distorsion d'un accord qui soit +la plus semblable ou la plus diffŽrente de l'accord donnŽ +dans . Test effectuŽ par 'common-notes' +arguments : +minout, maxout = listes de valeurs ˆ tester (l'un des 2 peut tre un atom) +approx = approx choisie pour la comparaison +compa : choisir 'diff' ou 'sim'" + + + (let* ((orig (chord->list! orig)) + (accord (chord->list! orig)) + (minout (list! minout)) (maxout (list! maxout)) (longd (length maxout)) + notescom posi valm mintrouve maxtrouve ) + (dolist (mn minout) + (dolist (mx maxout) + (push (length (common-notes (om-scale accord mn mx) approx orig)) notescom))) + (setq notescom (nreverse notescom)) + (setq valm (if (equal compa 'sim) (list-max notescom ) (list-min notescom))) + (format t "nb max ou min d'ŽlŽments communs: ~S ~%" valm) + (setq posi (positions notescom valm)) + (setq mintrouve (posn-match minout (first (multiple-value-list (om// posi longd))))) + (setq maxtrouve (posn-match maxout (second (multiple-value-list (om// posi longd))))) + (cond ((one-elem maxout) (format t "liste des minout: ~%") mintrouve) + ((one-elem minout) (format t "liste des maxout: ~%") maxtrouve) + (t (format t "couples minout/maxout: ~%") + (list-explode (l-couple mintrouve maxtrouve) (length mintrouve)))) + )) + + +;====Rename diff-sim-scaling as match-disto 25-06-2007============= + +(om::defmethod! match-dist ((minout t) (accord t) (maxout t) (orig t) (approx integer) (compa symbol)) + :initvals '('(1 2) '(6000) '(1 2) '(6000) 8 'diff) + :menuins '((5 (("diff" 'diff) ("sim" 'sim)))) + :indoc '("minout" "chord" "maxout" "original" "approximation" "comparison") + :icon 136 + :doc "Looks for the matching distortion of a chord (through scaling) that resembles the input chord most closely or differs from it most. Effectively tests with Ôcommon-notesÕ. +Arguments: + = lists of values defining the scaling processes that are tested (one of them may be an atom) + = the desired approximation (to 1/2 tone, 1/4 tone or 1/8th tone) before the common-note comparison is applied + = mode of comparison, either resulting in the most similar chord through or the most different ." + + (diff-sim-scaling minout accord maxout orig approx compa)) + +;============================================================== + +(om::defmethod! diff-sim-transpo ((transpo t) + (accord t) + (approx integer) + (orig t) + (compa symbol)) + + :initvals '('(1 2) '(6000) 8 '(6000) 'diff) + :menuins '((4 (("diff" 'diff) ("sim" 'sim)))) + :indoc '("transpo" "accord" "approx" "orig" "compa") + :icon 136 + :doc "Looks for a transposition of one chord that resembles another chord most closely or differs from it most. Effectively tests with Ôcommon-notesÕ. +Arguments: + = transposition value that is tested (atom or list) + = the desired approximation (to 1/2 tone, 1/4 tone or 1/8th tone) before the common-note comparison is applied + = mode of comparison, either resulting in the most similar chord through or the most different ." + + + (let* ((orig (chord->list! orig)) (accord (chord->list! accord)) + (transpo (list! transpo)) + notescom posi valm ttrouve ) + + (dolist (mn transpo) + (push (length (common-notes (om+ accord mn ) approx orig)) notescom)) + + (setq notescom (nreverse notescom)) + (print notescom) + (setq valm (if (equal compa 'sim) (list-max notescom ) (list-min notescom))) + (format t "nb max ou min d'ŽlŽments communs: ~S ~%" valm) + (setq posi (positions notescom valm)) + (setq ttrouve (posn-match transpo posi )) + + (format t "liste des transpo: ~%") ttrouve)) + + +;====Rename diff-sim-transpo as match-trans 25-06-2007========== + +(om::defmethod! match-trans ((transpo t) (accord t) (approx integer) (orig t) (compa symbol)) + :initvals '('(1 2) '(6000) 8 '(6000) 'diff) + :menuins '((4 (("diff" 'diff) ("sim" 'sim)))) + :indoc '("transposition" "chord" "approximation" "original" "comparison") + :icon 136 + :doc "Looks for a transposition of one chord that resembles another chord most closely or differs from it most. Effectively tests with Ôcommon-notesÕ. +Arguments: + = transposition value that is tested (atom or list) + = the desired approximation (to 1/2 tone, 1/4 tone or 1/8th tone) before the common-note comparison is applied + = mode of comparison, either resulting in the most similar chord through or the most different ." + + (diff-sim-transpo transpo accord approx orig compa)) + +;================================================================= + + + +; ================= SŽries numŽriques ====================== + + + +(om::defmethod! arithm-crible ((begin integer) (end integer) + (numer integer) (denom integer)) + + + :initvals '(1 1 1 2 ) + :indoc '("begin" "end" "numer" "denom") + :icon 136 + :doc "sŽrie arithmŽtique (entiers) avec crible numer/denom" + + (let ((cdeb (mod begin denom)) (pas (if (< end begin) -1 1)) res) + (for (n begin pas end) + (if (not (>= (mod (- n cdeb) denom) numer)) (push n res)) ) + (nreverse res))) + + + + + +(om::defmethod! n-arithm ((deb number) (fin number) (nbval integer) + &optional (format 'inclus)) + + :initvals '(0 10 5 'inclus) + :indoc '("deb" "fin" "nbval" "bornes inclues ou exclues") + :menuins '((3 (("inclus" 'inclus) ("exclus" 'exclus)))) + :icon 137 + :doc "sŽrie arithmŽtique : ŽlŽments depuis deb jusqu'a fin" + + (let ((step (om/ (om- fin deb) (1- nbval )))) + (cond ((= nbval 1) fin) + ((= deb fin) (create-list nbval deb)) + ((eq format 'exclus) (butlast (cdr (arithm-ser deb fin step )))) + (t (arithm-ser deb fin step ))))) + + + +(om::defmethod! x-arithm ((deb number) (step number) (nbval integer) ) + + :initvals '(0 .1 5 ) + :indoc '("deb" "pas" "nbval") + :menuins '((3 (("inclus" 'inclus) ("exclus" 'exclus)))) + :icon 136 + :doc "sŽrie arithmŽtique : ŽlŽments en cumulant depuis deb " + (dx->x deb (create-list (1- nbval) step))) + +(om::defmethod! x-arithm ((deb number) (step list) (nbval list) ) + (loop for s in step + for n in nbval + collect (x-arithm deb s n))) + +(om::defmethod! x-arithm ((deb list) (step list) (nbval list) ) + (loop for d in deb + for s in step + for n in nbval + collect (x-arithm d s n))) + + +(defun fib-recur (liste end) + (if (<= (last-elem liste) end) + (fib-recur (x-append liste (+ (last-elem liste) (last-elem (butlast liste)))) end) + (butlast liste))) + +(defun fib-nb (liste nbval) + (if (<= (length liste) nbval) + (fib-nb (x-append liste (+ (last-elem liste) (last-elem (butlast liste)))) nbval) + (butlast liste))) + +(om::defmethod! fibonacci ((seed1 number) (seed2 number) + (end number) &optional (nbval 1)) + :initvals '(1 2 10 1 ) + :indoc '("seed1" "seed2" "end" "nbval") + :icon 137 + :doc "sŽrie de Fibonacci, calculŽe ˆ partir de 2 valeurs initiales, jusqu'ˆ atteindre + +Argument optionnel: nb de valeurs ˆ calculer;si nbval>1, prend le pas sur " + + (if (> nbval 1) (fib-nb (list seed1 seed2) nbval) (fib-recur (list seed1 seed2) end))) + + + +(defun geom-recur (liste end facteur) + (if (<= (last-elem liste) end) + (geom-recur (x-append liste (* (last-elem liste) facteur)) end facteur) + (butlast liste))) + +(defun geom-nb (liste facteur nbval) + (if (<= (length liste) nbval) + (geom-nb (x-append liste (* (last-elem liste) facteur)) facteur nbval) + (butlast liste))) + +(om::defmethod! geom-ser ((begin number) (end number) + (facteur number) &optional (nbval 1)) + :initvals '(1 10 2 1 ) + :indoc '("begin" "end" "facteur" "nbval") + :icon 137 + :doc "sŽrie gŽomŽtrique, calculŽe ˆ partir de valeur initiale, et , +jusqu'ˆ atteindre +Argument optionnel: nb de valeurs ˆ calculer;si nbval>1, prend le pas sur " +(if (> nbval 1) (geom-nb (list begin) facteur nbval) (geom-recur (list begin) end facteur))) + + + +(om::defmethod! power-ser ((x0 number) (y0 number) (x1 number) (y1 number) (x2 number) (y2 number) + (nbval integer)) + :initvals '(0.1 0.1 0.1 0.1 0.1 0.1 1 ) + :indoc '("x0" "y0" "x1" "y1" "x2" "y2" "nbval") + :icon 136 + :doc "sŽrie puissance on donne trois points : dŽbut, intermŽdiaire , fin +La fonction rend valeurs entre dŽbut et fin selon fct puissance" +(power/3 (n-arithm x0 x2 nbval ) x0 y0 x1 y1 x2 y2 )) + + + + + +(om::defmethod! puiss/to9-ser ((x0 number) (y0 number) + (x1 number) (y1 number) + (x2 number) (y2 number) + (nbval number)) + :initvals '(1 1 2 3 4 5 6) + :indoc '( "x0" "y0" "x1" "y1" "x2" "y2" "nbval") + :icon 136 + :doc "sŽrie puissance on donne trois points : dŽbut, intermŽdiaire , fin +La fonction rend valeurs entre dŽbut et fin selon fct puissance +Algorithme TO9 (marche mieux pour fct dŽcroissante)" + +(puiss/to9 (n-arithm x0 x2 nbval) x0 y0 x1 y1 x2 y2 )) + + + + +; Had to change the name because name of slot in OM +(om::defmethod! triangle-ser ((x0 integer ) (y0 integer ) + (x1 integer ) (y1 integer ) + (x2 integer ) (y2 integer)) + :initvals '(0 0 50 127 100 0 ) + :indoc '("x0" "y0" "x1" "y1" "x2" "y2") + :icon 136 + :doc "sŽrie numŽrique consistant en deux segments de droite" + + (let ((l1 (n-arithm y0 y1 (1+ (- x1 x0) ))) + (l2 (n-arithm y1 y2 (1+ (- x2 x1) )))) + (if (one-elem l2) l1 (x-append l1 (rest l2))))) + + + +; fct prŽsente dans PW (Num-series) + +(om::defmethod! sinus-ser ((phase number) (nb-osc number) + (nb-samples number) (amp t)) + :initvals '(0 1 8 1 ) + :indoc '("phase" "nb-osc" "nb-samples" "amp") + :icon 136 + :doc "parameters: phase = where we start on the sine curve (xmin) +nb-osc = number of oscillations needed (-> determines xmax) +nb-samples = how many steps on the fragment of curve thus defined +amplitude (ambitus normal -1 / 1)" + + +(let* ((xmin (* phase (/ pi 180))) (xmax (+ xmin (* 2 pi nb-osc))) + (step (/ (- xmax xmin) (1- nb-samples)))) + (om* amp (samplefun 'sin step xmin xmax)))) + + + + + +; =================== fonctions ====================================== + + + (om::defmethod! sample-fun ((fun function) (xmin number) + (xmax number) (step number)) + :initvals '('+ 1 10 1 ) + :icon 136 + :doc "Returns the list of values of from to with . +For example: +(pw::sample-fun 'sin 0 1 6.3) +will return +? PW->(0.0 0.8414709848078965 0.9092974268256817 0.1411200080598672 +-0.7568024953079282 -0.9589242746631385 -0.27941549819892586) +and +(pw::sample-fun (pw::make-num-fun '(f(x)= x + 1)) 0 1 10) +will return +? OM->(1 2 3 4 5 6 7 8 9 10 11) +" + (mapcar fun (arithm-ser xmin xmax step ))) + + + +(om::defmethod! bpf-transfer ((bpf bpf) (xval number ) &optional (nbdec nil)) + :initvals (list (make-instance 'bpf) 10 nil) + :indoc '("BPF" "x" ) + :icon 136 + :doc "rend la valeur y correspondant ˆ un x donnŽ. Accepte liste ou liste de listes de xs " + + +(let* ((x1 (list-max (filtre-liste '> xval (x-points bpf)))) + (x2 (list-min (filtre-liste '< xval (x-points bpf)))) + + (res (if (= x1 x2) (l-nth (y-points bpf) (position x1 (x-points bpf))) + (funcall (linear-fun x1 (l-nth (y-points bpf) (position x1 (x-points bpf))) + x2 (l-nth (y-points bpf) (position x2 (x-points bpf)))) + xval )))) + (if (null nbdec) (float res) (om-round res nbdec)))) + + + +(defun transfer/map (xval bpf nbdec) ; seulement pour que la liste xval soit le 1er argument pour le deep-mapcar + (bpf-transfer bpf xval nbdec)) + +(om::defmethod! bpf-transfer ((bpf bpf) (xval list ) &optional (nbdec nil)) + (deep-mapcar/1 'transfer/map xval bpf nbdec)) + + + + + +; (linear parabole/2 parabole/3 power/2 power/3 ) +; sont dŽfinis dans PW : Num-fun-Gen +; puiss/TO9 est dŽfinie dans Esquisse : Freq-Harmony + +;linear included in OM in Functions.lisp + + +;a utiliser comme lambda function +; par rapport ˆ l'originale: +; le premier argument est nouveau c'est l'x propose (sauf pour Lagrange) +; le dernier argument de l'ancienne fonction n'existe plus + + + + +(om::defmethod! tm-oper ((fun symbol) (obj1? list ) &optional (obj2? nil )) + :initvals '('+ '(1 2) nil) + :indoc '("Function" "Obj1" "Obj2" ) + :icon 137 + :doc "Applies fun to leaves of trees of obj1? and (optionally) obj2? +(tm-oper '+ 4 5) will +return ? OM->9 , +(tm-oper 'list 4 5) will return ? OM->(4 5) , +(tm-oper '+ '(1 2) '( 3 4)) will return ? OM->(4 6) " + + (if obj2? + (arith-tree-mapcar (if (functionp fun) fun (fdefinition fun)) obj1? obj2?) + (deep-mapcar/1 fun obj1?))) + + +;====Rename tm-oper as tree-oper 27-06-2007=============================== + +(om::defmethod! tree-oper ((fun symbol) (obj1? list ) &optional (obj2? nil )) + :initvals '('+ '(1 2) nil) + :indoc '("Function" "Obj1" "Obj2" ) + :icon 137 + :doc "Applies a given function to the leaves of trees of and (optionally) of . + +Examples: +(tree-oper '+ 4 5) will return ? OM->9 +(tree-oper 'list 4 5) will return ? OM->(4 5) +(tree-oper '+ '(1 2) '( 3 4)) will return ? OM->(4 6)" + + (tm-oper fun obj1? obj2?)) + +;========================================================================= + + + +(om::defmethod! parabole ((x0 number) (y0 number) (x1 number) (y1 number) + &optional (x2 ()) (y2 9.0)) + + :initvals '(1 1 2 4 () 9.0) + :indoc '("X0" "Y0" "X1" "Y1" "X2" "Y2") + :icon 137 + :doc "Calculates the parameters of the equation y = ax^2 + b or y = ax^2 + bx + c +as a function of the points (x0,y0) (x1,y1) and (optional) (x2,y2) +and creates the corresponding function " + (if x2 + (parabole/3 x0 y0 x1 y1 x2 y2 ) + (parabole/2 x0 y0 x1 y1 ))) + + +(om::defmethod! parabole/2 ((x number) (x0 number) (y0 number) + (x1 number) (y1 number)) + :initvals '(1 1 1 2 4 ) + :indoc '("X" "X0" "Y0" "X1" "Y1" ) + :icon 136 + :doc "calcule les paramŽtres de l'Žquation y = ax^2 + b en fct de deux points +(x0,y0) (x1,y1) +x = valeur(s) ˆ calculer" + + (let* ((a (/ (- y1 y0) (- (* x1 x1) (* x0 x0)) )) + (b (- y0 (* a x0 x0)) ) ) + ; (format t "y = ~S x 2 + ~S ~%" (om-round a 6) (om-round b 6)) + (+ (* a x x ) b ))) + +(om::defmethod! parabole/2 ((x list) (x0 number) (y0 number) + (x1 number) (y1 number)) + + (let* ((a (/ (- y1 y0) (- (* x1 x1) (* x0 x0)) )) + (b (- y0 (* a x0 x0)) ) res ) + (format t "y = ~S x 2 + ~S ~%" (om-round a 6) (om-round b 6)) + (dolist (xn x) + (push (+ (* a xn xn ) b ) res)) + (nreverse res))) + +;====Rename parabole/2 as parabole2 in order to avoid / in the name 27-06-2007========== + +(om::defmethod! parabole2 ((x number) (x0 number) (y0 number) (x1 number) (y1 number)) + :initvals '(1 1 1 2 4 ) + :indoc '("X" "X0" "Y0" "X1" "Y1" ) + :icon 136 + :doc "Calculates the parameters of the equation y = ax^2 + b as a function of the points (x0,y0) (x1,y1) and (optional) (x2,y2) and creates the corresponding function." + + (let* ((a (/ (- y1 y0) (- (* x1 x1) (* x0 x0)) )) + (b (- y0 (* a x0 x0)) ) ) + ; (format t "y = ~S x 2 + ~S ~%" (om-round a 6) (om-round b 6)) + (+ (* a x x ) b ))) + +(om::defmethod! parabole2 ((x list) (x0 number) (y0 number) (x1 number) (y1 number)) + + (let* ((a (/ (- y1 y0) (- (* x1 x1) (* x0 x0)) )) + (b (- y0 (* a x0 x0)) ) res ) + (format t "y = ~S x 2 + ~S ~%" (om-round a 6) (om-round b 6)) + (dolist (xn x) + (push (+ (* a xn xn ) b ) res)) + (nreverse res))) + +;========================================================================== + + + +(om::defmethod! parabole/3 ((x number) (x0 number) (y0 number) + (x1 number) (y1 number) + (x2 number) (y2 number)) + :initvals '(1 1 1 2 4 5 6) + :indoc '("X" "X0" "Y0" "X1" "Y1" "X2" "Y2") + :icon 136 + :doc "calcule les paramŽtres de l'Žquation y = ax^2 + bx + c en fct de trois points +(x0,y0) (x1,y1) (x2,y2) +x = valeur(s) ˆ calculer ." + + (let* ((a (/ (+ (* y0 (- x1 x2)) + (* y1 (- x2 x0)) + (* y2 (- x0 x1))) + (+ (* x0 x0 (- x1 x2)) + (* x1 x1 (- x2 x0)) + (* x2 x2 (- x0 x1))))) + (b (/ (+ y1 (- y2) (* a (- (* x2 x2) (* x1 x1)))) + (- x1 x2))) + (c (- y2 (* a x2 x2) (* b x2)))) + ; (format t "y = ~S x 2 + ~S x + ~S ~%" (om-round a 6) (om-round b 6) (om-round c 6)) + (+ (+ (* a x x ) (* b x) c)))) + + +(om::defmethod! parabole/3 ((x list) (x0 number) (y0 number) + (x1 number) (y1 number) + (x2 number) (y2 number)) + + (let* ((a (/ (+ (* y0 (- x1 x2)) + (* y1 (- x2 x0)) + (* y2 (- x0 x1))) + (+ (* x0 x0 (- x1 x2)) + (* x1 x1 (- x2 x0)) + (* x2 x2 (- x0 x1))))) + (b (/ (+ y1 (- y2) (* a (- (* x2 x2) (* x1 x1)))) + (- x1 x2))) + (c (- y2 (* a x2 x2) (* b x2))) + res) + (format t "y = ~S x 2 + ~S x + ~S ~%" (om-round a 6) (om-round b 6) (om-round c 6)) + + (dolist (xn x) + (push (+ (+ (+ (* a xn xn ) (* b xn) c)) b ) res)) + (nreverse res))) + + +;====Rename parabole/3 as parabole3 in order to avoid / in the name 27-06-2007======================= + +(om::defmethod! parabole3 ((x number) (x0 number) (y0 number) (x1 number) (y1 number) (x2 number) (y2 number)) + :initvals '(1 1 1 2 4 5 6) + :indoc '("X" "X0" "Y0" "X1" "Y1" "X2" "Y2") + :icon 136 + :doc "Calculates the parameters of the equation y = ax^2 + bx + c as a function of three points (x0,y0) (x1,y1) and (x2,y2) and creates the corresponding function." + + (let* ((a (/ (+ (* y0 (- x1 x2)) + (* y1 (- x2 x0)) + (* y2 (- x0 x1))) + (+ (* x0 x0 (- x1 x2)) + (* x1 x1 (- x2 x0)) + (* x2 x2 (- x0 x1))))) + (b (/ (+ y1 (- y2) (* a (- (* x2 x2) (* x1 x1)))) + (- x1 x2))) + (c (- y2 (* a x2 x2) (* b x2)))) + ; (format t "y = ~S x 2 + ~S x + ~S ~%" (om-round a 6) (om-round b 6) (om-round c 6)) + (+ (+ (* a x x ) (* b x) c)))) + +(om::defmethod! parabole3 ((x list) (x0 number) (y0 number) (x1 number) (y1 number) (x2 number) (y2 number)) + + (let* ((a (/ (+ (* y0 (- x1 x2)) + (* y1 (- x2 x0)) + (* y2 (- x0 x1))) + (+ (* x0 x0 (- x1 x2)) + (* x1 x1 (- x2 x0)) + (* x2 x2 (- x0 x1))))) + (b (/ (+ y1 (- y2) (* a (- (* x2 x2) (* x1 x1)))) + (- x1 x2))) + (c (- y2 (* a x2 x2) (* b x2))) + res) + (format t "y = ~S x 2 + ~S x + ~S ~%" (om-round a 6) (om-round b 6) (om-round c 6)) + + (dolist (xn x) + (push (+ (+ (+ (* a xn xn ) (* b xn) c)) b ) res)) + (nreverse res))) + +;==================================================================== + + +(om::defmethod! lagrange ((l-x-y list )) + + :initvals '('(1 10 3 25 10 100)) + :indoc '("List of points x y") + :icon 136 + :doc "Returns a Lagrange polynomial defined by the points of list . Connect +to sample-fun to calculate values" + + (let ((length (length l-x-y)) index cp) + (unless (evenp length) + (error "You must give as many ys as xs in ~S." l-x-y)) + (unless (every #'numberp l-x-y) + (error "l-x-y must contain only numbers ~S." l-x-y)) + (let* ((length (/ length 2)) + (vx (make-array length)) + (vy (make-array length)) + (Aitken (make-array length))) + (setq length (1- length) index -1) + (while l-x-y + (incf index) + (setf (aref vx index) (nextl l-x-y)) + (setf (aref Aitken index) (car l-x-y)) + (setf (aref vy index) (nextl l-x-y))) + (for (j 1 1 length) + (setq cp (aref Aitken (1- j))) + (for (i j 1 length) + (psetf (aref Aitken i) (/ (- (aref Aitken i) cp) (- (aref vx i) (aref vx (- i j)))) + cp (aref Aitken i)))) + ;;(compile () + (eval `(function + (lambda (x) + (let* ((length ,length) (vx ',vx) (Aitken ',Aitken) (z (aref Aitken length))) + (for (i (1- length) -1 0) + (setq z (+ (aref Aitken i) (* z (- x (aref vx i)))))) + z))))))) + + + + + +(om::defmethod! linear-fct ((x number) (x0 number) (y0 number) (x1 number ) (y1 number ) ) + :initvals '(1 0 0 1 1) + :indoc '( "x" "x0" "y0" "x1" "y1") + :icon 136 + :doc + "Calculate the parameters of the equation y = a x + b as a function +of the two points (x0,y0) (x1,y1). +x = valeur(s) ˆ calculer " + (let* ((a (/ (- y1 y0) (- x1 x0))) + (b (- y1 (* x1 a)))) + (format t "y = ~S x + ~S ~%" (om-round a 6) (om-round b 6) ) + + (+ b (* x a))) ) + +(om::defmethod! linear-fct ((x list) (x0 number) (y0 number) (x1 number ) (y1 number ) ) + (let* ((a (/ (- y1 y0) (- x1 x0))) + (b (- y1 (* x1 a))) + res) + (format t "y = ~S x + ~S ~%" (om-round a 6) (om-round b 6) ) + (dolist (xn x) + (push (+ b (* x a)) res)) + (nreverse res))) + + +;-------------- puissances -------------------------- + + +(om::defmethod! puiss/TO9 ((x number) (x0 number) + (y0 number)(x1 number) + (y1 number)(x2 number) + (y2 number)) + :initvals '(1 1 2 3 4 5 6) + :indoc '("x" "x0" "y0" "x1" "y1" "x2" "y2") + :icon 136 + :doc "calcule les paramŽtres de l'Žquation y=a (x+c)^b+d en fct de trois points +(x0,y0) (x1,y1) (x2,y2) . +La fct doit tre continžment croissante ou dŽcroissante. +Les points doivent tre donnŽs dans l'ordre (donc : x2 > x1 > x0). +Utilise l'ancien algorithme du TO9. +Extrapolation ˆ gauche interdite +x = valeur(s) ˆ calculer" + + (let* ((c (- x0)) + (d y0) + (b (/ (- (log (abs (- y2 y0))) (log (abs (- y1 y0)))) + (- (log (- x2 x0)) (log (- x1 x0))))) + (a (if (>= y2 y0) (/ (- y1 y0) (expt (- x1 x0) b)) (/ (- y2 y0) (expt (- x2 x0) b))))) +(+ d (* a (expt (+ x c) b))))) + + +(om::defmethod! puiss/TO9 ((x list) (x0 number) (y0 number)(x1 number) (y1 number) + (x2 number) (y2 number)) +(let* ((c (- x0)) + (d y0) + (b (/ (- (log (abs (- y2 y0))) (log (abs (- y1 y0)))) + (- (log (- x2 x0)) (log (- x1 x0))))) + (a (if (>= y2 y0) (/ (- y1 y0) (expt (- x1 x0) b)) (/ (- y2 y0) (expt (- x2 x0) b)))) + res) + + (dolist (xn x) + (push (+ d (* a (expt (+ xn c) b))) res)) + (nreverse res))) + + +(om::defmethod! power/2 ((x number) (x0 number) + (y0 number) (x1 number) + (y1 number)) + :initvals '(1 1 1 2 4) + :indoc '( "x" "x0" "y0" "x1" "y1") + :icon 136 + :doc "calcule les paramètres de l'Žquation y=ax^b en fct de deux points (x0,y0) (x1,y1). +x = valeur(s) ˆ calculer" + +(if (zerop (* x1 x0 y0 y1)) + (progn (print "values of x and y must be different from zero") (beep)) + (let* ((b (/ (log (/ y1 y0)) (log (/ x1 x0)))) + (a (/ y1 (expt x1 b)))) + (format t "y = ~S x ** ~S ~%" (om-round a 10) (om-round b 10) ) + (* a (expt x b))) + )) + +(om::defmethod! power/2 ((x list) (x0 number) + (y0 number) (x1 number) + (y1 number)) + (if (zerop (* x1 x0 y0 y1)) + (progn (print "values of x and y must be different from zero") (beep)) + (let* ((b (/ (log (/ y1 y0)) (log (/ x1 x0)))) + (a (/ y1 (expt x1 b))) + res) + (format t "y = ~S x ** ~S ~%" (om-round a 10) (om-round b 10) ) + (dolist (xn x) + (push (* a (expt xn b)) res)) + (nreverse res)))) + + + +;;Taken from (c) Copyright Gerald Roylance 1982 +(defun false-position-search (fcn s1 s2 eps) + (do ((x1 s1) (y1 (funcall fcn s1)) + (x2 s2) (y2 (funcall fcn s2)) + (xn 0.0) (yn 0.0)) + (NIL) + (declare (float x1 x2 y1 y2 xn yn)) + (if (= y1 y2) (return nil)) ;;(error "FALSE-POSITION-SEARCH Lost")) + (setq xn (- x1 (* y1 (/ (- x2 x1) (- y2 y1))))) + (setq yn (funcall fcn xn)) + (cond ((< (abs yn) eps) (return xn))) + (cond ((> (abs y1) (abs y2)) + (setq x1 xn) (setq y1 yn)) + (t + (setq x2 xn) (setq y2 yn))))) + + + +(defun power-search (x0 y0 x1 y1 x2 y2) +;bmin et bmax fixent les limites de la recherche du paramŽtre b par la +;mŽthode dichotomique. Prendre un intervalle nŽgatif pour une fct dŽcroissante, +;positif autrement. 19 ( ou -19) sont les valeurs maximales + (setq x0 (float x0) x1 (float x1) x2 (float x2) + y0 (float y0) y1 (float y1) y2 (float y2)) + (let* (a b c res power + (y/y (/ (- y2 y1) (- y1 y0))) + (bmin 0) (bmax 19) + (growing (or (and (> x2 x1) (> y2 y1)) (and (< x2 x1) (< y2 y1)))) + (bmin-min (if growing 1.0 -19)) ;0.1)) + (incr (if growing 1 1)) ;0.1)) + (bmax (if growing 19 -1))) ;;1.0))) + (setq b + (do ((bmin bmin-min (+ bmin incr))) + ((>= bmin bmax) (and res (apply 'max res))) + (setq power + (false-position-search + #'(lambda (b) (- (* y/y (- (expt x1 b) (expt x0 b))) (- (expt x2 b) (expt x1 b)))) + bmin bmax 0.001)) + (if power (push power res)))) + (unless b + (beep) + (error "sorry... couldn't find an interpolation with these values")) + + (setq a (/ (- y1 y0) (- (expt x1 b) (expt x0 b)))) + (setq c (- y0 (* a (expt x0 b)))) + + ;(format t "y = ~S x ** ~S + ~S ~%" (om-round a 10) (om-round b 10) (om-round c 10)) + (list a b c))) + + + + +(om::defmethod! power/3 ((x number) (x0 number) (y0 number) + (x1 number) (y1 number) (x2 number) (y2 number)) + :initvals '(1 1 1 2 4 3 9) + :indoc '( "x" "x0" "y0" "x1" "y1" "x2" "y2" ) + :icon 136 + :doc "calcule les paramŽtres de l'Žquation y=ax^b+c en fct de trois points +(x0,y0) (x1,y1) (x2,y2) et crŽe la fonction correspondante . +La fct doit tre continžment croissante ou dŽcroissante. +x = valeur(s) ˆ calculer" + + (let* ((param (power-search x0 y0 x1 y1 x2 y2)) + (a (first param)) + (b (second param)) + (c (third param))) + (+ c (* a (expt x b))))) + + + +(om::defmethod! power/3 ((x list) (x0 number) (y0 number) + (x1 number) (y1 number) (x2 number) (y2 number) ) +(let* ((param (power-search x0 y0 x1 y1 x2 y2)) + (a (first param)) + (b (second param)) + (c (third param)) + solutions) + (dolist ( nx x) + (push (+ c (* a (expt nx b))) solutions)) + (nreverse solutions))) + + + + +#| +(om::defmethod! power-fct ((x list) (x0 number) (y0 number) (x1 number) (y1 number) + &optional (x2 ()) (y2 9.0)) + + :initvals '(1 1 1 2 4 '() 9.0) + :indoc '("X0" "Y0" "X1" "Y1" "X2" "Y2") + :icon 137 + :doc "Calculates the parameters of the equation y = a x b + c or y = a x b +as a function of the points (x0,y0) (x1,y1) and (optional) (x2,y2) +and creates the corresponding function " + (if x2 + (power/3 x x0 y0 x1 y1 x2 y2) + (power/2 x x0 y0 x1 y1 ))) + +|# + + + +(om::defmethod! bpf-gen ((pts list) (nbdec integer)) + + :initvals '('((1 2) (3 4)) 0) + :indoc '("pts" "nbdec") + :icon 136 + :doc "" + + (let (res) + (for (i 0 2 (- (length pts) 3)) + (push (second (nth i pts)) res) + (push (interpolation (second (nth i pts)) (second (nth (+ 2 i) pts)) + (- (first (nth (+ 2 i) pts)) (first (nth i pts))) + (first (om-round (nth (1+ i) pts) nbdec)) + ) res) ) + (push (second (first (last pts))) res) + (cdr(butlast (om-round (flat (nreverse res)) nbdec))))) + + + + +; ========================= traitements de fonctions =========================== + + +(om::defmethod! thales ((newmin number) (newmax number) (liste list)) + + :initvals '(0 0 '(1 2)) + :indoc '("newmin" "newmax" "liste" ) + :icon 136 + :doc "rŽgle de trois sur une liste ; +on donne 2 points de rŽfŽrence: nouveau minimum, nouveau maximum +(Žquivaut ˆ DISTOR )" + + + (mapcar (linear (list-min liste) newmin (list-max liste) newmax) liste)) + + + +; l-distor/2 l-distor/3 L*line L*curb/2 L*curb/3 +; sont dŽfinis dans Esquisse : Freq-Harmony + +; ces fct ne marchent pas !!! linear, ec.. sont probablement differents dans OM + + +; il faudrait tester si la liste contient + qu'un ŽlŽment +(om::defmethod! L*line ((fact1st number) (factlast number) (liste list)) + :initvals '(0.1 1.2 '(1 2)) + :indoc '("fact1st" "factlast" "liste" ) + :icon 136 + :doc "Multiplies a list, , by a linear function. The first element is +multiplied by , the last by and all intermediate +elements by linear interpolations between those values." + + (let ((long (length liste))) + (om* liste (sample-fun (linear-fun 1 fact1st long factlast) 1 long 1 )))) + +;................. ces 2 fct sont remplacŽes dans le menu par L*curb ............ + +(om::defmethod! L*curb/2 ((fact1st number) + (factlast number) (liste list)) + :initvals '(1.0 2.0 '(1 2)) + :indoc '("fact1st" "factlast" "liste") + :icon 136 + :doc "Multiplies a list, , by a power function. The first element is +multiplied by , the last by and all intermediate +elements by interpolations along a power function between those values." + + + (let ((long (length liste))) + (om* liste (power/2 (arithm-ser 1 long 1) 1 fact1st long factlast)) )) + + +(om::defmethod! L*curb/3 ((fact1st number) (factlast number) + (ref integer) (factref number ) + (liste list)) + + :initvals '(1.0 4.0 2 3.0 '(1 2 3 4)) + :indoc '("fact1st" "factlast" "ref" "factref" "liste") + :icon 136 + :doc "Multiplies a list, , by a power function. This box is identical to +'l*curb/2' except that a reference point is controllable. The first +element is multiplied by , the last by and the +element of the original list with a value of will be multiplied by +. All intermediate elements will be multiplied by interpolations +along a power function between and . The power +function, however, will be altered to accommodate the reference point." + + + (let ((long (length liste))) + (if (or (> fact1st factref factlast) (< fact1st factref factlast)) + (om* liste (puiss/TO9 (arithm-ser 1 long 1) 1 fact1st ref factref long factlast)) + (om* liste (power/3 (arithm-ser 1 long 1) 1 fact1st ref factref long factlast))))) + + +(om::defmethod! L*curb ((liste list) (fact1st number) (factlast number) + &optional (ref nil) (factref 2 )) + :initvals '('(1 2 3 4) 1.0 4.0 nil 3.0 ) + :icon 137 + :doc "Multiplies a list, , by a power function. The first +element is multiplied by , the last by ; optionally the +element of the original list with a value of will be multiplied by +. All intermediate elements will be multiplied by interpolations +along a power function between and . The power +function will be altered to accommodate the optional reference point." + +(if (one-elem liste) + (om* fact1st liste) + (if (null ref) (L*curb/2 fact1st factlast liste ) (L*curb/3 fact1st factlast ref factref liste )))) + +;.................................................................... + + + +(defun l-min (list) + "minimum value(s) of a list or list of numbers" + (if (not (consp (first list))) + (apply 'min list) + (mapcar #'(lambda (x) (apply 'min x)) list))) + +(defun l-max (list) + "maximum value(s) of a list or list of numbers" + (if (not (consp (first list))) + (apply 'max list) + (mapcar #'(lambda (x) (apply 'max x)) list))) + + +(om::defmethod! l-distor/2 ((newmin number ) (newmax number) + (liste list)) +:initvals '(1 2 '(0.5 0.7)) + :indoc '("newmin" "newmax" "liste") + :icon 136 + :doc "Distorts a list, , by a power function, thus if the list is linear +the result follow the power function, if the list is non-linear the +result will be a hybrid of the old liste and the power function. +The arguments and determine the scaling of the new +list. ( will be the smallest value present, the largest)" +(let ((liste (list! liste))) + (mapcar #'(lambda (x) (power/2 x (l-min liste) newmin (l-max liste) newmax)) liste))) + + + +(om::defmethod! l-distor/3 ((newmin number) (newmax number) + (ref number) (newref number) + (liste list)) + :initvals '(0.5 1.0 0.7 2 '(0.6 0.9)) + :indoc '("newmin" "newmax" "ref" "newref" "liste") + :icon 136 + :doc "Distorts a list, , by a power function, thus if the list is linear +the result will follow the power function, if the list is non-linear the +result will be a hybrid of the old liste and the power function. This box +is identical to 'l-distor/2' except that a reference point is +controllable. +The arguments and determine the scaling of the new +list. ( will be the smallest value present, the largest) +The values and are used to specify that the element of the +original list with a value of will be moved to the value of +. The curve will be altered in order to accommodate the reference +point." + (if (or (> newmin newref newmax) (< newmin newref newmax)) + (mapcar #'(lambda (x) (puiss/TO9 x (l-min liste) newmin ref newref (l-max liste) newmax )) liste) + (mapcar #'(lambda (x) (parabole/3 x (l-min liste) newmin ref newref (l-max liste) newmax )) liste))) + + + + +(om::defmethod! deformer ((ref number ) (newref number ) (liste list )) + :initvals '(1.0 4.0 2 3.0 '(1 2 3 4)) + :indoc '("ref" "newref" "liste") + :icon 136 + :doc "Change la ''courbure'' d'une liste, en conservant +le min et le max; on donne un point de rŽfŽrence +intermŽdiaire: +ancienne valeur -> nouvelle valeur" + + (l-distor/3 (list-min liste) (list-max liste) ref newref liste)) + + +(defun deform-1 (liste pcent ) + (let ((maxim (list-max liste))) + (l-distor/3 (list-min liste) maxim (/ maxim 2) (/ (* maxim pcent) 100) liste))) + +(om::defmethod! deformer% ((liste list ) (pcent number)) + :initvals '('(1 2 3 4) 50) + :indoc '("liste" "pcent") + :icon 136 + :doc "Change la ''courbure'' d'une liste, en conservant +le min et le max; on donne un pourcentage d'effet (0-100) +qui agira sur la position de la valeur mŽdiane considŽrŽe +comme point de rŽfŽrence -> pcent=50 = pas d'effet" + + (less-deep-mapcar 'deform-1 liste pcent)) + + + +(defun ll-deform-1 (liste fct) + (mapcar fct liste )) + +(om::defmethod! ll-deformer% ((liste list )(pcent number)) + :initvals '('((1 2) (3 4)) 50) + :indoc '("liste" "pcent") + :icon 136 + :doc "comme deformer%, mais toutes les sous-listes sont soumises +ˆ la mme dŽformation (avec deformer%, la dŽformation est diffŽrente +pour chaque sous-liste, en fct des min et max propres)" + + (let* ((minim (list-min (list-min liste))) (maxim (list-max (list-max liste))) + (fct (lambda (x) (puiss/TO9 x minim minim (/ maxim 2) (/ (* maxim pcent) 100) maxim maxim )))) + (less-deep-mapcar 'll-deform-1 liste fct))) + + + + +(defun smooth2 (list) + (let (a b c newlist (list `(,(/ (+ (first list) (second list)) 2.0) ,.list + ,(/ (+ (first (last (butlast list))) (first (last list))) 2.0)))) + ;(print list) + (while (cddr list) + (setf a (pop list) b (first list) c (second list)) + (setf b (float (average2 a b c))) + ;(setf (first list) b) + (push b newlist)) + (nreverse newlist) + )) + +(defun average2 (&rest list) + (/ (apply '+ list) (length list))) + +(om::defmethod! lisser ((list list) (order integer)) + :initvals '('(1 2) 1) + :indoc '("liste" "order") + :icon 136 + :doc "" +"" + (dotimes (i order) + (setf list (smooth2 list))) + list) + + +;====Rename lisser as smoothing 27-06-2007============ + +(om::defmethod! smoothing ((list list) (order integer)) + :initvals '('(1 2) 1) + :indoc '("liste" "order") + :icon 136 + :doc "Smoothing of a list of values by averaging between the successive elements of the list. For example, the list (1 2 3 4 5 10 1 12 13 17) will become (1.5 2.0 3.0 4.0 6.33 5.33 7.67 8.67 14.0 15.0)." + + (lisser list order)) + + +; ==================================================== + + + + + + +; ======================= chaos ==================== + + + +(defun fractrec (liste listdiv prof) + (if (eq prof *n) (diffract liste listdiv) + (fractrec (diffract liste listdiv) listdiv (1+ prof)))) + +(om::defmethod! fractal+ ((liste list) (listdiv list) (level integer)) + + :initvals '('(1 2) '(1 2) 0) + :indoc '("liste" "listdiv" "level") + :icon 136 + :doc "fractalisation de la liste selon le dŽcoupage + avec niveaux de rŽcursion" + (if (= level 0) + (setq liste liste) + (let ((*n (1- level))) + (declare (special *n)) + (fractrec liste listdiv 0)))) + + + + + +;...............anciennes fonctions........................................... +(defun fract-recurs (liste prof) + (if (eq prof *n) + (list liste) + (flat-once (mapcar #'(lambda (item) (fract-gen item liste prof)) liste)))) + + +(defun fract-gen (num liste prof) + (let ((sum (apply '+ liste))) + (fract-recurs (mapcar #'(lambda (item) (/ (* num item) sum)) liste) (1+ prof)))) + + +(defun fractal (liste level ) +"fractalisation de la liste avec niveaux de rŽcursion" + (let ((*n level)) (declare (special *n)) + (fract-recurs liste 0))) + +(defun fract1 (liste listdiv) + (let ((res ()) (long (length liste))) + (dotimes (n long) + (push (om-scale/sum listdiv (car liste))res) + (setq liste (cdr liste))) + (reverse res))) + +(defun diffract (liste listdiv) +"fractalise une fois, selon la liste , la liste +de niveau quelconque" + (lldecimals (less-deep-mapcar 'fract1 liste listdiv) 4)) + + +; ............................................................... + + +(defun logistic-rec (x taux iter i res) + (push (* taux x (- 1 x)) res) + (if (< i iter) + (logistic-rec (* taux x (- 1 x)) taux iter (1+ i) res) + (nreverse res))) + +(om::defmethod! logistic ((xdeb number) + (taux number) + (iter number)) + + :initvals '( 0.02 2.7 30) + :indoc '("xdeb" "taux" "iter") + :icon 136 + :doc "Žquation 'diffŽrentielle logistique' +Simule une Žvolution de population en fonction de population +de dŽpart (xdeb) et d'un taux . Iter = nombre de fois o +l'on rŽpŽte l'Žquation : x = rx (1 - x) +x doit tre < 1" + + + (logistic-rec xdeb taux iter 1 ())) + + + +(defun henon-rec (x y taux iter i resx resy) + (push (- (1+ y ) (* taux x x)) resx) + (push (/ x 3) resy) + (if (< i iter) + (henon-rec (- (1+ y ) (* taux x x)) (/ x 3) taux iter (1+ i) resx resy) + (list (nreverse resx) (nreverse resy)))) + +(om::defmethod! henon ((xdeb number ) (ydeb number ) + (taux number ) (iter number )) + + :initvals '( .9 .8 1.4 30) + :indoc '("xdeb" "ydeb" "taux" "iter") + :icon 136 + :doc " attracteur de HŽnon +Simule une Žvolution de population en fonction de population +de dŽpart (xdeb) et d'un taux . Iter = nombre de fois o +l'on rŽpŽte l'Žquation : x = rx (1 - x) +x doit tre < 1 " + (henon-rec xdeb ydeb taux iter 1 () ())) + + + +; ================== alea ================================== + + + +(om::defmethod! LLalea ((list list) (percent% number)) + :initvals '('(2 3 3 5 8) 0.1) + :indoc '("list" "vrai pourcentage: Žcrire <10> pour 10%") + :icon 136 + :doc "Ajoute ou retranche alŽa ˆ la liste (de profondeur quelconque) +selon % indiquŽ" + (deep-mapcar/1 'mulalea list (/ percent% 100))) + + + +(om::defmethod! tirage ((percent% number)) + :initvals '(50) + :indoc '("vrai pourcentage: Žcrire <10> pour 10%") + :icon 136 + :doc "sort nil ou t selon % de chances indiquŽ: ie. 30 % = 30% de chances de sortir t" +(<(om-random 0 100) percent% )) + + + +(defun rec-tirage (nbelem larithm res n) + (let ((tirage (nth-random larithm))) + (push tirage res) + (setq larithm (remove tirage larithm)) + (setq n (1+ n)) + (if ( = n nbelem ) + res + (rec-tirage nbelem larithm res n)))) + + +(om::defmethod! list-tirage ((liste list) (nbelem integer)) + :initvals '('(1 2 3 4 5) 3) + :indoc '("liste simple" "nb elem ˆ tirer") + :icon 136 + :doc "garde alŽatoirement nbelem ŽlŽments de la liste" + (let* ((larithm (arithm-ser 0 (1- (length liste)) 1)) ) + (posn-match liste (sort (rec-tirage nbelem larithm nil 0) '< )))) + + +(om::defmethod! list-alea-filter ((liste list) (percent% number)) + :initvals '('(1 2 3 4 5) 50) + :indoc '("liste simple" "vrai pourcentage: Žcrire <10> pour 10%") + :icon 136 + :doc "garde alŽatoirement percent% des ŽlŽments de la liste" +(let* ((larithm (arithm-ser 0 (1- (length liste)) 1)) + (nbelem (round (* (length liste) (/ percent% 100.))))) + (if (< nbelem 1) nil + (posn-match liste (sort (rec-tirage nbelem larithm nil 0) '< ))))) + + + +(om::defmethod! random-list ((nb integer) (low number) (high number)) + :initvals '(10 0 1) + :icon 136 + :doc "crŽŽe une liste de nb ŽlŽments aux valeurs alŽatoires entre low et high" +(let ((res)) +(for (i 1 1 nb) + (push (om-random low high) res)) +res)) + + +(om::defmethod! random-from-list ((liste list) (nb integer) ) + :initvals '(3 '(1 2 3 4 5)) + :icon 136 + :doc "tire au hasard nb ŽlŽments dans la liste ; pour ne pas avoir de rŽpŽtitions +utiliser list-tirage " +(let ((res)) +(for (i 1 1 nb) + (push (nth-random liste) res)) +res)) + +; ======================= arithmŽtique ==================== + + + + + +(om::defmethod! om-modulo ((numbers t) (mod number)) + :initvals '('(10 11 12) 3) + :indoc '( "numbers" "mod") + :icon 136 + :doc "Calculates the number that is congruent modulo mod to numbers, or the remainder +of an integer division (Euclidean division between two numbers numbers and mod). " + (arith-tree-mapcar (function mod) numbers mod)) + + +(om::defmethod! om-floor ((numbers t) &optional (div 1)) + :initvals '( 52.71 1) + :indoc '( "numbers" "div") + :icon 137 + :doc "Truncation of number or tree. Rounded to the larger integer. " + (deep-mapcar/1 'floor numbers div)) + + + + +(om::defmethod! cumul ((liste list)) + :initvals '('(1 2 3 4 5)) + :indoc '( "liste" ) + :icon 136 + :doc "Cumuls successifs de la liste " + (let ((x 0)) + (deep-mapcar/1 #'(lambda (dx) (incf x dx)) liste))) + + + + +(om::defmethod! diff ((liste list)) + :initvals '('(2 3 3 5 8)) + :indoc '( "liste" ) + :icon 136 + :doc "Returns the list of the intervals between the contiguous values of a list, + starting from 0." + (cons (car liste) (mapcar #'- (cdr liste) liste))) + + + +(defun comparres (modliste toler) + (let ((res t) (azaz (mapcar '<= modliste toler))) + (dolist (i azaz) + (if (null i) (setq res nil))) + res)) + +(om::defmethod! l-pgcd ((liste list) (precision number) (pas number)) + :initvals '('(45 81 103 127) 1 0.1) + :indoc '( "liste" "precision" "pas" ) + :icon 136 + (let ((depart (list-min liste)) (toler (om* liste (/ precision 100))) res) + (do ( (i depart (- i pas)) ) + ((< i pas)) + (setq res i) + (if (comparres (om-modulo liste i) toler) (return))) + (om-round res 8))) + + + + + +(om::defmethod! ll-scaling ((list list) (min number) (max number)) + :initvals '('((1 3 15) (6 7 8)) 0.5 20) + :indoc '( "liste" "min" "max") + :icon 136 + :doc "scaling d'une liste de liste en fct du max et du min +globaux de toutes les sous-listes confondues" + (om-scale list min max (list-min (list-min list)) (list-max (list-max list)))) + + +(defun scale% (num %scfc) + "Returns an integer that is scaled as %scfc percentage of num." + (round (* num %scfc) 100)) + +(om::defmethod! l-scale% ((l1? list) (l2? list)) + :initvals '('(1 3 15) '(6 7 8)) + :indoc '( "list1" "list2") + :icon 136 + :doc + "Divides by 100 the product of and ." + (double-mapcar 'scale% l1? l2?)) + + +(om::defmethod! scale-r ((liste list) (min number) (max number) (dec integer)) + :initvals '('(1 3 15 6 7 8) 0.5 20 2) + :indoc '( "liste" "min" "max" "dec" ) + :icon 136 + :doc + "om-scaling avec arrondi" + (om-round (om-scale liste min max) dec)) + + + + +(defun compris (val min max) + (and (< val max) (> val min))) + +(defun compris= (val min max) + (and (<= val max) (>= val min))) + +(defun exclus (val min max) + (or (> val max) (< val min))) + +(defun exclus= (val min max) + (or (>= val max) (<= val min))) + + + +(om::defmethod! <> ((l? t) (min number) (max number) + (bornes? symbol)) + + :initvals (list 5 1 10 '<>=) + :indoc '("l?" "min" "max" "bornes") + :menuins '((3 (("<>" '<>) + ("<>=" '<>= )))) + :icon 136 + :doc "l? est-il dans l'intervalle min max ?" + + (let ((fct (if (equal bornes? '<>) 'compris 'compris=))) + (car-mapcar fct l? min max))) + + +(om::defmethod! >< ((l? t) (min number) (max number) (bornes? symbol )) + :initvals '('(1 3 15) 0.5 3 '>< ) + :indoc '("l?" "min" "max" "bornes") + :icon 136 + :menuins '((3 (("><" '><) ("><=" '><=) ))) + :doc "l? est-il hors de l'intervalle min max ? - bornes incluses ou excluses" + (let ((fct (if (equal bornes? '><) 'exclus 'exclus=))) + (car-mapcar fct l? min max))) + + + + + +(om::defmethod! x->dx+ ((liste list) (elem number)) + :initvals '('((1 3 15) (6 7 8)) 0.5 20) + :indoc '("liste" "elem") + :icon 136 + :doc "comme x->dx, mais ajoute un ŽlŽment final" + (x-append (x->dx liste) elem)) + + + +(om::defmethod! l-prime? ((liste list )) + :initvals '('((1 3 15) (6 7 8)) 0.5 20) + :indoc '("liste") + :icon 136 + :doc "Teste liste de nb premiers - doivent être < 99460729." + (mapcar 'prime? liste)) + + + +(defun accumule-rec (accum fct liste res) + (setq liste (cdr liste)) + (setq accum (funcall fct accum (first liste))) + (push accum res) + (if (one-elem liste) res (accumule-rec accum fct liste res))) + + + + +(om::defmethod! accumule ((fct t ) (liste list) + (format symbol )) + + :initvals '('+ '(1 2) 'incl) + :indoc '("fct" "liste" "format") + :menuins '((2 (("incl" 'incl) ("excl" 'excl) ))) + :icon 136 + :doc "effectue une opŽration cumulative sur une liste. La fonction fct est +appliquŽe sur les 2 1ers ŽlŽments, puis sur le rŽsultat obtenu et le +3e ŽlŽment, etc... La premiŽre valeur peut tre incluse ou excluse. +Ex : si la fct est + (1 2 3 5) rend (1 3 6 11)" + + (let* ((accum (first liste)) (res (if (equal format 'excl) () (list (first liste))))) + (nreverse (accumule-rec accum fct liste res)))) + +; ============================== midi ========================== + +; ajouter port + +(om::defmethod! joue ((chord chord ) (approx integer ) &optional (port 0)) + :initvals '( nil 4 0) + :icon 137 +(midi-o (mat-trans (list (om+ 143 (om+ (lchan chord) (om-round (om/ + (om-modulo (approx-m (lmidic chord) approx) 100) 25)))) + (om-floor (approx-m (lmidic chord) approx) 100) + (lvel chord) )) port) ) + + + + +(om::defmethod! tx-duo-pgm ((son1 integer ) (son2 integer ) &optional (port 0)) + :initvals '( 1 1 0) + :indoc '("son1" "son2") + :doc "numŽros de prg--> TX1/4, TX5/8" + :icon 137 + (pgmout son1 '(1 2 3 4) port) + (pgmout son2 '(5 6 7 8) port) + "ok") + + +(om::defmethod! tx-duo-vol ((vol1 integer ) (vol2 integer ) &optional (port 0)) + :initvals '( 127 127 0) + :indoc '("vol1" "vol2" "port") + :icon 137 + :doc "volume--> TX1/4, TX5/8" + (volume vol1 '(1 2 3 4) port) + (volume vol2 '(5 6 7 8) port) + "ok") + + + +(defun TXtun1 (tune canal port) +"accord TX: 0= bŽcarre 21= +1/8 42= +1/4 63= + 3/8" + (midi-o (list 240 67 (+ 15 canal) 4 64 (+ 64 tune) 247) port)) + + +(om::defmethod! TXtune ((tunings t) (chans t ) &optional (port 0)) + :initvals '( '(0 21 42 63 0 21 42 63) '(1 2 3 4 5 6 7 8) 0) + :indoc '("tunings" "chans" "port") + :icon 137 + :doc "Sends global tuning parameters to a Yamaha TX-816. The value +will be sent to the midi channel specified, . If is a list +the tuning will be sent to all listed channels." + (let ((port (create-list 8 port))) + (cond ((not (consp tunings)) + (mapc #'(lambda (canal) (TXtun1 tunings canal port)) (list! chans))) + ((not (consp chans)) + (mapc #'(lambda (tun) (TXtun1 tun chans port)) (list! tunings))) + (t (mapc #'TXtun1 tunings chans port) ) ) )) + + + +(defun gen-TXtun1 (tune canal) +"accord TX: 0= bŽcarre 21= +1/8 42= +1/4 63= + 3/8" + (list 240 67 (+ 15 canal) 4 64 (+ 64 tune) 247)) + + +(om::defmethod! gen-TXtune ((tunings integer) (chans integer )) + :initvals '( '(0 21 42 63 0 21 42 63) '(1 2 3 4 5 6 7 8)) + :indoc '("tunings" "chans") + :icon 136 + :doc "Generates tuning parameters to a Yamaha TX-816. Useful for maquettes" +(gen-TXtun1 tunings chans)) + + +(om::defmethod! gen-TXtune ((tunings list) (chans list )) +(flat (loop for tune in tunings + for chan in chans + collect (gen-TXtun1 tune chan)))) + + +(om::defmethod! gen-TXtune ((tunings integer) (chans list )) +(flat (loop for chan in chans + collect (gen-TXtun1 tunings chan)))) + + + + + +(om::defmethod! tx-duo-tune ((tune1 integer ) (tune2 integer ) &optional (port 0)) + :initvals '( 8 8 0) + :indoc '("tune1" "tune2" "port") + :icon 137 + :doc "tune (4 ou 8) --> TX1/4, TX5/8" + (txtune (if (= tune1 4) '(0 0 43 43) '(0 21 42 63)) '(1 2 3 4) port ) + (txtune (if (= tune2 4) '(0 0 43 43) '(0 21 42 63)) '(5 6 7 8) port) + "ok") + + +(om::defmethod! tx-pgm ((son1 integer ) (son2 integer ) (son3 integer ) (son4 integer ) + (son5 integer ) (son6 integer ) (son7 integer ) (son8 integer ) &optional (port 0)) + :initvals '( 1 1 1 1 1 1 1 1 0) + :indoc '("son1" "son2" "son3" "son4" "son5" "son6" "son7" "son8" "port") + :icon 137 + (pgmout (list son1 son2 son3 son4 son5 son6 son7 son8) '(1 2 3 4 5 6 7 8) port) + "ok") + + +; ========================== PORTS ================================================== + + + + +; methodes ˆ utiliser en conjonction avec sel-maq et channel->voice pour transformer une maquette en mseq +; ameliorer pour que l'attribution du port dans canal+->port se fasse pour chaque note + +(om::defmethod! port->canal+ ((self container) ) + :initvals '(nil ) + :icon 136 + :doc "transforme infos de port + canal en notation canal+ = port*16 + (canal - 1)" + (ch-modif self '= (om+ (om- (lchan self) 1) (om* 16 (get-port self))) 'lchan)) + +; nom abrŽgŽ +(om::defmethod! pc+ ((self container) ) + (port->canal+ self)) + + +#| (om::defmethod! canal+->port ((self multi-seq) ) + + :initvals '(nil ) + :icon 136 + :doc "transforme info canal+ en notation port et canal midi. Suppose que les notes de +chaque chord possdent le mme port" +(let ( (lport (om// (lchan self) 16)) + + (self (ch-modif self '= (om+ 1 (om-modulo (lchan self) 16)) 'lchan))) + +(loop for chseq in (chord-seqs self) + for lpcs in lport + do (loop for ch in (chords chseq) + for lpch in lpcs + do (setf (LPort ch) (car lpch)) + finally (return self)) + finally (return self)))) +|# + + +(om::defmethod! canal+->port ((self chord-seq) ) + :initvals '(nil ) + :icon 136 + :doc "transforme info canal+ en notation port et canal midi. Suppose que les notes de +chaque chord possdent le mme port" +(let ( (ports (om// (lchan self) 16)) + (self (ch-modif self '= (om+ 1 (om-modulo (lchan self) 16)) 'lchan))) + (setf (LPort self) ports))) + + +(om::defmethod! canal+->port ((self multi-seq) ) + (mki 'multi-seq + :chord-seqs (mapcar 'canal+->port (chord-seqs self) ))) + + + + + + +; nom abrŽgŽ +(om::defmethod! cp+ ((self container) ) + (canal+->port self)) + + + +; ---------- permet de jouer plusieurs ports midi dans un multiseq ------- + +#| (defmethod* PrepareToPlay ((self multi-seq) at &key approx port interval) + (setf port (verify-port port)) + (loop for sub in (inside self) + for myport in *myports* do + (let ((objstart (+ at (offset->ms sub)))) + (if interval + (let ((newinterval (interval-intersec interval + (list objstart (+ objstart (get-obj-dur sub)))))) + (when newinterval + (PrepareToPlay sub objstart + :approx approx + :port myport + :interval interval))) + (PrepareToPlay sub objstart + :approx approx + :port myport))))) + +(om::defmethod! gport ((ports list)) + :initvals '('( 0 0 0 0 1 1 1 1)) + :doc "assign ports to the chord-seqs of the multi-seqs. + Changes a global variable : all multi-seqs will be effected" + :icon 136 + (setf *myports* ports)) + +|# + + + +(defun pb-range-one (canal range ) + (midi-o (list 240 67 (+ 15 canal) 4 4 0 247)) ; step ˆ 0 + (midi-o (list 240 67 (+ 15 canal) 4 3 range 247))) + + +(om::defmethod! pb-range ((range integer) (canaux t)) + :initvals '( 12 '(1 2 3 4 5 6 7 8) ) + :indoc '("range" "canaux") + :icon 136 + :doc "fixe l'intervalle du pitch bender, en 1/2 tons" + (car-mapcar #'pb-range-one canaux range ) ) + + + + +(defun ctrl1 (canal num val) + (midi-o (list (+ 175 canal) num val))) + +(om::defmethod! ctrlout ((num integer) (val integer) (canaux t )) + :initvals '(1 127 '(1 2 3 4 5 6 7 8)) + :indoc '("num" "val" "canaux") + :icon 136 + "valeur de sortie d'un contrôleur" + (car-mapcar #'ctrl1 canaux num val ) ) + + +; ........................................................ +; jeu d'un spectre dynamique avec pitch-bend et ctrl 7 + +(defvar *range) + +(om::defmethod! accord-moyen ((l-fqs list) (nbhq integer)) + :indoc '("l-fqs" "nbhq") + :initvals '('(1 2) 1) + :icon 136 + :doc "" + (let ((l-midics (f->mc (list-pos l-fqs 0 (1- nbhq) 1))) res l-ecarts) + (dolist (hq l-midics) + (let ((valmoy (om-round (average (list (list-max hq) (list-min hq)) 1) -2))) + (push valmoy res) + (push (list-max (om-abs (om- hq valmoy))) l-ecarts))) + + (setf *range (ceiling (list-max l-ecarts) 100)) + (nreverse res))) + + + + +(defun pb-val (l-midics valmoy densite) + (x-append "pb" (om-round + (densifier (om* (om/ (om- l-midics valmoy) *range) 81.90) densite)))) + +(defun ctrl-val (l-vels densite) + (let ((l-vels (om-round (densifier l-vels densite)) ) res ) + (dolist (n l-vels) + (push 7 res) + (push n res)) + (x-append "ctrl" (nreverse res)))) + + +(om::defmethod! pbend-ctrl7 ((l-fqs list) (l-amps list) + (nbhq integer) (acmoyen list) + (densite integer) (curve integer)) + + :indoc '("l-fqs" "l-amps" "nbhq" "acmoyen" "densite" "curve") + :initvals '('(220 440) '(80 80) 1 '(2 2) 1 75) + :icon 136 + :doc "entrŽes: +l-fqs = liste des frŽqs +l-amps = liste des amplitudes +nbhq = nombre de partiels considŽrŽs +acmoyen = accord moyen (rendu par la bo”te de ce nom) +densitŽ = nb d'interpolations entre les valeurs pb et ctrl7 +curve = dŽformation Žchelle des amplitudes en % +(pour passer de linŽaire ˆ vŽlocitŽs midi) 50% = linŽaire +> 50% = exponentielle" + + (let ((l-midics (f->mc (list-pos l-fqs 0 (1- nbhq) 1))) + (l-vels (om-round (ll-deformer% + (ll-scaling (list-pos l-amps 0 (1- nbhq) 1) 0 127) curve))) + res ) + (dotimes (hq nbhq) + (push (list + (pb-val (nth hq l-midics) (nth hq acmoyen) densite) + (ctrl-val (nth hq l-vels) densite)) + res)) + (nreverse res))) + +; =============================== objets ================================ + +; tests + + +;(make-instance 'chord-seq + ; :lmidic chords + ; :lonset lonset + ; :legato 100 +; (mki 'chord +; :LMidic +; :Lvel +; :Loffset +; :Ldur + ; :Lchan +; :lport + + + +(defun set-chord-slot (accord slot value) + (cond ((eq slot 'lmidic) (setf (lmidic accord) value)) + ((eq slot 'ldur) (setf (ldur accord) value)) + ((eq slot 'loffset) (setf (loffset accord) value)) + ((eq slot 'lchan) (setf (lchan accord) value)) + ((eq slot 'lvel) (setf (lvel accord) value)) + ((eq slot 'lport) (setf (lport accord) value)) )) + + + +(defun ch-dur (chord) + (list-max (om+ (ldur chord) (loffset chord)))) + + +(om::defmethod! ch-length ((obj chord)) + :initvals '(nil ) + :icon 136 + :doc "nb notes d'un accord - si obj est un ch-seq, liste nb de notes de chaque accord " + (length (lmidic obj))) + +(om::defmethod! ch-length ((obj chord-seq)) + (mapcar 'length (lmidic obj))) + + + + + +(om::defmethod! obj-dur ((obj chord)) + :initvals '(nil ) + :icon 136 + :doc "duree d'un objet - tenant compte de offset et dur " + (list-max (om+ (ldur obj) (loffset obj)))) + +(om::defmethod! obj-dur ((obj chord-seq)) +(list-max (om+ (mapcar 'obj-dur (get-chords obj)) (butlast (lonset obj))))) + + +(om::defmethod! obj-dur ((obj multi-seq)) +(list-max (mapcar 'obj-dur (chord-seqs obj)))) + + + +(om::defmethod! canaux ((obj container)) + :initvals '(nil ) + :icon 136 + :doc "liste des canaux presents dans l'objet " + (sort (remove-dup (remove nil (flat (lchan obj))) 'eq 1) '<)) + + + +(om::defmethod! obj-minmax ((obj t)) + :initvals '(nil ) + :numouts 2 + :icon 136 + :doc "midic minimal et maximal de l'objet " + (values-list (list (list-min (lmidic obj)) (list-max (lmidic obj))))) + + + + + +;(om::defmethod! selectf ((self container) (start number) (end t) &optional (track nil)) +;:initvals '(nil 0 nil nil) +; :icon 137 +; :doc "comme select, mais neutralise les C4 indŽsirables +; piste permet de choisir une seule piste (dans un multi-seq) +;Si self = maquette , extrait les objets dont offset est entre start et end" +;(cond ((null piste) (filterC4 (select self start end))) +; ((listp piste) +; (filterC4 (select (mki 'multi-seq :chord-seqs (posn-match (chord-seqs self) piste)) start end))) +; (t (filterC4 (select (nth piste (chord-seqs self)) start end)) +; ))) +; correction 9-05 teste valeur de end + +(om::defmethod! selectf ((self chord-seq) (start number) (end t) &optional (piste nil)) +:initvals '(nil 0 nil nil) + :icon 137 + :doc "comme select, mais neutralise les C4 indŽsirables +piste permet de choisir une seule piste (dans un multi-seq) +Si self = maquette , extrait les objets dont offset est entre start et end" + + (let ((end (if end (min end (last-elem (lonset self))) (last-elem (lonset self))))) + + (filterC4 (select self start end)))) + +(om::defmethod! selectf ((self multi-seq) (start number) (end t) &optional (piste nil)) +:initvals '(nil 0 nil nil) + (let ( (piste (if (null piste) (arithm-ser 0 (length-1 (chord-seqs self)) 1) piste)) + res) + + (if (listp piste) + (progn (dolist (p piste) + (push (selectf (nth-obj self p) start end piste) res)) + (mki 'multi-seq :chord-seqs (reverse res))) + (selectf (nth piste (chord-seqs self)) start end piste)))) + +(om::defmethod! selectf ((self ommaquette) (start t) (end t) &optional (piste nil)) + (let* ((objets (temporalboxes self)) (start (if (eq start nil) 0 start)) + (end (if (eq end nil) (l-max (mapcar 'offset objets)) end)) + res) +(loop for ob in objets + do (if (<> (offset ob ) start end '<>=) (push (value ob) res)) + finally (return (reverse res))))) + +;====Rename selectf as select-filt 28-06-2007========================= + +(om::defmethod! select-filt ((self chord-seq) (start number) (end t) &optional (track nil)) + :initvals '(nil 0 nil nil) + :icon 137 + :doc "Returns the selected excerpt between and while neutralizing the undesired C4s. The optional allows to specify a single track in a multi-seq. In case is a maquette, the objects possessing an offset between and will be extracted." + + (selectf self start end track)) + +(om::defmethod! select-filt ((self multi-seq) (start number) (end t) &optional (track nil)) + + (selectf self start end track)) + +(om::defmethod! select-filt ((self ommaquette) (start t) (end t) &optional (track nil)) + + (selectf self start end track)) + +;==================================================================== + + +(om::defmethod! seq-extract ( (chseq chord-seq) (begin integer) (end integer)) + :initvals '(nil 0 3) + :icon 136 + :doc "Extracts part of a chord sequence between and . N.B. =0 indicates that the selection starts with the very first chord of the original sequence." + + (mki 'chord-seq + :lmidic (posn-match (get-chords chseq) (arithm-ser begin end 1)) + :lonset (om- (posn-match (lonset chseq) (arithm-ser begin end 1)) (nth deb (lonset chseq))) + :legato (legato chseq))) + + +(om::defmethod! nth-obj ( (obj chord-seq) (nth t)) + :initvals '(nil 0) + :icon 136 + :doc "Extracts the nth chord from a chord sequence object, or the nth chord sequence from a multi sequence object, or the nth object from a maquette. may be a liste. +N.B. =0 indicates the first object." + + (posn-match (get-chords obj) nth)) + +(om::defmethod! nth-obj ( (obj multi-seq) (nth t)) + (posn-match (chord-seqs obj) nth)) + +; --- nth-obj pour maquettes + +(om::defmethod! nth-obj ( (obj ommaquette) (nth integer)) + (let ((objets (temporalboxes obj))) + (car (value (posn-match (second (sort-table (list (mapcar 'offset objets) objets) 0)) nth))))) + + +(om::defmethod! nth-obj ( (obj ommaquette) (nth list)) + (let ((objets (temporalboxes obj))) + (mapcar 'value (posn-match (second (sort-table (list (mapcar 'offset objets) objets) 0)) nth)))) + +(om::defmethod! last-n ( (obj chord-seq) (nth number)) + (let ((long (1- (length (lmidic obj))))) + (posn-match (get-chords obj) (arithm-ser (- long (1- nth)) long 1 )))) + + + +; tester encore +(om::defmethod! sort-chords ((object chord-seq)) + :initvals '(nil ) + :icon 136 + :doc "remet les accords d'un chord-seq dans l'ordre des onset +si object = accord : remet les midic dans l'ordre ascendant" +(let ((lchords (sort-table (list (get-chords object) (butlast (lonset object))) 1))) + (mki 'chord-seq + :LMidic (first lchords) + :lonset (x-append (second lchords) (max (last-elem (lonset object)) + (+ (last-elem (second lchords) ) + (list-max (ldur (last-elem (first lchords)))) + (list-max (loffset (last-elem (first lchords))))))) + :legato (legato object)))) + + + +(om::defmethod! sort-chords ((object chord)) + +(notes->chord (mat-trans (sort-table (mat-trans (chord->notes object)) 0)))) + + + + + +(om::defmethod! chord->notes ((self chord)) + :initvals '(nil ) + :icon 136 + :doc "extrait les notes d'un chord. Les notes sont ici de simples listes +(pitch vel offset dur chan port) " + (loop for pitch in (lmidic self) + for dur in (ldur self) + for vel in (lvel self) + for offset in (loffset self) + for chan in (lchan self) + for port in (lport self) + collect (list pitch vel offset dur chan port)) ) + + +(om::defmethod! notes->chord ((notes list)) + :initvals '(nil ) + :icon 136 + :doc "Reconstruit un accord ˆ partir de simples listes +(pitch vel offset dur chan port) " +(let ((notes (remove nil notes))) + (mki 'chord + :LMidic (mapcar 'first notes) + :Lvel (mapcar 'second notes) + :Loffset (mapcar 'third notes) + :Ldur (mapcar 'fourth notes) + :Lchan (mapcar 'fifth notes) + :Lport (mapcar 'sixth notes)))) + + + + +; from chord-seq->mf-info but here pitch = midicent legato = 0 + +(om::defmethod! seq->notes ((self chord-seq)) + :initvals '(nil ) + :icon 136 + :doc "extrait les notes d'un ch-seq (multi-seq). Les notes sont ici de simples listes +(pitch (+ onset offset) dur vel chan) " + (loop for lpitch in (lmidic self) + for onset in (lonset self) + for ldur in (ldur self) + for lvel in (lvel self) + for loffset in (loffset self) + for lchan in (lchan self) + for lport in (lport self) + append (loop for pitch in lpitch + for dur in ldur + for vel in lvel + for offset in loffset + for chan in lchan + for port in lport + collect (list pitch (+ onset offset) dur vel chan port)) )) + + +(om::defmethod! seq->notes ((self multi-seq)) +(mapcar 'seq->notes (chord-seqs self))) + + +(om::defmethod! notes->seq ((lnotes list)) + :initvals '( '((6000 0 1000 80 1) (6900 0 1000 80 1))) + :icon 136 + :doc "crŽe un chord-seq ˆ partir de notes (listes +(pitch onset dur vel chan port)) " +(if (atom (first (first lnotes))) (notes->chord-seq lnotes) (notes->multi-seq lnotes))) + + +(om::defmethod! notes->chord-seq ((lnotes list)) + :initvals '( '((6000 0 1000 80 1 0) (6900 0 1000 80 1 0))) + :icon 136 + :doc "crŽe un chord-seq ˆ partir de notes (listes +(pitch onset dur vel chan port)) " + (let* ( (lnotes (mat-trans (sort-table (mat-trans lnotes) 1))) (lastnote (last-elem lnotes)) lchords) + (dolist (note lnotes) + (push (mki 'chord + :LMidic (list (first note)) + :Ldur (list (third note)) + :Loffset '(0) + :Lchan (list (fifth note)) + :Lvel (list (fourth note)) + :lport (list (sixth note)) ) + lchords)) + (mki 'chord-seq + :LMidic (nreverse lchords) + :lonset (x-append (mapcar 'second lnotes) (+ (second lastnote) (third lastnote))) + :legato 0))) + + + + + +(om::defmethod! notes->multi-seq ((lnotes list)) + :initvals '( '(((6000 0 1000 80 1) (6900 0 1000 80 1)) ((6000 0 1000 80 1) (6900 0 1000 80 1)))) + :icon 136 + :doc "crŽe un multi-seq ˆ partir de notes (listes +(pitch onset dur vel chan)) " +(mki 'multi-seq :chord-seqs + (mapcar 'notes->seq lnotes))) + + +(om::defmethod! multi-seq-vide ((ntracks integer)) + :initvals '(5) + :icon 136 + :doc "Creates an empty multi sequence object with tracks." + +(mki 'multi-seq :chord-seqs + (mapcar 'notes->seq (create-list ntracks '((6000 0 10 0 1 999)))))) + + + +; explosion est la nv fct gŽnŽrale . explode-seq est gardŽ pour compatibilitŽ + +(om::defmethod! explode-seq ((obj chord-seq) ) +:initvals '(nil ) + :icon 136 + :doc "explose les accords d'un chord-seq (multi-seq) en accords ne +contenant qu'une seule note . Utile aussi pour changer les modif d'offsets en +onsets modifiŽs" +(notes->seq (seq->notes obj))) + +(om::defmethod! explode-seq ((obj multi-seq) ) +(mki 'multi-seq :chord-seqs + (loop for c in (chord-seqs obj) + collect (if (null (seq->notes c)) (notes->seq '((6000 0 10 0 1 999)) ) ; note bidon + (explode-seq c ))))) + + +(om::defmethod! explosion ((obj chord) ) +:initvals '(nil ) + :icon 136 + :doc "explose les notes d'un chord , chord-seq ou multi-seq en accords ne +contenant qu'une seule note . Change les offsets en onsets " +(let ((lnotes (chord->notes obj))) + + (mki 'chord-seq + :lmidic (mapcar 'first lnotes) + :lvel (mapcar 'second lnotes) + :lonset (mapcar 'third lnotes) + :ldur (mapcar 'fourth lnotes) + :lchan (mapcar 'fifth lnotes) + :lport (mapcar 'list! (mapcar 'sixth lnotes)) ; mapcar 'list! parce que lport (ch-seq) attend une liste de listes + :legato 0))) + + + + +(om::defmethod! explosion ((obj chord-seq) ) +(explode-seq obj)) + +(om::defmethod! explosion ((obj multi-seq) ) +(explode-seq obj)) + + + + +(om::defmethod! implosion ((obj chord-seq) ) +:initvals '(nil ) + :icon 136 + :doc "transforms a chord-seq (or multi-seq) into a chord . Change onsets into offsets. Useful for iterations, trills, etc... +as it should simplify internal representation . " + +(let ((lnotes (seq->notes obj))) + + (mki 'chord + :lmidic (mapcar 'first lnotes) + :lvel (mapcar 'fourth lnotes) + :loffset (mapcar 'second lnotes) + :ldur (mapcar 'third lnotes) + :lchan (mapcar 'fifth lnotes) + :lport (mapcar 'sixth lnotes) + ))) + + +(om::defmethod! implosion ((obj multi-seq)) + :initvals '(nil) + :icon 136 + (implosion (mixer obj nil))) + + + + + + +(om::defmethod! lier ((obj chord-seq) &optional (legato 100)) + :initvals '(nil 100) + :icon 137 + :doc "chord-seq : chaque note de chaque accord dure jusqu'ˆ l'onset suivant +chord : chaque note dure jusqu'ˆ la note suivante (si offsets <> 0) +arg optionnel legato : durŽe Žgale ˆ un % de l'intervalle de temps ainsi dŽfini (100 = legato parfait, +> 100 = tuilage , < 100 = staccato " + (let* ( (interv (butlast (x->dx (lonset obj)))) + (res (loop for ch in (butlast (chords obj)) + for in in interv + collect (ch-modif ch '= (om-round (om/ (om* legato in) 100)) 'ldur)))) + (mki 'chord-seq :lmidic (x-append res (last-elem (chords obj))) :lonset (lonset obj)))) + + +; corr 11/10/03 le dernier objet reste inchangŽ (prŽcŽdemment, sa durŽe Žtait la durŽe de son ŽlŽment le plus long : +;(setf (ldur res) (x-append (om-round (om/ (om* legato (butlast (x->dx (lonset obj)))) 100)) (last-elem (ldur obj)))) + ; res)) + + + +(om::defmethod! lier ((obj chord) &optional (legato 100)) + +(let* ((lparam (sort-table (mat-trans (chord->notes obj)) 2)) + (ldurres (x-append (om-round (om/ (om* legato (x->dx (nth 2 lparam)))) 100) (last-elem (nth 3 lparam)))) + (lparam (list (nth 0 lparam) (nth 1 lparam) (nth 2 lparam) ldurres (nth 4 lparam)))) + (notes->chord (mat-trans lparam)))) + + +(om::defmethod! lier ((obj multi-seq) &optional (legato 100)) + (mki 'multi-seq + :chord-seqs (car-mapcar 'lier (chord-seqs obj) legato))) + + +;====Rename lier as slur 28-06-2007======================================== + +(om::defmethod! lier ((obj chord-seq) &optional (legato 100)) + :initvals '(nil 100) + :icon 137 + :doc "Adds a slur to the notes within an object . +In case is a chord sequence object: Each note of every chord will will be modified to last exactly until the subsequent onset. +In case is a chord object: Each note will be modified to last exactly until the subsequent note occurs (if onsets are <>0). + +Optional: =percentage of the total duration (i.e. 100% means perfect legato; > 100 means overlap, <100 means staccato)." + + (lier obj legato)) + +(om::defmethod! slur ((obj chord) &optional (legato 100)) + :icon 137 + (lier obj legato)) + +(om::defmethod! slur ((obj multi-seq) &optional (legato 100)) + :icon 137 + (lier obj legato)) + +;========================================================================== + +(om::defmethod! lier* ((obj t) (muldur number) &optional (legato 100)) + :initvals '(nil 1 100) + :icon 137 + :doc "Adds a slur and a duration stretch to the notes of an object . The stretch is obtained by a multiplication of the duration values, leading to an accelerando or rallentando)." + + (lier (om* obj muldur) legato)) + + +;====Rename lier* as slur-stretch 28-06-2007================================ + +(om::defmethod! slur-stretch ((obj t) (muldur number) &optional (legato 100)) + :initvals '(nil 1 100) + :icon 137 + :doc + "Adds a slur and a duration stretch to the notes of an object . The stretch is obtained by a multiplication of the duration values." + + (lier* obj muldur legato)) + +;============================================================================ + +(om::defmethod! lier-nth ((obj multi-seq) (nth t) &optional (legato 100) ) + :initvals '(nil 0 100) + :icon 137 + :doc "Adds a slur to the notes within the chord sequence objects within a multi sequence object . + may be a number or a list." + +(let ((long (1- (length (chord-seqs obj)))) (nth (list! nth)) res) + (for (n 0 1 long) + (push (if (included? n nth) (lier (nth-obj obj n) legato) (nth-obj obj n)) res)) + (mki 'multi-seq + :chord-seqs (nreverse res)))) + + +;====Rename lier-nth as n-slur 28-06-2007==================================== + +(om::defmethod! lier-nth ((obj multi-seq) (nth t) &optional (legato 100)) + :initvals '(nil 0 100) + :icon 137 + :doc "Adds a slur to the notes within the chord sequence objects within a multi sequence object . + may be a number or a list." + + (lier-nth obj nth legato)) + +;============================================================================ + + + + + + + + +(om::defmethod! ch-modif ((object t) (fct t) (arg t) (slot t)) + :initvals '(nil '+ 100 'lmidic) + :menuins '((3 (("midic" 'lmidic) ("vel" 'lvel) ("dur" 'ldur) ("offset" 'loffset) ("chan" 'lchan) ("port" 'lport) ))) + :indoc '("object" "function" "argument" "slot") + :icon 136 + :doc "remplace les valeurs du par ( ) +Si fct est '' = '' remplace ancienne valeur par +Accepte accord, chordseq, multiseq. +Si chseq et arg=liste, la liste des arg et celle des accords sont +dŽroulŽes de faon synchrone. " + + + (let ((res (clone object))) + (set-chord-slot res slot + (if (eq fct '=) + (if (atom arg) (create-list (length (lmidic object)) (om-round arg)) (om-round arg)) + (om-round (tm-oper fct (funcall slot res ) arg)))) + res)) + + +(om::defmethod! ch-modif ((object list) (fct t) (arg t) (slot t)) + (car-mapcar 'ch-modif object fct arg slot)) + +; a cause mauvaise definition de setf lport + +(om::defmethod! ch-modif ((object chord-seq) (fct t) (arg t) (slot t)) + (let ((res (clone object)) + (arg (if (and (eq slot 'lport) (one-elem arg)) (create-list (mapcar 'length (lmidic object)) arg) arg))) + (set-chord-slot res slot + (if (eq fct '=) + (if (atom arg) (create-list (length (lmidic object)) (om-round arg)) (om-round arg)) + (om-round (tm-oper fct (funcall slot res ) arg)))) + res)) + +; corr 26-9-03 + +(om::defmethod! ch-modif ((object multi-seq) (fct t) (arg number) (slot t)) +(mki 'multi-seq + :chord-seqs (loop for chseq in (chord-seqs object) + collect (ch-modif chseq fct arg slot)))) + + +(om::defmethod! ch-modif ((object multi-seq) (fct t) (arg list) (slot t)) + (mki 'multi-seq + :chord-seqs (loop for chseq in (chord-seqs object) + for a in arg + collect (ch-modif chseq fct a slot)))) + + + + +(defun set-chord-slot (accord slot value) + + (cond ((eq slot 'lmidic) (setf (lmidic accord) value)) + ((eq slot 'ldur) (setf (ldur accord) value)) + ((eq slot 'loffset) (setf (loffset accord) value)) + ((eq slot 'lchan) (setf (lchan accord) value)) + ((eq slot 'lvel) (setf (lvel accord) value)) + ((eq slot 'lport) (setf (lport accord) value)) )) + + + + + +; ajout options 14-9-02 + +(om::defmethod! ch-distor ((object t) (min number) (max number) (mode t) &optional (minin nil) (maxin nil)) + :initvals '(nil 3600 8400 'midic nil nil) + :menuins '((3 (("midic" 'midic) ("freq" 'freq) ("multipl" 'multipl) ))) + :indoc '("object" "nv minimum" "nv maximum" "mode" "min ref" "max ref") + :icon 137 + :doc "distorsion de hauteur. Indiquer nouvelles hauteurs minimales et maximales. +Option : donner des hauteurs min et max de reference (cf fonction om-scale) +Si mode 'midic' : distorsion calculŽe sur midic +Si mode 'freq' : distorsion calculŽe sur fq (donner nŽanmoins les min et max en midic) +Si mode 'multipl' : distorsion calculŽe sur fq, min et max sont des multiplicateurs de +la frequence (ie. si min et max = 1, rien ne se passe, si min = 2, la hauteur la plus basse est +remontŽe d'une octave, etc... +Accepte accord, chordseq, multiseq, liste chseq." + (let* ((res (clone object)) + (midics (lmidic object) ) + (minmidics (if (null minin) (list-min midics) minin)) + (maxmidics (if (null maxin) (list-max midics) maxin))) + + (set-chord-slot res 'lmidic (om-round + (cond ((eq mode 'midic) (om-scale midics min max minmidics maxmidics)) + ((eq mode 'freq) (f->mc (om-scale (mc->f midics) (mc->f min) (mc->f max) + (mc->f minmidics) (mc->f maxmidics)))) + ((eq mode 'multipl) (f->mc (om-scale (mc->f midics) (* min (mc->f minmidics)) + (* max (mc->f maxmidics)) (mc->f minmidics) (mc->f maxmidics))))))) +res)) + + + + + +(defun multi-distor (object min max minmidics maxmidics mode ) +(let* ((res (clone object)) + (midics (lmidic object) )) + (set-chord-slot res 'lmidic (om-round + (cond ((eq mode 'midic) (om-scale midics min max minmidics maxmidics)) + ((eq mode 'freq) (f->mc (om-scale (mc->f midics) (mc->f min) (mc->f max) + (mc->f minmidics) (mc->f maxmidics)))) + ((eq mode 'multipl) (f->mc (om-scale (mc->f midics) (* min (mc->f minmidics)) + (* max (mc->f maxmidics)) (mc->f minmidics) (mc->f maxmidics))))))) +res)) + + +; liste chseq +(om::defmethod! ch-distor ((object list) (min number) (max number) (mode t) &optional (minin nil) (maxin nil)) + (let* ((midics (mapcar 'lmidic object)) + (minmidics (if (null minin) (list-min midics) minin)) + (maxmidics (if (null maxin) (list-max midics) maxin))) +(car-mapcar 'multi-distor object min max + minmidics maxmidics mode))) + + +(om::defmethod! ch-distor ((object multi-seq) (min number) (max number) (mode t) &optional (minin nil) (maxin nil)) + (mki 'multi-seq + :chord-seqs (ch-distor (chord-seqs object) min max mode minin maxin))) + + + +; interpolation d'accords + +(om::defmethod! ch-interpol ((begin chord) (end chord) (samples integer) (curve float) (mode t)) + :initvals '(nil nil 4 1.0 'midic) + :menuins '((4 (("midic" 'midic) ("freq" 'freq) ))) + :icon 136 + :doc "interpole des accords (de mme nombre de notes) ; mode : interpolation par midic ou par freq +dur et vel sont aussi interpolŽs +canaux et ports = canaux et ports accord initial +rend un chord-seq" + (let ((res (mki 'chord-seq + :LMidic (om-round (if (eq mode 'midic) (interpolation (lmidic begin) (lmidic end) samples curve) + (fq-interpol (lmidic begin) (lmidic end) samples curve))) + :Ldur (om-round (interpolation (ldur begin) (ldur end) samples curve)) + :LOffset (om-round (interpolation (loffset begin) (loffset end) samples curve)) + :Lchan (create-list samples (lchan begin)) + :Lvel (om-round(interpolation (lvel begin) (lvel end) samples curve)) + :lonset (dx->x 0 (mapcar 'list-max (om-round (interpolation (ldur begin) (ldur end) samples curve)))) + ))) + +(set-chord-slot res 'lport (create-list samples (lport begin))))) + + + + + + +(om::defmethod! lonset-modif ((object chord-seq) (fct t) (arg t) &optional (deb nil) (fin nil)) + :initvals '(nil '* 2 nil nil) + :icon 137 + :doc "remplace les valeurs du slot 'lonset' par ( ) +Si fct est '' = '' remplace ancienne valeur par +Si arg=liste, la liste des arg et celle des accords sont +dŽroulŽes de faon synchrone +Accepte chseq et mseq +Optional : permet de ne traiter qu'une sŽlection, entre deb et fin" +(if (null deb) + (mki 'chord-seq + :LMidic (get-chords object) + :lonset (if (eq fct '=) + arg + (om-round (tm-oper fct (lonset object ) arg))) + :legato (legato object)) + (lonset-modif-sel object fct arg deb fin))) + + + +(om::defmethod! lonset-modif ((object multi-seq) (fct t) (arg number) &optional (deb nil) (fin nil)) + (if (null deb) + (mki 'multi-seq + :chord-seqs + (car-mapcar 'lonset-modif (chord-seqs object) fct arg)) + (lonset-modif-sel object fct arg deb fin))) + + +(defun lonset-modif2 (object arg fct deb fin) +(lonset-modif object fct arg deb fin)) + +(om::defmethod! lonset-modif ((object multi-seq) (fct t) (arg list) &optional (deb nil) (fin nil)) +(mki 'multi-seq + :chord-seqs + (double-mapcar 'lonset-modif2 (chord-seqs object) arg fct deb fin ))) + + + + + +(om::defmethod! lonset-modif-sel ((object chord-seq) (fct t) (arg t) (deb integer) (fin t) ) + :initvals '(nil '* 2 1000 2000) + :icon 136 + (let ((fin (if (null fin) (last-elem (lonset object)) fin)) newonsets) + (dolist (att (lonset object)) + (if (<> att deb fin '<>=) + (push (if (eq fct '=) + arg + (om-round (funcall fct att arg))) newonsets) + (push att newonsets))) + (mki 'chord-seq + :LMidic (get-chords object) + :lonset (nreverse newonsets) + :legato (legato object)))) + + +(om::defmethod! lonset-modif-sel ((object chord-seq) (fct t) (arg t) (deb integer) (fin t) ) + :initvals '(nil ) + :icon 136 + (mki 'multi-seq + :chord-seqs + (loop for seq in (chord-seqs object) + collect (lonset-modif-sel seq fct arg deb fin)))) + + + + + +(om::defmethod! reverse-obj ((object chord) ) + :initvals '(nil ) + :icon 136 + (setf (loffset (clone object)) (nreverse (loffset object)))) + + +(om::defmethod! reverse-obj ((object chord-seq) ) + :initvals '(nil ) + :icon 136 +(reverse-chseq object (first (lonset object)))) + + +(om::defmethod! reverse-obj ((object multi-seq) ) + +(let ((lastatt (list-max (flat (mapcar 'butlast (lonset object)))))) + + (mki 'multi-seq + :chord-seqs + (loop for seq in (chord-seqs object) + collect (reverse-chseq seq (- lastatt (last-elem (butlast (lonset seq ))))))))) + + +(defun reverse-chseq (object deb) +(let ((newonsets (x-append (dx->x deb (nreverse (butlast (x->dx (lonset object))))) + (last-elem (lonset object))))) +(mki 'chord-seq + :LMidic (nreverse (mapcar 'reverse-obj (get-chords object))) + :lonset newonsets + :legato (legato object)))) + + + + + + + + + + + + +(defun chord-filter1 (accord deb fin numer denom ) + (let* ((liste (arithm-crible deb (min fin (1- (length (lmidic accord)))) numer denom))) + (mki 'chord + :LMidic (posn-match (lmidic accord) liste) + :Ldur (posn-match (ldur accord) liste) + :Loffset (posn-match (loffset accord) liste) + :Lchan (posn-match (lchan accord) liste) + :Lvel (posn-match (lvel accord) liste) + :Lport (posn-match (lport accord) liste) +))) + +(om::defmethod! ch-filter ((objet chord) (deb integer) (fin integer) &optional (numer 1) (denom 1)) + :initvals '((make-instance 'chord) 1 2 1 1) + :indoc '("object" "dŽbut" "fin" "numŽrateur" "dŽnominateur") + :icon 137 + :doc "ne garde de l'objet accord que les notes dont le numero +d'ordre est compris entre deb et fin +options: filtrage en peigne : garder +numer sur denom " + (chord-filter1 objet deb fin numer denom )) + + +(om::defmethod! ch-filter ((objet chord) (deb integer) (fin null) &optional (numer 1) (denom 1)) +(ch-filter objet deb (1- (length (lmidic objet))) numer denom )) + + + +(om::defmethod! ch-filter ((objet chord-seq) (deb integer) (fin integer) &optional (numer 1) (denom 1)) + (let* ((lchords (car-mapcar #'chord-filter1 (get-chords objet) deb fin numer denom )) + (res (objfromobjs lchords objet))) + (setf (lonset res) (lonset objet)) + (setf (legato res) (legato objet)) + res)) + + + + + +; faire methode pour ch-seq et multi-seq - pb : le filtrage peut rapporter des ch-seq vides + + +(om::defmethod! ch-test-filter ((obj chord) (fct t) (arg t) (slot t)) + :initvals '(nil '> 10800 'lmidic) + :menuins '((3 (("midic" 'lmidic) ("vel" 'lvel) ("dur" 'ldur) ("offset" 'loffset) ("chan" 'lchan)))) + :icon 136 + :doc "filtre les notes qui rŽpondent au test - chord et ch-seq seulement " + (let ((notes (chord->notes obj)) + (nbslot (position slot '(lmidic lvel loffset ldur lchan))) + res) + (dolist (n notes) + (if (not (funcall fct (nth nbslot n) arg) ) (push n res))) + (notes->chord (nreverse res)))) + +(om::defmethod! ch-test-filter ((obj chord-seq) (fct t) (arg t) (slot t)) +(let ((lchords (get-chords obj)) (lonsets (lonset obj)) reschord resonset) + (for (i 0 1 (1- (length lchords))) + (let ((ch (ch-test-filter (nth i lchords) fct arg slot))) + (if (not (null (lmidic ch))) + (progn (push ch reschord) (push (nth i lonsets) resonset))))) + (mki 'chord-seq + :Lmidic (nreverse reschord) + :Lonset (nreverse resonset) + :legato (legato obj)))) + + + +; faire methode liste d'accords +; le filtrage ne tient pas compte des velocitŽs ; idŽalement, il faudrait garder la note +; ayant la plus forte vŽlocitŽ + +(om::defmethod! ch-remdup ((obj chord) (approx integer) ) + :initvals '(nil 4) + :icon 136 + :doc "retire les notes de hauteur identique, selon l'approximation indiquŽe " +(let ((notes (chord->notes obj)) + (midics (cdr (approx-m (lmidic obj) approx))) + res) + (dolist (n notes) + (if (not (member (approx-m (first n) approx) midics)) + (push n res)) + (setf midics (cdr midics))) + (notes->chord (nreverse res)))) + + +(om::defmethod! ch-remdup ((obj chord-seq) (approx integer) ) +(mki 'chord-seq + :Lmidic (list! (car-mapcar 'ch-remdup (chords obj) approx)) ;list! permet ch-seq ne comportant qu'un seul accord + :Lonset (lonset obj) + :legato (legato obj))) + +(om::defmethod! ch-remdup ((object multi-seq) (approx integer) ) + (mki 'multi-seq + :chord-seqs (car-mapcar 'ch-remdup (chord-seqs object) approx))) + +; nv version ˆ tester +; garde la plus forte vŽlocitŽ, le + petit midi, la + longue durŽe, le + petit offset + +(om::defmethod! ch-remdup ((obj chord) (approx integer) ) + :initvals '(nil 4) + :icon 136 + :doc "retire les notes de hauteur identique, selon l'approximation indiquŽe " + (let ((notes (chord->notes obj)) + (midics (approx-m (lmidic obj) approx)) + lpos res) + (dolist (n notes) + (push (positions midics (approx-m (first n) approx) ) lpos) + ) + (dolist (pos (remove-dup lpos 'equal 1)) + (let* ((dupnotes (posn-match notes pos)) + (dpitch (first (first dupnotes))) + (dvel (list-max (mapcar 'second dupnotes))) + (doff (list-min (mapcar 'third dupnotes))) + (ddur (list-max (mapcar 'fourth dupnotes))) + (dchan (list-min (mapcar 'fifth dupnotes))) + (dport (list-min (mapcar 'sixth dupnotes)))) + (push (list dpitch dvel doff ddur dchan dport) res))) + (notes->chord res))) + + + + + +(om::defmethod! ch-vocoder ((object chord) (reservoir list) + &optional (mode 'midic)) + :initvals '((make-instance 'chord) '(6000 6400) 'midic) + :menuins '((2 (("Midics" 'midic) ("Freqs" 'freqs)))) + :indoc '("object" "rŽservoir" "mode") + :icon 137 + :doc + "Applies the structure of an object onto a harmonic reservoir . It chooses those values from the harmonic reservoir which match the structure of most closely. may be a chord, chord-seq, multi-seq or a list of chord-seq. Because of the extended possibilities for the format of the input, this is a slightly more elaborate function than vocoder." + +(mki 'chord + :LMidic (vocoder (lmidic object) reservoir mode) + :Ldur (ldur object ) + :LOffset (loffset object ) + :Lchan (lchan object ) + :Lvel (lvel object ) + :Lport (lport object ) +)) + +(om::defmethod! ch-vocoder ((object chord-seq) (reservoir list) + &optional (mode 'midic)) + + + (mki 'chord-seq + :lmidic (loop for ch in (chords object) + collect (ch-vocoder ch reservoir mode)) + :lonset (lonset object) + :legato (legato object))) + + + +(om::defmethod! ch-vocoder ((object multi-seq) (reservoir list) &optional (mode 'midic )) + (mki 'multi-seq + :chord-seqs (ch-vocoder (chord-seqs object) reservoir mode))) + + +(om::defmethod! ch-vocoder ((object list) (reservoir list) &optional (mode 'midic) ) + (car-mapcar 'ch-vocoder object reservoir mode)) + + + + +(om::defmethod! channel->micro ((object chord) (approx integer) &optional (mode 'keep)) + :initvals '((make-instance 'chord) 4 'keep) + :menuins '((1 (("1/4" 4) ("1/8" 8))) (2 (("Keep" 'keep) ("Reduce" 'reduce)))) + :icon 137 + :doc "transforms midi channel informations into midicents; ie chan 1 -> natural, +chan 2 -> +25 cents, chan 3 -> + 50 cents, chan 4 -> + 75 cents (when approx = 1/8). +When approx = 1/4 : chan 1 and chan 2 -> natural, chan 3 & chan 4 -> + 50 cents +Mode : 'keep' = chan 5, 6, 7, 8 become chan 5 + midicent increment, and so forth +'reduce' = all channels become chan 1 + midicent increment" + (let ((lincr (if (= approx 8 ) (om-modulo (om- (lchan object) 1) 4) + (om* 2 (om// (om-modulo (om- (lchan object) 1) 4) 2)))) + (lcan (if (eq mode 'keep) (om+ 1 (om* 4 (om// (om- (lchan object) 1) 4))) + 1))) + (mki 'chord + :LMidic (om+ (lmidic object) (om* lincr 25)) + :Ldur (ldur object ) + :LOffset (loffset object ) + :Lchan lcan + :Lvel (lvel object ) + :Lport (lport object )))) + +(om::defmethod! channel->micro ((object chord-seq) (approx integer) &optional (mode 'keep)) + (let ((lincr (if (= approx 8 ) (om-modulo (om- (lchan object) 1) 4) + (om* 2 (om// (om-modulo (om- (lchan object) 1) 4) 2)))) + (lcan (if (eq mode 'keep) (om+ 1 (om* 4 (om// (om- (lchan object) 1) 4))) + 1))) + (mki 'chord-seq + :LMidic (om+ (lmidic object) (om* lincr 25)) + :lonset (lonset object) + :Ldur (ldur object ) + :LOffset (loffset object ) + :Lchan lcan + :Lvel (lvel object ) + :Lport (lport object )))) + + +; comparer avec chseq->multi-seq +; ajout de la mŽthode port->canal+ et rŽciproquement pour rŽpartir les ch-seq en fonction +; des ports et des canaux + +#| (om::defmethod! channel->voice ((obj multi-seq) (align t) &optional (canaux nil )) + :initvals '(nil 50 nil) + :icon 137 + :doc "organise multi-seq : chaque canal est mis sur une piste diffŽrente +La structure d'accords n'est pas gardŽe telle qu'elle etait dans l'objet d'origine, mais +reconstruite en fonction de la valeur de (ms). Si align = nil, les accords ne +sont pas reconstruits . +Les pistes sont rangŽes dans l'ordre des canaux, sauf si on donne une liste ordonnŽes de canaux +(optional : canaux)" +(let ((lnotes (flat-once (seq->notes obj))) + (canaux (if (null canaux) (canaux obj) canaux)) + lchseq) + (dolist (chan canaux) + (push (mkpiste1 lnotes chan 'remove) lchseq)) + (align-chords (mki 'multi-seq :chord-seqs (nreverse (remove nil lchseq)) ) align))) +|# + + +(om::defmethod! channel->voice ((obj multi-seq) (align t) &optional (canaux nil )) + :initvals '(nil 50 nil) + :icon 137 + :doc "organise multi-seq : chaque canal est mis sur une piste diffŽrente +La structure d'accords n'est pas gardŽe telle qu'elle etait dans l'objet d'origine, mais +reconstruite en fonction de la valeur de (ms). Si align = nil, les accords ne +sont pas reconstruits . +Les pistes sont rangŽes dans l'ordre des canaux, sauf si on donne une liste ordonnŽes de canaux +(optional : canaux)" +(let* ((obj (pc+ obj)) + (lnotes (flat-once (seq->notes obj))) + (canaux (if (null canaux) (canaux obj) canaux)) + lchseq) + (dolist (chan canaux) + (push (mkpiste1 lnotes chan 'remove) lchseq)) + (cp+ (align-chords (mki 'multi-seq :chord-seqs (nreverse (remove nil lchseq)) ) align)))) + + + +(om::defmethod! channel->voice ((obj chord-seq) (align t) &optional (canaux nil )) +(let* ((obj (pc+ obj)) + (lnotes (seq->notes obj)) + (canaux (if (null canaux) (canaux obj) canaux)) + lchseq) + (dolist (chan canaux) + (push (mkpiste1 lnotes chan 'remove) lchseq) ) + (cp+ (align-chords (mki 'multi-seq :chord-seqs (nreverse (remove nil lchseq)) ) align)))) + + +#| + +(om::defmethod! channel->voice ((obj chord-seq) (align t) &optional (canaux nil )) +(let ((lnotes (seq->notes obj)) + (canaux (if (null canaux) (canaux obj) canaux)) + lchseq) + (dolist (chan canaux) + (push (mkpiste1 lnotes chan 'remove) lchseq) ) + (align-chords (mki 'multi-seq :chord-seqs (nreverse (remove nil lchseq)) ) align))) +|# + + +; note = pitch (+ onset offset) dur vel chan + + +; retester seq-part (mkpiste changŽ pour Žviter chseq vides) + + +(defun mkpiste1 (lnotes chan mode) + (let ( res) + (dolist (note lnotes) + (if (= chan (fifth note)) + (push note res))) + (if (null res) + (if (eq mode 'remove) () (notes->seq '((6000 0 10 0 1 999)))) ; note bidon pour Žviter chseq vide + (notes->seq (nreverse res))))) + + + +(defun mkpiste2 (lnotes chan mode) + (let (res) + (dolist (note lnotes) + (cond ((= (first chan) (fifth note)) (push note res)) + ((= (second chan) (fifth note)) + (push (list (+ (first note) 50) (second note) (third note) (fourth note) (first chan) (sixth note)) + res)))) + (if (null res) + (if (eq mode 'remove) () (notes->seq '((6000 0 10 0 1 999)))) + (notes->seq (nreverse res))))) + + + + + +(om::defmethod! seq-part ((object chord-seq) (appar list) &optional (mode 'remove) + (delta 0)) + :initvals '(nil ((1 3) (2 4) 6 8) 'remove 0) + :menuins '((2 (("remove" 'remove) ("keep" 'keep)))) + :icon 137 + :doc "lit ch-seq provenant d'un enregistrement ; rend liste de ch-seq pour multi-seq. +Les structures d'accord ne sont pas gardŽes; les ch-seq ne contiennent qu'une seule note. +Les notes sont rŽparties dans diffŽrents ch-seq, en fct des canaux et de la liste +les canaux appariŽs sont fondus, le deuxiŽme canal de chaque couple +Žtant considŽrŽ comme jouant 1/4 de ton -> chseq dont canal = 1er canal +si une seule piste indiquŽe : chseq gardant canal original + syntaxe de : ((1 3) (2 4) 6 8) +optional : 'remove' = enlever les ch-seq vides (pas de notes correspondant au canal midi demandŽ) +'keep' = il y aura des ch-seq vides (permet de garder la mme disposition entre plusieurs multi-seq +delta : permet de regrouper les notes en accord quand elle sont sŽparŽes de moins de ms +que la valeur indiquŽe (cf 'align-chords' ) " +(let ((lnotes (seq->notes object)) + lchseq) + (dolist (chan appar) + (if (atom chan) + (push (mkpiste1 lnotes chan mode) lchseq) + (push (mkpiste2 lnotes chan mode) lchseq))) + (if (> delta 0) + (car-mapcar 'align-chords (nreverse (remove nil lchseq)) delta) + (nreverse (remove nil lchseq))))) + + + + + + +(om::defmethod! chseq->mseq ((object chord-seq) (chan list) &optional (mode 'remove) + ) + :initvals '(nil (1 3 5 6 8) 'remove ) + :menuins '((2 (("remove" 'remove) ("keep" 'keep)))) + :icon 137 + :doc "lit ch-seq ; rend liste de ch-seq pour multi-seq. +Les structures d'accord ne sont pas gardŽes; les ch-seq ne contiennent qu'une seule note. +Les notes sont rŽparties dans diffŽrents ch-seq, en fct des canaux +optional : 'remove' = enlever les ch-seq vides (pas de notes correspondant au canal midi demandŽ) +'keep' = il y aura des ch-seq vides (permet de garder la mme disposition entre plusieurs multi-seq + " +(let ((lnotes (seq->notes object)) lchseq ) + (dolist (c chan) + (push (mkpiste1 lnotes c mode) lchseq)) +(mki 'multi-seq :chord-seqs + (nreverse (remove nil lchseq))))) + + + +(om::defmethod! velo ((object container) (mulvel number) ) + :initvals '(nil .5 ) + :icon 136 + :doc "multiplie vŽlocitŽs" +(ch-modif object 'om* mulvel 'lvel)) + +(om::defmethod! velo ((liste list) (mulvel number) ) + :initvals '(nil .5) + :icon 136 + :doc "multiplie vŽlocitŽs" +(om-round (om* liste mulvel))) + + +; ajouter choix de pistes pour multi-seq +(om::defmethod! tm-cresc ((object chord-seq) (fact1st number) (factlast number) + &optional (ref nil) (factref 2 )) + :initvals '(nil 1.0 4.0 nil 3.0 ) + :icon 137 + :doc "multiplie vŽlocitŽs en forme de cresc ou de dim; multi-seq : ne marche bien que si les pistes contiennent +des donnŽes reparties dans le temps de manire semblable" + +(ch-modif object '= (om-round (l*curb (lvel object) fact1st factlast ref factref )) 'lvel)) + + + +(om::defmethod! tm-cresc ((object multi-seq) (fact1st number) (factlast number) + &optional (ref nil) (factref 2 )) + (mki 'multi-seq :chord-seqs (car-mapcar 'tm-cresc (chord-seqs object) fact1st factlast ref factref))) + + + + + + + +(om::defmethod! duree ((object container) (dur number)) + :initvals '(nil 2000 ) + :icon 136 + :doc "donne ˆ l'objet la durŽe dur, en faisant un scaling" + + (om* object (/ dur (obj-dur object)))) + +;===Rename duree as tm-dur as to avoid the same name present in om2csound 28-06-2007=========== + +(om::defmethod! tm-dur ((object container) (dur number) ) + :initvals '(nil 2000 ) + :icon 136 + :doc "Returns the with a a desired duration . The processing is done through scaling of the duration values." + + (duree object dur)) +;============================================================================================== + + + +(om::defmethod! canal ((object container) (can t) ) + :initvals '(nil 1 ) + :icon 136 + :doc "donne ˆ l'objet le canal can" + (ch-modif object '= can 'lchan)) + + +(om::defmethod! newport ((object container) (port t) ) + :initvals '(nil 1 ) + :icon 136 + :doc "donne ˆ l'objet le port " + (ch-modif object '= port 'lport)) + + + +(om::defmethod! arpeggio ((obj chord) (dur t) (direction t) (curve number) &optional (format 'chord) ) + :initvals '(nil 1000 'up 50 'chord) + :menuins '((2 (("up" 'up) ("down" 'down))) (4 (("chord" 'chord) ("chord-seq" 'chord-seq))) ) + :icon 137 + :doc "arpeggiates chord . Order of chord is kept (use before to order chord if necessary) +Duration of notes are not changed . Use after to synchronise endings. +Curve = 50 :linear 0-49 : rall 51-100 : accel" + (let* ((arp (om-round (deformer% (n-arithm 0 dur (ch-length obj)) curve))) + (offs (if (eq direction 'up) arp (reverse arp)))) + + (if (eq format 'chord) (ch-modif obj '= offs 'loffset) + (explosion (ch-modif obj '= offs 'loffset))))) + + +(om::defmethod! accel-ral ((obj chord-seq) (curve number) &optional (muldur 1.0) ) + :initvals '(nil 50 1.0 ) + :icon 137 + :doc "creates accel or rall according to the value of : +Curve = 50 :linear 0-49 : rall 51-100 : accel +Only onsets are modified. See s-curve (also called seq-stretch-curve) for a more +sophisticated function. +multi-seq: will work well only if chord-seqs have same length +optional : muldur = multiplicator of total duration" + (om* (lonset-modif obj '= (om-round (deformer% (lonset obj) curve))) muldur)) + + +(om::defmethod! accel-ral ((obj multi-seq) (curve number) &optional (muldur 1.0) ) + (mki 'multi-seq :chord-seqs (car-mapcar 'accel-ral (chord-seqs obj) curve muldur))) + + + + +(om::defmethod! synch-fin ((object chord) (end number) ) + :initvals '(nil 2000 ) + :icon 136 + :doc "toutes les notes de l'objet finissent en mme temps (utile si attaques dŽcalŽes, mais fin synchrone)" + (let ((nvdur + (loop for d in (ldur object) + for o in (loffset object) + collect (if (< end o) d (- end o))))) + (ch-modif object '= nvdur 'ldur))) + +(om::defmethod! synch-fin ((object chord-seq) (end number) ) + (let* ((lendpoints (om- end (lonset object)))) + (mki 'chord-seq + :lmidic (loop for ch in (chords object) + for e in lendpoints + collect (synch-fin ch e)) + :lonset (lonset object)))) + + +(om::defmethod! synch-fin ((object multi-seq) (end number) ) + (mki 'multi-seq :chord-seqs (car-mapcar 'synch-fin (chord-seqs object) end))) + + + + + +(om::defmethod! ch-trim ((object chord) (end number) ) + :initvals '(nil 2000 ) + :icon 136 + :doc "no note will end later than end value " + (let* ((endpoint (om+ (loffset object) (ldur object))) + (nvdur (om- (loop for i in endpoint + collect (min i end))(loffset object) ))) + (if (test<=0 nvdur) (print "end value too small") + (ch-modif object '= nvdur 'ldur)))) + + +(om::defmethod! ch-trim ((object chord-seq) (end number) ) + (let* ((lendpoints (om- end (lonset object)))) + (mki 'chord-seq + :lmidic (loop for ch in (chords object) + for e in lendpoints + collect (ch-trim ch e)) + :lonset (lonset object)))) + + +(om::defmethod! ch-trim ((object multi-seq) (end number) ) + (mki 'multi-seq :chord-seqs (car-mapcar 'ch-trim (chord-seqs object) end))) + + + +(defun test<=0 (list) +(let ((flag nil)) + (dolist ( v list) + (if (<= v 0) (setf flag t))) +flag)) + + + + + + +; nv methode qui regroupe chord-stretch et seq-stretch (qui sont gardŽs pour compatibilitŽ) +; synonyme : om* (mŽthodes ajoutŽes en tte de fichier) +; il y a une mŽthode stretch dans geste.lisp ; heureusement les arguments sont compatibles, et le type diffŽrent! + +(om::defmethod! stretch ((object chord-seq) (muldur number) ) + :initvals '(nil 2) + :icon 136 + :doc "multiplie (onset), dur et offset par muldur. Accepte multi-seq" + (seq-stretch object muldur)) + +(om::defmethod! stretch ((object multi-seq) (muldur t) ) + (seq-stretch object muldur)) + +(om::defmethod! stretch ((object chord) (muldur t) ) + (chord-stretch object muldur)) + + + + +(om::defmethod! seq-stretch ((object chord-seq) (muldur number) ) + :initvals '(nil 2) + :icon 136 + :doc "multiplie onset, dur et offset par muldur. Accepte multi-seq" +(mki 'chord-seq + :LMidic (lmidic object) + :lonset (om-round (om* muldur (lonset object))) + :Ldur (om-round (om* muldur (ldur object ))) + :LOffset (om-round (om* muldur (loffset object ))) + :Lchan (lchan object ) + :Lvel (lvel object ) + :Lport (lport object ) + :legato (legato object))) + + + + +(om::defmethod seq-stretch ((self chord-seq) (num list)) + (append-seq + (loop for n in num + collect (seq-stretch self n )) nil)) + + + + +(om::defmethod! seq-stretch ((object multi-seq) (muldur number) ) + (mki 'multi-seq + :chord-seqs (car-mapcar 'seq-stretch (chord-seqs object) muldur))) + + + +(om::defmethod! chord-stretch ((object chord) (muldur number) ) + :initvals '(nil 2) + :icon 136 + :doc "multiplie dur et offset par muldur" +(mki 'chord + :LMidic (lmidic object) + :Ldur (om-round (om* muldur (ldur object ))) + :LOffset (om-round (om* muldur (loffset object ))) + :Lchan (lchan object ) + :Lvel (lvel object ) + :Lport (lport object ) + )) + + +(om::defmethod! chord-stretch ((self chord) (num list)) + (let ((lchords + (loop for n in num + collect (chord-stretch self n )))) + (mki 'chord-seq + :lmidic lchords + :lonset (om-round (dx->x 0 (om* (obj-dur self) num)))))) + + + +(om::defmethod! stretch-chunk ((object chord-seq) (begin number) (end number) (muldur number) &optional (voice 0 )) + :initvals '(nil 1000 2000 0.7 0) + :icon 137 + :doc "stretches the region between begin and end by a factor muldur. Whatever is after does not move. +Overlapping or gap may result. If object is a multi-seq , indicate voice(s) concerned" + + (paste-in-multi object (seq-stretch (selectf object begin end voice) muldur) voice begin 'replace)) + + +(om::defmethod! stretch-chunk ((object multi-seq) (begin number) (end number) (muldur number) &optional (voice 0 )) + :initvals '(nil 1000 2000 0.7 0) + :icon 137 + :doc "stretches the region between begin and end by a factor muldur. Whatever is after does not move. +Overlapping or gap may result. If object is a multi-seq , indicate voice(s) concerned" + + (paste-in-multi object (seq-stretch (selectf object begin end voice) muldur) voice begin 'replace)) + + + + +(om::defmethod! stretch-region ((object chord-seq) (begin number) (end number) (muldur number) ) + :initvals '(nil 1000 2000 0.7) + :icon 136 + :doc "stretches the region between begin and end by a factor muldur. +The region situated after is moved accordingly. Accepts chord-seq and multi-seq " + + (let ((newdur (om-round(* muldur (- end begin))))) + (chainer (list (selectf object 0 begin) (seq-stretch (selectf object begin end) muldur) (selectf object end nil)) + (list 0 begin (+ begin newdur))))) + + +(om::defmethod! stretch-region ((object multi-seq) (begin number) (end number) (muldur number) ) + + (let ((newdur (om-round (* muldur (- end begin))))) + + (chainer (list (selectf object 0 begin) (seq-stretch (selectf object begin end) muldur) (selectf object end nil)) + (list 0 begin (+ begin newdur))))) + + + + + +; ˆ tester !!! pb with offsets - pb if one elem in chseq +; ne marche pas bien avec mseq - il faudrait une vraie fct de transfert +; durŽes mal recalculŽes + +(om::defmethod! seq-stretch-curve ((object chord-seq) + (fact1st number) (factlast number) + &optional (ref nil) (factref nil )) + :initvals '(nil 1 2.5 nil nil) + :icon 137 + :doc "multiplies onsets, durs and offsets by Lcurb/2 or Lcurb/3 . Accepts multi-seq. +Use after align-chord if division by 0 is detected." + (let ((newonsets (om-round (L*curb (lonset object) fact1st factlast ref factref)))) +(mki 'chord-seq + :LMidic (lmidic object) + :lonset newonsets + :Ldur (om-round (L*curb (ldur object) fact1st factlast ref factref)) + :LOffset (om-round (om* (om/ (x->dx newonsets) (x->dx (lonset object))) (loffset object ))) + :Lchan (lchan object ) + :Lvel (lvel object ) + :Lport (lport object ) + :legato (legato object)))) + + +(om::defmethod! seq-stretch-curve ((object multi-seq) + (fact1st number) (factlast number) + &optional (ref nil) (factref nil )) +(mki 'multi-seq + :chord-seqs + (loop for chseq in (chord-seqs object) + collect (seq-stretch-curve chseq fact1st factlast ref factref)))) + + + +; nom simplifiŽ +(om::defmethod! s-curve ((object multi-seq) + (fact1st number) (factlast number) + &optional (ref nil) (factref nil )) +:initvals '(nil 1 2.5 nil nil) + :icon 137 + :doc "multiplies onsets, durs and offsets by Lcurb/2 or Lcurb/3 . Accepts multi-seq. +Use after align-chord if division by 0 is detected." +(seq-stretch-curve object fact1st factlast ref factref)) + + +(om::defmethod! s-curve ((object chord-seq) + (fact1st number) (factlast number) + &optional (ref nil) (factref nil )) +:initvals '(nil 1 2.5 nil nil) + :icon 137 + :doc "multiplies onsets, durs and offsets by Lcurb/2 or Lcurb/3 . Accepts multi-seq. +Use after align-chord if division by 0 is detected." +(seq-stretch-curve object fact1st factlast ref factref)) + + + + + +; (pitch vel offset dur chan) + +(om::defmethod! filterC4 ((object chord) ) + :initvals '(nil ) + :icon 136 + :doc " sert ˆ neutraliser les C4 indŽsirables en leur donnant une vŽlocitŽ nulle et un port=999" +(notes->chord + (loop for n in (chord->notes object) + collect (if (and (= (first n) 6000) (= (second n) 100) (= (third n) 0) + (= (fourth n) 1000) (= (fifth n) 1)) + (list 6000 0 0 1 1 999) n )))) + + +(om::defmethod! filterC4 ((object chord-seq) ) + (mki 'chord-seq + :LMidic (mapcar 'filterC4 (get-chords object)) + :lonset (lonset object) + :legato (legato object))) + + + +(om::defmethod! filterC4 ((object multi-seq) ) + (mki 'multi-seq :chord-seqs (mapcar 'filterC4 (chord-seqs object)))) + + + + +(om::defmethod! chords->seq ((chord chord) &rest chords ) + :initvals '(nil ) + :icon 137 + :doc "Makes a chord-seq from a list of chords. The onsets are calculated according to offsets and maximum durations for each chord, so neither gap nor overlapping occurs within the new chord sequence. Allows for as many inlets as desired." + +(let ((lchords (flat (list chord chords)))) +(mki 'chord-seq :lmidic lchords :lonset (dx->x 0 (mapcar 'obj-dur lchords))))) + + +(om::defmethod! chords->seq ((chord list) &rest chords ) +(mki 'chord-seq :lmidic chord :lonset (dx->x 0 (mapcar 'obj-dur chord)))) + +;==test this +;tester encore ces mŽthodes - faire un append-seq pour mseq acceptant des dim. diff. + + +(om::defmethod! append-seq ((seq1 chord-seq) (seq2 chord-seq) &optional (interval nil)) + :initvals '(nil nil nil) + :icon 137 + :doc "Puts a chord sequence after another chord sequence at a specified interval after the attack of the last note within . +This means the starting point of occurs at t = (attack of the last note in , taking into account the offset) + . +If = nil, starts right after the end of , taking into account both duration and offset. +Accepts chord sequences and multi sequences of the same dimensions. + may be a list of chord sequence objects or multi sequence objects. + may be one interval or a list of intervals." + +(let* ((lchords1 (get-chords seq1)) + (lchords2 (get-chords seq2)) + (lonset1 (butlast (lonset seq1))) ; lonset comporte une valeur finale du chseq, ˆ Žliminer + (lonset2 (lonset seq2)) + (endseq (list-max (flat (om+ lonset1 (om+ (ldur seq1) (loffset seq1)))))) + (lastattack (list-max (flat (om+ lonset1 (loffset seq1))))) + (delta (if (null interval) endseq (+ interval lastattack)))) + (make-instance 'chord-seq + :Lmidic (flat (list lchords1 lchords2)) + :Lonset (flat (list lonset1 (om+ lonset2 delta) ))))) + + +(om::defmethod! append-seq ((seq1 chord-seq) (seq2 chord) &optional (interval nil)) + (append-seq seq1 (mki 'chord-seq :lmidic (list seq2) :lonset '(0)) interval)) + + +(om::defmethod! append-seq ((seq1 multi-seq) (seq2 multi-seq) &optional (interval nil)) + (let* ((lchseq1 (chord-seqs seq1)) + (lchseq2 (chord-seqs seq2)) + (llonset1 (mapcar 'butlast (lonset seq1))) ;lonset comporte une valeur finale du chseq, ˆ Žliminer + (llonset2 (lonset seq2)) + (endseq (list-max (flat (om+ llonset1 (om+ (ldur seq1) (loffset seq1)))))) + (lastattack (list-max (flat (om+ llonset1 (loffset seq1))))) + (delta (if (null interval) endseq (+ interval lastattack))) + res) + (loop for chseq1 in lchseq1 + for chseq2 in lchseq2 + for lonset1 in llonset1 + for lonset2 in llonset2 + do (push (make-instance 'chord-seq + :Lmidic (flat (list (get-chords chseq1) (get-chords chseq2))) + :Lonset (flat (list lonset1 (om+ lonset2 delta) ))) res) + finally (return (mki 'multi-seq + :chord-seqs (nreverse res)))))) + + + + +(om::defmethod! append-seq ((seq1 list) (seq2 t) &optional (interval nil)) + + (let* ((seq1 (remove nil seq1)) + (interval (if (atom interval) (create-list (1- (length seq1)) interval) interval)) + (res (append-seq (first seq1) (second seq1) (first interval)))) + (for (s 2 1 (1- (length seq1))) + (setq res (append-seq res (nth s seq1) + (if (one-elem interval) interval (nth (- s 1) interval))))) + res)) + +;................................................................................ + + +(om::defmethod! chainer ((seqs list) (onsets list)) + :initvals '(nil '(0 1000)) + :icon 136 + :doc "Creates a sequence which contains all the sequences of the list , pasted at the onsets indicated in the onset list . Accepts multi-seqs - even multi-seqs with different dimensions." + +(if (typep (first seqs) 'chord-seq) (chainer-chseq seqs onsets) (chainer-mseq seqs onsets) )) + + +(defun chainer-chseq (seqs onsets) +(let* ((lchords (flat (mapcar 'get-chords seqs))) + (lastonset (+ (last-elem (lonset (last-elem seqs))) (last-elem onsets))) + (newonsets (loop for seq in seqs + for att in onsets + collect (om+ att (butlast (lonset seq)))))) + (sort-chords (make-instance 'chord-seq + :Lmidic lchords + :Lonset (flat (x-append newonsets lastonset)))))) + + + +(defun chainer-mseq (seqs onsets) + (let* ((lseqs (mapcar 'chord-seqs seqs)) + (nmax (list-max (mapcar 'length lseqs))) res) + +(for (i 0 1 (1- nmax)) + (let* ((chseqs (mapcar #'(lambda (x) (nth i x)) lseqs)) + + (lonsets (loop for j in (arithm-ser 0 (length-1 seqs) 1) + collect (if (not (null (nth j chseqs))) (nth j onsets))) )) + + (push (chainer (list! (remove nil chseqs)) (list! (remove nil lonsets))) res)) ) + + (mki 'multi-seq :chord-seqs (reverse res)))) + + + +(om::defmethod! add-chseq ((seq chord-seq) (mseq multi-seq) &optional (onset 0)) + :initvals '(nil nil 0) + :icon 137 + :doc "Adds (a) chord sequence(s) into a multi sequence. + may be a chord sequence, a list of chord sequence objects or a multi sequence object. + may be a list of the same length as the number of to be added." + + (mki 'multi-seq :chord-seqs (x-append (chord-seqs mseq) (lonset-modif seq '+ onset)))) + + +(om::defmethod! add-chseq ((seq list) (mseq multi-seq) &optional (onset nil)) + (let* ( (onset (if (atom onset) (create-list (1+ (length seq)) onset) onset)) res + (seq (if (null onset ) seq + (loop for s in seq + for o in onset + do (push (lonset-modif s '+ o) res) + finally (return (reverse res)))))) + (mki 'multi-seq :chord-seqs (x-append (chord-seqs mseq) seq)))) + +(om::defmethod! add-chseq ((seq multi-seq) (mseq multi-seq) &optional (onset nil)) + (add-chseq (chord-seqs seq) mseq onset)) + + + +;................................................................................ + + + + + +(defmethod mixe-obj ((obj1 chord) (obj2 chord)) +(mki 'chord + :LMidic (flat (list (lmidic obj1) (lmidic obj2))) + :Ldur (flat (list (ldur obj1) (ldur obj2))) + :LOffset (flat (list (loffset obj1) (loffset obj2))) + :Lchan (flat (list (lchan obj1) (lchan obj2))) + :Lvel (flat (list (lvel obj1) (lvel obj2))) + :Lport (flat (list (lport obj1) (lport obj2))))) + +(defmethod mixe-obj ((obj1 chord-seq) (obj2 chord-seq)) +(mki 'chord-seq + :lmidic (flat (list (get-chords obj1) (get-chords obj2))) + :lonset (flat (list (butlast (lonset obj1)) (butlast (lonset obj2)) + (max (list-max (lonset obj1)) (list-max (lonset obj2))))))) + + +(om::defmethod! mixer ((obj1 chord) (obj2 chord) &rest objs ) + :initvals '(nil nil nil) + :icon 137 + :doc "Mixes two objects (chord, chord sequence or multi sequence objects). permits the mixing of more than two objects. may be a list. may be empty. +If the s are chords, the chords will be mixed into one single chord. +If the s are chord sequence objects or multi sequence objects, the chords will be mixed into a sequence containing the original chords." + + (let ((res (mixe-obj obj1 obj2)) + (objs (flat objs))) + (if (null (car objs)) res + (for (c 0 1 (1- (length objs))) + (setq res (mixe-obj res (nth c objs) )))) + res)) + +(defun multi-mixer (obj1) + (mixer obj1 nil nil)) + +(om::defmethod! mixer ((obj1 list) (obj2 t) &rest objs ) + (if (typep (car obj1) 'multi-seq) + (multi-mixer obj1) + (let ((res (mixe-obj (first obj1) (second obj1)))) + (for (c 2 1 (1- (length obj1))) + (setq res (mixe-obj res (nth c obj1) ))) + res))) + +; a tester + +(om::defmethod! mixer ((obj1 chord-seq) (obj2 chord-seq) &rest objs ) + (let ((res (mixe-obj obj1 obj2)) + (objs (flat objs))) + (if (null (car objs)) res + (for (c 0 1 (1- (length objs))) + (setq res (mixe-obj res (nth c objs) )))) + (sort-chords res))) + +(om::defmethod! mixer ((obj1 chord-seq) (obj2 null) &rest objs ) + (mixer (chords obj1) nil)) + +(om::defmethod! mixer ((obj1 multi-seq) (obj2 multi-seq) &rest objs ) +(mki 'multi-seq :chord-seqs + (car-mapcar 'mixer (chord-seqs (flat (list obj1 + obj2 + (if (not (null (car objs))) objs))))))) + +(om::defmethod! mixer ((obj1 multi-seq) (obj2 null) &rest objs ) + (mixer (chord-seqs obj1) nil)) + +;................................................................................ + +(om::defmethod! paste-object ((seq1 chord-seq) (obj chord-seq) (onset integer) &optional + (mode 'merge)) + :initvals '(nil nil 1000 'merge) + :menuins '((3 (("merge" 'merge) ("replace" 'replace)))) + :icon 137 + :doc "Pastes an object into a chord sequence object at a specified . +Optional mode means that the new object will be merged with the old material within the specified zone. +Optional mode will erase the old material within the specified zone where the new object is pasted. +The zone is defined by the onsets of the chords (the offsets are not taken into account). + may be a chord or a chord sequence object. + and may be lists of the same dimensions (i.e. lengths)." + + (let* ((seq1 (if (eq mode 'merge) seq1 + (erase-chords seq1 onset (+ onset (last-elem (butlast (lonset obj))))))) + (lonset1 (lonset seq1)) + (lonset2 (om+ onset (lonset obj))) + (lastonset (max (last-elem lonset1) (last-elem lonset2))) + (contenu (sort-table (list (append (get-chords seq1) (get-chords obj)) + (append (butlast lonset1) (butlast lonset2))) 1))) + + (make-instance 'chord-seq + :Lmidic (first contenu) + :Lonset (x-append (second contenu) lastonset)))) + +(om::defmethod! paste-object ((seq1 chord-seq) (obj chord) (onset integer) &optional + (mode 'merge)) + (let* ((seq1 (if (eq mode 'merge) seq1 + (erase-chords seq1 onset onset 'keep))) ; onset (obj-dur obj))))) + (lonset1 (lonset seq1)) + (lastonset (max (last-elem lonset1) onset)) + (contenu (sort-table (list (x-append (get-chords seq1) obj) + (x-append (butlast lonset1) onset)) 1))) + (make-instance 'chord-seq + :Lmidic (first contenu) + :Lonset (x-append (second contenu) lastonset)))) + +(om::defmethod! paste-object ((seq1 multi-seq) (obj multi-seq) (onset integer) &optional + (mode 'merge)) + (mki 'multi-seq :chord-seqs + (double-mapcar 'paste-object (chord-seqs seq1) (chord-seqs obj) onset mode))) + +(om::defmethod! paste-object ((seq1 t) (obj list) (onset list) &optional + (mode 'merge)) + +(loop for i in obj for j in onset + do (setq seq1 (paste-object seq1 i j mode)) + finally (return seq1))) + + +; il se peut que toutes les combinaisons possibles ne soient pas prises en compte +; il faudrait crŽer les voix nŽcessaires si la m-seq ne possde pas les voix indiquŽes dans voice + +(om::defmethod! paste-in-multi ((mseq multi-seq) (obj chord-seq) (voice integer) (onset integer) + &optional (mode 'merge)) + :initvals '(nil nil 0 1000 'merge) + :menuins '((4 (("merge" 'merge) ("replace" 'replace)))) + :icon 137 + :doc "Pastes an object into a multi sequence object at an absolute and a specified . +N.B. If =0, this means the first voice of the multi sequence object. +Optional mode means that the new object and the old material at the specified onset will be merged. +Optional mode will erase the old material at the specified onset where the new object is pasted. + may be a chord or chord sequence object. +, and may be lists with the same dimensions." + + + (let* ((lchseq (chord-seqs mseq)) res) + (for (n 0 1 (1- (length lchseq) )) + (if (= n voice) (push (paste-object (nth n lchseq) obj onset mode) res) + (push (nth n lchseq) res))) + (mki 'multi-seq :chord-seqs (nreverse res)))) + + +; pour raccourcir le nom + +(om::defmethod! pim ((mseq multi-seq) (obj t) (voice t) (onset t) + &optional (mode 'merge)) + :initvals '(nil nil 0 1000 'merge) + :menuins '((4 (("merge" 'merge) ("replace" 'replace)))) + :icon 137 + (paste-in-multi mseq obj voice onset mode)) + + + +(om::defmethod! paste-in-multi ((mseq multi-seq) (obj chord) (voice integer) (onset integer) + &optional (mode 'merge)) + (let* ((lchseq (chord-seqs mseq)) res) + (for (n 0 1 (1- (length lchseq) )) + (if (= n voice) (push (paste-object (nth n lchseq) obj onset mode) res) + (push (nth n lchseq) res))) + (mki 'multi-seq :chord-seqs (nreverse res)))) + + +(om::defmethod! paste-in-multi ((mseq multi-seq) (obj multi-seq) (voice t) (onset integer) + &optional (mode 'merge)) + (paste-object mseq obj onset mode)) + + + +(om::defmethod! paste-in-multi ((mseq multi-seq) (obj list) (voice integer) (onset list) + &optional (mode 'merge)) + (let ((res mseq) (nbobj (1- (length obj )))) +(for (n 0 1 nbobj) + (setq res (paste-in-multi res (nth n obj) voice (nth n onset) mode))) +res)) + + +(om::defmethod! paste-in-multi ((mseq multi-seq) (obj list) (voice list) (onset list) + &optional (mode 'merge)) + (let ((res mseq) (nbobj (1- (length obj )))) +(for (n 0 1 nbobj) + (setq res (paste-in-multi res (nth n obj) (nth n voice) (nth n onset) mode))) +res)) + + +(om::defmethod! paste-in-multi ((mseq multi-seq) (obj chord-seq) (voice list) (onset integer) + &optional (mode 'merge)) + (let ((res mseq) (nbvoice (1- (length voice )))) +(loop for v in voice + do (setq res (paste-in-multi res obj v onset mode)) + finally (return res)))) + + +(om::defmethod! paste-in-multi ((mseq multi-seq) (obj multi-seq) (voice list) (onset integer) + &optional (mode 'merge)) + (let ((res mseq) (nbvoices (1- (length voice )))) +(for (n 0 1 nbvoices) + (setq res (paste-in-multi res (nth n (chord-seqs obj)) (nth n voice) onset mode))) +res)) + + + + + +(om::defmethod! modif-sel ((obj chord-seq) (fct t) (arg t) (slot t) (deb t) (fin t) + &optional (piste nil)) + :initvals '(nil '+ 100 'lmidic 0 nil nil) + :menuins '((3 (("midic" 'lmidic) ("vel" 'lvel) ("dur" 'ldur) ("offset" 'loffset) ("chan" 'lchan)))) + :icon 137 + :doc "modifie la sŽlection; si multi-seq : indiquer la ou les piste(s) ; si piste=nil +toutes les pistes sont modifiŽes. +Marche avec chord ; dans ce cas , deb et fin se rŽfrent au numŽro d'ordre des notes ˆ modifier" +(paste-object obj (ch-modif (selectf obj deb fin) fct arg slot) deb 'replace)) + + +(om::defmethod! modif-sel ((obj multi-seq) (fct t) (arg t) (slot t) (deb t) (fin t) + &optional (piste nil)) +(let ((modif (cond ((null piste) (ch-modif (selectf obj deb fin piste) fct arg slot)) + ((atom piste) (ch-modif (selectf obj deb fin piste) fct arg slot)) + ((listp piste) + (loop for p in piste + collect (ch-modif (selectf obj deb fin p) fct arg slot))))) + (deb (cond ((null piste) deb) + ((atom piste) deb) + ((listp piste) (create-list (length piste)) ) )) ) +(paste-in-multi obj modif piste deb 'replace))) + + +(om::defmethod! modif-sel ((obj chord) (fct t) (arg t) (slot t) (deb t) (fin t) + &optional (piste nil)) + +(let ((ch1 (if (> deb 0) (ch-filter obj 0 (1- deb) ) nil)) + (ch2 (if (< fin (- (ch-length obj) 2)) (ch-filter obj (1+ fin) (1- (ch-length obj))) nil))) +(mixer (remove nil (list ch1 (ch-modif (ch-filter obj deb fin) fct arg slot) ch2)) nil))) + + + + +(om::defmethod! insert-object ((seq1 chord-seq) (obj chord) (onset integer) &optional + (endinsert nil)) + :initvals '(nil nil 1000 nil) + :icon 137 + :doc + "Inserts an object into a sequence object at an absolute . +In case is a chord sequence object or a multi sequence object, the ending of the insert corresponds with the last onset of the . +In case is a chord, the ending of the insert corresponds to the duration of the . + may be a chord sequence object or a multi sequence object. + may be chird, chord sequence object or multi sequence object. + +Optionals: With a different absolute onset (i.e. end of insert) can be specified." + + (let* ((durins (if endinsert (- endinsert onset) (ch-dur obj))) + (endins (+ onset durins)) + (newonsets (loop for n in (lonset seq1) + collect (if (< n onset) n (+ n durins))))) + (sort-chords + (make-instance 'chord-seq + :Lmidic (x-append (get-chords seq1) obj ) + :Lonset (x-append (butlast newonsets) onset (max endins (last-elem newonsets))))))) + + +(om::defmethod! insert-object ((seq1 chord-seq) (obj chord-seq) (onset integer) &optional + (endinsert nil)) + (let* ((durins (if endinsert (- endinsert onset) (list-max (lonset obj)))) + (endins (+ onset durins)) + (newonsets (loop for n in (lonset seq1) + collect (if (< n onset) n (+ n durins))))) +(sort-chords + (make-instance 'chord-seq + :Lmidic (x-append (get-chords seq1) (get-chords obj) ) + :Lonset (x-append (butlast newonsets) (om+ (butlast (lonset obj)) onset) + (max endins (last-elem newonsets))))))) + + +(om::defmethod! insert-object ((seq1 multi-seq) (obj multi-seq) (onset integer) &optional + (endinsert nil)) + (let ((endins (if endinsert endinsert (+ onset (list-max (lonset obj)))))) + (mki 'multi-seq + :chord-seqs + (double-mapcar 'insert-object (chord-seqs seq1) (chord-seqs obj) onset endins)))) + + + + + +(om::defmethod! insert-silence ((seq1 chord-seq) (onset integer) (dur integer)) + :initvals '(nil 1000 1000) + :icon 136 + :doc "Inserts a silence of duration into a sequence at an absolute onset . + may be a chord sequence object or a multi sequence object." + +(lonset-modif seq1 '= + (loop for n in (lonset seq1) + collect (if (< n onset) n (+ n dur))))) + + +(om::defmethod! insert-silence ((seq1 multi-seq) (onset integer) (dur integer)) + (mki 'multi-seq + :chord-seqs + (car-mapcar 'insert-silence (chord-seqs seq1) onset dur))) + + + + + +(om::defmethod! erase-chords ((seq chord-seq) (debut integer) (fin integer) + &optional (mode 'keep)) + :initvals '(nil 1000 2000 'keep) + :menuins '((3 (("keep" 'keep) ("snip" 'snip)))) + :icon 137 + :doc "Erases the chords with onsets that are located within indicated and (included). +Optional mode means that the erased chords are replaced by silence. +Optional mode means that the two remaining pieces of the sequence are pasted together." + + (let* ((lchords (get-chords seq)) + (lonset (lonset seq)) + (interv (if (eq mode 'keep) 0 (- fin debut))) + accords attaques) + + (loop for ch in lchords + for att in lonset + do (if ( < att debut) (progn (push ch accords) + (push att attaques))) + do (if ( > att fin) (progn (push ch accords) + (push (- att interv) attaques))) + finally (return (mki 'chord-seq + :lmidic (nreverse accords) + :lonset (x-append (nreverse attaques) (last-elem lonset)) + :legato (legato seq)))))) + + +(om::defmethod! erase-chords ((seq multi-seq) (debut integer) (fin integer) &optional (mode 'keep)) + (mki 'multi-seq :chord-seqs (car-mapcar 'erase-chords (chord-seqs seq) debut fin mode))) + + +;................................................................................ +; mixtur replaces mixture 01-11-2006 +; the old method is kept for compatiblity with old patches + + +(om::defmethod! mixtur ((object chord) (interv t) (%amp t) (delai t) (mode t) + &optional (canal nil) (port nil)) + :initvals '(nil 700 100 0 'interv nil nil) + :menuins '((4 (("interv" 'interv) ("nharm" 'nharm)))) + :icon 137 + :doc +"Adds an echo and/or harmonizer effect. Effectively, it returns a mixture of every note and its double, either at a fixed interval (midic) or as a defined harmonic partial . The choice between these two options is made at . At the input <%ampl> the amplitude of the mixture can be defined as a percentage of (relative to) the amplitude of the original note. At a time interval or delay can be specified between the attacks of the mixture and the original note. essentially changes the offset of the mixture. , <%ampl> and may be atoms or lists of the same lengths. + +Optionals: The mixtures may be routed through voices or ports that differ from those of the original sounds. or may be atoms or lists of the same length as <%ampl> and +" +(mixer + (addmixtur object interv %amp delai mode canal port ) object)) + + + +(defun addmixtur (object interv %amp delai mode canal port ) + (if (atom interv) (simplemixtur object interv %amp delai mode canal +port ) + (multiplemixtur object interv %amp delai mode canal port ))) + + + +(defun simplemixtur (object interv %amp delai mode canal port) + (mki 'chord + :LMidic (if (eq mode 'interv ) (om+ (lmidic object) interv) + (list! (n-harm (lmidic object) interv 'midic 'chord))) + :Ldur (ldur object ) + :LOffset (om+ (loffset object) delai) + :Lchan (if (null canal) (lchan object ) (list! canal)) + :Lvel (om// (om* (lvel object ) %amp) 100) + ; :Lport (if (null port) (lport object ) (list! port)))) toujours ce pb avec Lport... + :Lport (if (null port) (lport object ) (create-list (ch-length object) port)))) + + +(defun multiplemixtur (object interv %amp delai mode canal port ) + (let* ((nbtrans (length interv)) + (%amp (if (atom %amp) (create-list nbtrans %amp) %amp)) + (delai (if (atom delai) (create-list nbtrans delai) delai)) + (canal (if (atom canal) (create-list nbtrans canal) canal)) + (port (if (atom port) (create-list nbtrans port) port))) + (mixer (loop for i in interv + for a in %amp + for d in delai + for c in canal + for p in port + collect (simplemixtur object i a d mode c p )) nil))) + + +(om::defmethod! mixtur ((object chord-seq) (interv t) (%amp t) (delai +t) (mode t) + &optional (canal nil) (port nil)) + (mki 'chord-seq + :lmidic (loop for ch in (chords object) + collect (mixtur ch interv %amp delai mode canal +port )) + :lonset (lonset object))) + + +(om::defmethod! mixtur ((object multi-seq) (interv t) (%amp t) (delai +t) (mode t) + &optional (canal nil) (port nil)) + (mki 'multi-seq + :chord-seqs (loop for cs in (chord-seqs object) + collect (mixtur cs interv %amp delai mode +canal port )))) + + +;====Rename mixtur as ch-mixture 24-06-2007================================= + + +(om::defmethod! ch-mixture ((object chord) (interv t) (%amp t) (delay t) (mode t) + &optional (channel nil) (port nil)) + + :initvals '(nil 700 100 0 'interv nil nil) + :menuins '((4 (("interv" 'interv) ("nharm" 'nharm)))) + :icon 137 + :doc + "Adds an echo and/or harmonizer effect to an object: a chord object, a chord-seq or multi-seq. Effectively, it returns a mixture of every note and its double, either at a fixed interval (midic) or as a defined harmonic partial . The choice between these two options is made at . At the input <%ampl> the amplitude of the mixture can be defined as a percentage of (relative to) the amplitude of the original note. At a time interval or delay can be specified between the attacks of the mixture and the original note. essentially changes the offset of the mixture. , <%ampl> and may be atoms or lists of the same lengths. +Optionals: The mixtures may be routed through voices or ports that differ from those of the original sounds. or may be atoms or lists of the same length as <%ampl> and ." + + (mixtur object interv %amp delay mode channel port)) + + +(om::defmethod! ch-mixture ((object chord-seq) (interv t) (%amp t) (delay t) (mode t) + &optional (channel nil) (port nil)) + + (mixtur object interv %amp delay mode channel port)) + + +(om::defmethod! ch-mixture ((object multi-seq) (interv t) (%amp t) (delay t) (mode t) + &optional (channel nil) (port nil)) + + (mixtur object interv %amp delay mode channel port)) + + +;=========================================================================== + + +(om::defmethod! mixture ((object chord) (interv number) (%amp integer) (delai integer) (mode t) + &optional (canal nil) (port nil) (format 'ch-seq) ) + :initvals '(nil 700 100 0 'interv nil nil 'ch-seq ) + :menuins '((7 (("ch-seq" 'ch-seq) ("multi-seq" 'multi-seq)))) + :menuins '((4 (("interv" 'interv) ("nharm" 'nharm)))) + :icon 137 + :doc "double chaque note ˆ un intervalle (midic) ou en calculant son harmonique , selon +choix fait dans . +%amp = % amplitude +delai = dŽlai entre original et mixture (ms). Interv, %amp, delai, peuvent tre des listes +NB : Peut crŽer des Žchos ou des effets d'harmoniseur. +Pour les ch-seq et m-seq, il peut tre utile d'utiliser align-chords, lorsque delai = 0 +ch-seq et m-seq : toutes les config n'ont pas ŽtŽ testŽes" +(mixer + (mixture1 object interv %amp delai canal port mode) object)) + + + +; j'ai du mettre un (list! ) pour canal et port, pour une raison inconnue... (pour quand on a chord-seq , liste d'intervalles) + + +(defun mixture1 (object interv %amp delai canal port mode ) + +(mki 'chord + :LMidic (if (eq mode 'interv ) (om+ (lmidic object) interv) (n-harm (lmidic object) interv 'midic 'chord)) + :Ldur (ldur object ) + :LOffset (om+ (loffset object) delai) + :Lchan (if (null canal) (lchan object ) (list! canal)) + :Lvel (om// (om* (lvel object ) %amp) 100) + :Lport (if (null port) (lport object ) (list! port)))) + + +(om::defmethod! mixture ((object chord) (interv t) (%amp t) (delai t) (mode t) + &optional (canal nil) (port nil) (format 'ch-seq)) +(let* ((iter (max (length (list! interv)) (length (list! %amp)) (length (list! delai)))) + (interv (if (one-elem interv) (create-list iter interv) (list! interv))) + (%amp (if (one-elem %amp) (create-list iter %amp)(list! %amp))) + (delai (if (one-elem delai) (create-list iter delai) (list! delai))) + (canal (if (one-elem canal) (create-list iter canal) (list! canal))) + (port (if (one-elem port) (create-list iter port) (list! port)))) + +(mixer (x-append object (loop for i in interv + for a in %amp + for d in delai + for c in canal + for p in port + collect (mixture1 object i a d c p mode ))) nil))) + + + +(om::defmethod! mixture ((object chord-seq) (interv number) (%amp integer) (delai integer) (mode t) + &optional (canal nil) (port nil) (format 'ch-seq)) + +(if (equal format 'ch-seq) (mixer (mixture-seq object interv %amp delai canal port) object) + (mki 'multi-seq + :chord-seqs (list object (mixture-seq object interv %amp delai canal port))))) + + + + +; a revoir (pb avec lport) + + +(defun mixture-seq (object interv %amp delai canal port ) + + (mki 'chord-seq + :LMidic (if (eq mode 'interv ) (om+ (lmidic object) interv) (n-harm (lmidic object) interv 'midic 'chord)) + :lonset (om+ (lonset object) delai) + :Ldur (ldur object ) + :LOffset (loffset object ) + :Lchan (if (null canal) (lchan object ) canal) + :Lvel (om// (om* (lvel object ) %amp) 100) + :Lport (if (null port) (lport object ) port))) + + + + +; a revoir + + + +(om::defmethod! mixture ((object chord-seq) (interv t) (%amp t) (delai t) (mode t) + &optional (canal nil) (port nil) (format 'ch-seq)) +(print format) + +(if (equal format 'ch-seq) + (mki 'chord-seq + :LMidic (loop for ch in (chords object) + collect (mixture ch interv %amp delai mode canal port format )) + :lonset (lonset object)) + + (mixt-mseq object interv %amp delai canal port ))) + + + +; a revoir + +(defun mixt-mseq (object interv %amp delai canal port ) + +(let* ((iter (max (length (list! interv)) (length (list! %amp)) (length (list! delai)))) + (interv (if (one-elem interv) (create-list iter interv) (list! interv))) + (%amp (if (one-elem %amp) (create-list iter %amp)(list! %amp))) + (delai (if (one-elem delai) (create-list iter delai) (list! delai))) + (canal (if (one-elem canal) (create-list iter canal) (list! canal))) + (port (print (if (one-elem port) (create-list iter port) (list! port))) ) + + (res (loop for i in interv + for a in %amp + for d in delai + for c in canal + for p in port + collect (mixture object i a d mode c p 'ch-seq)))) + + (mki 'multi-seq + :chord-seqs (x-append object res)))) + + + + +(om::defmethod! mixture ((object multi-seq) (interv number) (%amp integer) (delai integer) (mode t) + &optional (canal nil) (port nil) (format 'ch-seq)) + + +(mki 'multi-seq :chord-seqs + (loop for ch in (chord-seqs object) + collect (mixture ch interv %amp delai mode canal port 'ch-seq)))) + + + + + + + + + +(om::defmethod! diamanter ((chseq chord-seq) (nth-harm t) (pcent% number) (dur integer) + (chan integer) (port integer) + &optional (approx 4) (filter 10800)) + :initvals '(nil '(3 5) 50 1000 1 0 4 10800) + :icon 137 + :doc +"Returns the harmonics of every note of specified chords. It returns only a certain percentage of these harmonics which are aleatorically chosen. The harmonic attacks are spread out between the attack of the original chord and the attack of the next. Diamanter is a term coined by Olivier Messiaen. As an example, Messiaen explained in his orchestration class how the high register of the piano may add brilliance to orchestral sound textures: le piano diamante lÕorchestre." + + (let* ((lchords (get-chords chseq)) + (lonset (lonset chseq)) + (linterv (x->dx lonset)) + accords attaques) + + (loop for ch in lchords + for attack in lonset + for interv in linterv + with midics + do (setq midics + (permut-random (list-alea-filter + (list-filter #'(lambda (x) (funcall '<= x filter)) + (flat (nth-polysp (lmidic ch) nth-harm 0 0 approx)) 'pass) + pcent%))) + + do (if (eq midics nil) () + (push + (mki 'chord + :Lmidic midics + :LVel (list (round (om-mean (lvel ch)))) + :LDur (list! dur) + :LOffset (om-round (first-n + (n-arithm 0 interv (1+ (length midics)) 'inclus ) + (length midics))) + :LChan (list! chan) + :Lport (list! port)) + accords)) + + do (if (eq midics nil) () + (push attack attaques)) + + finally (return (if (not (null accords)) + (mki 'chord-seq + :lmidic (nreverse accords) + :lonset (x-append (nreverse attaques) (+ (first attaques) dur)) + :legato 0)))))) + +; ------------------------------------------------------------------------------------------------- + +; ----------------------------------engendrement-------------------------------------------- + + +(om::defmethod! trill ((chord chord) (freq number) (dur number) ) + + :initvals '(nil 10 1000 ) + :icon 136 + :doc "Iterates the notes in with in hz and in msec. The velocity, channel and port remain identical to 1st note of the . If the has 2 notes, a trill is obtained, if the has only one note, the result is a repeated note. With 3 notes or more, various types of iterations can be created." + +(let* ((nbnotes (round (* freq (/ dur 1000)))) (lgtrille (length (lmidic chord))) + (lnotes (list-pos (flat (create-list (ceiling (/ nbnotes lgtrille)) (lmidic chord))) 0 (1- nbnotes))) + (loffsets (om-round (x-arithm 0 (/ 1000 freq) nbnotes)))) + + (ch-modif + (mki 'chord + :lmidic lnotes + :LVel (list (first (lvel chord))) + :LDur (list! (round (/ 1000 freq))) + :LOffset loffsets + :LChan (list! (first (lchan chord))) + ) '= (first(lport chord)) 'lport))) + +; ---------- maquettes ------------------ + +(om::defmethod! order-maq ( (maq ommaquette)) + :initvals '(nil) + :icon 136 + :doc "donne la liste des objets de la maquette, dans l'ordre des offsets" + (let ((objets (temporalboxes maq))) + (second (sort-table (list (mapcar 'offset objets) objets) 0)))) + + + + + +#| (om::defmethod! sel-maq ((self ommaquette) (offset t) &optional (end nil)) + :initvals '(0 nil) + :icon 137 + :doc "extrait le ou les objet(s) d'offset . Optional : extrait touts les objets dont l'offset est compris entre +offset et end" + +(if (eq end nil) + (let ((objets (temporalboxes self)) res) + (loop for ob in objets + do (if (= (offset ob ) offset ) (push (value ob) res)) + finally (return (carlist! (reverse res))))) + + (selectf self offset end nil))) +|# + + +(defmethod test-editeur (self) + (or (typep self 'chord) (typep self 'note) (typep self 'chord-seq) (typep self 'multi-seq))) + + + + +(om::defmethod! sel-maq ((self ommaquette) (offset t) &optional (end nil)) + :initvals '(nil 0 nil) + :icon 137 + :numouts 2 + :doc "extrait le ou les objet(s) d'offset . Ne considre que les notes, chords, ch-seq, multi-seq. + Optional : extrait touts les objets dont l'offset est compris entre +offset et end . output 1 = objets output 2 = offsets" + (if (eq end nil) + (let ((objets (temporalboxes self)) res) + (dolist ( ob objets ) + (if (and (= (offset ob ) offset ) (test-editeur (car (value ob)) )) + (push (car(value ob)) res))) + (values (carlist! (reverse res)) offset)) + + (let ((res (sel-maq-interv self offset end ))) + (values (carlist! (first res)) (carlist! (second res)))))) + + + + + +(defmethod sel-maq-interv (self start end ) + (let* ((objets (temporalboxes self)) (start (if (eq start nil) 0 start)) + (end (if (eq end nil) (l-max (mapcar 'offset objets)) end)) + res loffsets ) + (dolist (ob objets) + (if (and (<> (offset ob ) start end '<>=) (test-editeur (car (value ob)) )) + (progn (push (value ob) res) (push (offset ob ) loffsets)))) + (sort-table (list (flat res) loffsets ) 1))) + + + +(om::defmethod! maq->mseq ((self ommaquette) (deb integer) (fin integer) (delta integer )) + :initvals '(nil 0 10000 0) + :icon 136 + :doc "le contenu de la maquette entre deb et fin est transfŽrŽ dans un multi-seq. Les canaux et ports +sont repartis sur diffŽrentes pistes. Delta (ms) : permet de grouper les notes en accord (cf: align-chords)" + +(let* ((liste-objets (first (multiple-value-list (sel-maq self deb fin)))) ; sel-maq filtre les boxes; ne garde que ch, ch-seq,mseq + (liste-offsets (second (multiple-value-list (sel-maq self deb fin)))) + + (objets + (loop for ob in liste-objets + collect (cond ((typep ob 'multi-seq) (mixer ob nil)) + ((typep ob 'chord) (mki 'chord-seq :lmidic (list ob))) + (t ob))))) + (channel->voice (chainer objets (x-append 0 (om- (cdr liste-offsets) (first liste-offsets)))) delta))) + + + + + + +;.................essais objets............... + + + + + + + +(om::defmethod! midic->canal ((accord chord) (approx integer)) + :initvals '(nil 4) + :icon 136 + :indoc '("accord, liste d'accords, ou seq" "approx") + :doc "rend accord approximŽ où l'indication de 1/4 de ton ou de 1/8 ton est fournie +par le canal (+ 1 2 3 selon micro-int)" + + (let* ((hauteurs (approx-m (LMidic accord) approx)) + (canaux (LChan accord))) + (make-instance 'chord + :Lmidic (om* 100 (om-floor (om/ hauteurs 100))) + :LVel (lvel accord) + :LDur (ldur accord) + :LOffset (loffset accord) + :Lport (lport accord) + :LChan (om+ canaux (om/ (om-modulo hauteurs 100) 25))))) + + +; liste d'accords +(om::defmethod! midic->canal ((accord list) (approx integer)) + (car-mapcar #'midic->canal accord approx )) + + +; chord-seq +(om::defmethod! midic->canal ((seq chord-seq) (approx integer)) + (let* ((hauteurs (approx-m (LMidic seq) approx)) + (canaux (LChan seq))) + (make-instance 'chord-seq + :Lmidic (om* 100 (om-floor (om/ hauteurs 100))) + :LVel (lvel seq) + :LDur (ldur seq) + :LOffset (loffset seq) + :Lonset (lonset seq) + :Lport (lport accord) + :LChan (om+ canaux (om/ (om-modulo hauteurs 100) 25))))) + + + + + +; faire aussi pour multi-seq + + + + +; =============================== files i/o ================================ + +(defun read-file-list (fichier ) + (let (list item + (nom (if (null fichier ) (choose-file-dialog ) fichier))) + (when nom + (with-open-file (file nom :direction :input + :if-does-not-exist nil) + (while (not (eq :eof (setq item (read file nil :eof)))) + (push item list))) + (nreverse list) + ))) + +(defun read-file-array (dimension fichier ) + (let (item + (nom (if (equal fichier "name") (choose-file-dialog ) fichier)) + (tab (make-array dimension :adjustable t :fill-pointer 0))) + (when nom + (with-open-file (file nom :direction :input + :if-does-not-exist nil) + (while (not (eq :eof (setq item (read file nil :eof)))) + (vector-push item tab)))) + + (setf tab (adjust-array tab (fill-pointer tab) :fill-pointer t :initial-element 0)) + + (print (format nil "nb ŽlŽments: ~A " (fill-pointer tab))) + tab)) + + +(om::defmethod! read-file (&optional (fichier nil ) (format 'list ) + (dimension 100000 )) + :initvals '(nil 'list 100000) + :menuins '((1 (("list" 'list) ("array" 'array)) )) + :icon 136 + :doc "lit un fichier texte +ext: fichier = donner nom de fichier avec son ''path'' - sinon un dialogue s'ouvre +format de sortie : list par dŽfaut, array par option " + (if (equal format 'array) (read-file-array dimension fichier) (read-file-list fichier))) + + + +(om::defmethod! write-file ((list t) + &optional (sep 'rien ) (fichier nil ) (fmat nil)) + :initvals '('(1 2 3 4 5) 'rien nil nil ) + :menuins '((1 (("rien" 'rien) ("espace" 'espace) ("ligne" 'ligne) ("tab" 'tab)))) + :icon 137 + :doc " option : sŽparateur de donnŽes (rien, espace, ligne, tab) +''rien'' suppose que la liste est dŽjˆ formatŽe " + (let ((nom (if (equal fichier 'nil) (choose-new-file-dialog ) fichier)) + (char (case sep + (rien "" ) + (espace #\Space) + (ligne #\newline) + (tab #\tab)))) + (print sep) + (print char) + (when nom + (with-open-file (file nom :direction :output + :if-exists :supersede) + (while list + (if (null fmat ) (princ (pop list) file) + (princ (format nil fmat (pop list)) file)) + (princ char file))) + nil))) + + + + +(om::defmethod! ll-write-file ((list list) + &optional (sep 'espace ) (fichier nil ) (fmat 0 )) + + :initvals '('((1 2 3) (a b c)) 'espace nil 0) + :menuins '((1 ( ("espace" 'espace) ("tab" 'tab)))) + :icon 137 + :doc " Žcrit sur fichier une liste de listes : chaque sous-liste sera Žcrite comme +une nouvelle ligne +options : sŽparateur de donnŽes ˆ l'intŽrieur de chaque ligne ( space ou tab) + nom de fichier + fmat = nombre de chiffres pour reprŽsenter les nombres (Žvite aussi notation +exponentielle) . Si fmat=0 les nombres sont Žcrits tels quels " + + (let ((nom (if (equal fichier 'nil) (choose-new-file-dialog ) fichier)) + (char (case sep + (espace #\Space) + (tab #\tab)))) + (when nom + (with-open-file (file nom :direction :output + :if-exists :supersede) + (dolist (sousliste list) + (dolist (i sousliste) + (if (= fmat 0) + (princ i file) + (if (numberp i) (format file (format nil "~A~AF" '~ fmat) i) (princ i file))) + (princ char file)) + (princ #\newline file))) + nil)) + (print "fichier Žcrit ") + nil) + + +; ====================== opŽrations sur tableaux ====================== + + +(defvar *tab*) +(defvar *fcttab*) +(defvar *valtab*) +(defvar *tlim*) + +(defun dimensions (tableau) + (let ((ndim (array-rank tableau))) + (mapcar #'(lambda (x) (array-dimension tableau x)) (arithm-ser 0 1 (1- ndim))))) + + + +(om::defmethod! creer-tab ((dimensions t) (valinit t)) + :initvals '('(5) '(1 2 3 4 5)) + :indoc '( "dimensions" "valinit") + :icon 136 + :doc "crŽe un tableau - dimensions = liste des dimensions +valinit : si c'est un atome, toutes les cases du tableau +sont initialisŽes ˆ cette valeur +sinon entrer une liste de structure identique ˆ celle +du tableau" + + + (if (atom valinit) (t-init (make-array dimensions ) valinit) + (make-array dimensions :initial-contents valinit))) + + + + +(defun recurindexinit (tindex i vali maxi ) + (if (< i 0) () + (cond ((and (= i maxi) (= (nth i tindex ) (nth i *tlim* ))) (setf (nth i tindex ) 0) + (setq i (1- i)) (recurindexinit tindex i i maxi )) + ((> (nth i tindex ) (nth i *tlim* )) (setf (nth i tindex ) 0) (setq i (1- i)) + (recurindexinit tindex i i maxi )) + (t (setq i vali) (setf (nth i tindex ) (1+ (nth i tindex ))) + (if (<= (nth i tindex ) (nth i *tlim* )) + ;(print tindex)) + (setf (apply #'aref *tab* tindex) + (setf (apply #'aref *tab* tindex) *valtab* ))) + (recurindexinit tindex i maxi maxi )) + ))) + +(om::defmethod! t-init ((*tab* t) (*valtab* t)) + :initvals '(t t) + :indoc '( "tab" "valtab") + :icon 136 + :doc "" + + (let* ((*tlim* (om- (dimensions *tab*) 1)) (rank (length *tlim*)) + (maxi (1- rank)) + (tindex (create-list rank 0))) + (setf (apply #'aref *tab* tindex) + (setf (apply #'aref *tab* tindex) *valtab* )) + (recurindexinit tindex maxi maxi maxi ) + *tab*)) + + +(om::defmethod! l-aref ((tableau t) (indices t)) + :initvals '('(5) '(1 2 3 4 5)) + :indoc '( "tableau" "indices") + :icon 136 + :doc "donne les cases d'un tableau spŽcifiŽes par +la structure de doit reflŽter celle du tableau +ex: pour un tableau ˆ deux dim : +'((0 0) (1 0)) ou mme : '((0 0))" + + + (cond ((atom indices) (aref tableau indices ) ) + ((= (array-rank tableau) 1) (mapcar #'(lambda (x) (aref tableau x)) indices)) + (t (mapcar #'(lambda (x) (apply #'aref tableau x )) indices )))) + + +(om::defmethod! t-substit ((tab t) (case list) (val list)) + :initvals '(t '(1 2) '(1 2)) + :indoc '( "tableau" "case" "val") + :icon 136 + :doc "" + (let ((case (list! case))) + (dolist (l case) + (setf (aref tab l) val)) + tab)) + + + +(defun recurindex ( tindex i vali maxi ) + (if (< i 0) () + (cond ((and (= i maxi) (= (nth i tindex ) (nth i *tlim* ))) (setf (nth i tindex ) 0) + (setq i (1- i)) (recurindex tindex i i maxi )) + ((> (nth i tindex ) (nth i *tlim* )) (setf (nth i tindex ) 0) (setq i (1- i)) + (recurindex tindex i i maxi )) + (t (setq i vali) (setf (nth i tindex ) (1+ (nth i tindex ))) + (if (<= (nth i tindex ) (nth i *tlim* )) + ;(print tindex)) + (setf (apply #'aref *tab* tindex) + (funcall *fcttab* (apply #'aref *tab* tindex) *valtab* ))) + (recurindex tindex i maxi maxi )) + ))) + +(om::defmethod! t-oper ((tableau t) (*fcttab* t) (*valtab* t)) + :initvals '(t '+ t) + :indoc '( "tableau" "fcttab" "valtab") + :icon 136 + :doc "t-oper copie le tableau d'entrŽe, mais +attention au sort futur du tableau de sortie!" + + (let* (( *tab* (make-array (dimensions tableau) :initial-contents (coerce tableau 'list))) + (*tlim* (g- (dimensions tableau) 1)) (rank (length *tlim*)) (maxi (1- rank)) + (tindex (create-list rank 0))) + (setf (apply #'aref *tab* tindex) + (funcall *fcttab* (apply #'aref *tab* tindex) *valtab* )) + (recurindex tindex maxi maxi maxi ) + *tab*)) + + + + +(om::defmethod! v-oper-1 ((vecteur t) (fct t) (val t)) + :initvals '(t '+ t) + :indoc '( "vecteur" "fct" "val") + :icon 136 + :doc " opŽration sur vecteur +v-oper copie le vecteur d'entrŽe, mais +attention au sort futur du vecteur de sortie!" + + (let* ((long (length vecteur) ) + ( tab (make-array long :initial-contents (coerce vecteur 'list)))) + (dotimes (n long) + (setf (aref tab n) + (funcall fct (aref tab n) val ))) + tab)) + + +(om::defmethod! v-oper ((vecteurs t) (fct t ) (val t)) + :initvals '(t '+ t) + :indoc '( "vecteur" "fct" "val") + :icon 136 + :doc " opŽration sur vecteur +v-oper copie le vecteur d'entrŽe, mais +attention au sort futur du vecteur de sortie! +accepte listes de vecteurs" + (car-mapcar 'v-oper-1 vecteurs fct val)) + + +; ceci ne fonctionne plus avec Lisp 4.0 + +(om::defmethod! l-coerce ((lliste list) (format symbol)) + :initvals '('(1 2) 'list) + :indoc '( "lliste" "format") + :menuins '((1 ( ("list" 'list) ("array" 'array)))) + :icon 136 + :doc "lliste must be a list of list. This funct apparently transforms +each list of list into a vector" + (car-mapcar 'coerce lliste (if (equal format 'list) 'list 'array))) + + + +(defun complete-liste1 (liste long elem) + (x-append liste (create-list (- long (length liste)) elem))) + +(defun complete-lliste (liste long elem) + (car-mapcar 'complete-liste1 liste long elem)) + + +(om::defmethod! liste->tab ((liste list)) + :initvals '( '((1 2) (1 2)) ) + :indoc '( "lliste" ) + :icon 136 + :doc "transforme une liste de listes en tableau ˆ deux dim +dim1 = nb des sous-listes +dim2 = longueur max des sous-listes" + + (let* ((larg (list-max (mapcar 'length liste))) + (liste (complete-lliste liste larg nil)) + (dim (list (length liste) larg))) + (make-array dim :initial-contents liste))) + + + + + + +;;; ------------------------------------------------------------------------- +;;; ------------------------------------------------------------------------- +;;; Fondamentales virtuelles multiples. Algorithme par Olivier Delerue. +;;; ------------------------------------------------------------------------- +;;; ------------------------------------------------------------------------- + + + + + + +(defvar *tolerance* 1.0293 ) ;;; quart de ton +(defvar *frequence-min* 30 ) + +;;; (setf *frequence-min* 20 ) +;;; (setf *tolerance* 1.01 ) un pour cent d'erreur + +;;; ------------------------------------------------------------------------- +;;; DŽfinition des classes +;;; ------------------------------------------------------------------------- + +(defclass spectre ( ) + ((fondamentales :initarg :fondamentales :initform () :accessor fondamentales ) + (partiels :initarg :partiels :initform () :type list :accessor partiels :documentation "une liste d'objets partiels" ) + )) + +(defclass partiel () ((frequence :initarg :frequence :initform 0 :accessor frequence ))) + +(defclass regroupement () ( (spectres :initarg :spectres :initform () :accessor spectres :type list ))) + +(defclass classement () + ((regroupements :initarg :regroupements :initform () :accessor regroupements :type list ) + (itere0-p :initform nil :accessor itere0-p )) + ) + +;;; ------------------------------------------------------------------------- +;;; Fonctions utiles +;;; ------------------------------------------------------------------------- + + +(defmethod fondamentales-communes-spectres ((sp1 spectre) (sp2 spectre)) + (fondamentales-communes (fondamentales sp1) (fondamentales sp2 )) + ) + +(defmethod fondamentales-communes-spectres ((sp1 spectre) (sp2 list)) + (fondamentales-communes (fondamentales sp1) sp2) + ) + +(defmethod fondamentales-communes ((liste1 list) (liste2 list) ) + (if (and liste1 liste2) + (let ((temp (intersection-p (car liste1) (car liste2) ))) + (if temp + (cons temp (fondamentales-communes (cdr liste1) (cdr liste2)) ) + (if (<= (caar liste1) (caar liste2) ) + (fondamentales-communes liste1 (cdr liste2) ) + (fondamentales-communes (cdr liste1) liste2 ) + ) + ) + ) + () + ) + ) + +(defmethod fondamentales-communes-liste ( liste-spectres ) + (if (cdr liste-spectres) + (fondamentales-communes (fondamentales (car liste-spectres)) + (fondamentales-communes-liste (cdr liste-spectres))) + (fondamentales (car liste-spectres)) + ) + ) + +(defmethod premiere-fondamentale-commune ((sp1 spectre) (sp2 spectre)) + (premiere-fondamentale-commune (fondamentales sp1) (fondamentales sp2)) + ) + +(defmethod premiere-fondamentale-commune ((liste1 list) (liste2 list)) + (if (and liste1 liste2) + (let ((temp (intersection-p (car liste1) (car liste2) ))) + (if temp + temp + (if (<= (caar liste1) (caar liste2) ) + (premiere-fondamentale-commune liste1 (cdr liste2) ) + (premiere-fondamentale-commune (cdr liste1) liste2 ) + ) + ) + ) + '(1 1) + ) + ) + +(defun cree-partiels (liste-frequences) + (loop for item in liste-frequences collect (make-instance 'partiel :frequence item ) ) + ) + +(defun cree-liste-spectres (liste-frequences tolerance freq-min) + (loop for item in liste-frequences collect + (make-instance 'spectre + :partiels (list (make-instance 'partiel :frequence item ) ) + :fondamentales (liste-fondamentales-possibles (list (/ item tolerance ) (* item tolerance )) freq-min)) + ) + ) + +(defun liste-fondamentales-possibles ( partiels freq-min) + (loop for sub from 1 + while (>= (/ (car partiels) sub) freq-min ) + collect (list (float (/ (car partiels) sub)) (float (/ (cadr partiels) sub )) ) + ) + ) + +(defun intersection-p ( liste1 liste2 ) + (if (or (and (<= (car liste2) (cadr liste1) ) (>= (car liste2) (car liste1) )) + (and (<= (cadr liste2) (cadr liste1)) (>= (cadr liste2) (car liste1) )) + (and (<= (car liste2) (car liste1)) (>= (cadr liste2) (cadr liste1) )) + ) + (list (max (car liste1) (car liste2) ) (min (cadr liste1) (cadr liste2) ) ) + () + ) + ) + +(defun make-classement (liste-partiels tolerance freq-min) + (make-instance 'classement + :regroupements (list (make-instance 'regroupement + :spectres (cree-liste-spectres liste-partiels tolerance freq-min))) )) + + +(defmethod regroupe-deux-spectres ((spectre1 spectre) (spectre2 spectre)) + (make-instance 'spectre + :partiels (append (partiels spectre1 ) (partiels spectre2 )) + :fondamentales (fondamentales-communes-spectres spectre1 spectre2) + ) + ) + + +;;; ------------------------------------------------------------------------- +;;; Fonction de distance. +;;; ------------------------------------------------------------------------- + +(defmethod distance-nulle ((sp1 spectre) (sp2 spectre)) + (if (> (caar (fondamentales sp1)) (caar (fondamentales sp2))) + (distance-nulle sp2 sp1) + (let ((temp (premiere-fondamentale-commune (list (car (fondamentales sp1))) (fondamentales sp2)) )) + (if (eq (car temp) 1) + () + temp + ) + ) + ) + ) + +;;; ------------------------------------------------------------------------- +;;; Methode globale d'iteration sur un classement +;;; ------------------------------------------------------------------------- + +(defmethod iteration ((self classement)) + (if (itere0-p self ) + (if (> (length ( spectres (car (last ( regroupements self ))))) 1 ) + (let ((temp (regroupe-distance-non-nulle (car (last ( regroupements self )))) )) + (if temp + (true (setf (regroupements self) + (append ( regroupements self ) + (list temp)) )) + nil + ) + ) + nil + ) + (progn + (setf (regroupements self) + (append (regroupements self) + (list (regroupe-spectres-distance-nulle (car (last (regroupements self ))))))) + (setf (itere0-p self) T ) + ) + ) + ) + +;;; ------------------------------------------------------------------------- +;;; Regroupement de spectres ˆ distance nulle +;;; ------------------------------------------------------------------------- + +(defmethod regroupe-spectres-distance-nulle ((self regroupement)) + (make-instance 'regroupement + :spectres (bidon (spectres self)) + ) + ) + +(defun bidon (liste-spectres) + (if liste-spectres + (let ((new-spectre (make-instance 'spectre + :partiels (partiels (car liste-spectres)) + :fondamentales (fondamentales (car liste-spectres )) + ))) + (let ((temp + (loop for item in (cdr liste-spectres ) + when (distance-nulle new-spectre item) + do (progn + (setf (partiels new-spectre) (append (partiels new-spectre) (partiels item) ) ) + (setf (fondamentales new-spectre) (fondamentales-communes-spectres new-spectre item)) + ) + and collect item + ))) + (cons new-spectre (bidon (set-difference (cdr liste-spectres) temp ))) + ) + ) + + () + ) + ) + +;;; ------------------------------------------------------------------------- +;;; Regroupement de spectres ˆ distance NON nulle +;;; ------------------------------------------------------------------------- + +(defmethod regroupe-distance-non-nulle ((self regroupement)) + (let ((temp (evalue-distances self ))) + (if (eq (caaar temp) 1) + () + (make-instance 'regroupement + :spectres (append (list (regroupe-deux-spectres (cadar temp) (caddar temp) ) ) + (set-difference ( spectres self) (cdar temp)) + ) + ) + ) + ) + ) + +(defmethod evalue-distances (( self regroupement ) ) + (let (temp) + (loop for x on ( spectres self) do + (loop for y in (cdr x ) + do (push (list (premiere-fondamentale-commune (car x) y ) (car x) y ) temp ) + ) + ) + (sort temp #'> :key #'caar ) + ) + ) + + + + + +;=========================================================================== +;;; INTERFACE +;=========================================================================== + + +(defun join-fund-to-spec (fund spec) + (if (<= (first fund) (first spec) (second fund)) + spec + (cons (second fund) spec))) + + + + +(defun gather-duplicates-1 (list accum) + (cond ((null list) (reverse accum )) + ((or (null (first accum)) (= (first list) (first (first accum)))) + (gather-duplicates-1 (rest list) (cons (cons (first list) (first + accum)) (rest accum)))) + (t (gather-duplicates-1 (rest list) (cons (list (first list)) + accum))))) + + +(defun gather-duplicates (list) + (and list (gather-duplicates-1 list (list (list))))) + + + + + + +;====================================== INFOS =============================== +;;(list-filter #'(lambda (x) (funcall '< x 5 )) '(1 2 3 10) 'reject) +;;(do-filter '(1 2 3 10) #'(lambda (x) (funcall '< x 5 ))) + + +;====================================== 19 aug 2016 new additions to OMTristan from TM ============ + + + + +(om::defmethod! iso-dur ((object chord-seq) (dur number) (mode t)) + :initvals '(nil 200 'durtot) + :icon 136 + :menuins (list (list 2 '(("interval" 'interv) ("durtotal" 'durtot) ))) + :doc "place les notes d'un chord-seq à intervalles réguliers; on donne l'intervalle de temps entre 2 notes, + ou la durée totale. Les durées sont égales aux intervalles de durée; dans l'option 'interval' la dernière +durée est conservée comme dans le ch-seq original. Accepte multi-seq. +Faire précéder d'un align-chords si nécessaire" + + (let ((res (if (eq mode 'interv) + (mki 'chord-seq + :LMidic (lmidic object) + :Lchan (lchan object) + :Lvel (lvel object) + :LOffset (loffset object) + :Ldur (ldur object) + :lonset (x-arithm 0 dur (length (ldur object)))) + (mki 'chord-seq + :LMidic (lmidic object) + :Lchan (lchan object) + :Lvel (lvel object) + :LOffset (loffset object) + :Ldur (om-round (create-list (length (ldur object)) (om/ dur (length (ldur object))))) + :lonset (om-round (dx->x 0 (create-list (length (ldur object)) (om/ dur (length (ldur object)))))))))) + + (newport (lier res) (lport object)))) + + +(om::defmethod! iso-dur ((object multi-seq) (dur number) (mode t)) + :initvals '(nil 200 'durtot) + :icon 136 + :menuins (list (list 2 '(("interval" 'interv) ("durtotal" 'durtot) ))) + + (let* ((res )) + (dolist (seq (chord-seqs object)) + (push (iso-dur seq dur mode) res )) + (mki 'multi-seq :chord-seqs (reverse res)))) + + + + + +(om::defmethod! 0start ((object t) ) + :initvals '(nil ) + :icon 136 + (lonset-modif object '- (list-min (lonset object)))) + + + +(om::defmethod! ch-onsets->seq ((chords list) (onsets list) &optional delta) + :initvals '(nil nil nil) + :icon 137 + :doc "makes a chord-seq out of a list of chords and a list of corresponding onsets.If delta not null, +chords will be grouped with the function . Same as 'chainer' , but adds the possibility +of chord alignment" +(if delta (align-chords (mki 'chord-seq :lmidic chords :lonset onsets) delta) + (mki 'chord-seq :lmidic chords :lonset onsets))) + + + + + +(om::defmethod! append-mseq ((liste list) &optional (interval nil)) + :initvals '(nil nil) + :icon 137 + :doc "construit un multi-seq unique à partir d'une liste de multi-seqs de taille différente; +la liste peut comporter des chord-seqs " + +(let + ((taille (list-max (loop for seq in liste + collect (if (typep seq 'multi-seq) (length (chord-seqs seq)) 1))))) + + (ch-test-filter (append-seq + (loop for seq in liste + do (print seq) + collect (if (typep seq 'multi-seq) + (paste-in-multi (multi-seq-vide taille) (chord-seqs seq) (arithm-ser 0 (length-1 (chord-seqs seq)) 1) (create-list (length (chord-seqs seq)) 0) 'replace) + (paste-in-multi (multi-seq-vide taille) seq 0 0 'replace))) nil interval) '= 0 'lvel))) + + + +(om::defmethod! copy-paste ((seq multi-seq) (begin number) (end number) (destination number) + (orivoices t) (destvoices t) &optional (mode 'merge)) +:initvals '(nil 1000 2000 4000 '(0 1) '(0 1) 'merge) + :menuins (list (list 6 '(("merge" 'merge) ("replace" 'replace)))) + :icon 137 + :doc "If seq is a multi-seq, pastes at in voices the excerpt between + and in voices . If seq is a chord-seq, voices are not considered. + " + (paste-in-multi seq (selectf seq begin end orivoices) destvoices destination mode)) + + + +(om::defmethod! copy-paste ((seq chord-seq) (begin number) (end number) (destination number) + (orivoices t) (destvoices t) &optional (mode 'merge)) + (paste-object seq (selectf seq begin end) destination mode)) + + + + + + +(om::defmethod! cresc-gen ((obj chord-seq) (begin t) (end t) (curve number) ) + :initvals '(nil 30 100 50) + :icon 136 + :doc "creates cresc or dim from velocity value to velocity value +Curve : if = 50 , linear progression . If curve < 50 = more exponential . If curve > 50 = more logarithmic +Does not work on multi-seqs +If division by 0 error generated, slightly change one of the values" + + (let* ((velo (om-round (deformer% (n-arithm begin end (length (lmidic obj))) curve)))) + (ch-modif obj '= velo 'lvel) )) + + + + +(om::defmethod! map-channel ((obj chord) (mapping list)) + :initvals '(nil (((0 1) (1 3)))) + :indoc '("chord" "mapping list") + :icon 136 + :doc "gives new port and channel numbers . Format of mapping list : +(((oldport oldchannel) (newport newchannel)) ((oldport oldchannel) (newport newchannel))...) +ex : ( ((0 1) (3 5)) ((1 3) (1 7)) ((1 9) (2 11)) ) +if one change only, don't forget outer brackets : ( ((0 1) (3 5)) ) " + + (let ((ports (lport obj)) (chans (lchan obj)) ) + (for (i 0 1 (length-1 ports)) + (loop for m in mapping + + do (if (and (= (nth i ports) (car (car m))) (= (nth i chans) (second (car m)))) + (progn (setf (nth i ports)(car (second m))) + (setf (nth i chans)(second (second m))))))) + (mki 'chord + :LMidic (lmidic obj) + :Lvel (lvel obj) + :Loffset (loffset obj) + :Ldur (ldur obj) + :Lchan chans + :Lport ports))) + + + +(om::defmethod! map-channel ((obj chord-seq) (mapping list)) +(mki 'chord-seq + :lmidic (loop for ch in (chords obj) + collect (map-channel ch mapping)) + :lonset (lonset obj) + :legato (legato obj))) + + + +(om::defmethod! map-channel ((obj multi-seq) (mapping list)) + + (mki 'multi-seq + :chord-seqs (loop for chseq in (chord-seqs obj) + collect (map-channel chseq mapping)))) + + + + + +(om::defmethod! implosion ((obj chord-seq) ) +:initvals '(nil ) + :icon 136 + :doc "transforms a chord-seq (or multi-seq) into a chord . Change onsets into offsets. Useful for iterations, trills, etc... +as it should simplify internal representation . " + + (let ((lnotes (seq->notes obj))) + + (mki 'chord + :lmidic (mapcar 'first lnotes) + :lvel (mapcar 'fourth lnotes) + :loffset (mapcar 'second lnotes) + :ldur (mapcar 'third lnotes) + :lchan (mapcar 'fifth lnotes) + :lport (mapcar 'sixth lnotes) + ))) + + +(om::defmethod! implosion ((obj multi-seq) ) +:initvals '(nil ) + :icon 136 + + (implosion (mixer obj nil))) + + + + +(om::defmethod! portchan ((object container) (port t) (chan t)) + :initvals '(nil 1 1 ) + :icon 136 + :doc "donne à l'objet le port et le canal " + (ch-modif (ch-modif object '= port 'lport) '= chan 'lchan)) + + + + + + + +(om::defmethod! iso-dur ((object chord-seq) (dur number) (mode t)) + :initvals '(nil 200 'durtot) + :icon 136 + :menuins (list (list 2 '(("interval" 'interv) ("durtotal" 'durtot) ))) + :doc "place les notes d'un chord-seq à intervalles réguliers; on donne l'intervalle de temps entre 2 notes, + ou la durée totale. Les durées sont égales aux intervalles de durée; dans l'option 'interval' la dernière +durée est conservée comme dans le ch-seq original. Accepte multi-seq. +Faire précéder d'un align-chords si nécessaire" + + (let ((res (if (eq mode 'interv) + (mki 'chord-seq + :LMidic (lmidic object) + :Lchan (lchan object) + :Lvel (lvel object) + :LOffset (loffset object) + :Ldur (ldur object) + :lonset (x-arithm 0 dur (length (ldur object)))) + (mki 'chord-seq + :LMidic (lmidic object) + :Lchan (lchan object) + :Lvel (lvel object) + :LOffset (loffset object) + :Ldur (om-round (create-list (length (ldur object)) (om/ dur (length (ldur object))))) + :lonset (om-round (dx->x 0 (create-list (length (ldur object)) (om/ dur (length (ldur object)))))))))) + + (newport (lier res) (lport object)))) + + +(om::defmethod! iso-dur ((object multi-seq) (dur number) (mode t)) + :initvals '(nil 200 'durtot) + :icon 136 + :menuins (list (list 2 '(("interval" 'interv) ("durtotal" 'durtot) ))) + + (let* ((res )) + (dolist (seq (chord-seqs object)) + (push (iso-dur seq dur mode) res )) + (mki 'multi-seq :chord-seqs (reverse res)))) + + + + + +(om::defmethod! time-vocoder ((object chord-seq) (reservoirs chord-seq) + &optional (mode 'midic)) + + :initvals '(nil nil 'midic) + :menuins (list ( list 2 '(("Midics" 'midic) ("Freqs" 'freqs)))) + :indoc '("object" "réservoir" "mode") + :icon 137 + :doc "applique le contenu du ch-seq sur la succession de champs harmoniques . + i.e. chaque note de sera 'accordée' sur le champ harmonique correspondant au même instant. + doit avoir une duree au moins égale à celle de " + +(let* ((obj (explosion object)) + (obj-onsets (lonset obj)) + (champs (chords reservoirs)) + (intervalles (lonset reservoirs)) + voconotes) + +(loop for ch in (chords obj ) + for ons in obj-onsets + do (push (ch-vocoder ch (lmidic (nth-obj reservoirs (cherche-intervalle ons intervalles)))) voconotes)) + +(mki 'chord-seq + :lmidic (nreverse voconotes) + :lonset obj-onsets + :legato (legato object)))) + + + +(om::defmethod! time-vocoder ((object multi-seq) (reservoirs chord-seq) + &optional (mode 'midic)) + +(let ((res)) +(loop for seq in (chord-seqs object) + do (push (time-vocoder seq reservoirs mode) res)) +(mki 'multi-seq :chord-seqs (reverse res)))) + + + + + + +(defun cherche-intervalle (nb intervalles) + (let* ((long (- (length intervalles) 2)) res) + (for (i 0 1 long) + (if (and (>= nb (nth i intervalles)) (< nb (nth (1+ i) intervalles))) (setq res i))) + res)) + + + + +(om::defmethod! triller ((chord chord) (interval number) (freq number) (dur number) ) + + :initvals '(nil 100 10 1000 ) + :icon 136 + :doc "create trills on all the notes of . interval of trill given by (midic) + in hz, in msec . +velocity, channel and port identical to 1st note of " + + (let* ((lch (chords (explosion chord))) + (ltrilles (loop for n in lch + collect (trille (mixer (list n (om+ n interval)) nil) freq dur)))) + (mixer ltrilles nil))) + + + + + +(om::defmethod! proliferer ((chseq chord-seq) (density number) (ecart integer) ) + :initvals '(nil 1.5 200) + :icon 136 + :doc "add notes - number defined by density (float) - pitch defined by ecart (midic)) - other parameters=average of seq " + + (let* ((notes (lmidic chseq)) + (nbnewnotes (om-round (- (* (length notes) density) (length notes)))) + (newmax (+ (list-max notes) ecart)) + (newmin (- (list-min notes) ecart)) + (resulseq chseq) + (newnotes (om-round (n-arithm newmin newmax nbnewnotes))) + (durmoy (list! (om-round (om-mean (flat (ldur chseq)))))) + (canal (first (lchan chseq))) + (port (first (lport chseq))) + (velo (list! (om-round (om-mean (flat (lvel chseq)))))) ) + +(print durmoy) +(print velo) +(print canal) +(print port) + + (dolist (n newnotes) + (setq resulseq (random-insert n durmoy velo canal port resulseq))) +resulseq)) + + +(defun random-insert (newnote durmoy velo canal port resulseq) + (let* ((onsets (lonset resulseq)) + ) + (insert-object resulseq + (mki 'chord + :Lmidic (list newnote) + :LVel velo + :LDur durmoy + :LOffset (list 0) + :LChan canal + :Lport port) (nth-random onsets)))) + + diff --git a/sources/speartext.lisp b/sources/speartext.lisp new file mode 100755 index 0000000..18aa238 --- /dev/null +++ b/sources/speartext.lisp @@ -0,0 +1,707 @@ + +(in-package :om) + + + + +;; +;; need to allow linefeed for end of line as well as newline +;; +(defun getline (input-stream eof-error-p eof-value) + (declare (optimize (speed 3) (safety 1))) + (if (stream-eofp input-stream) + (if eof-error-p + (error 'end-of-file :stream input-stream) + (values eof-value (or eof-value t))) + (let ((char nil) + (str (make-array 20 + :element-type 'base-character + :adjustable t :fill-pointer 0))) + ;(multiple-value-bind (reader reader-arg) (stream-reader input-stream) + (while (and (setq char (read-char input-stream nil nil)) ; (funcall reader reader-arg)) + (not (eq char #\newline)) + (not (eq char #\linefeed))) + ;;; !!! CCL + ;(when (and (not (base-character-p char)) (base-string-p str)) + ; (setq str (ccl-string-to-extended-string str))) + (vector-push-extend char str)) + ; ) + (values str (null char))))) + + +;; first -- list of times +;; second -- list of freq frames +;; third -- list of amp frames +;; fourth -- list of index frames + + +(om::defmethod! spear-write ( times indices frequencies amplitudes &optional (filename nil)) + + :initvals (list nil nil nil nil nil) + :icon 128 + :doc "" + + (setf filename (if (equal filename 'nil) (om-choose-new-file-dialog ) filename)) + (with-open-file (file filename :direction :output :if-exists :supersede) + (let ((num-frames (length times))) + (format file "par-text-frame-format~c" #\linefeed) + (format file "point-type index frequency amplitude~c" #\linefeed) + (format file "frame-count ~d~c" num-frames #\linefeed) + (format file "frame-data~c" #\linefeed) + (loop for time in times + for freqs in frequencies + for amps in amplitudes + for inds in indices + do + (format file "~d ~d" time (length freqs)) + (loop for freq in freqs + for amp in amps + for index in inds + do + (format file " ~d ~d ~d" index freq amp)) + (format file "~c" #\linefeed))))) + + + + + +#| + +(let ((data (read-spear-text-format "HDN:Users:mkling:Desktop:Earth62Noisy.sdif.txt" 100))) + (write-spear-text-format "HDN:Users:mkling:Desktop:foo.txt" + (first data) + (second data) + (third data) + (fourth data))) +|# + +(defmethod read-spear-spdata ((self C-spdata-seq) filename beg end &optional nmax) + (with-open-file (input filename :direction :input) + (let* ((valid-format t) + (header + (loop with reading-header = t + for i from 0 + while (and valid-format reading-header) + collect + (let* ((line (getline input nil nil)) + (line-list (loop with stream = (make-string-input-stream line) + for item = (read stream nil :eof) + while (not (eq item :eof)) + collect item))) + (cond + ((and (= i 0) (not (eq (first line-list) 'par-text-frame-format))) + (progn + (setf valid-format nil) + nil)) + ((eq (first line-list) 'frame-data) + (progn + (setf reading-header nil) + line-list)) + (t + line-list)))))) + (when (first header) + (let* ((point-type (cdr (assoc 'point-type header :test 'eq))) + (requested-types '(index frequency amplitude)) + (requested-length (length requested-types)) + (avail-types (intersection requested-types point-type)) + (point-length (length point-type)) + (frame-count (car (cdr (assoc 'frame-count header :test 'eq)))) + point-indexing + time point-count current-frame) + (when (= (length requested-types) (length avail-types)) + (setf point-indexing + (loop for pt in point-type + collect + (position pt requested-types))) + + ;;; Now read the frames + ;;; should worry about eof's + (loop for fr from 0 below frame-count + ;;; read time + for time = (read input nil :eof) + for before-end = (or (not end) (and end (<= time end))) + for after-beg = (or (not beg) (and beg (>= time beg))) + for store = (and after-beg before-end) + while before-end + do + ;;;;;;;;;;;;;;;;;; (push time (elt all-data 0)) + (setf point-count (read input nil :eof)) + ;;;; make a data structure to store the data for this frame + (when store (setf current-frame (make-instance 'C-spdata))) + (loop for ix from 0 below point-count + do + (loop for ip in point-indexing + for value = (read input nil :eof) + if store do + (cond ((= ip 0) + ;; index type + (push value (partials current-frame))) + ((= ip 1) + ;; frequency type + (push value (freqs current-frame))) + ((= ip 2) + (push value (amps current-frame)))))) + (when store + (setf (size current-frame) point-count) + ;;;; frame appears to be the time value of this frame + (setf (frame current-frame) time) + (setf (partials current-frame) (nreverse (partials current-frame))) + (setf (freqs current-frame) (nreverse (freqs current-frame))) + (setf (amps current-frame) (nreverse (amps current-frame))) + ;;;; what is this???? + (setf (weights current-frame) (make-list point-count :initial-element 1)) + (setf (bws current-frame) (make-list point-count :initial-element 1)) + (push current-frame (spdata self)))) + (setf (spdata self) (nreverse (spdata self))) + + (setf (file self) (namestring filename)) + (setf (typ self) 'mask) + (let ((end-time (frame (car (last (spdata self))))) + (start-time (frame (first (spdata self))))) + (setf (duration self) (- end-time start-time)) + (format t "finished reading SPEAR additive synthesis file ~D from time ~5F to ~5F duration ~5F ~%" filename + start-time end-time (duration self))) + + (when beg ;; if begin time was specified, adjust all time frame values + ;;(when (= beg (frame (first (spdata self)))) + ;; I think this is wrong -- + ;; (setf beg (- beg (- (first (spdata self)) (second (spdata self)))))) + (mapc #'(lambda (x) (setf (frame x) (- (frame x) beg))) (spdata self))) + + self)))))) + + + + + +#| +(pprint (read-spear-text-format "HDN:Users:mkling:Desktop:Earth62Noisy.sdif.txt" 4)) + +(read-spear-text-format "HDN:Users:mkling:Desktop:Frequency.dmg") +|# + +#| +(om::defmethod! spear-read ((filename t) + &optional (beg nil) (end nil) (nmax nil)) + :initvals (list nil nil nil nil) + :indoc '("filename" "beg" "end" "nmax") + :icon 128 + :doc "reads SPEAR analysis data from a text file and returns a spdata object (c-spdata-seq class)" + (let ((spdata-seq (make-instance 'C-spdata-seq))) + (unless filename + (setf filename (CCL:choose-file-dialog :directory *lastspfile* + :button-string "SPEAR text file"))) + (when filename + (setf *lastspfile* filename) + (read-spear-spdata spdata-seq filename beg end nmax) + ) + ) + ) + +|# + + +; :directory *lastspfile* pose probleme quand on change d'environnement + + +(om::defmethod! spear-read ((filename t) + &optional (beg nil) (end nil) (nmax nil)) + :initvals (list nil nil nil nil) + :indoc '("filename" "beg" "end" "nmax") + :icon 128 + :doc "reads SPEAR analysis data from a text file and returns a spdata object (c-spdata-seq class)" + (let ((spdata-seq (make-instance 'C-spdata-seq))) + (unless filename + (setf filename (om-choose-file-dialog + :button-string "SPEAR text file"))) + (when filename + (setf *lastspfile* filename) + (read-spear-spdata spdata-seq filename beg end nmax) + ) + ) + ) + + + + +#| +(defun read-spear-text-format (filename &optional (num-frames 5)) + (with-open-file (input filename :direction :input) + (let* ((valid-format t) + (header + (loop with reading-header = t + for i from 0 + while (and valid-format reading-header) + collect + (let* ((line (getline input nil nil)) + (line-list (loop with stream = (make-string-input-stream line) + for item = (read stream nil :eof) + while (neq item :eof) + collect item))) + (cond + ((and (= i 0) (neq (first line-list) 'par-text-frame-format)) + (progn + (setf valid-format nil) + nil)) + ((eq (first line-list) 'frame-data) + (progn + (setf reading-header nil) + line-list)) + (t + line-list)))))) + (when (first header) + (let* ((point-type (cdr (assq 'point-type header))) + (requested-types '(index frequency amplitude)) + (requested-length (length requested-types)) + (avail-types (intersection requested-types point-type)) + (point-length (length point-type)) + (frame-count (car (cdr (assq 'frame-count header)))) + time point-count frame-data point-indexing + all-data + ) + (when (= (length requested-types) (length avail-types)) + (setf point-indexing + (loop for pt in point-type + collect + (position pt requested-types))) + + (setf all-data (make-list (1+ requested-length))) + + (loop for fr from 0 below (min num-frames frame-count) + ;;; Now read the frames + ;;; should worry about eof's + ;;; read time + do + (setf time (read input nil :eof)) + (push time (elt all-data 0)) + collect + (progn + ;;(setf time (read input nil :eof)) + (setf point-count (read input nil :eof)) + (setf frame-data (make-list (length requested-types))) + (loop for ix from 0 below point-count + do + (loop for ip in point-indexing + for value = (read input nil :eof) + do + (when ip + (push value (elt frame-data ip))))) + (loop for ix from 0 below requested-length + do + (push (nreverse (elt frame-data ix)) (elt all-data (1+ ix)))))) + (loop for ix from 0 to requested-length + do + (setf (elt all-data ix) (nreverse (elt all-data ix)))) + all-data)))))) +|# + + + +;================================= matching ====================================================== + + + + + + +(om::defmethod! matching ((dates list) (frqs list) (amps list) (spatia list) + (fichier list)) +:initvals (list '(1 2) '(1 2) '(1 2) '(1 2) nil) + :indoc '("dates" "frqs" "amps" "spatia" "fichier") + :icon 128 + :doc "" + + + (let ((nom (or fichier (choose-new-file-dialog))) + (prev-frame nil) + (prev-time nil)) + + (flet ((output-frame (fil time frame) + (format fil "~f " time) + (loop for ix from 0 below (length prev-frame) + for elem = (elt prev-frame ix) + do + (format fil "~f ~f ~f ~d " (first elem) (second elem) (third elem) (sixth elem))) + (format fil "~%"))) + + (when nom + (with-open-file (file nom :direction :output + :if-exists :supersede) + ;; magic number + (format file "omTr~%") + + (loop with track-count = 0 + for cur-time in dates + for cur-freq-frame in frqs + for cur-amp-frame in amps + for cur-pan-frame in spatia + for cur-frame = (make-array (length cur-freq-frame)) + do + ;; genreate format of new frame as an array + (loop for ix from 0 + for freq in cur-freq-frame + for amp in cur-amp-frame + for pan in cur-pan-frame + do + ;; format is freq, amp, pan, forward index, backward index + (setf (elt cur-frame ix) (list freq amp pan nil nil nil))) + + (when prev-frame + ;; if previous frame, match from previous forward to new frame + (loop for pix from 0 below (length prev-frame) + for prev = (elt prev-frame pix) + do + (loop for cix from 0 below (length cur-frame) + for cur = (elt cur-frame cix) + for cents = (abs (* 1200 (log (/ (first cur) (first prev)) 2))) + for other-match = nil + do + ;;; check distance in frequency + (when (< cents 125) + ;;; see if this is already claimed match + (if (fourth prev) + ;;; previous already matched forward + (setf other-match (abs (* 1200 + (log (/ (first prev) + (first (elt cur-frame (fourth prev)))) 2)))) + (when (fifth cur) + ;;; current is already matched backward to another peak + (setf other-match (abs (* 1200 + (log (/ (first cur) + (first (elt prev-frame (fifth cur)))) 2)))))) + + (when (or (not other-match) + (< cents other-match)) + + ;;; connect previous to current + ;;; clear other connections + (when (fourth prev) + ;;; previous already points forward + ;;; clear the backward reference from the forward reference + (setf (fifth (elt cur-frame (fourth prev))) nil) + (setf (sixth (elt cur-frame (fourth prev))) nil)) + (when (fifth cur) + ;;; current already points backward + ;;; clear the forward reference from the backward reference + (setf (fourth (elt prev-frame (fifth cur))) nil)) + + + ;;; forward match + (setf (fourth prev) cix) + ;;; backward match + (setf (fifth cur) pix) + ;;; track index + (setf (sixth cur) (sixth prev)) + )))) + ;; unmatched forward in previous frame are deaths (insert into current?) + ;; unmatched back in current frame are births (insert into previous?) + + ;; now output the previous frame + (output-frame file prev-time prev-frame)) + + ;; fill in unmatched back in current frame with birth index + (loop for ix from 0 below (length cur-frame) + for cur = (elt cur-frame ix) + if (not (sixth cur)) + do + (setf (sixth cur) track-count) + (incf track-count)) + + + (setf prev-frame cur-frame) + (setf prev-time cur-time)) + + (when prev-frame + (output-frame file prev-time prev-frame)) + ))))) + + +;;; defines the data structure for a single partial +(defstruct (sp-partial (:constructor + make-partial + (&optional (size 0) + (time (make-array size :element-type 'float)) + (freq (make-array size :element-type 'float)) + (amp (make-array size :element-type 'float))))) + (size 0 :type integer) + (time (make-array 0 :element-type 'float) :type array) + (freq (make-array 0 :element-type 'float) :type array) + (amp (make-array 0 :element-type 'float) :type array)) + +(defun sp-partial-start (par) + (elt (sp-partial-time par) 0)) + +(defun sp-partial-end (par) + (elt (sp-partial-time par) (- (sp-partial-size par) 1))) + +(defun sp-partial-dur (par) + (- (sp-partial-end par) (sp-partial-start par))) + +;; times of all partials as a list of lists +(defun sp-partials-times (partials) + (loop for par in partials + collect (coerce (sp-partial-time par) 'list))) + +;; frequencies of all partials as a list of lists +(defun sp-partials-freqs (partials) + (loop for par in partials + collect (coerce (sp-partial-freq par) 'list))) + +;; amplitudes of all partials as a list of lists +(defun sp-partials-amps (partials) + (loop for par in partials + collect (coerce (sp-partial-amp par) 'list))) + +;; read a spear file in par-text-partials format +(defun read-sp-partials (filename) + (with-open-file (input filename :direction :input) + (let* ((partials nil) + (valid-format t) + (header + (loop with reading-header = t + for i from 0 + while (and valid-format reading-header) + collect + (let* ((line (read-line input nil nil)) + (line-list (loop with stream = (make-string-input-stream line) + for item = (read stream nil :eof) + while (not (eq item :eof)) + collect item))) + (cond + ((and (= i 0) (not (eq (first line-list) 'par-text-partials-format))) + (progn + (setf valid-format nil) + nil)) + ((eq (first line-list) 'partials-data) + (progn + (setf reading-header nil) + line-list)) + (t + line-list)))))) + (when (first header) + (let* ((point-type (cdr (assoc 'point-type header))) + (requested-types '(time frequency amplitude)) + ;;(requested-length (length requested-types)) + (avail-types (intersection requested-types point-type)) + ;;(point-length (length point-type)) + (partials-count (car (cdr (assoc 'partials-count header)))) + point-indexing + current-partial) + (when (= (length requested-types) (length avail-types)) + (setf point-indexing + (loop for pt in point-type + collect + (position pt requested-types))) + +;;; Now read the partials +;;; should worry about eof's + (loop for pr from 0 below partials-count +;;; read index + for index = (read input nil :eof) +;;; read length + for point-count = (read input nil :eof) +;;; read start time + for start-time = (read input nil :eof) +;;; read end time + for end-time = (read input nil :eof) + for store = t + do +;;;; make a data structure to store the data for this frame + (when store (setf current-partial (make-partial point-count)) + start-time + end-time + index + (loop for ix from 0 below point-count + do + (loop for ip in point-indexing + for value = (read input nil :eof) + if store do + (cond + ((= ip 0) + ;; time type + (setf (elt (sp-partial-time current-partial) ix) (coerce value 'float))) + ((= ip 1) + ;; frequency type + (setf (elt (sp-partial-freq current-partial) ix) (coerce value 'float))) + ;; amplitude type + ((= ip 2) + (setf (elt (sp-partial-amp current-partial) ix) (coerce value 'float))))))) + (when store + (push current-partial partials)))))) + (nreverse partials)))) + + +(om::defmethod! spear-read-partials ((filename t)) + :initvals (list nil) + :indoc '("filename") + :icon 128 + :doc "reads SPEAR analysis data in partials format from a text file and returns a list of sp-partials" + (unless filename + (setf filename (om-choose-file-dialog + :button-string "SPEAR text file"))) + (when filename + (read-sp-partials filename))) + +(defun write-sp-partials (filename partials) + (format t "Writing partials...") + (with-open-file (file filename :direction :output :if-exists :supersede) + (let ((num-partials (length partials))) + (write-partials-header file num-partials) + (loop for par in partials + for ix from 0 + do + (write-partial file par ix)))) + (format t "done~%")) + +(defun write-partials-header (file count) + (format file "par-text-partials-format~c" #\linefeed) + (format file "point-type time frequency amplitude~c" #\linefeed) + (format file "partials-count ~d~c" count #\linefeed) + (format file "partials-data~c" #\linefeed)) + +(defun write-partial (file partial index) + (let* ((times (sp-partial-time partial)) + (freqs (sp-partial-freq partial)) + (amps (sp-partial-amp partial)) + (length (min (length times) (length freqs) (length amps)))) + (when (> length 0) + (format file "~d ~d ~d ~d~c" index length + (elt times 0) + (elt times (1- length)) + #\linefeed) + (format file "~d ~d ~d" (elt times 0) (elt freqs 0) (elt amps 0)) + (loop for i from 1 below length + do (format file " ~d ~d ~d" (elt times i) (elt freqs i) (elt amps i))) + (format file "~c" #\linefeed)))) + +(om::defmethod! spear-write-partials ((partials t) (filename t)) + :initvals (list nil nil) + :indoc '("partials" "filename") + :icon 128 + :doc "write SPEAR analysis data in partials format" + (unless filename + (setf filename (om-choose-new-file-dialog))) + (write-sp-partials filename partials)) + +(om::defmethod! spear-make-partials ((times list) (frequencies list) (amplitudes list)) + :initvals (list nil nil nil) + :icon 128 + :doc "make a list of sp-partials suitable for writing using spear-write-partials" + (loop for time-l in times + for freq-l in frequencies + for amp-l in amplitudes + collect + (make-partial (length time-l) (coerce time-l 'vector) (coerce freq-l 'vector) (coerce amp-l 'vector)))) + +(defun copy-partial (partial) + (make-partial (sp-partial-size partial) + (copy-seq (sp-partial-time partial)) + (copy-seq (sp-partial-freq partial)) + (copy-seq (sp-partial-amp partial)))) + +(defun offset-partial (partial offset &optional (copy t)) + (let ((np (if copy (copy-partial partial) + partial))) + (loop for i from 0 below (sp-partial-size np) + do + (incf (elt (sp-partial-time np) i) offset)) + np)) + +(defun transpose-partial (partial interval-ratio &optional (copy t)) + (let ((np (if copy (copy-partial partial) + partial))) + (loop for i from 0 below (sp-partial-size np) + for f = (elt (sp-partial-freq np) i) + do + (setf (elt (sp-partial-freq np) i) (* f interval-ratio))) + np)) + +(defun transpose-partial-env (partial interval-ratio strength-env &optional (copy t)) + (let ((np (if copy (copy-partial partial) + partial))) + (loop for i from 0 below (sp-partial-size np) + for f = (elt (sp-partial-freq np) i) + for time = (elt (sp-partial-time np) i) + do + (setf (elt (sp-partial-freq np) i) + (* f (+ 1.0 (* (interpl time strength-env) (- interval-ratio 1.0)))))) + np)) + +(defun stretch-partial (partial timescale &optional (copy t)) + (let* ((np (if copy (copy-partial partial) + partial)) + (start (sp-partial-start np))) + (loop for i from 0 below (sp-partial-size np) + for time = (elt (sp-partial-time np) i) + do + (setf (elt (sp-partial-time np) i) + (+ start (* timescale (- time start))))))) + +(defun time-scale-partial (partial timescale &optional (copy t)) + (stretch-partial partial timescale copy)) + +(defun amplitude-scale-partial (partial ampscale &optional (copy t)) + (let ((np (if copy (copy-partial partial) + partial))) + (loop for i from 0 below (sp-partial-size np) + for a = (elt (sp-partial-amp np) i) + do + (setf (elt (sp-partial-amp np) i) (* a ampscale))) + np)) + +(defun ambitus-scale-partial (partial scaling average-freq &optional (copy t)) + (let* ((np (if copy (copy-partial partial) + partial)) + (minf (loop for i from 0 below (sp-partial-size np) + for f = (elt (sp-partial-freq np) i) + minimize f)) + (maxf (loop for i from 0 below (sp-partial-size np) + for f = (elt (sp-partial-freq np) i) + maximize f)) + (newmin (- average-freq (* (- average-freq minf) scaling))) + (newmax (+ average-freq (* (- maxf average-freq) scaling)))) + (loop for i from 0 below (sp-partial-size np) + for f = (elt (sp-partial-freq np) i) + do + (if (/= minf maxf) + (setf (elt (sp-partial-freq np) i) (rescale f minf maxf newmin newmax)))) + np)) + +;; assumes amplitude envelope from 0 to 100! +(defun amp-env-partial (partial env &optional (copy t)) + (let* ((np (if copy (copy-partial partial) + partial)) + (start (sp-partial-start np)) + (end (sp-partial-end np)) + (envmin (first env)) + (envmax (first (last env 2)))) + (loop for i from 0 below (sp-partial-size np) + for time = (elt (sp-partial-time np) i) + for pamp = (elt (sp-partial-amp np) i) + for amp = (* pamp (interpl (rescale time start end envmin envmax) env)) + do + (setf (elt (sp-partial-amp np) i) amp)))) + +;;(defun ampmax-env-partial (partial env &optional (copy nil)) + ;; TODO + +(defun sp-partial-avg-freq (partial) + (let* ((freqs (sp-partial-freq partial)) + (len (length freqs))) + (/ (loop for i from 0 below len + summing + (elt freqs i)) len))) + +(defun sp-partial-avg-amp (partial &optional (points nil)) + (let* ((amps (sp-partial-amp partial)) + (len (if points (min points (length amps)) (length amps)))) + (/ (loop for i from 0 below len + summing + (elt amps i)) len))) + +(defun sp-partials-avg-freqs (partials) + (loop for par in partials collect (sp-partial-avg-freq par))) + +(defun sp-partials-avg-amps (partials) + (loop for par in partials collect (sp-partial-avg-amp par))) + diff --git a/sources/utils.lisp b/sources/utils.lisp new file mode 100755 index 0000000..062b8ab --- /dev/null +++ b/sources/utils.lisp @@ -0,0 +1,272 @@ +(in-package :om) + + +; =========== fonctions utiles ======================== + +; om-mean ne marche que sur des listes simples +(defmethod! tm-average ((liste list) &optional (weights 1)) + :initvals (list '(1 3 5) 1) + :indoc '("list of numbers" "list of numbers") + :icon 136 + :doc "like om-mean, but accepts trees" + (less-tree-mapcar (function average) liste weights)) + + + +; ---------------pour compatibilité----------------- + +(defun l-nth (list positions) + (posn-match list positions)) + + +; --------------------------------------------------- + +(defun car! (thing) + "Returns (caa...ar ). Applies #'car as many times as possible (maybe 0)." + (ifnot (consp thing) thing (car! (car thing)))) + + +(defun carlist! (thing) + "Returns an atom if thing is an atom or a one-element list, + otherwise returns the list unchanged " + (if (and (consp thing) (= (length thing) 1)) (car! thing) thing)) + + + +(defun double-mapcar (fun1 list1? list2? &rest args) + "Mapcars or applies to +whether each of is a list or not." + (cond + ((consp list1?) + (if (consp list2?) + ;(error "cannot double-mapcar 2 lists: ~S and ~S~%." list1? list2?) + (mapcar #'(lambda (x1 x2) (apply fun1 x1 x2 args)) + list1? list2?) + (mapcar #'(lambda (x) (apply fun1 x list2? args)) + list1?))) + ((consp list2?) + (mapcar #'(lambda (x) (apply fun1 list1? x args)) + list2?)) + (t (apply fun1 list1? list2? args)))) + + +(defmethod arith-tree-mapcar ((fun function) (arg1 number) (arg2 number) &optional accumulator) + (if accumulator (reverse (cons (funcall fun arg1 arg2) accumulator)) (funcall fun arg1 arg2))) + +(defmethod arith-tree-mapcar ((fun function) (arg1 cons) (arg2 number) &optional accumulator) + (arith-tree-mapcar fun (cdr arg1) arg2 (cons (arith-tree-mapcar fun (car arg1) arg2) accumulator))) + +(defmethod arith-tree-mapcar ((fun function) (arg1 null) arg2 &optional accumulator) + (declare (ignore arg1 arg2)) (reverse accumulator)) + +(defmethod arith-tree-mapcar ((fun function) (arg1 number) (arg2 cons) &optional accumulator) + (arith-tree-mapcar fun arg1 (cdr arg2) (cons (arith-tree-mapcar fun arg1 (car arg2)) accumulator))) + +(defmethod arith-tree-mapcar ((fun function) arg1 (arg2 null) &optional accumulator) + (declare (ignore arg1 arg2 )) (reverse accumulator)) + +(defmethod arith-tree-mapcar ((fun function) (arg1 cons) (arg2 cons) &optional accumulator) + (arith-tree-mapcar fun (cdr arg1) (cdr arg2) + (cons (arith-tree-mapcar fun (car arg1) (car arg2)) accumulator))) + + +#| +(defmethod LLdecimals ((list t) (nbdec integer)) + "Arrondit liste de profondeur quelconque avec dŽcimales" +(let ((ndec + (if (> nbdec 0 ) (float (expt 10 nbdec)) (expt 10 nbdec)))) + (deep-mapcar/1 '/ + (deep-mapcar/1 'round list (/ 1 ndec)) ndec ))) +|# + + +(defun list-fill (list len) + "Duplicates the elements of until its length equals ." + (check-type len (integer 0 *) "a positive integer") + (let* ((length (length (setq list (list! list)))) + ;; len = length*n + r + (n (floor len length)) + (r (mod len length)) + ;; len = r*(n+1) + (length-r)*n + (l ())) + (repeat r + (repeat (1+ n) (newl l (car list))) + (nextl list)) + (repeat (- length r) + (repeat n (newl l (car list))) + (nextl list)) + (nreverse l))) + + +(defun unique-1 (lst test ) + "returns a copy of the list, dropping duplicate values" + (cond + ((null lst) ()) + ((member (car lst) (cdr lst) :test test) (unique-1 (cdr lst) test)) + (t (cons (car lst) (unique-1 (cdr lst) test))))) + +(defun unique (lst ) + "returns a copy of , dropping duplicate values (deepest level)" + (less-deep-mapcar #'(lambda (x) (unique-1 x #'eq)) lst)) + + + +(defun LL/round (l1? div ) + "Rounding of two of numbers or lists." + (deep-mapcar/1 'round l1? div)) + + +; ------------------------------------------- +; fonctions existant déjà dans Esquisse + + +(defun car-mapcar (fun list? &rest args) + "Mapcars if list? is a list or applies if it is an atom or +a one-element list" + (cond ((atom list?) (apply fun list? args)) + ((= (length list?) 1) (apply fun (car list?) args)) + (t (mapcar #'(lambda (x) (apply fun x args )) list? )))) + +(defun less-deep-mapcar (fun list? &rest args) + "Applies to if is a one-level list . + Mapcars to if is a multi-level list. " + (cond + ((null list?) ()) + ((atom (car list?)) (apply fun list? args)) + ((atom (car (car list?))) + (cons (apply fun (car list?) args ) (apply #'less-deep-mapcar fun (cdr list?) args))) + (t (cons (apply #'less-deep-mapcar fun (car list?) args) + (apply #'less-deep-mapcar fun (cdr list?) args))))) + + +(defun one-elem (item) + (or (atom item) (= (length item) 1))) + +(defun carlist! (thing) + "Returns an atom if thing is an atom or a one-element list, + otherwise returns the list unchanged " + (if (and (consp thing) (= (length thing) 1)) (car! thing) thing)) + + + + +#| +;Exists already in OM ??? + +(defmethod! band-filter+ ((list list) (bounds list) (mode symbol)) + :initvals '('(1 2 3 4 5) '((0 2) (5 10)) 'pass) + :indoc '("list" "bounds" "mode" ) + :menuins '((2 (("Reject" 'reject) ("Pass" 'pass)))) + :icon 235 + :doc "filters out (a list or a tree of numbers) using . + is a list of pairs (min-value max-value). Elts in list are selected if they stay between the bounds. + is a menu input. 'Reject' means reject elts that are selected. +'Pass' means retain only elts that are selected." + (let ((bounds (if (atom (first bounds)) (list bounds) bounds))) + (list-filter + #'(lambda (item) + (some #'(lambda (bound) (and (>= item (first bound)) (<= item (second bound)))) bounds)) + list + mode))) + +|# + +; ------------------------------------------- +;Keep it finaly for compatibility +; à réécrire, si nécessaire + +(defun chord->list! (accord) +"teste si type accord ou liste; rend midics" + (if (typep accord 'list) accord (lmidic accord ))) + +; -> donner ce type en entrée de l'accord : (list (:value () :dialog-item-text "()" :type-list ())) + + +;Methode ˆ integrer directement ds OpenMusic + +(defmethod om-scale/max ((list list) (max number)) +"scales (may be tree) so that its max becomes . Trees must be +well-formed: The children of a node must be either all leaves or all nonleaves. " + (less-tree-mapcar #'(lambda (x y) (om* x (/ y (list-max x)))) list max t)) + +;--------------------------------------------------------------------------------------- +;------------------------------------Integres monmentanement----------------------------- +;------------------------pour l'ouverture des patchs joints------------------------------ + +(defun l-max (list) + "maximum value(s) of a list or list of numbers" + (if (not (consp (first list))) + (apply 'max list) + (mapcar #'(lambda (x) (apply 'max x)) list))) + +(om::defmethod* l-assoc ((format symbol) + (list1 list) (list2 list) + &rest lst?) + + + :initvals (list "flat" '(1 2) '(1 2) '(1 2)) + :indoc '("format" "list1" "list2" "other lists") + :icon 132 + :menuins '((0 (("flat" 'flat) ("struct" 'struct) ("flat-low" 'flat-low)))) + :doc "couple les listes : (1 2 3) (10 11 12) --> (1 10 2 11 3 12)" + + (let* ((listgen (append (list list1 list2) lst?)) + (long (1- (l-max (mapcar #'length listgen)))) res) + (for (i 0 1 long) + (push (car-mapcar #'l-nth listgen i) res)) + (cond ((equal format 'flat) (flat (nreverse res))) + ((equal format 'struct) (nreverse res)) + ((equal format 'flat-low) (flat-low (nreverse res)))))) + + + +#| +;librairie-TM.lisp + + +(defun substit-one (liste elem val fct) + (let ((long (1- (length liste) )) (val (list val))) + (x-append (l-nth liste (arithm-ser 0 (1- elem) 1)) + (if (equal fct '=) val (funcall fct (l-nth liste elem) val )) + (l-nth liste (arithm-ser (1+ elem) long 1)) ))) + +(defmethod substit ((liste list) (elem list) (val list) + &optional (fct '=)) + + :initvals (list '(1 2) '(1 2) "name" '=) + :indoc '("liste" "elem" "val" "fct" ) + :icon 132 + :doc "remplace les ŽlŽments de n¡ par les valeurs + extension: = fonction ; si diffŽrent de ''='', + on remplace alors par ( )" + + + (let* ((elem (list! elem)) (lg (1- (length elem))) + (val (if (and (consp val) (one-elem elem)) (list val) (list! val)))) + (for (n 0 1 lg) + (setq liste (substit-one liste (l-nth elem n) (l-nth val n) fct))) + liste)) +|# + + +;--------------------------------------lfa->coll------------------------------------------------ + + + + + + + + + + + + + + + + + + + +