pax_global_header00006660000000000000000000000064141560155130014513gustar00rootroot0000000000000052 comment=916b007cc7cc4bf250e6f71203bb36afb4ed8634 ocaml-mm-0.7.3/000077500000000000000000000000001415601551300132245ustar00rootroot00000000000000ocaml-mm-0.7.3/.github/000077500000000000000000000000001415601551300145645ustar00rootroot00000000000000ocaml-mm-0.7.3/.github/workflows/000077500000000000000000000000001415601551300166215ustar00rootroot00000000000000ocaml-mm-0.7.3/.github/workflows/doc.yml000066400000000000000000000010651415601551300201130ustar00rootroot00000000000000name: Build doc on: push: branches: - master jobs: build_doc: runs-on: ubuntu-latest steps: - name: Checkout code uses: actions/checkout@v2 - name: Setup OCaml uses: avsm/setup-ocaml@v2 - name: Pin locally run: opam pin -y add -n . - name: Install locally run: opam install -y odoc mm - name: Build doc run: opam exec dune build @doc - name: Deploy doc uses: JamesIves/github-pages-deploy-action@4.1.6 with: branch: gh-pages folder: _build/default/_doc/_html ocaml-mm-0.7.3/.github/workflows/main.yml000066400000000000000000000021261415601551300202710ustar00rootroot00000000000000name: Build on: [push] jobs: cancel_previous_run: runs-on: ubuntu-latest steps: - name: Cancel Previous Runs uses: styfle/cancel-workflow-action@0.8.0 with: access_token: ${{ github.token }} build: runs-on: ${{ matrix.operating-system }} strategy: matrix: operating-system: [ubuntu-latest, macos-latest] steps: - name: Checkout code uses: actions/checkout@v1 - name: Install OCaml uses: ocaml/setup-ocaml@v2 - name: Update packages run: | sudo apt-get update if: matrix.operating-system != 'macos-latest' - name: Pin locally run: opam pin -y add --no-action . - name: Install locally (macos) run: opam install -y mm ao mad pulseaudio theora gstreamer # SDL and graphics fail on OSX if: matrix.operating-system == 'macos-latest' - name: Install locally (ubuntu) run: opam install -y mm alsa ao mad pulseaudio ocamlsdl theora graphics gstreamer if: matrix.operating-system != 'macos-latest' - name: Run tests locally run: opam exec dune runtest ocaml-mm-0.7.3/.gitignore000066400000000000000000000000711415601551300152120ustar00rootroot00000000000000*~ _build *.byte *.native _tests .merlin *.install *.sw* ocaml-mm-0.7.3/.ocamlformat000066400000000000000000000003201415601551300155240ustar00rootroot00000000000000profile = conventional break-separators = after space-around-lists = false doc-comments = before match-indent = 2 match-indent-nested = always parens-ite exp-grouping = preserve module-item-spacing = compact ocaml-mm-0.7.3/CHANGES.md000066400000000000000000000032601415601551300146170ustar00rootroot000000000000000.7.3 (10-12-2021) ===== * Remove usage of __mingw_aligned_malloc as it needs a special free call. 0.7.2 (22-11-2021) ===== * Fix offsets in to_{s16, u8} functions. * Switch to `aligned_alloc` for allocate aligned memory, fix minor heap stats when allocating bigarrays with aligned memory. (ocaml/ocaml#10788) 0.7.1 (10-01-2021) ===== * Use only our own custom byte swap implementations. 0.7.0 (04-01-2021) ====== * Switch to dune! * Add set_alpha * Add box_alpha 0.6.0 (12-10-2020) ===== - Use `YUV420` for video frames. - Use bigarrays to implement mono audio buffers, should be more efficient. - Add `Image.Generic.blank`. - Add `scale` and `disk` effects on alpha channel for YUV420. - Make sure `to_mono` initializes an audio array with zeroes. 0.5.0 (18-08-2019) ===== * New implementation of `YUV420`, added many function to manipulate those. * Enhanced `Video` module. 0.4.1 (27-06-2019) ===== * Fix memory leak in `RGBA32.of_RGB24_string`. * Add `YUV420.of_string`. 0.4.0 (18-08-2018) ===== * Use bytes instead of strings whenever appropriate. 0.3.1 (16-10-2017) ===== * Fixed compilation with OCaml 4.06 0.3.0 (03-08-2015) ===== * Add support for S16BE, S24LE and S32LE * Fix deprecated APIs 0.2.1 (2013-02-18) ===== * Add pulseaudio backend. * Add channel and rate parameters for AO. * Add resampling mode (`Nearest or `Linear). * Remove on-the-fly samplerate conversions which were of bad quality (please use a proper resampler such as ocaml-samplerate instead). * Handle BGRA format. * Check for memory allocation failures. * Add a video player example. 0.2.0 (2011-10-04) ===== * Add alpha channel for drawn lines. * Improved autoconf. 0.1.0 (2011-06-30) ===== * Initial release. ocaml-mm-0.7.3/COPYING000066400000000000000000000654371415601551300142760ustar00rootroot00000000000000This program is released under the LGPL version 2.1 (see the text below) with the additional exemption that compiling, linking, and/or using OpenSSL is allowed. As a special exception to the GNU Library General Public License, you may also link, statically or dynamically, a "work that uses the Library" with a publicly distributed version of the Library to produce an executable file containing portions of the Library, and distribute that executable file under terms of your choice, without any of the additional requirements listed in clause 6 of the GNU Library General Public License. By "a publicly distributed version of the Library", we mean either the unmodified Library, or a modified version of the Library that is distributed under the conditions defined in clause 3 of the GNU Library General Public License. This exception does not however invalidate any other reasons why the executable file might be covered by the GNU Library General Public License. GNU LESSER GENERAL PUBLIC LICENSE Version 2.1, February 1999 Copyright (C) 1991, 1999 Free Software Foundation, Inc. 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. [This is the first released version of the Lesser GPL. It also counts as the successor of the GNU Library Public License, version 2, hence the version number 2.1.] Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public Licenses are intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This license, the Lesser General Public License, applies to some specially designated software packages--typically libraries--of the Free Software Foundation and other authors who decide to use it. You can use it too, but we suggest you first think carefully about whether this license or the ordinary General Public License is the better strategy to use in any particular case, based on the explanations below. When we speak of free software, we are referring to freedom of use, 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 this service if you wish); that you receive source code or can get it if you want it; that you can change the software and use pieces of it in new free programs; and that you are informed that you can do these things. To protect your rights, we need to make restrictions that forbid distributors to deny you these rights or to ask you to surrender these rights. These restrictions translate to certain responsibilities for you if you distribute copies of the library or if you modify it. For example, if you distribute copies of the library, whether gratis or for a fee, you must give the recipients all the rights that we gave you. You must make sure that they, too, receive or can get the source code. If you link other code with the library, you must provide complete object files to the recipients, so that they can relink them with the library after making changes to the library and recompiling it. And you must show them these terms so they know their rights. We protect your rights with a two-step method: (1) we copyright the library, and (2) we offer you this license, which gives you legal permission to copy, distribute and/or modify the library. To protect each distributor, we want to make it very clear that there is no warranty for the free library. Also, if the library is modified by someone else and passed on, the recipients should know that what they have is not the original version, so that the original author's reputation will not be affected by problems that might be introduced by others. Finally, software patents pose a constant threat to the existence of any free program. We wish to make sure that a company cannot effectively restrict the users of a free program by obtaining a restrictive license from a patent holder. Therefore, we insist that any patent license obtained for a version of the library must be consistent with the full freedom of use specified in this license. Most GNU software, including some libraries, is covered by the ordinary GNU General Public License. This license, the GNU Lesser General Public License, applies to certain designated libraries, and is quite different from the ordinary General Public License. We use this license for certain libraries in order to permit linking those libraries into non-free programs. When a program is linked with a library, whether statically or using a shared library, the combination of the two is legally speaking a combined work, a derivative of the original library. The ordinary General Public License therefore permits such linking only if the entire combination fits its criteria of freedom. The Lesser General Public License permits more lax criteria for linking other code with the library. We call this license the "Lesser" General Public License because it does Less to protect the user's freedom than the ordinary General Public License. It also provides other free software developers Less of an advantage over competing non-free programs. These disadvantages are the reason we use the ordinary General Public License for many libraries. However, the Lesser license provides advantages in certain special circumstances. For example, on rare occasions, there may be a special need to encourage the widest possible use of a certain library, so that it becomes a de-facto standard. To achieve this, non-free programs must be allowed to use the library. A more frequent case is that a free library does the same job as widely used non-free libraries. In this case, there is little to gain by limiting the free library to free software only, so we use the Lesser General Public License. In other cases, permission to use a particular library in non-free programs enables a greater number of people to use a large body of free software. For example, permission to use the GNU C Library in non-free programs enables many more people to use the whole GNU operating system, as well as its variant, the GNU/Linux operating system. Although the Lesser General Public License is Less protective of the users' freedom, it does ensure that the user of a program that is linked with the Library has the freedom and the wherewithal to run that program using a modified version of the Library. The precise terms and conditions for copying, distribution and modification follow. Pay close attention to the difference between a "work based on the library" and a "work that uses the library". The former contains code derived from the library, whereas the latter must be combined with the library in order to run. GNU LESSER GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any software library or other program which contains a notice placed by the copyright holder or other authorized party saying it may be distributed under the terms of this Lesser General Public License (also called "this License"). Each licensee is addressed as "you". A "library" means a collection of software functions and/or data prepared so as to be conveniently linked with application programs (which use some of those functions and data) to form executables. The "Library", below, refers to any such software library or work which has been distributed under these terms. A "work based on the Library" means either the Library or any derivative work under copyright law: that is to say, a work containing the Library or a portion of it, either verbatim or with modifications and/or translated straightforwardly into another language. (Hereinafter, translation is included without limitation in the term "modification".) "Source code" for a work means the preferred form of the work for making modifications to it. For a library, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the library. Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running a program using the Library is not restricted, and output from such a program is covered only if its contents constitute a work based on the Library (independent of the use of the Library in a tool for writing it). Whether that is true depends on what the Library does and what the program that uses the Library does. 1. You may copy and distribute verbatim copies of the Library's complete source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and distribute a copy of this License along with the Library. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Library or any portion of it, thus forming a work based on the Library, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) The modified work must itself be a software library. b) You must cause the files modified to carry prominent notices stating that you changed the files and the date of any change. c) You must cause the whole of the work to be licensed at no charge to all third parties under the terms of this License. d) If a facility in the modified Library refers to a function or a table of data to be supplied by an application program that uses the facility, other than as an argument passed when the facility is invoked, then you must make a good faith effort to ensure that, in the event an application does not supply such function or table, the facility still operates, and performs whatever part of its purpose remains meaningful. (For example, a function in a library to compute square roots has a purpose that is entirely well-defined independent of the application. Therefore, Subsection 2d requires that any application-supplied function or table used by this function must be optional: if the application does not supply it, the square root function must still compute square roots.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Library, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Library, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Library. In addition, mere aggregation of another work not based on the Library with the Library (or with a work based on the Library) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may opt to apply the terms of the ordinary GNU General Public License instead of this License to a given copy of the Library. To do this, you must alter all the notices that refer to this License, so that they refer to the ordinary GNU General Public License, version 2, instead of to this License. (If a newer version than version 2 of the ordinary GNU General Public License has appeared, then you can specify that version instead if you wish.) Do not make any other change in these notices. Once this change is made in a given copy, it is irreversible for that copy, so the ordinary GNU General Public License applies to all subsequent copies and derivative works made from that copy. This option is useful when you wish to copy part of the code of the Library into a program that is not a library. 4. You may copy and distribute the Library (or a portion or derivative of it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange. If distribution of object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place satisfies the requirement to distribute the source code, even though third parties are not compelled to copy the source along with the object code. 5. A program that contains no derivative of any portion of the Library, but is designed to work with the Library by being compiled or linked with it, is called a "work that uses the Library". Such a work, in isolation, is not a derivative work of the Library, and therefore falls outside the scope of this License. However, linking a "work that uses the Library" with the Library creates an executable that is a derivative of the Library (because it contains portions of the Library), rather than a "work that uses the library". The executable is therefore covered by this License. Section 6 states terms for distribution of such executables. When a "work that uses the Library" uses material from a header file that is part of the Library, the object code for the work may be a derivative work of the Library even though the source code is not. Whether this is true is especially significant if the work can be linked without the Library, or if the work is itself a library. The threshold for this to be true is not precisely defined by law. If such an object file uses only numerical parameters, data structure layouts and accessors, and small macros and small inline functions (ten lines or less in length), then the use of the object file is unrestricted, regardless of whether it is legally a derivative work. (Executables containing this object code plus portions of the Library will still fall under Section 6.) Otherwise, if the work is a derivative of the Library, you may distribute the object code for the work under the terms of Section 6. Any executables containing that work also fall under Section 6, whether or not they are linked directly with the Library itself. 6. As an exception to the Sections above, you may also combine or link a "work that uses the Library" with the Library to produce a work containing portions of the Library, and distribute that work under terms of your choice, provided that the terms permit modification of the work for the customer's own use and reverse engineering for debugging such modifications. You must give prominent notice with each copy of the work that the Library is used in it and that the Library and its use are covered by this License. You must supply a copy of this License. If the work during execution displays copyright notices, you must include the copyright notice for the Library among them, as well as a reference directing the user to the copy of this License. Also, you must do one of these things: a) Accompany the work with the complete corresponding machine-readable source code for the Library including whatever changes were used in the work (which must be distributed under Sections 1 and 2 above); and, if the work is an executable linked with the Library, with the complete machine-readable "work that uses the Library", as object code and/or source code, so that the user can modify the Library and then relink to produce a modified executable containing the modified Library. (It is understood that the user who changes the contents of definitions files in the Library will not necessarily be able to recompile the application to use the modified definitions.) b) Use a suitable shared library mechanism for linking with the Library. A suitable mechanism is one that (1) uses at run time a copy of the library already present on the user's computer system, rather than copying library functions into the executable, and (2) will operate properly with a modified version of the library, if the user installs one, as long as the modified version is interface-compatible with the version that the work was made with. c) Accompany the work with a written offer, valid for at least three years, to give the same user the materials specified in Subsection 6a, above, for a charge no more than the cost of performing this distribution. d) If distribution of the work is made by offering access to copy from a designated place, offer equivalent access to copy the above specified materials from the same place. e) Verify that the user has already received a copy of these materials or that you have already sent this user a copy. For an executable, the required form of the "work that uses the Library" must include any data and utility programs needed for reproducing the executable from it. However, as a special exception, the materials to be distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. It may happen that this requirement contradicts the license restrictions of other proprietary libraries that do not normally accompany the operating system. Such a contradiction means you cannot use both them and the Library together in an executable that you distribute. 7. You may place library facilities that are a work based on the Library side-by-side in a single library together with other library facilities not covered by this License, and distribute such a combined library, provided that the separate distribution of the work based on the Library and of the other library facilities is otherwise permitted, and provided that you do these two things: a) Accompany the combined library with a copy of the same work based on the Library, uncombined with any other library facilities. This must be distributed under the terms of the Sections above. b) Give prominent notice with the combined library of the fact that part of it is a work based on the Library, and explaining where to find the accompanying uncombined form of the same work. 8. You may not copy, modify, sublicense, link with, or distribute the Library except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense, link with, or distribute the Library is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 9. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Library or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Library (or any work based on the Library), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Library or works based on it. 10. Each time you redistribute the Library (or any work based on the Library), the recipient automatically receives a license from the original licensor to copy, distribute, link with or modify the Library subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties with this License. 11. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), 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 distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Library at all. For example, if a patent license would not permit royalty-free redistribution of the Library by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Library. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply, and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 12. If the distribution and/or use of the Library is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Library under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 13. The Free Software Foundation may publish revised and/or new versions of the Lesser 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 Library specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Library does not specify a license version number, you may choose any version ever published by the Free Software Foundation. 14. If you wish to incorporate parts of the Library into other free programs whose distribution conditions are incompatible with these, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE LIBRARY "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 LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE LIBRARY 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 LIBRARY (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 LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Libraries If you develop a new library, and you want it to be of the greatest possible use to the public, we recommend making it free software that everyone can redistribute and change. You can do so by permitting redistribution under these terms (or, alternatively, under the terms of the ordinary General Public License). To apply these terms, attach the following notices to the library. It is safest to attach them to the start of each source file to most effectively convey 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 library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library 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 Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA Also add information on how to contact you by electronic and paper mail. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the library, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the library `Frob' (a library for tweaking knobs) written by James Random Hacker. , 1 April 1990 Ty Coon, President of Vice That's all there is to it! ocaml-mm-0.7.3/README.md000066400000000000000000000005171415601551300145060ustar00rootroot00000000000000The multimedia library ====================== ocaml-mm is a library dedicated to performing operations on multimedia contents: audio, video and MIDI. The core is designed as a pure OCaml library (no dependencies are required). Some extensions requiring bindings to various libraries are located in the [external](external) directory. ocaml-mm-0.7.3/dune-project000066400000000000000000000010211415601551300155400ustar00rootroot00000000000000(lang dune 2.8) (version 0.7.3) (name mm) (source (github savonet/ocaml-mm)) (license GPL-2.0) (authors "Romain Beauxis ") (maintainers "The Savonet Team ") (generate_opam_files true) (package (name mm) (synopsis "The mm library contains high-level to create and manipulate multimedia streams (audio, video, MIDI)") (depends dune dune-configurator) (depopts alsa ao mad pulseaudio ocamlsdl theora) (conflicts (mad (< 0.5.0)) (alsa (< 0.3.0)))) ocaml-mm-0.7.3/examples/000077500000000000000000000000001415601551300150425ustar00rootroot00000000000000ocaml-mm-0.7.3/examples/Makefile000066400000000000000000000006071415601551300165050ustar00rootroot00000000000000all: build build: @dune build autotune: build dune exec ./autotune.exe dictee: build dune exec ./dictee.exe test.mp3 display: build dune exec ./display.exe test.ppm drums: build dune exec ./drums.exe fft: build dune exec ./fft.exe test.wav id: build dune exec ./id.exe test.wav midiplayer: build dune exec ./midiplayer.exe test.mid sine_wav: build dune exec ./sine_wav.exe ocaml-mm-0.7.3/examples/autotune.ml000066400000000000000000000022411415601551300172370ustar00rootroot00000000000000open Mm_audio module FFT = Audio.Mono.Analyze.FFT let channels = 2 let sample_rate = 44100 let periods = 4 let () = let fft = FFT.init 11 in let blen = FFT.length fft in let alsa_in = Mm_alsa.rw channels sample_rate ~capture:true ~buffer_size:(periods * blen) ~periods () in let alsa_out = Mm_alsa.rw channels sample_rate ~playback:true ~blocking:false ~buffer_size:(periods * blen) ~periods () in let buf = Audio.create channels blen in (* let agc = Audio.Effect.auto_gain_control channels sample_rate ~rms_target:2. () in *) let _ = new Audio.Generator.of_mono (new Audio.Mono.Generator.saw sample_rate 440.) in let loop = ref true in Printf.printf "Using Alsa %s (delay: %d samples).\n" alsa_out#version alsa_out#delay; (* alsa#prepare; *) while !loop do (* gen#fill buf 0 blen; *) (try assert (alsa_out#wait 1000); let w = alsa_out#write buf in Printf.printf "Wrote: %d\n%!" w with Alsa.Buffer_xrun as e -> alsa_out#recover e; ignore (alsa_out#write buf)); let _ = alsa_in#read buf in (* Printf.printf "Read: %d\n%!" r *) () done; alsa_in#close; alsa_out#close ocaml-mm-0.7.3/examples/dictee.ml000066400000000000000000000040701415601551300166320ustar00rootroot00000000000000open Mm_audio open Mm_midi module FFT = Audio.Mono.Analyze.FFT let polyphony = 1 let mchan = 0 let oss_out = true let list_diff cmp l1 l2 = List.fold_left (fun acc x -> if not (List.exists (cmp x) l2) then x :: acc else acc) [] l1 let rec list_head_n n l = if n = 0 then [] else (match l with h :: t -> h :: list_head_n (n - 1) t | [] -> []) let () = let fname = Sys.argv.(1) in let f = new Mm_mad.reader_of_file fname in let oss = new Mm_oss.writer f#channels f#sample_rate in let wav = new Audio.IO.Writer.to_wav_file f#channels f#sample_rate "out.wav" in let mid = new MIDI.IO.Writer.to_file f#sample_rate "out.mid" in let fft_n = 11 in let fft = FFT.init fft_n in let blen = FFT.length fft in let buf = Audio.create f#channels blen in let agc = Audio.Effect.auto_gain_control f#channels f#sample_rate ~kup:0.9 ~kdown:0.7 ~rms_target:2. () in let adsr = Audio.Mono.Effect.ADSR.make f#sample_rate (0.02, 0.01, 0.9, 0.05) in let synth = new Synth.saw ~adsr f#sample_rate in let loop = ref true in let prevnotes = ref [] in synth#set_volume 0.1; while !loop do let r = f#read buf in agc#process buf; loop := r <> 0; let notes = FFT.notes f#sample_rate fft ~note_min:(Audio.Note.create 0 4) ~volume_min:0.01 ~filter_harmonics:false (Audio.to_mono buf) in let notes = List.sort (fun (_, v1) (_, v2) -> if v1 < v2 then 1 else -1) notes in let notes = list_head_n polyphony notes in (* Printf.printf "Notes: %d\n%!" (List.length notes); *) let ncmp (n1, _) (n2, _) = n1 = n2 in List.iter (fun (n, v) -> synth#note_off n 1.; mid#note_off mchan n (10. *. v)) (list_diff ncmp !prevnotes notes); List.iter (fun (n, v) -> synth#note_on n 1.; mid#note_on mchan n (10. *. v)) (list_diff ncmp notes !prevnotes); prevnotes := notes; synth#fill_add buf; mid#advance blen; Audio.amplify 2. buf; wav#write buf; if oss_out then oss#write buf done; wav#close; mid#close; oss#close; f#close ocaml-mm-0.7.3/examples/display.ml000066400000000000000000000011701415601551300170400ustar00rootroot00000000000000open Mm_image module Img = Image.RGBA32 let read_PPM ?alpha fname = let ic = open_in_bin fname in let len = in_channel_length ic in let data = Bytes.create len in really_input ic data 0 len; close_in ic; Img.of_PPM ?alpha (Bytes.unsafe_to_string data) let () = let fname = Sys.argv.(1) in let img = read_PPM fname in (* let img = Img.Scale.create ~kind:Img.Scale.Bilinear img 500 500 in *) let w, h = Img.dimensions img in Graphics.open_graph ""; Graphics.resize_window w h; Graphics.draw_image (Graphics.make_image (Img.to_int_image img)) 0 0; ignore (Graphics.wait_next_event [Graphics.Key_pressed]) ocaml-mm-0.7.3/examples/drums.ml000066400000000000000000000040001415601551300165200ustar00rootroot00000000000000open Mm_audio let sample_rate = 44100 let channels = 2 let sd freq _ = let lpf = new Audio.Mono.Effect.biquad_filter sample_rate `Low_pass (freq *. 5.) 2. in let adsr = Audio.Mono.Effect.ADSR.make sample_rate (0., 0.25, 0., 1.) in let g = new Audio.Mono.Generator.white_noise sample_rate in let g = new Audio.Mono.Generator.chain g lpf in let g = new Audio.Mono.Generator.adsr adsr g in let g = new Audio.Generator.of_mono g in g let bd freq _ = let lpf = new Audio.Mono.Effect.biquad_filter sample_rate `Low_pass (freq *. 1.) 2. in let adsr = Audio.Mono.Effect.ADSR.make sample_rate (0.001, 0.3, 0., 1.) in let g = new Audio.Mono.Generator.sine sample_rate 80. in let g2 = new Audio.Mono.Generator.sine sample_rate 90. in let g = new Audio.Mono.Generator.mult g g2 in let g2 = new Audio.Mono.Generator.white_noise ~volume:0.5 sample_rate in let g = new Audio.Mono.Generator.add g g2 in let g = new Audio.Mono.Generator.chain g lpf in let g = new Audio.Mono.Generator.adsr adsr g in let g = new Audio.Mono.Generator.chain g (new Audio.Mono.Effect.clip 0.9) in let g = new Audio.Mono.Generator.chain g (new Audio.Mono.Effect.amplify 5.) in let g = new Audio.Generator.of_mono g in g let blen = sample_rate / 3 let no = Audio.create channels blen let gen i = let buf = Audio.create channels blen in (i 440. 1.)#fill buf; buf let bd = gen bd let sd = gen sd let () = let oss = new Mm_oss.writer channels sample_rate in (* let wav = new Audio.IO.Writer.to_wav_file channels sample_rate "out.wav" in *) (* let buf = Audio.create channels blen in *) (* let mbuf = MIDI.create blen in *) (* let synth_sd = new Synth.create sd in *) (* let keybd = new MMSDL.midi_keyboard in *) (* MIDI.insert mbuf (0, MIDI.Note_on (MIDI.note_of_name "a4", 1.)); *) (* keybd#read sample_rate [|mbuf|] 0 blen; *) (* synth_sd#play mbuf 0 buf 0 blen; *) let buf = Audio.append bd sd in while true do (* wav#write buf 0 blen; *) oss#write buf done; (* wav#close; *) oss#close ocaml-mm-0.7.3/examples/dune000066400000000000000000000015021415601551300157160ustar00rootroot00000000000000(executable (name autotune) (modules autotune) (optional) (libraries mm.audio mm.alsa)) (executable (name dictee) (modules dictee) (optional) (libraries mm.audio mm.midi mm.mad mm.oss)) (executable (name display) (modules display) (optional) (libraries graphics mm.image)) (executable (name drums) (modules drums) (optional) (libraries mm.audio mm.oss)) (executable (name fft) (modules fft) (optional) (libraries graphics mm.audio mm.oss)) (executable (name id) (modules id) (optional) (libraries mm.audio)) (executable (name midiplayer) (modules midiplayer) (optional) (libraries mm.audio mm.oss)) (executable (name sine_wav) (modules sine_wav) (optional) (libraries mm.audio mm.ao)) (executable (name test) (modules test) (optional) (libraries gstreamer mm.audio mm.video mm.sdl mm.oss)) ocaml-mm-0.7.3/examples/fft.ml000066400000000000000000000024721415601551300161600ustar00rootroot00000000000000open Mm_audio module FFT = Audio.Mono.Analyze.FFT let () = let fname = Sys.argv.(1) in let f = new Audio.IO.Reader.of_wav_file fname in let oss = new Mm_oss.writer f#channels f#sample_rate in Printf.printf "Opened WAV file with %d channels at %dHz.\n%!" f#channels f#sample_rate; let fft_n = 11 in let fft = FFT.init fft_n in let fft_times_per_buf = 4 in let blen = 1 lsl fft_n in let buf = Audio.create f#channels (2 * blen) in let loop = ref true in Graphics.open_graph ""; let i = ref 0 in while !loop do Audio.blit (Audio.sub buf blen blen) (Audio.sub buf 0 blen); let n = f#read (Audio.sub buf blen blen) in oss#write (Audio.sub buf blen n); for o = 0 to fft_times_per_buf - 1 do let c = FFT.complex_create (Audio.Mono.sub (Audio.to_mono buf) (o * blen / fft_times_per_buf) blen) in FFT.Window.cosine c; FFT.fft fft c; for j = 0 to Graphics.size_y () - 1 do let v = Complex.norm c.(j * blen / (2 * Graphics.size_y ())) in let v = int_of_float (v *. 255.) in let color = v lsl 16 in Graphics.set_color color; Graphics.plot !i j done; incr i; if !i >= Graphics.size_x () then i := 0 done; if n = 0 then loop := false done; oss#close; f#close ocaml-mm-0.7.3/examples/id.ml000066400000000000000000000014411415601551300157700ustar00rootroot00000000000000(** Perform and FFT followed by an IFFT, so it should be roughly the identity... *) open Mm_audio module FFT = Audio.Mono.Analyze.FFT let () = let read = new Audio.IO.Reader.of_wav_file Sys.argv.(1) in let write = new Audio.IO.Writer.to_wav_file read#channels read#sample_rate "out.wav" in let fft_n = 11 in let fft = FFT.init fft_n in let blen = 1 lsl fft_n in let buf = Audio.create read#channels blen in let loop = ref true in while !loop do let n = read#read buf in if n = 0 then loop := false; let c = FFT.complex_create (Audio.to_mono buf) in FFT.Window.cosine c; FFT.fft fft c; let c = Array.map (fun c -> c.Complex.re) c in let buf = Audio.of_array (Array.make read#channels c) in write#write buf done; write#close; read#close ocaml-mm-0.7.3/examples/midiplayer.ml000066400000000000000000000013121415601551300175300ustar00rootroot00000000000000open Mm_audio let () = let fname = Sys.argv.(1) in let f = new Audio.IO.Reader.of_wav_file fname in let oss = new Mm_oss.writer f#channels f#sample_rate in let blen = 1024 in let buf = Audio.create f#channels blen in Printf.printf "Opened WAV file with %d channels at %dHz.\n%!" f#channels f#sample_rate; let _ = Audio.Effect.delay f#channels f#sample_rate 0.2 ~ping_pong:true 0.5 in let _ = new Audio.Effect.biquad_filter f#channels f#sample_rate `High_pass 400. 1. in let loop = ref true in while !loop do let r = f#read buf in loop := r <> 0; (* delay#process buf 0 r; *) (* bqf#process buf 0 r; *) oss#write (Audio.sub buf 0 r) done; oss#close; f#close ocaml-mm-0.7.3/examples/sine_wav.ml000066400000000000000000000010331415601551300172040ustar00rootroot00000000000000open Mm_audio let total_duration = 10 let () = let channels = 2 in let sample_rate = 44100 in let ao = new Mm_ao.writer channels sample_rate in let wav = new Audio.IO.Writer.to_wav_file channels sample_rate "out.wav" in let blen = 1024 in let buf = Audio.create channels blen in let sine = new Audio.Generator.of_mono (new Audio.Mono.Generator.sine sample_rate 440.) in for _ = 0 to (sample_rate / blen * total_duration) - 1 do sine#fill buf; wav#write buf; ao#write buf done; wav#close; ao#close ocaml-mm-0.7.3/examples/test.ml000066400000000000000000000037231415601551300163600ustar00rootroot00000000000000open Gstreamer open Mm_audio open Mm_video let width = 320 let height = 240 let fps = 24 let audio_channels = 2 let audio_rate = 44100 let src = "filesrc location=../test.wmv" let pipeline = Printf.sprintf "%s ! decodebin name=decode decode. ! ffmpegcolorspace ! videoscale ! \ videorate ! appsink max-buffers=2 drop=true name=videosink \ caps=\"video/x-raw-rgb,width=%d,height=%d,pixel-aspect-ratio=1/1,bpp=(int)24,depth=(int)24,endianness=(int)4321,red_mask=(int)0xff0000,green_mask=(int)0x00ff00,blue_mask=(int)0x0000ff,framerate=(fraction)%d/1\" \ decode. ! audioconvert ! audioresample ! appsink max-buffers=2 drop=true \ name=audiosink \ caps=\"audio/x-raw-int,width=16,channels=%d,rate=%d,signed=true\"" src width height fps audio_channels audio_rate let () = Gstreamer.init (); Printf.printf "%s\n%!" (version_string ()); Printf.printf "%s\n%!" pipeline; let bin = Pipeline.parse_launch pipeline in let _ = Bin.get_by_name (Bin.of_element bin) "videosink" in let audiosink = Bin.get_by_name (Bin.of_element bin) "audiosink" in let sdl = new Mm_sdl.writer_to_screen width height in let oss = new Mm_oss.writer audio_channels audio_rate in ignore (Element.set_state bin State_playing); while true do (* Video *) (* let b = App_sink.pull_buffer (App_sink.of_element videosink) in *) (* let img = Image.Generic.make Image.Generic.Pixel.YUVJ420 width height b in *) (* let out = Video.Image.create width height in *) let out = assert false in (* Image.Generic.convert ~copy:true ~proportional:true img (Image.Generic.of_YUV420 out); *) let vid = Video.single out in sdl#write vid 0 1; (* Audio *) let b = App_sink.pull_buffer_string (App_sink.of_element audiosink) in let samples = Audio.S16LE.length audio_channels (String.length b) in let buf = Audio.create audio_channels samples in Audio.S16LE.to_audio b 0 buf; oss#write buf done; ignore (Element.set_state bin State_null) ocaml-mm-0.7.3/external/000077500000000000000000000000001415601551300150465ustar00rootroot00000000000000ocaml-mm-0.7.3/external/README000066400000000000000000000000411415601551300157210ustar00rootroot00000000000000Bindings for external libraries. ocaml-mm-0.7.3/external/deprecated/000077500000000000000000000000001415601551300171465ustar00rootroot00000000000000ocaml-mm-0.7.3/external/deprecated/MMFFmpeg.ml000066400000000000000000000104631415601551300211020ustar00rootroot00000000000000(* * Copyright 2011 The Savonet Team * * This file is part of ocaml-mm. * * ocaml-mm is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * ocaml-mm 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 Lesser General Public License * along with ocaml-mm; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA * * As a special exception to the GNU Library General Public License, you may * link, statically or dynamically, a "work that uses the Library" with a publicly * distributed version of the Library to produce an executable file containing * portions of the Library, and distribute that executable file under terms of * your choice, without any of the additional requirements listed in clause 6 * of the GNU Library General Public License. * By "a publicly distributed version of the Library", we mean either the unmodified * Library as distributed by The Savonet Team, or a modified version of the Library that is * distributed under the conditions defined in clause 3 of the GNU Library General * Public License. This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU Library General Public License. * *) (* Register codecs. *) (* TODO: for now the size of the output frames have to match the size of the vid. *) module FFmpeg = struct external init : unit -> unit = "caml_ffmpeg_init" exception End_of_stream let () = Callback.register_exception "ffmpeg_exn_end_of_stream" End_of_stream module Decoder = struct type t external openfile : string -> t = "caml_ffmpeg_dec_openfile" external dump_format : t -> string -> unit = "caml_ffmpeg_dec_dump_format" external width : t -> int = "caml_ffmpeg_dec_width" external height : t -> int = "caml_ffmpeg_dec_height" external read_frame : t -> Video.frame -> unit = "caml_ffmpeg_dec_read_frame" external close : t -> unit = "caml_ffmpeg_dec_close" external set_target_size : t -> int -> int -> unit = "caml_ffmpeg_dec_set_target_size" external frame_rate : t -> float = "caml_ffmpeg_dec_fps" end module Encoder = struct type t external openfile : string -> int * int -> int -> int -> int -> t = "caml_ffmpeg_enc_openfile" external dump_format : t -> string -> unit = "caml_ffmpeg_enc_dump_format" external write_frame : t -> Image.RGBA32.t -> unit = "caml_ffmpeg_enc_write_frame" external close : t -> unit = "caml_ffmpeg_enc_close" end (* module Scale = struct type t external create : int * int -> int * int -> t = "caml_sws_create" external scale_to : t -> Video.frame -> Video.frame -> unit = "caml_sws_scale_to" end *) end module D = FFmpeg.Decoder module E = FFmpeg.Encoder class reader_of_file fname = (* TODO: we should do this only once *) let () = FFmpeg.init () in let ff = D.openfile fname in let () = D.dump_format ff fname in let width = D.width ff in let height = D.height ff in object (self) method frame_rate = D.frame_rate ff method width = width method height = height (* method set_target_size (w:int) (h:int) : unit = (* Not working yet *) assert false (* FFmpeg.set_target_size ff w h *) *) method private read_frame = let img = Image.RGBA32.create width height in D.read_frame ff img; img method read buf ofs len = let n = ref 0 in try while !n < len do buf.(ofs + !n) <- self#read_frame; incr n done; !n with FFmpeg.End_of_stream -> !n method close = D.close ff end class writer_to_file fname fr w h br = let fr = Video.FPS.to_frac fr in let enc = E.openfile fname fr w h br in let () = E.dump_format enc fname in object (self) method write buf ofs len = for i = ofs to ofs + len - 1 do E.write_frame enc buf.(i) done method close = E.close enc end ocaml-mm-0.7.3/external/deprecated/MMFFmpeg.mli000066400000000000000000000002041415601551300212430ustar00rootroot00000000000000class reader_of_file : string -> Video.IO.Reader.t class writer_to_file : string -> float -> int -> int -> int -> Video.IO.Writer.t ocaml-mm-0.7.3/external/deprecated/MMV4L.ml000066400000000000000000000055341415601551300203460ustar00rootroot00000000000000(* * Copyright 2011 The Savonet Team * * This file is part of ocaml-mm. * * ocaml-mm is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * ocaml-mm 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 Lesser General Public License * along with ocaml-mm; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA * * As a special exception to the GNU Library General Public License, you may * link, statically or dynamically, a "work that uses the Library" with a publicly * distributed version of the Library to produce an executable file containing * portions of the Library, and distribute that executable file under terms of * your choice, without any of the additional requirements listed in clause 6 * of the GNU Library General Public License. * By "a publicly distributed version of the Library", we mean either the unmodified * Library as distributed by The Savonet Team, or a modified version of the Library that is * distributed under the conditions defined in clause 3 of the GNU Library General * Public License. This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU Library General Public License. * *) module G = Image.Generic module V4L1 = struct type device = Unix.file_descr external opendev : string -> int -> int -> int -> device = "caml_v4l1_open" external grab : device -> G.data -> unit = "caml_v4l1_grab" external close : device -> unit = "caml_v4l1_close" end module V4L2 = struct type device = Unix.file_descr external opendev : string -> int -> int -> int -> device = "caml_v4l2_open" external grab : device -> G.data -> unit = "caml_v4l2_grab" external close : device -> unit = "caml_v4l2_close" end module V4L = V4L2 class reader device width height = object (self) val dev = V4L.opendev device width height (3 * width) val img = let data = Bigarray.Array1.create Bigarray.int8_unsigned Bigarray.c_layout (width * height * 3) in G.make_rgb G.Pixel.RGB24 width height data method frame_rate = 12. method width = width method height = height method read buf ofs len = V4L.grab dev (fst (G.rgb_data img)); for i = ofs to ofs + len - 1 do buf.(i) <- Image.RGBA32.create width height; G.convert ~copy:true ~proportional:true img (G.of_RGBA32 buf.(i)) done; len method close = V4L.close dev end ocaml-mm-0.7.3/external/deprecated/MMV4L.mli000066400000000000000000000000711415601551300205060ustar00rootroot00000000000000class reader : string -> int -> int -> Video.IO.Reader.t ocaml-mm-0.7.3/external/deprecated/ffmpeg_stubs.c000066400000000000000000000370341415601551300220050ustar00rootroot00000000000000/* * Copyright 2011 The Savonet Team * * This file is part of ocaml-mm. * * ocaml-mm is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * ocaml-mm 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 Lesser General Public License * along with ocaml-mm; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA * * As a special exception to the GNU Library General Public License, you may * link, statically or dynamically, a "work that uses the Library" with a publicly * distributed version of the Library to produce an executable file containing * portions of the Library, and distribute that executable file under terms of * your choice, without any of the additional requirements listed in clause 6 * of the GNU Library General Public License. * By "a publicly distributed version of the Library", we mean either the unmodified * Library as distributed by The Savonet Team, or a modified version of the Library that is * distributed under the conditions defined in clause 3 of the GNU Library General * Public License. This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU Library General Public License. * */ /* Inspired of * http://dranger.com/ffmpeg/tutorial01.html * and */ #include #include #include #include #include #include #include #include #include #include #include #include "image_c.h" typedef struct { AVFormatContext *av_format_ctx; AVCodecContext *av_codec_ctx; AVCodec *av_codec; struct SwsContext *convert_ctx; int video_stream; AVFrame* av_frame; AVFrame* av_frame_rgb; uint8_t* buffer; } ffmpeg_dec_t; #define Dec_val(v) ((ffmpeg_dec_t*)v) CAMLprim value caml_ffmpeg_init(value unit) { CAMLparam0(); av_register_all(); CAMLreturn(Val_unit); } /* TODO: add a finalizer!!!! */ CAMLprim value caml_ffmpeg_dec_openfile(value fname) { CAMLparam1(fname); ffmpeg_dec_t *ffd = malloc(sizeof(ffmpeg_dec_t)); int i; int buflen; int width, height; /* Open the file */ assert(av_open_input_file(&ffd->av_format_ctx, String_val(fname), NULL, 0, NULL) == 0); /* Retrieve stream information */ assert(av_find_stream_info(ffd->av_format_ctx) >= 0); ffd->video_stream = -1; /* Find a video stream */ for(i=0; iav_format_ctx->nb_streams; i++) if(ffd->av_format_ctx->streams[i]->codec->codec_type==CODEC_TYPE_VIDEO) { ffd->video_stream = i; break; } assert(ffd->video_stream != -1); ffd->av_codec_ctx = ffd->av_format_ctx->streams[ffd->video_stream]->codec; /* Find a decoder */ ffd->av_codec = avcodec_find_decoder(ffd->av_codec_ctx->codec_id); /* Is the codec supported? */ assert(ffd->av_codec); /* Open the codec */ assert(avcodec_open(ffd->av_codec_ctx, ffd->av_codec) >= 0); width = ffd->av_codec_ctx->width; height = ffd->av_codec_ctx->height; ffd->av_frame = avcodec_alloc_frame(); ffd->av_frame_rgb = avcodec_alloc_frame(); /* Allocate a suitable buffer */ buflen = avpicture_get_size(PIX_FMT_RGBA, width, height); ffd->buffer = (uint8_t*)av_malloc(buflen * sizeof(uint8_t)); /* Assign appropriate parts of buffer to image planes in av_frame_rgb */ avpicture_fill((AVPicture*)ffd->av_frame_rgb, ffd->buffer, PIX_FMT_RGBA, width, height); /* Init conversion context */ ffd->convert_ctx = sws_getContext(width, height, ffd->av_codec_ctx->pix_fmt, width, height, PIX_FMT_RGBA, SWS_BICUBIC, NULL, NULL, NULL); assert(ffd->convert_ctx); CAMLreturn((value)ffd); } CAMLprim value caml_ffmpeg_dec_dump_format(value _ffd, value _fname) { CAMLparam2(_ffd, _fname); ffmpeg_dec_t* ffd = Dec_val(_ffd); /* Dump info about the file on stderr */ dump_format(ffd->av_format_ctx, 0, String_val(_fname), 0); CAMLreturn(Val_unit); } CAMLprim value caml_ffmpeg_dec_set_target_size(value _ffd, value _w, value _h) { CAMLparam1(_ffd); ffmpeg_dec_t* ffd = Dec_val(_ffd); int w = Int_val(_w); int h = Int_val(_h); int width = ffd->av_codec_ctx->width; int height = ffd->av_codec_ctx->height; sws_freeContext(ffd->convert_ctx); ffd->convert_ctx = sws_getContext(width, height, ffd->av_codec_ctx->pix_fmt, w, h, PIX_FMT_RGBA, SWS_BICUBIC, NULL, NULL, NULL); CAMLreturn(Val_unit); } CAMLprim value caml_ffmpeg_dec_width(value ffd) { CAMLparam1(ffd); CAMLreturn(Val_int(Dec_val(ffd)->av_codec_ctx->width)); } CAMLprim value caml_ffmpeg_dec_height(value ffd) { CAMLparam1(ffd); CAMLreturn(Val_int(Dec_val(ffd)->av_codec_ctx->height)); } CAMLprim value caml_ffmpeg_dec_fps(value _ffd) { CAMLparam1(_ffd); ffmpeg_dec_t* ffd = Dec_val(_ffd); double n = (double)ffd->av_codec_ctx->time_base.num; double d = (double)ffd->av_codec_ctx->time_base.den; CAMLreturn(caml_copy_double(d/n)); } CAMLprim value caml_ffmpeg_dec_read_frame(value _ffd, value _rgb) { CAMLparam2(_ffd, _rgb); CAMLlocal1(ans); frame rgb; ffmpeg_dec_t* ffd = Dec_val(_ffd); AVPacket packet; int frame_finished; int width = ffd->av_codec_ctx->width; int height = ffd->av_codec_ctx->height; int ansbuflen = width*height*3; int j; frame_of_value(_rgb, &rgb); assert(rgb.width == width && rgb.height == height); caml_enter_blocking_section(); while (av_read_frame(ffd->av_format_ctx, &packet) >= 0) { if(packet.stream_index == ffd->video_stream) { avcodec_decode_video(ffd->av_codec_ctx, ffd->av_frame, &frame_finished, packet.data, packet.size); if (frame_finished) { sws_scale(ffd->convert_ctx, (const uint8_t * const*)ffd->av_frame->data, ffd->av_frame->linesize, 0, height, ffd->av_frame_rgb->data, ffd->av_frame_rgb->linesize); for (j = 0; j < height; j++) memcpy(rgb.data+j*width*4, ffd->av_frame_rgb->data[0]+j*ffd->av_frame_rgb->linesize[0], width*4); caml_leave_blocking_section(); CAMLreturn(Val_unit); } } /* Free the packet allocated by av_read_frame */ av_free_packet(&packet); } caml_leave_blocking_section(); caml_raise_constant(*caml_named_value("ffmpeg_exn_end_of_stream")); } /* TODO: finalizer!!!! */ CAMLprim value caml_ffmpeg_dec_close(value _ffd) { CAMLparam1(_ffd); ffmpeg_dec_t* ffd = Dec_val(_ffd); sws_freeContext(ffd->convert_ctx); av_free(ffd->buffer); av_free(ffd->av_frame_rgb); av_free(ffd->av_frame); free(ffd); CAMLreturn(Val_unit); } /* See http://cekirdek.pardus.org.tr/~ismail/ffmpeg-docs/output-example_8c-source.html */ typedef struct { AVFormatContext *format_ctx; AVStream *video_stream; uint8_t *video_buffer; int video_buffer_size; AVFrame *frame; AVFrame *tmpframe; struct SwsContext *convert_ctx; } ffmpeg_enc_t; #define Enc_val(v) ((ffmpeg_enc_t*)v) static AVFrame *alloc_picture(int pix_fmt, int width, int height) { AVFrame *picture; uint8_t *picture_buf; int size; picture = avcodec_alloc_frame(); if (!picture) return NULL; size = avpicture_get_size(pix_fmt, width, height); picture_buf = malloc(size); if (!picture_buf) { av_free(picture); return NULL; } avpicture_fill((AVPicture*)picture, picture_buf, pix_fmt, width, height); return picture; } CAMLprim value caml_ffmpeg_enc_openfile(value _fname, value _fr, value _width, value _height, value _bitrate) { CAMLparam2(_fname, _fr); ffmpeg_enc_t *ffe = malloc(sizeof(ffmpeg_enc_t)); AVOutputFormat *output_format; int frn = Int_val(Field(_fr, 0)); int frd = Int_val(Field(_fr, 1)); /* Guess the output format based on the extension */ output_format = av_guess_format(NULL, String_val(_fname), NULL); if (!output_format) /* Fallback on mpeg */ output_format = av_guess_format("mpeg", NULL, NULL); assert(output_format); //printf("Found format: %s\n", output_format->name); /* Allocate the output media context */ ffe->format_ctx = avformat_alloc_context(); assert(ffe->format_ctx); ffe->format_ctx->oformat = output_format; /* Add a video stream. */ /* TODO: also allocate the audio stream if necessary */ assert(output_format->video_codec != CODEC_ID_NONE); //ffe->video_stream = add_video_stream(ffe->format_ctx, ffe->output_format->video_codec); ffe->video_stream = av_new_stream(ffe->format_ctx, 0); assert(ffe->video_stream); AVCodecContext *c = ffe->video_stream->codec; c->codec_id = output_format->video_codec; c->codec_type = CODEC_TYPE_VIDEO; c->bit_rate = Int_val(_bitrate); c->width = Int_val(_width); /* Resolution must be a power of two */ c->height = Int_val(_height); /* TODO: in parameter */ /* time base: this is the fundamental unit of time (in seconds) in terms of which frame timestamps are represented. for fixed-fps content, timebase should be 1/framerate and timestamp increments should be identically 1. */ c->time_base.den = frn; c->time_base.num = frd; c->gop_size = 12; /* emit one intra frame every twelve frames at most */ c->pix_fmt = PIX_FMT_YUV420P; /* just for testing, we also add B frames */ if (c->codec_id == CODEC_ID_MPEG2VIDEO) c->max_b_frames = 2; /* needed to avoid using macroblocks in which some coeffs overflow this doesn't happen with normal video, it just happens here as the motion of the chroma plane doesn't match the luma plane */ if (c->codec_id == CODEC_ID_MPEG1VIDEO) c->mb_decision=2; /* some formats want stream headers to be seperate */ if(!strcmp(ffe->format_ctx->oformat->name, "mp4") || !strcmp(ffe->format_ctx->oformat->name, "mov") || !strcmp(ffe->format_ctx->oformat->name, "3gp")) c->flags |= CODEC_FLAG_GLOBAL_HEADER; /* Set the parameters */ assert(av_set_parameters(ffe->format_ctx, NULL) >= 0); /* Display what we have so far on stderr */ //dump_format(ffe->format_ctx, 0, String_val(_fname), 1); /* Now that all the parameters are set, we can open the audio and video codecs * and allocate the necessary encode buffers */ c = ffe->video_stream->codec; AVCodec *codec = avcodec_find_encoder(c->codec_id); assert(codec); assert(avcodec_open(c, codec) >= 0); ffe->video_buffer = NULL; ffe->video_buffer_size = 0; if (!(ffe->format_ctx->oformat->flags & AVFMT_RAWPICTURE)) { ffe->video_buffer_size = 200000; ffe->video_buffer = av_malloc(ffe->video_buffer_size); } /* allocate the encoded raw picture */ ffe->frame = alloc_picture(c->pix_fmt, c->width, c->height); assert(ffe->frame); /* if the output format is not YUV420P, then a temporary YUV420P picture is needed too. It is then converted to the required output format */ ffe->tmpframe = NULL; if (c->pix_fmt != PIX_FMT_RGBA) ffe->tmpframe = alloc_picture(PIX_FMT_RGBA, c->width, c->height); /* Prepare the conversion context */ ffe->convert_ctx = sws_getContext(c->width, c->height, PIX_FMT_RGBA, c->width, c->height, c->pix_fmt, SWS_BICUBIC, NULL, NULL, NULL); /* open the output file, if needed */ if (!(output_format->flags & AVFMT_NOFILE)) assert (url_fopen(&ffe->format_ctx->pb, String_val(_fname), URL_WRONLY) >= 0); /* write the stream header, if any */ av_write_header(ffe->format_ctx); CAMLreturn((value)ffe); } CAMLprim value caml_ffmpeg_enc_dump_format(value _ffe, value _fname) { CAMLparam2(_ffe, _fname); ffmpeg_enc_t* ffe = Enc_val(_ffe); /* Dump info about the file on stderr */ dump_format(ffe->format_ctx, 0, String_val(_fname), 1); CAMLreturn(Val_unit); } static void fill_picture(AVFrame *pict, frame *rgb) { int j; for(j = 0; j < rgb->height; j++) memcpy(pict->data[0]+j*pict->linesize[0], rgb->data+j*4*rgb->width, 4*rgb->width); } CAMLprim value caml_ffmpeg_enc_write_frame(value _ffe, value _f) { CAMLparam2(_ffe, _f); frame rgb; frame_of_value(_f, &rgb); ffmpeg_enc_t *ffe = Enc_val(_ffe); AVCodecContext *c = ffe->video_stream->codec; int out_size; assert(rgb.width == c->width && rgb.height == c->height); caml_enter_blocking_section(); /* We have to convert the frame to the right format. */ if (c->pix_fmt != PIX_FMT_RGBA) { fill_picture(ffe->tmpframe, &rgb); sws_scale(ffe->convert_ctx, (const uint8_t * const*)ffe->tmpframe->data, ffe->tmpframe->linesize, 0, c->height, ffe->frame->data, ffe->frame->linesize); } else fill_picture(ffe->frame, &rgb); if (ffe->format_ctx->oformat->flags & AVFMT_RAWPICTURE) { /* raw video case. The API will change slightly in the near futur for that */ AVPacket pkt; av_init_packet(&pkt); pkt.flags |= PKT_FLAG_KEY; pkt.stream_index= ffe->video_stream->index; pkt.data= (uint8_t*)ffe->frame; pkt.size= sizeof(AVPicture); assert(av_write_frame(ffe->format_ctx, &pkt) == 0); } else { /* encode the image */ out_size = avcodec_encode_video(c, ffe->video_buffer, ffe->video_buffer_size, ffe->frame); /* if zero size, it means the image was buffered */ if (out_size > 0) { AVPacket pkt; av_init_packet(&pkt); pkt.pts= av_rescale_q(c->coded_frame->pts, c->time_base, ffe->video_stream->time_base); if(c->coded_frame->key_frame) pkt.flags |= PKT_FLAG_KEY; pkt.stream_index= ffe->video_stream->index; pkt.data= ffe->video_buffer; pkt.size= out_size; /* write the compressed frame in the media file */ assert(av_write_frame(ffe->format_ctx, &pkt) == 0); } } caml_leave_blocking_section(); CAMLreturn(Val_unit); } CAMLprim value caml_ffmpeg_enc_close(value _ffe) { CAMLparam1(_ffe); ffmpeg_enc_t *ffe = Enc_val(_ffe); int i; /* Close codec */ avcodec_close(ffe->video_stream->codec); av_free(ffe->frame->data[0]); av_free(ffe->frame); if (ffe->tmpframe) { av_free(ffe->tmpframe->data[0]); av_free(ffe->tmpframe); } av_free(ffe->video_buffer); /* write the trailer, if any */ av_write_trailer(ffe->format_ctx); /* free the streams */ for(i = 0; i < ffe->format_ctx->nb_streams; i++) { av_freep(&ffe->format_ctx->streams[i]->codec); av_freep(&ffe->format_ctx->streams[i]); } /* close the output file */ if (!(ffe->format_ctx->oformat->flags & AVFMT_NOFILE)) url_fclose(ffe->format_ctx->pb); /* free the stream */ av_free(ffe->format_ctx); free(ffe); CAMLreturn(Val_unit); } /* TODO: finalizer with sws_freeContext */ /* TODO: handle pixel coding conversions too */ /* CAMLprim caml_sws_create(value src, value tgt, value th) { CAMLparam0(); struct SwsContext *swsc; swsc = sws_getContext(Int_val(Field(src,0)), Int_val(Field(src,1)), PIX_FMT_RGBA, Int_val(Field(src,0)), Int_val(Field(src,1)), PIX_FMT_RGBA, SWS_BICUBIC, NULL, NULL, NULL); CAMLreturn((value)swsc); } CAMLprim caml_sws_scale_to(value _swsc, value _src, value _dst) { CAMLparam2(_src, _tgt); frame src; frame dst; struct SwsContext *swsc = (struct SwsContext*)_swsc; frame_of_val(_src, &src); frame_of_val(_tgt, &tgt); caml_enter_blocking_section(); // The coding of images is weired sws_scale(swsc, (const uint8_t * const*)src.data, src.width*4, 0, src.height, dst.data, dst.width*4); caml_leave_blocking_section(); CAMLreturn(Val_unit); } */ ocaml-mm-0.7.3/external/deprecated/v4l_stubs.c000066400000000000000000000161651415601551300212500ustar00rootroot00000000000000/* * Copyright 2011 The Savonet Team * * This file is part of ocaml-mm. * * ocaml-mm is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * ocaml-mm 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 Lesser General Public License * along with ocaml-mm; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA * * As a special exception to the GNU Library General Public License, you may * link, statically or dynamically, a "work that uses the Library" with a publicly * distributed version of the Library to produce an executable file containing * portions of the Library, and distribute that executable file under terms of * your choice, without any of the additional requirements listed in clause 6 * of the GNU Library General Public License. * By "a publicly distributed version of the Library", we mean either the unmodified * Library as distributed by The Savonet Team, or a modified version of the Library that is * distributed under the conditions defined in clause 3 of the GNU Library General * Public License. This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU Library General Public License. * */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #define CLEAR(x) memset(&(x), 0, sizeof(x)) static int xioctl(int fh, int request, void *arg) { int r; do { r = ioctl(fh, request, arg); } while (r == -1 && ((errno == EINTR) || (errno == EAGAIN))); assert(r != -1); return r; } CAMLprim value caml_v4l2_open(value device, value w, value h, value stride) { CAMLparam1(device); // TODO: error codes // TODO: flags int fd = v4l2_open(String_val(device), O_RDWR | O_NONBLOCK); assert(fd >= 0); // TODO: different formats ? struct v4l2_format fmt; CLEAR(fmt); fmt.type = V4L2_BUF_TYPE_VIDEO_CAPTURE; fmt.fmt.pix.width = Int_val(w); fmt.fmt.pix.height = Int_val(h); fmt.fmt.pix.pixelformat = V4L2_PIX_FMT_RGB24; fmt.fmt.pix.field = V4L2_FIELD_INTERLACED; //fmt.fmt.pix.bytesperline = Int_val(stride); xioctl(fd, VIDIOC_S_FMT, &fmt); // TODO: check returned sizes assert(fmt.fmt.pix.pixelformat == V4L2_PIX_FMT_RGB24); CAMLreturn(Val_int(fd)); } /* CAMLprim value caml_v4l2_grab(value fd, value data) { CAMLparam1(data); int len = caml_ba_byte_size(Caml_ba_array_val(data)); // TODO: error codes caml_enter_blocking_section(); int ret = v4l2_read(Int_val(fd), Caml_ba_data_val(data), len); caml_leave_blocking_section(); if (ret < 0) printf("error: %d\n", errno); assert(ret == len); CAMLreturn(Val_unit); } */ CAMLprim value caml_v4l2_grab(value _fd, value data) { CAMLparam1(data); int fd = Int_val(_fd); int len = caml_ba_byte_size(Caml_ba_array_val(data)); char *buf = Caml_ba_data_val(data); char *mbuf; int mbuflen; struct v4l2_buffer vbuf; struct v4l2_requestbuffers req; enum v4l2_buf_type type; struct timeval tv; fd_set fds; int ret; caml_enter_blocking_section(); req.count = 1; req.type = V4L2_BUF_TYPE_VIDEO_CAPTURE; req.memory = V4L2_MEMORY_MMAP; xioctl(fd, VIDIOC_REQBUFS, &req); memset(&vbuf, 0, sizeof(vbuf)); vbuf.type = V4L2_BUF_TYPE_VIDEO_CAPTURE; vbuf.memory = V4L2_MEMORY_MMAP; vbuf.index = 0; xioctl(fd, VIDIOC_QUERYBUF, &vbuf); mbuflen = vbuf.length; mbuf = v4l2_mmap(NULL, mbuflen, PROT_READ | PROT_WRITE, MAP_SHARED, fd, vbuf.m.offset); assert(mbuf != MAP_FAILED); memset(&vbuf, 0, sizeof(vbuf)); vbuf.type = V4L2_BUF_TYPE_VIDEO_CAPTURE; vbuf.memory = V4L2_MEMORY_MMAP; vbuf.index = 0; xioctl(fd, VIDIOC_QBUF, &vbuf); type = V4L2_BUF_TYPE_VIDEO_CAPTURE; xioctl(fd, VIDIOC_STREAMON, &type); do { FD_ZERO(&fds); FD_SET(fd, &fds); /* Timeout. */ tv.tv_sec = 2; tv.tv_usec = 0; ret = select(fd + 1, &fds, NULL, NULL, &tv); } while ((ret == -1 && (errno == EINTR))); assert(ret != -1); memset(&vbuf, 0, sizeof(vbuf)); vbuf.type = V4L2_BUF_TYPE_VIDEO_CAPTURE; vbuf.memory = V4L2_MEMORY_MMAP; xioctl(fd, VIDIOC_DQBUF, &vbuf); memcpy(buf, mbuf, vbuf.bytesused); xioctl(fd, VIDIOC_QBUF, &vbuf); type = V4L2_BUF_TYPE_VIDEO_CAPTURE; xioctl(fd, VIDIOC_STREAMOFF, &type); v4l2_munmap(mbuf, mbuflen); caml_leave_blocking_section(); CAMLreturn(Val_unit); } CAMLprim value caml_v4l2_close(value fd) { CAMLparam0(); v4l2_close(Int_val(fd)); CAMLreturn(Val_unit); } CAMLprim value caml_v4l1_open(value device, value w, value h, value stride) { CAMLparam1(device); int fd; struct video_capability cap; struct video_window win; struct video_picture vpic; fd = open(String_val(device), O_RDONLY); assert(fd >= 0); assert(ioctl(fd, VIDIOCGCAP, &cap) >= 0); assert(ioctl(fd, VIDIOCGWIN, &win) >= 0); assert(ioctl(fd, VIDIOCGPICT, &vpic) >= 0); if (cap.type & VID_TYPE_MONOCHROME) { vpic.depth=8; vpic.palette=VIDEO_PALETTE_GREY; /* 8bit grey */ if(ioctl(fd, VIDIOCSPICT, &vpic) < 0) { vpic.depth=6; if(ioctl(fd, VIDIOCSPICT, &vpic) < 0) { vpic.depth=4; if(ioctl(fd, VIDIOCSPICT, &vpic) < 0) { //fprintf(stderr, "Unable to find a supported capture format.\n"); close(fd); assert(0); } } } } else { vpic.depth=24; vpic.palette=VIDEO_PALETTE_RGB24; if(ioctl(fd, VIDIOCSPICT, &vpic) < 0) { vpic.palette=VIDEO_PALETTE_RGB565; vpic.depth=16; if(ioctl(fd, VIDIOCSPICT, &vpic)==-1) { vpic.palette=VIDEO_PALETTE_RGB555; vpic.depth=15; if(ioctl(fd, VIDIOCSPICT, &vpic)==-1) { //fprintf(stderr, "Unable to find a supported capture format.\n"); //return -1; close(fd); assert(0); } } } } assert(!(cap.type & VID_TYPE_MONOCHROME)); assert(vpic.depth == 24); assert(vpic.palette == VIDEO_PALETTE_RGB24); CAMLreturn(Val_int(fd)); } CAMLprim value caml_v4l1_grab(value fd, value data) { CAMLparam1(data); int len = caml_ba_byte_size(Caml_ba_array_val(data)); int ret; caml_enter_blocking_section(); ret = read(fd, Caml_ba_data_val(data), len); caml_leave_blocking_section(); if (ret < 0) printf("error: %d\n", errno); assert(ret == len); CAMLreturn(Val_unit); } CAMLprim value caml_v4l1_close(value fd) { CAMLparam0(); close(Int_val(fd)); CAMLreturn(Val_unit); } ocaml-mm-0.7.3/external/dune000066400000000000000000000031471415601551300157310ustar00rootroot00000000000000(library (name mm_mad) (public_name mm.mad) (modules mm_mad) (optional) (libraries mad mm.base mm.audio) (synopsis "High-level APIs to create and manipulate multimedia streams -- optional mad module")) (library (name mm_theora) (public_name mm.theora) (modules mm_theora) (optional) (libraries theora mm.image mm.video) (synopsis "High-level APIs to create and manipulate multimedia streams -- optional theora module")) (library (name mm_ao) (public_name mm.ao) (modules mm_ao) (optional) (libraries ao mm.audio) (synopsis "High-level APIs to create and manipulate multimedia streams -- optional ao module")) (library (name mm_pulseaudio) (public_name mm.pulseaudio) (modules mm_pulseaudio) (optional) (libraries pulseaudio mm.audio) (synopsis "High-level APIs to create and manipulate multimedia streams -- optional pulseaudio module")) (library (name mm_sdl) (public_name mm.sdl) (modules mm_sdl) (optional) (libraries sdl mm.video mm.midi) (foreign_stubs (language c) (names sdl_stubs)) (synopsis "High-level APIs to create and manipulate multimedia streams -- optional sdl module")) (library (name mm_alsa) (public_name mm.alsa) (modules mm_alsa) (optional) (libraries alsa mm.audio) (synopsis "High-level APIs to create and manipulate multimedia streams -- optional alsa module")) (library (name mm_oss) (public_name mm.oss) (modules mm_oss) (libraries mm.base mm.audio) (foreign_stubs (language c) (names oss_stubs)) (enabled_if (= %{system} linux)) (optional) (synopsis "High-level APIs to create and manipulate multimedia streams -- optional oss module")) ocaml-mm-0.7.3/external/mm_alsa.ml000066400000000000000000000056621415601551300170220ustar00rootroot00000000000000(* * Copyright 2011 The Savonet Team * * This file is part of ocaml-mm. * * ocaml-mm is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * ocaml-mm 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 Lesser General Public License * along with ocaml-mm; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA * * As a special exception to the GNU Library General Public License, you may * link, statically or dynamically, a "work that uses the Library" with a publicly * distributed version of the Library to produce an executable file containing * portions of the Library, and distribute that executable file under terms of * your choice, without any of the additional requirements listed in clause 6 * of the GNU Library General Public License. * By "a publicly distributed version of the Library", we mean either the unmodified * Library as distributed by The Savonet Team, or a modified version of the Library that is * distributed under the conditions defined in clause 3 of the GNU Library General * Public License. This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU Library General Public License. * *) let rw channels samplerate ?(device = "default") ?(playback = false) ?(capture = false) ?(blocking = true) ?(buffer_size = 1024) ?(periods = 4) () = object (* inherit Audio.IO.rw_bufferized *) method version = Alsa.get_version () val dev = Alsa.Pcm.open_pcm device ((if playback then [Alsa.Pcm.Playback] else []) @ if capture then [Alsa.Pcm.Capture] else []) [] method delay = Alsa.Pcm.get_delay dev method prepare = Alsa.Pcm.prepare dev method wait t = Alsa.Pcm.wait dev t method recover e = Alsa.Pcm.recover dev e val mutable buffer_size = buffer_size initializer let params = Alsa.Pcm.get_params dev in Alsa.Pcm.set_access dev params Alsa.Pcm.Access_rw_noninterleaved; Alsa.Pcm.set_format dev params Alsa.Pcm.Format_float; Alsa.Pcm.set_channels dev params channels; Alsa.Pcm.set_periods dev params periods Alsa.Dir_eq; assert ( Alsa.Pcm.set_rate_near dev params samplerate Alsa.Dir_eq = samplerate); buffer_size <- Alsa.Pcm.set_buffer_size_near dev params buffer_size; Alsa.Pcm.set_params dev params; Alsa.Pcm.set_nonblock dev (not blocking) method read buf = Alsa.Pcm.readn_float_ba dev buf method write buf = Alsa.Pcm.writen_float_ba dev buf method close = Alsa.Pcm.close dev end ocaml-mm-0.7.3/external/mm_alsa.mli000066400000000000000000000005341415601551300171640ustar00rootroot00000000000000open Mm_audio val rw : int -> int -> ?device:string -> ?playback:bool -> ?capture:bool -> ?blocking:bool -> ?buffer_size:int -> ?periods:int -> unit -> < version : string ; delay : int ; prepare : unit ; wait : int -> bool ; recover : exn -> unit ; read : Audio.t -> int ; write : Audio.t -> int ; close : unit > ocaml-mm-0.7.3/external/mm_ao.ml000066400000000000000000000037141415601551300164750ustar00rootroot00000000000000(* * Copyright 2011 The Savonet Team * * This file is part of ocaml-mm. * * ocaml-mm is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * ocaml-mm 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 Lesser General Public License * along with ocaml-mm; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA * * As a special exception to the GNU Library General Public License, you may * link, statically or dynamically, a "work that uses the Library" with a publicly * distributed version of the Library to produce an executable file containing * portions of the Library, and distribute that executable file under terms of * your choice, without any of the additional requirements listed in clause 6 * of the GNU Library General Public License. * By "a publicly distributed version of the Library", we mean either the unmodified * Library as distributed by The Savonet Team, or a modified version of the Library that is * distributed under the conditions defined in clause 3 of the GNU Library General * Public License. This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU Library General Public License. * *) open Mm_audio (* unit argument because we might put optional arguments for parameters *) class writer channels rate = object val dev = Ao.open_live ~channels ~rate ~byte_format:`LITTLE_ENDIAN () method write buf = let s = Audio.S16LE.make buf in Ao.play dev s method close = Ao.close dev end ocaml-mm-0.7.3/external/mm_ao.mli000066400000000000000000000000761415601551300166440ustar00rootroot00000000000000open Mm_audio class writer : int -> int -> Audio.IO.Writer.t ocaml-mm-0.7.3/external/mm_mad.ml000066400000000000000000000064121415601551300166350ustar00rootroot00000000000000(* * Copyright 2011 The Savonet Team * * This file is part of ocaml-mm. * * ocaml-mm is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * ocaml-mm 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 Lesser General Public License * along with ocaml-mm; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA * * As a special exception to the GNU Library General Public License, you may * link, statically or dynamically, a "work that uses the Library" with a publicly * distributed version of the Library to produce an executable file containing * portions of the Library, and distribute that executable file under terms of * your choice, without any of the additional requirements listed in clause 6 * of the GNU Library General Public License. * By "a publicly distributed version of the Library", we mean either the unmodified * Library as distributed by The Savonet Team, or a modified version of the Library that is * distributed under the conditions defined in clause 3 of the GNU Library General * Public License. This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU Library General Public License. * *) open Mm_base open Mm_audio (* TODO: use optimized version for files. *) class virtual reader = object (self) inherit IO.helper method virtual private stream_close : unit val mutable channels = 0 method channels = channels (* TODO *) method length : int = failwith "TODO" method duration : float = failwith "TODO" method sample_rate = 44100 val mutable rb = Audio.Ringbuffer_ext.create 0 0 val mutable mf = None method private mf = match mf with Some mf -> mf | _ -> assert false initializer let f = Mad.openstream (fun b ofs len -> self#stream_read b ofs len) in (* let _, c, _ = Mad.get_output_format f in *) (* TODO: we should decode a frame in order to get the real number of channels... *) let c = 2 in mf <- Some f; channels <- c; rb <- Audio.Ringbuffer_ext.create channels 0 method private decode = Mad.decode_frame_float_ba self#mf method close = self#stream_close method read buf = let len = Audio.length buf in let r = ref (-1) in while !r <> 0 && Audio.Ringbuffer_ext.read_space rb < len do let data = try self#decode with Mad.End_of_stream -> Audio.create self#channels 0 in r := Audio.length data; Audio.Ringbuffer_ext.write rb data done; let maxlen = Audio.Ringbuffer_ext.read_space rb in let len = min maxlen len in Audio.Ringbuffer_ext.read rb (Audio.sub buf 0 len); len (* TODO *) method seek (_ : int) : unit = failwith "TODO" end class reader_of_file fname = object inherit IO.Unix.rw ~read:true fname inherit reader end ocaml-mm-0.7.3/external/mm_mad.mli000066400000000000000000000000741415601551300170040ustar00rootroot00000000000000class reader_of_file : string -> Mm_audio.Audio.IO.Reader.t ocaml-mm-0.7.3/external/mm_oss.ml000066400000000000000000000066251415601551300167060ustar00rootroot00000000000000(* * Copyright 2011 The Savonet Team * * This file is part of ocaml-mm. * * ocaml-mm is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * ocaml-mm 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 Lesser General Public License * along with ocaml-mm; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA * * As a special exception to the GNU Library General Public License, you may * link, statically or dynamically, a "work that uses the Library" with a publicly * distributed version of the Library to produce an executable file containing * portions of the Library, and distribute that executable file under terms of * your choice, without any of the additional requirements listed in clause 6 * of the GNU Library General Public License. * By "a publicly distributed version of the Library", we mean either the unmodified * Library as distributed by The Savonet Team, or a modified version of the Library that is * distributed under the conditions defined in clause 3 of the GNU Library General * Public License. This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU Library General Public License. * *) open Mm_base open Mm_audio module OSS = struct external set_format : Unix.file_descr -> int -> int = "caml_oss_dsp_setfmt" external set_channels : Unix.file_descr -> int -> int = "caml_oss_dsp_channels" external set_rate : Unix.file_descr -> int -> int = "caml_oss_dsp_speed" end (* TODO: other formats than 16 bits? *) class writer ?(device = "/dev/dsp") channels sample_rate = object (self) inherit IO.Unix.rw ~write:true device initializer assert (OSS.set_format fd 16 = 16); assert (OSS.set_channels fd channels = channels); assert (OSS.set_rate fd sample_rate = sample_rate) method private stream_really_write buf ofs len = let w = ref 0 in while !w <> len do w := !w + self#stream_write buf (ofs + !w) (len - !w) done method write buf = let s = Audio.S16LE.make buf in self#stream_really_write s 0 (String.length s) method close = self#stream_close end class reader ?(device = "/dev/dsp") channels sample_rate = object (self) inherit IO.Unix.rw ~read:true device initializer assert (OSS.set_format fd 16 = 16); assert (OSS.set_channels fd channels = channels); assert (OSS.set_rate fd sample_rate = sample_rate) method channels = channels method sample_rate = sample_rate method length : int = assert false method duration : float = assert false method read buf = let len = Audio.length buf in let slen = Audio.S16LE.length channels len in let s = Bytes.create slen in let r = self#stream_read s 0 slen in let len = Audio.S16LE.length channels r in Audio.S16LE.to_audio (Bytes.unsafe_to_string s) 0 (Audio.sub buf 0 len); len method seek (_ : int) : unit = assert false method close = self#stream_close end ocaml-mm-0.7.3/external/mm_oss.mli000066400000000000000000000003751415601551300170530ustar00rootroot00000000000000(** Audio input and output using the OSS sound devices. *) open Mm_audio (** Create a writer on an OSS sound device. *) class writer : ?device:string -> int -> int -> Audio.IO.Writer.t class reader : ?device:string -> int -> int -> Audio.IO.Reader.t ocaml-mm-0.7.3/external/mm_pulseaudio.ml000066400000000000000000000041461415601551300202500ustar00rootroot00000000000000(* * Copyright 2011 The Savonet Team * * This file is part of ocaml-mm. * * ocaml-mm is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * ocaml-mm 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 Lesser General Public License * along with ocaml-mm; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA * * As a special exception to the GNU Library General Public License, you may * link, statically or dynamically, a "work that uses the Library" with a publicly * distributed version of the Library to produce an executable file containing * portions of the Library, and distribute that executable file under terms of * your choice, without any of the additional requirements listed in clause 6 * of the GNU Library General Public License. * By "a publicly distributed version of the Library", we mean either the unmodified * Library as distributed by The Savonet Team, or a modified version of the Library that is * distributed under the conditions defined in clause 3 of the GNU Library General * Public License. This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU Library General Public License. * *) open Mm_audio open Pulseaudio class writer client_name stream_name channels rate = object val dev = let sample = { sample_format = Sample_format_float32le; sample_rate = rate; sample_chans = channels; } in Simple.create ~client_name ~dir:Dir_playback ~stream_name ~sample () method write buf = Simple.write dev (Audio.to_array buf) 0 (Audio.length buf) method close = Simple.free dev end ocaml-mm-0.7.3/external/mm_pulseaudio.mli000066400000000000000000000001221415601551300204070ustar00rootroot00000000000000open Mm_audio class writer : string -> string -> int -> int -> Audio.IO.Writer.t ocaml-mm-0.7.3/external/mm_sdl.ml000066400000000000000000000226571415601551300166670ustar00rootroot00000000000000(* * Copyright 2011 The Savonet Team * * This file is part of ocaml-mm. * * ocaml-mm is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * ocaml-mm 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 Lesser General Public License * along with ocaml-mm; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA * * As a special exception to the GNU Library General Public License, you may * link, statically or dynamically, a "work that uses the Library" with a publicly * distributed version of the Library to produce an executable file containing * portions of the Library, and distribute that executable file under terms of * your choice, without any of the additional requirements listed in clause 6 * of the GNU Library General Public License. * By "a publicly distributed version of the Library", we mean either the unmodified * Library as distributed by The Savonet Team, or a modified version of the Library that is * distributed under the conditions defined in clause 3 of the GNU Library General * Public License. This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU Library General Public License. * *) open Mm_video open Mm_midi let init () = Sdl.init [`VIDEO] (* (** 8bit surfaces always use a palette *) let from_8 surface = let width,height,pitch = Sdlvideo.surface_dims surface in let image = Sdlvideo.pixel_data_8 surface in let a = I.create width height in for i = 0 to width-1 do for j = 0 to height-1 do let r,g,b = Sdlvideo.get_palette_color surface image.{i+j*pitch} in I.set_pixel a i j (r,g,b,0xff) done done; a (** 16bits surfaces contain specially packed RGB *) let to_16 rgb surface = let s = Sdlvideo.pixel_data_16 surface in let width,height,pitch = Sdlvideo.surface_dims surface in let pitch = pitch/2 in (* initial pitch was in bytes *) let fmt = Sdlvideo.surface_format surface in assert (width = I.width rgb && height = I.height rgb); assert (fmt.Sdlvideo.amask = 0l && not fmt.Sdlvideo.palette) ; for i = 0 to width-1 do for j = 0 to height-1 do let r,g,b,_ = I.get_pixel rgb i j in let color = ((r lsr fmt.Sdlvideo.rloss) lsl fmt.Sdlvideo.rshift) lor ((g lsr fmt.Sdlvideo.gloss) lsl fmt.Sdlvideo.gshift) lor ((b lsr fmt.Sdlvideo.bloss) lsl fmt.Sdlvideo.bshift) in (* let color = Int32.to_int (Sdlvideo.map_RGB surface (r,g,b)) in *) s.{i+j*pitch} <- color done done *) (* (** 24bits surfaces are standard RGB stored in three different bytes, but the order might vary. *) let from_24 surface = let width,height,pitch = Sdlvideo.surface_dims surface in let fmt = Sdlvideo.surface_format surface in let rgb = Sdlvideo.pixel_data_24 surface in let a = I.create width height in for i = 0 to width-1 do for j = 0 to height-1 do for c = 0 to 2 do let c' = if fmt.Sdlvideo.rshift = 0 then c else 2-c in rgba.{c+i*4+j*a.RGB.stride} <- rgb.{c'+i*3+j*pitch} done ; rgba.{3+i*4+j*a.RGB.stride} <- 0xff done done ; a *) (** 32bits surfaces are standard RGBA However, the RGB components are (at least sometimes) packed in a different order as in liquidsoap: 0xAARRGGBB. An alternative implementation, which is surprisingly not sensibly faster, uses SDL blitting directly by casting a char* into an int*. The alpha is masked out because we don't want to see video frames on top of each other on screen. This hack might not work the same on different platforms. let s = Sdlvideo.create_RGB_surface_from_32 (Obj.magic rgb.RGB.data) ~w:rgb.RGB.width ~h:rgb.RGB.height ~pitch:rgb.RGB.stride (* The masks might be endianness dependent *) ~rmask:0xffl ~gmask:0xff00l ~bmask:0xff0000l ~amask:0l in Sdlvideo.blit_surface ~src:s ~dst:surface () *) (* let to_32 rgb surface = let s = Sdlvideo.pixel_data_32 surface in let width,height,pitch = Sdlvideo.surface_dims surface in let pitch = pitch/4 in (* initial pitch was in bytes *) let fmt = Sdlvideo.surface_format surface in assert (width = I.width rgb && height = I.height rgb); assert (fmt.Sdlvideo.amask = 0l && not fmt.Sdlvideo.palette); for i = 0 to width-1 do for j = 0 to height-1 do let r,g,b,_ = I.get_pixel rgb i j in let color = Int32.of_int ((r lsl fmt.Sdlvideo.rshift) lor (g lsl fmt.Sdlvideo.gshift) lor (b lsl fmt.Sdlvideo.bshift)) in s.{i+j*pitch} <- color done done *) external to_32 : Video.Image.t -> (int32, Bigarray.int32_elt, Bigarray.c_layout) Bigarray.Array1.t -> int * int * int -> unit = "caml_sdl_rgb_to32" let to_32 rgb surface = let sbuf = Sdlvideo.pixel_data_32 surface in let fmt = Sdlvideo.surface_format surface in to_32 rgb sbuf (fmt.Sdlvideo.rshift, fmt.Sdlvideo.gshift, fmt.Sdlvideo.bshift) (* let from_32 surface = let img = Sdlvideo.pixel_data_32 surface in let width,height,pitch = Sdlvideo.surface_dims surface in let fmt = Sdlvideo.surface_format surface in let pitch = pitch/4 in (* pitch is in bytes, convert for int32 array *) let a = RGB.create width height in let rgba = a.RGB.data in assert (fmt.Sdlvideo.rloss = 0 && fmt.Sdlvideo.gloss = 0 && fmt.Sdlvideo.bloss = 0) ; let (&&) = Int32.logand in let (>>) = Int32.shift_right in for i = 0 to width-1 do for j = 0 to height-1 do let pixel = img.{i+j*pitch} in let pos = i*4+j*a.RGB.stride in rgba.{0+pos} <- Int32.to_int ((pixel && fmt.Sdlvideo.rmask) >> fmt.Sdlvideo.rshift) ; rgba.{1+pos} <- Int32.to_int ((pixel && fmt.Sdlvideo.gmask) >> fmt.Sdlvideo.gshift) ; rgba.{2+pos} <- Int32.to_int ((pixel && fmt.Sdlvideo.bmask) >> fmt.Sdlvideo.bshift) ; rgba.{3+pos} <- Int32.to_int ((pixel && fmt.Sdlvideo.amask) >> fmt.Sdlvideo.ashift) done done ; a *) class writer_to_screen w h = object initializer Sdlevent.enable_events Sdlevent.quit_mask; (* Try to get 32bpp because it's faster (twice as fast here), but accept * other formats too. *) ignore (Sdlvideo.set_video_mode ~w ~h ~bpp:32 [`ANYFORMAT; `DOUBLEBUF]) method write buf ofs len = if Sdlevent.poll () = Some Sdlevent.QUIT then Sdl.quit () else if len > 0 then ( let surface = Sdlvideo.get_video_surface () in (* We only display the last image of each frame *) let rgb = buf.(ofs + len - 1) in begin match Sdlvideo.surface_bpp surface with (* | 16 -> to_16 rgb surface *) | 32 -> to_32 rgb surface | i -> failwith (Printf.sprintf "Unsupported format %dbpp" i) end; Sdlvideo.flip surface) method close = Sdl.quit () end class midi_keyboard : MIDI.IO.Reader.t = let knotes2 = [| '&'; 'a'; '\233'; 'z'; '"'; 'e'; 'r'; '('; 't'; '-'; 'y'; '\232'; 'u'; 'i'; '\231'; 'o'; '\224'; 'p'; |] in let knotes1 = [| 'q'; 'w'; 's'; 'x'; 'd'; 'c'; 'v'; 'g'; 'b'; 'h'; 'n'; 'j'; ','; ';'; 'l'; ':'; 'm'; '!'; |] in let array_index a x = let ans = ref None in for i = 0 to Array.length a - 1 do if a.(i) = x then ans := Some i done; match !ans with Some i -> i | None -> raise Not_found in let note_of_char c = try array_index knotes2 c + 71 with Not_found -> array_index knotes1 c + 59 in object initializer Sdl.init [`EVENTTHREAD; `VIDEO]; Sdlevent.disable_events Sdlevent.all_events_mask; Sdlevent.enable_events (Sdlevent.make_mask [Sdlevent.KEYDOWN_EVENT; Sdlevent.KEYUP_EVENT; Sdlevent.QUIT_EVENT]); ignore (Sdlvideo.set_video_mode ~w:640 ~h:480 ~bpp:16 []) val mutable velocity = 1. val channel = 0 method read _ buf ofs len = MIDI.Multitrack.clear buf ofs len; Sdlevent.pump (); while Sdlevent.has_event () do try match Sdlevent.poll () with | Some (Sdlevent.KEYDOWN k) -> let c = Sdlkey.char_of_key k.Sdlevent.keysym in if c = '+' || c = '*' then velocity <- min 1. (velocity +. 0.1) else if c = '-' || c = '/' then velocity <- max 0. (velocity -. 0.1) else ( let n = note_of_char c in (* Printf.printf "Playing note %d.\n%!" n; *) MIDI.insert buf.(channel) (ofs, MIDI.Note_on (n, velocity))) | Some (Sdlevent.KEYUP k) -> let c = Sdlkey.char_of_key k.Sdlevent.keysym in let n = note_of_char c in (* Printf.printf "Stopping note %d.\n%!" n; *) MIDI.insert buf.(channel) (ofs, MIDI.Note_off (n, velocity)) | _ -> () with Not_found | Invalid_argument _ -> () done; len method close = Sdl.quit () end ocaml-mm-0.7.3/external/mm_sdl.mli000066400000000000000000000002251415601551300170230ustar00rootroot00000000000000open Mm_video open Mm_midi val init : unit -> unit class writer_to_screen : int -> int -> Video.IO.Writer.t class midi_keyboard : MIDI.IO.Reader.t ocaml-mm-0.7.3/external/mm_theora.ml000066400000000000000000000112611415601551300173540ustar00rootroot00000000000000(* * Copyright 2011 The Savonet Team * * This file is part of ocaml-mm. * * ocaml-mm is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * ocaml-mm 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 Lesser General Public License * along with ocaml-mm; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA * * As a special exception to the GNU Library General Public License, you may * link, statically or dynamically, a "work that uses the Library" with a publicly * distributed version of the Library to produce an executable file containing * portions of the Library, and distribute that executable file under terms of * your choice, without any of the additional requirements listed in clause 6 * of the GNU Library General Public License. * By "a publicly distributed version of the Library", we mean either the unmodified * Library as distributed by The Savonet Team, or a modified version of the Library that is * distributed under the conditions defined in clause 3 of the GNU Library General * Public License. This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU Library General Public License. * *) open Mm_image open Mm_video class reader_of_file fname = let sync, fd = Ogg.Sync.create_from_file fname in let rec fill os = let page = Ogg.Sync.read sync in try (* We drop pages which are not for us.. *) if Ogg.Page.serialno page = Ogg.Stream.serialno os then Ogg.Stream.put_page os page with Ogg.Bad_data -> fill os (* Do not care about page that are not for us.. *) in (* Test wether the stream is theora *) let test_theora () = (* Get First page *) let page = Ogg.Sync.read sync in (* Check wether this is a b_o_s *) if not (Ogg.Page.bos page) then raise Video.IO.Invalid_file; (* Create a stream with this ID *) let serial = Ogg.Page.serialno page in Printf.printf "Testing stream %nx.\n" serial; let os = Ogg.Stream.create ~serial () in Ogg.Stream.put_page os page; let packet = Ogg.Stream.get_packet os in (* Test header. Do not catch anything, first page should be sufficient. *) if not (Theora.Decoder.check packet) then raise Not_found; Printf.printf "Got a theora stream!\n"; let dec = Theora.Decoder.create () in (* Decode headers *) let rec f packet = try Theora.Decoder.headerin dec packet with Ogg.Not_enough_data -> let rec g () = try let packet = Ogg.Stream.get_packet os in f packet with Ogg.Not_enough_data -> fill os; g () in g () in let dec, info, _, _ = f packet in (os, dec, info) in (* Now find a theora stream *) let rec init () = try test_theora () with | Not_found -> Printf.printf "This stream was not theora..\n"; init () | Video.IO.Invalid_file as e -> Printf.printf "No theora stream was found..\n%!"; raise e in let os, dec, info = init () in (* TODO: handle more formats *) let _ = assert (info.Theora.pixel_fmt = Theora.PF_420) in object (self) method width = info.Theora.frame_width method height = info.Theora.frame_height method frame_rate = float_of_int info.Theora.fps_numerator /. float_of_int info.Theora.fps_denominator val mutable latest_yuv = None method private get_yuv = try let yuv = Theora.Decoder.get_yuv dec os in let yuv = Theora.( Image.YUV420.make yuv.y_width yuv.y_height yuv.y yuv.y_stride yuv.u yuv.Theora.v yuv.u_stride) in latest_yuv <- Some yuv; yuv with | Ogg.Not_enough_data when not (Ogg.Stream.eos os) -> fill os; self#get_yuv | Theora.Duplicate_frame -> ( (* Got a duplicate frame, sending previous one ! *) match latest_yuv with | Some x -> x | None -> raise Video.IO.Invalid_file) method read buf ofs len = let n = ref 0 in try while !n < len do buf.(ofs + !n) <- self#get_yuv; incr n done; !n with Ogg.Not_enough_data -> !n method close = Unix.close fd end ocaml-mm-0.7.3/external/mm_theora.mli000066400000000000000000000001021415601551300175150ustar00rootroot00000000000000open Mm_video class reader_of_file : string -> Video.IO.Reader.t ocaml-mm-0.7.3/external/oss_stubs.c000066400000000000000000000046421415601551300172440ustar00rootroot00000000000000/* * Copyright 2011 The Savonet Team * * This file is part of ocaml-mm. * * ocaml-mm is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * ocaml-mm 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 Lesser General Public License * along with ocaml-mm; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA * * As a special exception to the GNU Library General Public License, you may * link, statically or dynamically, a "work that uses the Library" with a publicly * distributed version of the Library to produce an executable file containing * portions of the Library, and distribute that executable file under terms of * your choice, without any of the additional requirements listed in clause 6 * of the GNU Library General Public License. * By "a publicly distributed version of the Library", we mean either the unmodified * Library as distributed by The Savonet Team, or a modified version of the Library that is * distributed under the conditions defined in clause 3 of the GNU Library General * Public License. This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU Library General Public License. * */ #include #include #include #include #include #include #include #include #include CAMLprim value caml_oss_dsp_setfmt(value fd, value fmt) { int f = Int_val(fmt); /* TODO: raise errors */ /* TODO: use format constants */ assert(ioctl(Int_val(fd), SNDCTL_DSP_SETFMT, &f) != -1); return Val_int(f); } CAMLprim value caml_oss_dsp_channels(value fd, value chans) { int c = Int_val(chans); assert(ioctl(Int_val(fd), SNDCTL_DSP_CHANNELS, &c) != -1); return Val_int(c); } CAMLprim value caml_oss_dsp_speed(value fd, value speed) { int s = Int_val(speed); assert(ioctl(Int_val(fd), SNDCTL_DSP_SPEED, &s) != -1); return Val_int(s); } ocaml-mm-0.7.3/external/sdl_stubs.c000066400000000000000000000046231415601551300172210ustar00rootroot00000000000000/* * Copyright 2011 The Savonet Team * * This file is part of ocaml-mm. * * ocaml-mm is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * ocaml-mm 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 Lesser General Public License * along with ocaml-mm; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA * * As a special exception to the GNU Library General Public License, you may * link, statically or dynamically, a "work that uses the Library" with a publicly * distributed version of the Library to produce an executable file containing * portions of the Library, and distribute that executable file under terms of * your choice, without any of the additional requirements listed in clause 6 * of the GNU Library General Public License. * By "a publicly distributed version of the Library", we mean either the unmodified * Library as distributed by The Savonet Team, or a modified version of the Library that is * distributed under the conditions defined in clause 3 of the GNU Library General * Public License. This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU Library General Public License. * */ #include #include #include #include #include #include #include #include #include #include #include "image_rgb.h" CAMLprim value caml_sdl_rgb_to32(value _rgb, value _surf, value shift) { CAMLparam3(_rgb, _surf, shift); /* int sr = Int_val(Field(shift, 0)); int sg = Int_val(Field(shift, 1)); int sb = Int_val(Field(shift, 2)); */ frame rgb; frame_of_value(_rgb, &rgb); uint32_t *surf = Caml_ba_data_val(_surf); int i, j; int w = rgb.width; int h = rgb.height; for (j = 0; j < h; j++) for (i = 0; i < w; i++) surf[j*w+i] = htonl(Int_pixel(&rgb,i,j)) >> 8; CAMLreturn(Val_unit); } ocaml-mm-0.7.3/mm.opam000066400000000000000000000016421415601551300145160ustar00rootroot00000000000000# This file is generated by dune, edit dune-project instead opam-version: "2.0" version: "0.7.3" synopsis: "The mm library contains high-level to create and manipulate multimedia streams (audio, video, MIDI)" maintainer: ["The Savonet Team "] authors: ["Romain Beauxis "] license: "GPL-2.0" homepage: "https://github.com/savonet/ocaml-mm" bug-reports: "https://github.com/savonet/ocaml-mm/issues" depends: [ "dune" {>= "2.8"} "dune-configurator" "odoc" {with-doc} ] depopts: ["alsa" "ao" "mad" "pulseaudio" "ocamlsdl" "theora"] conflicts: [ "mad" {< "0.5.0"} "alsa" {< "0.3.0"} ] build: [ ["dune" "subst"] {dev} [ "dune" "build" "-p" name "-j" jobs "@install" "@runtest" {with-test} "@doc" {with-doc} ] ] dev-repo: "git+https://github.com/savonet/ocaml-mm.git" depexts: [ ["linux-headers"] {os-family = "alpine"} ] ocaml-mm-0.7.3/mm.opam.template000066400000000000000000000000701415601551300163220ustar00rootroot00000000000000depexts: [ ["linux-headers"] {os-family = "alpine"} ] ocaml-mm-0.7.3/src/000077500000000000000000000000001415601551300140135ustar00rootroot00000000000000ocaml-mm-0.7.3/src/IO.ml000066400000000000000000000116471415601551300146650ustar00rootroot00000000000000(* * Copyright 2011 The Savonet Team * * This file is part of ocaml-mm. * * ocaml-mm is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * ocaml-mm 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 Lesser General Public License * along with ocaml-mm; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA * * As a special exception to the GNU Library General Public License, you may * link, statically or dynamically, a "work that uses the Library" with a publicly * distributed version of the Library to produce an executable file containing * portions of the Library, and distribute that executable file under terms of * your choice, without any of the additional requirements listed in clause 6 * of the GNU Library General Public License. * By "a publicly distributed version of the Library", we mean either the unmodified * Library as distributed by The Savonet Team, or a modified version of the Library that is * distributed under the conditions defined in clause 3 of the GNU Library General * Public License. This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU Library General Public License. * *) (** Helper functions for reading and writing. *) exception Invalid_data module Unix = struct (** To be inherited to read and write from files. *) class virtual rw ?(read = false) ?(write = false) fname = object val fd = let flag, perms = match (read, write) with | false, false -> assert false | true, false -> ([Unix.O_RDONLY], 0o644) | false, true -> ([Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC], 0o644) | true, true -> ([Unix.O_RDWR; Unix.O_CREAT; Unix.O_TRUNC], 0o644) in Unix.openfile fname flag perms method private stream_read buf ofs len = Unix.read fd buf ofs len method private stream_write buf ofs len = Unix.write fd (Bytes.of_string buf) ofs len method private stream_close = Unix.close fd method private stream_seek n = ignore (Unix.lseek fd n Unix.SEEK_SET) method private stream_cur_pos = Unix.lseek fd 0 Unix.SEEK_CUR end end class virtual helper = object (self) method virtual private stream_read : Bytes.t -> int -> int -> int method private input_once n = let buf = Bytes.create n in let n = self#stream_read buf 0 n in if n = Bytes.length buf then buf else Bytes.sub buf 0 n method private input n = let buf = self#input_once n in let buf = Bytes.to_string buf in let buflen = String.length buf in if buflen = n || buflen = 0 then buf else buf ^ self#input (n - buflen) method private really_input n = let buf = self#input n in if String.length buf <> n then raise Invalid_data; buf method private input_byte = let buf = self#really_input 1 in int_of_char buf.[0] (* TODO: use really_input instead of input_byte *) method private input_int_num_bytes n = let rec aux = function | 0 -> 0 | n -> let b = self#input_byte in b + (256 * aux (n - 1)) in aux n method private input_int = self#input_int_num_bytes 4 method private input_short = self#input_int_num_bytes 2 method private input_int_num_bytes_be n = let ans = ref 0 in let buf = self#really_input n in for i = 0 to n - 1 do ans := (256 * !ans) + int_of_char buf.[i] done; !ans method private input_int_be = self#input_int_num_bytes_be 4 method private input_short_be = self#input_int_num_bytes_be 2 method virtual private stream_write : string -> int -> int -> int method private output s = let len = String.length s in assert (self#stream_write s 0 len = len) method private output_num b n = let s = Bytes.create b in for i = 0 to b - 1 do Bytes.set s i (char_of_int ((n lsr (8 * i)) land 0xff)) done; self#output (Bytes.to_string s) method private output_byte n = self#output_num 1 n method private output_short n = self#output_num 2 n method private output_int n = self#output_num 4 n method private output_num_be b n = let s = Bytes.create b in for i = 0 to b - 1 do Bytes.set s i (char_of_int ((n lsr (8 * (b - i - 1))) land 0xff)) done; self#output (Bytes.to_string s) method private output_short_be n = self#output_num_be 2 n method private output_int_be n = self#output_num_be 4 n end ocaml-mm-0.7.3/src/MIDI.ml000066400000000000000000000465501415601551300151010ustar00rootroot00000000000000(* * Copyright 2011 The Savonet Team * * This file is part of ocaml-mm. * * ocaml-mm is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * ocaml-mm 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 Lesser General Public License * along with ocaml-mm; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA * * As a special exception to the GNU Library General Public License, you may * link, statically or dynamically, a "work that uses the Library" with a publicly * distributed version of the Library to produce an executable file containing * portions of the Library, and distribute that executable file under terms of * your choice, without any of the additional requirements listed in clause 6 * of the GNU Library General Public License. * By "a publicly distributed version of the Library", we mean either the unmodified * Library as distributed by The Savonet Team, or a modified version of the Library that is * distributed under the conditions defined in clause 3 of the GNU Library General * Public License. This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU Library General Public License. * *) open Mm_base open Mm_audio type division = Ticks_per_quarter of int | SMPTE of int * int type event = | Note_off of Audio.Note.t * float | Note_on of Audio.Note.t * float (* Note on: note number (A4 = 69), velocity (between 0 and 1). *) | Aftertouch of int * float | Control_change of int * int (* TODO: specific type for common control changes *) | Patch of int | Channel_aftertouch of int | Pitch of int (* Meta-events *) | Sequence_number of int | Text of string | Copyright of string | Track_name of string | Instrument_name of string | Lyric of string | Marker of string | Cue of string | End_of_track | Tempo of int | Time_signature of int * int * int * int | Key_signature of int * bool | Custom of string (* Tempo is in microseconds per quarter. *) let samples_of_delta samplerate division tempo delta = match division with | Ticks_per_quarter tpq -> (* These computations sometimes overflow on 32 bits. *) let tpq = Int64.of_int tpq in let tempo = Int64.of_int tempo in let tps = Int64.of_int samplerate in let ten = Int64.of_int 1000000 in let delta = Int64.of_int delta in let ( * ) = Int64.mul in let ( / ) = Int64.div in Int64.to_int (delta * tempo / tpq * tps / ten) | SMPTE (fps, res) -> samplerate * delta / (fps * res) (* let delta_of_samples samplerate division tempo samples = match division with | Ticks_per_quarter tpq -> let tpq = Int64.of_int tpq in let tempo = Int64.of_int tempo in let samplerate = Int64.of_int samplerate in let ten = Int64.of_int 1000000 in let samples = Int64.of_int samples in let ( * ) = Int64.mul in let ( / ) = Int64.div in Int64.to_int (samples * samplerate * ten * tpq / tempo) | SMPTE (fps,res) -> (* TODO: could this overflow? *) (fps * res * samples) / samplerate *) let byte_of_float x = let clip x = max 0 (min 127 x) in char_of_int (clip (int_of_float (x *. 127.))) let encode_event chan e = let s = Bytes.create 3 in let coi = char_of_int in let bof = byte_of_float in (match e with | Note_off (n, v) -> Bytes.set s 0 (coi ((0x8 lsl 4) + chan)); Bytes.set s 1 (coi n); Bytes.set s 2 (bof v) | Note_on (n, v) -> Bytes.set s 0 (coi ((0x9 lsl 4) + chan)); Bytes.set s 1 (coi n); Bytes.set s 2 (bof v) | _ -> (* TODO *) assert false); Bytes.to_string s type buffer = { (* time is offset from the beginning of the buffer at given samplerate *) mutable data : (int * event) list; duration : int; } let create duration = { data = []; duration } let duration buf = buf.duration let copy b = let ans = create (duration b) in ans.data <- b.data; ans let clear_all buf = buf.data <- [] let clear buf ofs len = if ofs = 0 && len = duration buf then clear_all buf else buf.data <- List.filter (fun (t, _) -> t < ofs || t >= ofs + len) buf.data (* complement of clear *) let extract buf ofs len = if not (ofs = 0 && len = duration buf) then buf.data <- List.filter (fun (t, _) -> ofs <= t && t < ofs + len) buf.data let cmp te1 te2 = fst te1 - fst te2 let merge b1 b2 = b1.data <- List.merge cmp b1.data b2.data let translate b d = b.data <- List.map (fun (t, e) -> (t + d, e)) b.data let add b1 o1 b2 o2 len = let b2 = copy b2 in extract b2 o2 len; translate b2 (o1 - o2); merge b1 b2 let blit_all b1 b2 = b2.data <- b1.data let blit b1 o1 b2 o2 len = if o1 = 0 && o2 = 0 && duration b1 = len && duration b2 = len then blit_all b1 b2 else ( let b1 = copy b1 in clear b2 o2 len; extract b1 o1 len; translate b1 (o2 - o1); merge b2 b1) let insert b te = assert (fst te < duration b); b.data <- List.merge cmp b.data [te] let data buf = buf.data module Multitrack = struct type t = buffer array type buffer = t let channels buf = Array.length buf let duration buf = duration buf.(0) let create chans duration = Array.init chans (fun _ -> create duration) let clear ?channel buf ofs len = match channel with | None -> Array.iter (fun buf -> clear buf ofs len) buf | Some c -> clear buf.(c) ofs len end module IO = struct exception Invalid_header exception Invalid_data module Reader = struct class type t = object method read : int -> Multitrack.buffer -> int -> int -> int method close : unit end class virtual base = object (self) inherit IO.helper val mutable tracks = 0 val mutable division = Ticks_per_quarter 0 method private input_id = self#really_input 4 method! private input_int = self#input_int_be method! private input_short = self#input_short_be (** Read midi header. *) method private read_header = (* Actual header reading. *) let id = self#input_id in let len = self#input_int in let fmt = self#input_short in let track_nb = self#input_short in let div = self#input_short in let div = if div land 0x8000 = 0 then (* Delta-time ticks per quarter *) Ticks_per_quarter div else ( let frames = (div lsr 8) land 0x7f in let ticks = div land 0xff in SMPTE (frames, ticks)) in if id <> "MThd" || len <> 6 || (fmt <> 0 && fmt <> 1 && fmt <> 2) then raise Invalid_header; tracks <- track_nb; division <- div (** Read a midi track. *) method private decode_track_data data = let len = String.length data in let data = Array.init len (fun i -> int_of_char data.[i]) in let pos = ref 0 in let read_delta () = let ans = ref 0 in while data.(!pos) land 0x80 <> 0 do ans := (!ans lsl 7) + (data.(!pos) land 0x7f); incr pos; if !pos >= Array.length data then raise Invalid_data done; ans := (!ans lsl 7) + data.(!pos); incr pos; !ans in let status = ref 0 in (* for running status *) let read_event () = let get_byte () = if !pos >= Array.length data then raise Invalid_data; incr pos; data.(!pos - 1) in let get_text len = let ans = Bytes.create len in if !pos + len >= Array.length data then raise Invalid_data; for i = 0 to len - 1 do Bytes.set ans i (char_of_int data.(!pos + i)) done; pos := !pos + len; Bytes.to_string ans in let advance len = pos := !pos + len in let command = if !pos >= Array.length data then raise Invalid_data; data.(!pos) in incr pos; let command = if command land 0x80 <> 0 then ( status := command; command) else ( decr pos; !status) in let cmd = (command lsr 4) land 0xf in let chan = command land 0xf in match cmd with | 8 -> let n = get_byte () in let v = get_byte () in (Some chan, Note_off (n, float v /. 127.)) | 9 -> let n = get_byte () in let v = get_byte () in ( Some chan, if v = 0 then (* I have seen notes at 0. used as note off...... *) Note_off (n, 0.) else Note_on (n, float v /. 127.) ) | 0xa -> let n = get_byte () in let v = get_byte () in (Some chan, Aftertouch (n, float v /. 127.)) | 0xb -> let c = get_byte () in let v = get_byte () in (Some chan, Control_change (c, v)) | 0xc -> let p = get_byte () in (Some chan, Patch p) | 0xd -> let c = get_byte () in (Some chan, Channel_aftertouch c) | 0xe -> let l = get_byte () land 0x7f in let h = get_byte () land 0x7f in (Some chan, Pitch ((h lsl 7) + l)) | _ -> ( match command with | 0xf0 | 0xf7 -> (* SysEx *) let len = read_delta () in advance len; raise Not_found | 0xff -> ( let cmd = get_byte () in let len = read_delta () in match cmd with | 0 -> if len <> 2 then raise Invalid_data; let h = get_byte () in let l = get_byte () in (None, Sequence_number ((h lsl 8) + l)) | 1 -> (None, Text (get_text len)) | 2 -> (None, Copyright (get_text len)) | 3 -> (None, Track_name (get_text len)) | 4 -> (None, Instrument_name (get_text len)) | 5 -> (None, Lyric (get_text len)) | 6 -> (None, Marker (get_text len)) | 7 -> (None, Cue (get_text len)) | 0x2f (* End of track *) -> if len <> 0 then raise Invalid_data; raise Not_found | 0x51 (* Tempo in microseconds per quarter note *) -> if len <> 3 then raise Invalid_data; let t1 = get_byte () in let t2 = get_byte () in let t3 = get_byte () in let t = (t1 lsl 16) + (t2 lsl 8) + t3 in (None, Tempo t) | 0x58 (* Time signature *) -> if len <> 4 then raise Invalid_data; (* numerator, * denominator, * ticks in a metronome click, * 32nd notes to the quarter note *) let n = get_byte () in let d = get_byte () in let c = get_byte () in let b = get_byte () in (None, Time_signature (n, d, c, b)) | 0x59 (* Key signature *) -> if len <> 2 then raise Invalid_data; let sf = get_byte () in (* sharps / flats *) let m = get_byte () in (* minor? *) (None, Key_signature (sf, m <> 0)) | 0x54 (* SMPTE Offset *) | 0x7f (* Sequencer-specific data *) -> advance len; raise Not_found | _ -> advance len; Printf.printf "MIDI: unknown meta-event %x.\n%!" cmd; raise Not_found) | _ -> advance 1; Printf.printf "MIDI: unknown command %x (pos: %d)\n%!" command !pos; raise Not_found) in let ans = ref [] in while !pos < len do try let d = read_delta () in let e = read_event () in ans := (d, e) :: !ans with Not_found -> () done; List.rev !ans method private read_track = let id = self#input_id in let len = self#input_int in if id <> "MTrk" then raise Invalid_header; let data = self#really_input len in self#decode_track_data data end class of_file fname = object (self) inherit IO.Unix.rw ~read:true fname inherit IO.helper inherit! base val mutable track = [] val mutable tempo = 500000 initializer (* Read header. *) self#read_header; (* Read all tracks. *) let tracks = Array.init tracks (fun _ -> self#read_track) in (* Merge all tracks. *) let trk = let find_min () = let ans = ref None in for c = 0 to Array.length tracks - 1 do match tracks.(c) with | [] -> () | (d, _) :: _ -> ( match !ans with | None -> ans := Some (d, c) | Some (d', _) -> if d < d' then ans := Some (d, c)) done; match !ans with Some (d, c) -> (d, c) | None -> raise Not_found in let ans = ref [] in try while true do let d, c = find_min () in ans := List.hd tracks.(c) :: !ans; tracks.(c) <- List.tl tracks.(c); Array.iteri (fun n t -> if n <> c && t <> [] then ( let d', e = List.hd t in tracks.(n) <- (d' - d, e) :: List.tl t)) tracks done; assert false with Not_found -> List.rev !ans in track <- trk (* We store here the track with delta-times in samples. TODO: this way of doing things is messy but simpler to implement *) val mutable track_samples = [] val mutable track_samples_computed = false method private read_add sr buf ofs len = (* Compute track_samples if this has not been done yet. *) if not track_samples_computed then ( let t = tempo in track_samples <- List.map (fun (d, (c, e)) -> let d = samples_of_delta sr division tempo d in (match e with Tempo t -> tempo <- t | _ -> ()); (d, (c, e))) track; tempo <- t; track_samples_computed <- true); let offset_in_buf = ref 0 in while track_samples <> [] && !offset_in_buf < len do let d, (c, e) = List.hd track_samples in offset_in_buf := !offset_in_buf + d; (match e with Tempo t -> tempo <- t | _ -> ()); if !offset_in_buf < len then ( track_samples <- List.tl track_samples; match c with | Some c -> ( (* Filter out relevant events. *) match e with | Note_on _ | Note_off _ | Control_change _ -> if c < Array.length buf then insert buf.(c) (!offset_in_buf + ofs, e) | _ -> () (* TODO *)) | None -> () (* TODO *)) else track_samples <- (!offset_in_buf - len, (c, e)) :: List.tl track_samples done; if track_samples <> [] then len else !offset_in_buf method read sr buf ofs len = Multitrack.clear buf ofs len; self#read_add sr buf ofs len method close = self#stream_close end end module Writer = struct class type t = object method put : int -> event -> unit method note_off : int -> int -> float -> unit method note_on : int -> int -> float -> unit method advance : int -> unit method close : unit end class to_file samplerate fname = (* frames per second *) let fps = 25 in (* ticks per frame *) let tpf = 40 in (* delta of samples *) let rec delta d = if d = 0 then "" else delta (d lsr 7) ^ String.make 1 (char_of_int (128 + (d land 127))) in let delta d = delta (d lsr 7) ^ String.make 1 (char_of_int (d land 127)) in (* TODO: keep integer remainder in curdelta *) let delta d = delta (d * fps * tpf / samplerate) in object (self) inherit IO.Unix.rw ~write:true fname inherit IO.helper val mutable curdelta = 0 val mutable datalen = 0 method! private output_int = self#output_int_be method! private output_short = self#output_short_be initializer self#output "MThd"; self#output_int 6; (* format *) self#output_short 0; (* tracks *) self#output_short 1; (* time division *) self#output_short ((((fps - 1) lxor 0xff) lsl 8) + tpf); (* Printf.printf "%dx%d: %x\n%!" fps tpf ((((fps-1) lxor 0xff) lsl 8) + tpf); *) (* self#output_byte (128 + fps); self#output_byte tpf; *) (* fist track *) self#output "MTrk"; (* track length *) self#output_int 0 method put chan e = let d = delta curdelta in let e = encode_event chan e in self#output d; self#output e; datalen <- datalen + String.length d + String.length e; curdelta <- 0 method note_off chan n v = self#put chan (Note_off (n, v)) method note_on chan n v = self#put chan (Note_on (n, v)) method advance n = curdelta <- curdelta + n method close = self#stream_seek 18; self#output_int datalen; self#stream_close end end end ocaml-mm-0.7.3/src/MIDI.mli000066400000000000000000000077011415601551300152450ustar00rootroot00000000000000(* * Copyright 2011 The Savonet Team * * This file is part of ocaml-mm. * * ocaml-mm is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * ocaml-mm 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 Lesser General Public License * along with ocaml-mm; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA * * As a special exception to the GNU Library General Public License, you may * link, statically or dynamically, a "work that uses the Library" with a publicly * distributed version of the Library to produce an executable file containing * portions of the Library, and distribute that executable file under terms of * your choice, without any of the additional requirements listed in clause 6 * of the GNU Library General Public License. * By "a publicly distributed version of the Library", we mean either the unmodified * Library as distributed by The Savonet Team, or a modified version of the Library that is * distributed under the conditions defined in clause 3 of the GNU Library General * Public License. This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU Library General Public License. * *) open Mm_audio (** Operations on MIDI data. *) (** Units for delta-times. *) type division = | Ticks_per_quarter of int (** Ticks per quarter note. *) | SMPTE of int * int (** SMPTE (frames per second, ticks per frame). *) type event = | Note_off of Audio.Note.t * float | Note_on of Audio.Note.t * float | Aftertouch of int * float | Control_change of int * int | Patch of int | Channel_aftertouch of int | Pitch of int (* Meta-events *) | Sequence_number of int | Text of string | Copyright of string | Track_name of string | Instrument_name of string | Lyric of string | Marker of string | Cue of string | End_of_track | Tempo of int | Time_signature of int * int * int * int | Key_signature of int * bool | Custom of string (** A MIDI buffer. *) type buffer val data : buffer -> (int * event) list (** Create a MIDI buffer of given length in samples. *) val create : int -> buffer (** Create a copy of a MIDI buffer. *) val copy : buffer -> buffer val blit : buffer -> int -> buffer -> int -> int -> unit val blit_all : buffer -> buffer -> unit (** [merge b1 b2] merges the buffer [b2] into [b1]. *) val merge : buffer -> buffer -> unit val add : buffer -> int -> buffer -> int -> int -> unit val clear_all : buffer -> unit val insert : buffer -> int * event -> unit module Multitrack : sig type t = buffer array type buffer = t val channels : buffer -> int val duration : buffer -> int (** Create a multitrack MIDI buffer with given number of channels and length in samples. *) val create : int -> int -> buffer val clear : ?channel:int -> buffer -> int -> int -> unit end module IO : sig module Reader : sig class type t = object (** Read data at with given samplerate for events, in a given track, with a given length in samples. *) method read : int -> Multitrack.buffer -> int -> int -> int (** Close the stream. *) method close : unit end class of_file : string -> t end module Writer : sig class type t = object method put : int -> event -> unit method note_off : int -> int -> float -> unit method note_on : int -> int -> float -> unit method advance : int -> unit method close : unit end class to_file : int -> string -> t end end ocaml-mm-0.7.3/src/audio.ml000066400000000000000000001474241415601551300154620ustar00rootroot00000000000000(* * Copyright 2011 The Savonet Team * * This file is part of ocaml-mm. * * ocaml-mm is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * ocaml-mm 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 Lesser General Public License * along with ocaml-mm; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA * * As a special exception to the GNU Library General Public License, you may * link, statically or dynamically, a "work that uses the Library" with a publicly * distributed version of the Library to produce an executable file containing * portions of the Library, and distribute that executable file under terms of * your choice, without any of the additional requirements listed in clause 6 * of the GNU Library General Public License. * By "a publicly distributed version of the Library", we mean either the unmodified * Library as distributed by The Savonet Team, or a modified version of the Library that is * distributed under the conditions defined in clause 3 of the GNU Library General * Public License. This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU Library General Public License. * *) (* TODO: - lots of functions require offset and length whereas in most cases we want to apply the operations on the whole buffers -> labeled optional arguments? - do we want to pass samplerate as an argument or to store it in buffers? *) open Mm_base let list_filter_ctxt f l = let rec aux b = function | [] -> [] | h :: t -> if f b h t then h :: aux (b @ [h]) t else aux (b @ [h]) t in aux [] l let pi = 3.14159265358979323846 let lin_of_dB x = 10. ** (x /. 20.) let dB_of_lin x = 20. *. log x /. log 10. (** Fractional part of a float. *) let fracf x = if x < 1. then x else if x < 2. then x -. 1. else fst (modf x) let samples_of_seconds sr t = int_of_float (float sr *. t) let seconds_of_samples sr n = float n /. float sr module Note = struct (* A4 = 69 *) type t = int let a4 = 69 let c5 = 72 let c0 = 12 let create name oct = name + (12 * (oct + 1)) let freq n = 440. *. (2. ** ((float n -. 69.) /. 12.)) let of_freq f = int_of_float (0.5 +. ((12. *. log (f /. 440.) /. log 2.) +. 69.)) let name n = n mod 12 let octave n = (n / 12) - 1 let modulo n = (name n, octave n) let to_string n = let n, o = modulo n in (match n with | 0 -> "A" | 1 -> "A#" | 2 -> "B" | 3 -> "C" | 4 -> "C#" | 5 -> "D" | 6 -> "D#" | 7 -> "E" | 8 -> "F" | 9 -> "F#" | 10 -> "G" | 11 -> "G#" | _ -> assert false) ^ " " ^ string_of_int o (* TODO: sharps and flats *) let of_string s = assert (String.length s >= 2); let note = String.sub s 0 (String.length s - 1) in let oct = int_of_char s.[String.length s - 1] - int_of_char '0' in let off = match note with | "a" | "A" -> 0 | "b" | "B" -> 2 | "c" | "C" -> 3 | "d" | "D" -> 5 | "e" | "E" -> 7 | "f" | "F" -> 8 | "g" | "G" -> 10 | _ -> raise Not_found in 64 + (12 * (oct - 4)) + off end module Sample = struct type t = float let clip x = let x = max (-1.) x in let x = min 1. x in x end module Mono = struct type t = (float, Bigarray.float32_elt, Bigarray.c_layout) Bigarray.Array1.t type buffer = t let create n : t = Bigarray.Array1.create Bigarray.float32 Bigarray.c_layout n let length (buf : t) = Bigarray.Array1.dim buf let buffer_length = length let clear (b : t) = Bigarray.Array1.fill b 0. let make n x = let buf = create n in Bigarray.Array1.fill buf x; buf let unsafe_get (buf : t) = Bigarray.Array1.unsafe_get buf let unsafe_set (buf : t) = Bigarray.Array1.unsafe_set buf let of_array a = let len = Array.length a in let buf = create len in for i = 0 to len - 1 do unsafe_set buf i a.(i) done; buf let to_array buf = Array.init (length buf) (fun i -> unsafe_get buf i) let sub buf off len = Bigarray.Array1.sub buf off len let blit src dst = Bigarray.Array1.blit src dst let copy buf = let len = length buf in let ans = create len in blit buf ans; ans let append b1 b2 = let l1 = length b1 in let l2 = length b2 in let ans = create (l1 + l2) in blit b1 (sub ans 0 l1); blit b2 (sub ans l1 l2); ans (* TODO: implement the following functions on the C side *) let add b1 b2 = let len = length b1 in assert (length b2 = len); for i = 0 to len - 1 do unsafe_set b1 i (unsafe_get b1 i +. unsafe_get b2 i) done let add_coeff b1 k b2 = let len = length b1 in assert (length b2 = len); for i = 0 to len - 1 do b1.{i} <- b1.{i} +. (k *. b2.{i}) done let add_coeff b1 k b2 = if k = 0. then () else if k = 1. then add b1 b2 else add_coeff b1 k b2 let mult b1 b2 = let len = length b1 in assert (length b2 = len); for i = 0 to len - 1 do b1.{i} <- b1.{i} *. b2.{i} done let amplify k b = for i = 0 to length b - 1 do unsafe_set b i (k *. unsafe_get b i) done let clip buf = for i = 0 to length buf - 1 do buf.{i} <- Sample.clip buf.{i} done let noise buf = for i = 0 to length buf - 1 do buf.{i} <- Random.float 2. -. 1. done let resample ?(mode = `Linear) ratio inbuf = let len = length inbuf in if ratio = 1. then ( let outbuf = create len in Bigarray.Array1.blit inbuf outbuf; outbuf) else if mode = `Nearest then ( let outlen = int_of_float ((float len *. ratio) +. 0.5) in let outbuf = create outlen in for i = 0 to outlen - 1 do let pos = min (int_of_float ((float i /. ratio) +. 0.5)) (len - 1) in Bigarray.Array1.unsafe_set outbuf i (Bigarray.Array1.unsafe_get inbuf pos) done; outbuf) else ( let outlen = int_of_float (float len *. ratio) in let outbuf = create outlen in for i = 0 to outlen - 1 do let ir = float i /. ratio in let pos = min (int_of_float ir) (len - 1) in if pos = len - 1 then Bigarray.Array1.unsafe_set outbuf i (Bigarray.Array1.unsafe_get inbuf pos) else ( let a = ir -. float pos in outbuf.{i} <- (inbuf.{pos} *. (1. -. a)) +. (inbuf.{pos + 1} *. a)) done; outbuf) module B = struct type t = buffer let create = create let blit src soff dst doff len = blit (sub src soff len) (sub dst doff len) end module Ringbuffer_ext = Ringbuffer.Make_ext (B) module Ringbuffer = Ringbuffer.Make (B) (* TODO: refined allocation/deallocation policies *) module Buffer_ext = struct type t = { mutable buffer : buffer } let prepare buf len = if length buf.buffer >= len then sub buf.buffer 0 len else ( (* TODO: optionally blit the old buffer onto the new one. *) (* let oldbuf = buf.buffer in *) let newbuf = create len in buf.buffer <- newbuf; newbuf) let create len = { buffer = create len } let length buf = length buf.buffer end module Analyze = struct let rms buf = let len = length buf in let r = ref 0. in for i = 0 to len - 1 do let x = buf.{i} in r := !r +. (x *. x) done; sqrt (!r /. float len) module FFT = struct type t = { b : int; (* number of bits *) n : int; (* number of samples *) circle : Complex.t array; temp : Complex.t array; } let init b = let n = 1 lsl b in let h = n / 2 in let fh = float h in let circle = Array.make h Complex.zero in for i = 0 to h - 1 do let theta = pi *. float_of_int i /. fh in circle.(i) <- { Complex.re = cos theta; Complex.im = sin theta } done; { b; n; circle; temp = Array.make n Complex.zero } let length f = f.n let complex_create buf = Array.init (buffer_length buf) (fun i -> { Complex.re = buf.{i}; Complex.im = 0. }) let ccoef k c = { Complex.re = k *. c.Complex.re; Complex.im = k *. c.Complex.im } let fft f d = (* TODO: greater should be ok too? *) assert (Array.length d = f.n); let ( +~ ) = Complex.add in let ( -~ ) = Complex.sub in let ( *~ ) = Complex.mul in let rec fft t (* temporary buffer *) d (* data *) s (* stride in the data array *) n (* number of samples *) = if n > 1 then ( let h = n / 2 in for i = 0 to h - 1 do t.(s + i) <- d.(s + (2 * i)); (* even *) t.(s + h + i) <- d.(s + (2 * i) + 1) (* odd *) done; fft d t s h; fft d t (s + h) h; let a = f.n / n in for i = 0 to h - 1 do let wkt = f.circle.(i * a) *~ t.(s + h + i) in d.(s + i) <- t.(s + i) +~ wkt; d.(s + h + i) <- t.(s + i) -~ wkt done) in fft f.temp d 0 f.n (* See http://en.wikipedia.org/wiki/Window_function *) module Window = struct let iter f d = let len = Array.length d in let n = float len in for i = 0 to len - 1 do let k = f (float i) n in d.(i) <- ccoef k d.(i) done let hann d = iter (fun i n -> 0.5 *. (1. -. cos (2. *. pi *. i /. n))) d let hamming d = iter (fun i n -> 0.54 *. (0.46 *. cos (2. *. pi *. i /. n))) d let cosine d = iter (fun i n -> sin (pi *. i /. n)) d let lanczos d = let sinc x = let px = pi *. x in sin px /. px in iter (fun i n -> sinc (2. *. i /. n)) d let triangular d = iter (fun i n -> if i <= n /. 2. then 2. *. i /. n else ((n /. 2.) -. i) *. 2. /. n) d let bartlett_hann d = let a0 = 0.62 in let a1 = 0.48 in let a2 = 0.38 in iter (fun i n -> a0 -. (a1 *. abs_float ((i /. n) -. 0.5)) -. (a2 *. cos (2. *. pi *. i /. n))) d let blackman ?(alpha = 0.16) d = let a = alpha in let a0 = (1. -. a) /. 2. in let a1 = 1. /. 2. in let a2 = a /. 2. in iter (fun i n -> a0 -. (a1 *. cos (2. *. pi *. i /. n)) +. (a2 *. cos (4. *. pi *. i /. n))) d (* TODO: use circle to compute cosines *) let low_res a0 a1 a2 a3 d = iter (fun i n -> a0 -. (a1 *. cos (2. *. pi *. i /. n)) +. (a2 *. cos (4. *. pi *. i /. n)) -. (a3 *. cos (6. *. pi *. i /. n))) d let nuttall d = low_res 0.355768 0.487396 0.144232 0.012604 d let blackman_harris d = low_res 0.35875 0.48829 0.14128 0.01168 d let blackman_nuttall d = low_res 0.3635819 0.4891775 0.1365995 0.0106411 d end let band_freq sr f k = float k *. float sr /. float f.n let notes sr f ?(note_min = Note.c0) ?(note_max = 128) ?(volume_min = 0.01) ?(filter_harmonics = true) buf = let len = buffer_length buf in assert (len = length f); let bdur = float len /. float sr in let fdf = float (length f) in let c = complex_create buf in fft f c; let ans = ref [] in let kstart = max 0 (int_of_float (Note.freq note_min *. bdur)) in let kend = min (len / 2) (int_of_float (Note.freq note_max *. bdur)) in for k = kstart + 1 to kend - 2 do (* Quadratic interpolation. *) let v' = Complex.norm c.(k - 1) in let v = Complex.norm c.(k) in let v'' = Complex.norm c.(k - 1) in (* Do we have a maximum here? *) if v' +. v'' < 2. *. v then ( let p = (v'' -. v') /. ((2. *. v') -. (2. *. v) +. v'') in let v = v -. ((v' -. v'') *. p /. 4.) in let v = v /. fdf in let p = p +. float k in if v >= volume_min then ans := (p, v) :: !ans) done; let ans = List.map (fun (k, v) -> (Note.of_freq (k /. bdur), v)) !ans in (* TODO: improve this filtering... *) let ans = if filter_harmonics then list_filter_ctxt (fun b (n, _) t -> let o = Note.octave n in let n = Note.name n in List.for_all (fun (n', _) -> Note.name n' <> n || Note.octave n' >= o) (b @ t)) ans else ans in ans let loudest_note l = match l with | [] -> None | h :: t -> Some (List.fold_left (fun (nmax, vmax) (n, v) -> if v > vmax then (n, v) else (nmax, vmax)) h t) end end module Effect = struct let compand_mu_law mu buf = for i = 0 to length buf - 1 do let bufi = buf.{i} in let sign = if bufi < 0. then -1. else 1. in buf.{i} <- sign *. log (1. +. (mu *. abs_float bufi)) /. log (1. +. mu) done class type t = object method process : buffer -> unit end class amplify k : t = object method process = amplify k end class clip c : t = object method process buf = for i = 0 to length buf - 1 do unsafe_set buf i (max (-.c) (min c (unsafe_get buf i))) done end (* Digital filter based on "Cookbook formulae for audio EQ biquad filter coefficients" by Robert Bristow-Johnson . URL: http://www.musicdsp.org/files/Audio-EQ-Cookbook.txt *) class biquad_filter samplerate (kind : [ `Low_pass | `High_pass | `Band_pass | `Notch | `All_pass | `Peaking | `Low_shelf | `High_shelf ]) ?(gain = 0.) freq q = let samplerate = float samplerate in object (self) val mutable p0 = 0. val mutable p1 = 0. val mutable p2 = 0. val mutable q1 = 0. val mutable q2 = 0. method private init = let w0 = 2. *. pi *. freq /. samplerate in let cos_w0 = cos w0 in let sin_w0 = sin w0 in let alpha = sin w0 /. (2. *. q) in let a = if gain = 0. then 1. else 10. ** (gain /. 40.) in let b0, b1, b2, a0, a1, a2 = match kind with | `Low_pass -> let b1 = 1. -. cos_w0 in let b0 = b1 /. 2. in (b0, b1, b0, 1. +. alpha, -2. *. cos_w0, 1. -. alpha) | `High_pass -> let b1 = 1. +. cos_w0 in let b0 = b1 /. 2. in let b1 = -.b1 in (b0, b1, b0, 1. +. alpha, -2. *. cos_w0, 1. -. alpha) | `Band_pass -> let b0 = sin_w0 /. 2. in (b0, 0., -.b0, 1. +. alpha, -2. *. cos_w0, 1. -. alpha) | `Notch -> let b1 = -2. *. cos_w0 in (1., b1, 1., 1. +. alpha, b1, 1. -. alpha) | `All_pass -> let b0 = 1. -. alpha in let b1 = -2. *. cos_w0 in let b2 = 1. +. alpha in (b0, b1, b2, b2, b1, b0) | `Peaking -> let ama = alpha *. a in let ada = alpha /. a in let b1 = -2. *. cos_w0 in (1. +. ama, b1, 1. -. ama, 1. +. ada, b1, 1. -. ada) | `Low_shelf -> let s = 2. *. sqrt a *. alpha in ( a *. (a +. 1. -. ((a -. 1.) *. cos_w0) +. s), 2. *. a *. (a -. 1. -. ((a +. 1.) *. cos_w0)), a *. (a +. 1. -. ((a -. 1.) *. cos_w0) -. s), a +. 1. +. ((a -. 1.) *. cos_w0) +. s, (-2. *. (a -. 1.)) +. ((a +. 1.) *. cos_w0), a +. 1. +. ((a -. 1.) *. cos_w0) -. s ) | `High_shelf -> let s = 2. *. sqrt a *. alpha in ( a *. (a +. 1. +. ((a -. 1.) *. cos_w0) +. s), -2. *. a *. (a -. 1. +. ((a +. 1.) *. cos_w0)), a *. (a +. 1. +. ((a -. 1.) *. cos_w0) -. s), a +. 1. -. ((a -. 1.) *. cos_w0) +. s, (2. *. (a -. 1.)) -. ((a +. 1.) *. cos_w0), a +. 1. -. ((a -. 1.) *. cos_w0) -. s ) in p0 <- b0 /. a0; p1 <- b1 /. a0; p2 <- b2 /. a0; q1 <- a1 /. a0; q2 <- a2 /. a0 initializer self#init val mutable x1 = 0. val mutable x2 = 0. val mutable y0 = 0. val mutable y1 = 0. val mutable y2 = 0. method process (buf : buffer) = for i = 0 to length buf - 1 do let x0 = buf.{i} in let y0 = (p0 *. x0) +. (p1 *. x1) +. (p2 *. x2) -. (q1 *. y1) -. (q2 *. y2) in buf.{i} <- y0; x2 <- x1; x1 <- x0; y2 <- y1; y1 <- y0 done end module ADSR = struct type t = int * int * float * int (** Convert adsr in seconds to samples. *) let make sr (a, d, s, r) = ( samples_of_seconds sr a, samples_of_seconds sr d, s, samples_of_seconds sr r ) (** State in the ADSR enveloppe (A/D/S/R/dead + position in the state). *) type state = int * int let init () = (0, 0) let release (_, p) = (3, p) let dead (s, _) = s = 4 let rec process adsr st (buf : buffer) = let a, (d : int), s, (r : int) = adsr in let state, state_pos = st in let len = length buf in match state with | 0 -> let fa = float a in for i = 0 to min len (a - state_pos) - 1 do buf.{i} <- float (state_pos + i) /. fa *. buf.{i} done; if len < a - state_pos then (0, state_pos + len) else process adsr (1, 0) (sub buf (a - state_pos) (len - (a - state_pos))) | 1 -> let fd = float d in for i = 0 to min len (d - state_pos) - 1 do buf.{i} <- (1. -. (float (state_pos + i) /. fd *. (1. -. s))) *. buf.{i} done; if len < d - state_pos then (1, state_pos + len) else if (* Negative sustain means release immediately. *) s >= 0. then process adsr (2, 0) (sub buf (d - state_pos) (len - (d - state_pos))) else process adsr (3, 0) (sub buf (d - state_pos) (len - (d - state_pos))) | 2 -> amplify s buf; st | 3 -> let fr = float r in for i = 0 to min len (r - state_pos) - 1 do buf.{i} <- s *. (1. -. (float (state_pos + i) /. fr)) *. buf.{i} done; if len < r - state_pos then (3, state_pos + len) else process adsr (4, 0) (sub buf (r - state_pos) (len - (r - state_pos))) | 4 -> clear buf; st | _ -> assert false end end module Generator = struct let white_noise buf = noise buf class type t = object method set_volume : float -> unit method set_frequency : float -> unit method fill : buffer -> unit method fill_add : buffer -> unit method release : unit method dead : bool end class virtual base sample_rate ?(volume = 1.) freq = object (self) val mutable vol = volume val mutable freq : float = freq val mutable dead = false method dead = dead method release = vol <- 0.; dead <- true method private sample_rate : int = sample_rate method private volume : float = vol method set_volume v = vol <- v method set_frequency f = freq <- f method virtual fill : buffer -> unit (* TODO: might be optimized by various synths *) method fill_add (buf : buffer) = let tmp = create (length buf) in self#fill tmp; add buf tmp end class white_noise ?volume sr = object (self) inherit base sr ?volume 0. method fill buf = let volume = self#volume in for i = 0 to length buf - 1 do buf.{i} <- volume *. (Random.float 2. -. 1.) done end class sine sr ?volume ?(phase = 0.) freq = object (self) inherit base sr ?volume freq val mutable phase = phase method fill buf = let len = length buf in let sr = float self#sample_rate in let omega = 2. *. pi *. freq /. sr in let volume = self#volume in for i = 0 to len - 1 do buf.{i} <- volume *. sin ((float i *. omega) +. phase) done; phase <- mod_float (phase +. (float len *. omega)) (2. *. pi) end class square sr ?volume ?(phase = 0.) freq = object (self) inherit base sr ?volume freq val mutable phase = phase method fill buf = let len = length buf in let sr = float self#sample_rate in let volume = self#volume in let omega = freq /. sr in for i = 0 to len - 1 do let t = fracf ((float i *. omega) +. phase) in buf.{i} <- (if t < 0.5 then volume else -.volume) done; phase <- mod_float (phase +. (float len *. omega)) 1. end class saw sr ?volume ?(phase = 0.) freq = object (self) inherit base sr ?volume freq val mutable phase = phase method fill buf = let len = length buf in let volume = self#volume in let sr = float self#sample_rate in let omega = freq /. sr in for i = 0 to len - 1 do let t = fracf ((float i *. omega) +. phase) in buf.{i} <- volume *. ((2. *. t) -. 1.) done; phase <- mod_float (phase +. (float len *. omega)) 1. end class triangle sr ?volume ?(phase = 0.) freq = object (self) inherit base sr ?volume freq val mutable phase = phase method fill buf = let len = length buf in let sr = float self#sample_rate in let volume = self#volume in let omega = freq /. sr in for i = 0 to len - 1 do let t = fracf ((float i *. omega) +. phase +. 0.25) in buf.{i} <- (volume *. if t < 0.5 then (4. *. t) -. 1. else (4. *. (1. -. t)) -. 1.) done; phase <- mod_float (phase +. (float len *. omega)) 1. end class chain (g : t) (e : Effect.t) : t = object method fill buf = g#fill buf; e#process buf val tmpbuf = Buffer_ext.create 0 method fill_add (buf : buffer) = let tmpbuf = Buffer_ext.prepare tmpbuf (length buf) in g#fill tmpbuf; add buf tmpbuf method set_volume = g#set_volume method set_frequency = g#set_frequency method release = g#release method dead = g#dead end class combine f (g1 : t) (g2 : t) : t = object val tmpbuf = Buffer_ext.create 0 val tmpbuf2 = Buffer_ext.create 0 method fill buf = g1#fill buf; let tmpbuf = Buffer_ext.prepare tmpbuf (length buf) in g2#fill tmpbuf; f buf tmpbuf method fill_add buf = let len = length buf in let tmpbuf = Buffer_ext.prepare tmpbuf len in g1#fill tmpbuf; let tmpbuf2 = Buffer_ext.prepare tmpbuf2 len in g2#fill tmpbuf2; f tmpbuf tmpbuf2; add buf tmpbuf method set_volume v = g1#set_volume v; g2#set_volume v method set_frequency v = g1#set_frequency v; g2#set_frequency v method release = g1#release; g2#release method dead = g1#dead && g2#dead end class add g1 g2 = object inherit combine add g1 g2 end class mult g1 g2 = object inherit combine mult g1 g2 end class adsr (adsr : Effect.ADSR.t) (g : t) = object (self) val mutable adsr_st = Effect.ADSR.init () val tmpbuf = Buffer_ext.create 0 method set_volume = g#set_volume method set_frequency = g#set_frequency method fill buf = g#fill buf; adsr_st <- Effect.ADSR.process adsr adsr_st buf method fill_add buf = let len = length buf in let tmpbuf = Buffer_ext.prepare tmpbuf len in self#fill tmpbuf; blit tmpbuf buf method release = adsr_st <- Effect.ADSR.release adsr_st; g#release method dead = Effect.ADSR.dead adsr_st || g#dead end end end (** An audio buffer. *) type t = Mono.buffer array type buffer = t (** Iterate a function on each channel of the buffer. *) let iter f b = Array.iter f b let iter2 f b1 b2 = for c = 0 to Array.length b1 - 1 do f b1.(c) b2.(c) done let map f b = Array.map f b let create chans n = Array.init chans (fun _ -> Mono.create n) let make chans n x = Array.init chans (fun _ -> Mono.make n x) let of_array a = Array.map Mono.of_array a let to_array a = Array.map Mono.to_array a let channels buf = Array.length buf let length buf = Mono.length buf.(0) let buffer_length = length let same_length buf = let len = length buf in let ans = ref true in for c = 0 to channels buf - 1 do if Mono.length buf.(c) <> len then ans := false done; !ans let create_same buf = create (channels buf) (length buf) (* TODO: in C *) let interleave buf = assert (same_length buf); let chans = channels buf in let len = length buf in let ibuf = Bigarray.Array1.create Bigarray.float32 Bigarray.c_layout (chans * len) in for c = 0 to chans - 1 do let bufc = buf.(c) in for i = 0 to len - 1 do Bigarray.Array1.unsafe_set ibuf ((chans * i) + c) (Mono.unsafe_get bufc i) done done; ibuf (* TODO: in C *) let deinterleave chans ibuf = let len = Bigarray.Array1.dim ibuf / chans in let buf = Array.init chans (fun _ -> Mono.create len) in for c = 0 to chans - 1 do let bufc = buf.(c) in for i = 0 to len - 1 do Bigarray.Array1.unsafe_set bufc i (Bigarray.Array1.unsafe_get ibuf ((chans * i) + c)) done done; buf let append b1 b2 = Array.mapi (fun i b1 -> Mono.append b1 b2.(i)) b1 let clear = iter Mono.clear let clip = iter Mono.clip let noise = iter Mono.noise let copy b = Array.init (Array.length b) (fun i -> Mono.copy b.(i)) let blit b1 b2 = iter2 (fun b1 b2 -> Mono.blit b1 b2) b1 b2 let sub b ofs len = Array.map (fun buf -> Bigarray.Array1.sub buf ofs len) b let to_mono b = let channels = channels b in if channels = 1 then b.(0) else ( let len = length b in let chans = float channels in let ans = Mono.create len in Mono.clear ans; for i = 0 to len - 1 do for c = 0 to channels - 1 do ans.{i} <- ans.{i} +. b.(c).{i} done; ans.{i} <- ans.{i} /. chans done; ans) let of_mono b = [| b |] let resample ?mode ratio buf = map (fun buf -> Mono.resample ?mode ratio buf) buf module U8 = struct let size channels samples = channels * samples external of_audio : buffer -> Bytes.t -> int -> unit = "caml_float_pcm_to_u8" external to_audio : string -> int -> buffer -> unit = "caml_float_pcm_of_u8" end module S16LE = struct let size channels samples = channels * samples * 2 let length channels len = len / (2 * channels) external of_audio : bool -> buffer -> Bytes.t -> int -> unit = "caml_float_pcm_to_s16" let of_audio = of_audio true let make buf = let len = buffer_length buf in let slen = size (channels buf) len in let sbuf = Bytes.create slen in of_audio buf sbuf 0; Bytes.unsafe_to_string sbuf external to_audio : bool -> string -> int -> buffer -> unit = "caml_float_pcm_convert_s16" let to_audio = to_audio true end module S16BE = struct let size channels samples = channels * samples * 2 let length channels len = len / (2 * channels) external of_audio : bool -> buffer -> Bytes.t -> int -> unit = "caml_float_pcm_to_s16" let of_audio = of_audio false let make buf = let len = buffer_length buf in let slen = size (channels buf) len in let sbuf = Bytes.create slen in of_audio buf sbuf 0; Bytes.unsafe_to_string sbuf external to_audio : bool -> string -> int -> buffer -> unit = "caml_float_pcm_convert_s16" let to_audio = to_audio false end module S24LE = struct let size channels samples = channels * samples * 3 external of_audio : buffer -> Bytes.t -> int -> unit = "caml_float_pcm_to_s24le" external to_audio : string -> int -> buffer -> unit = "caml_float_pcm_convert_s24le" end module S32LE = struct let size channels samples = channels * samples * 4 external of_audio : buffer -> Bytes.t -> int -> unit = "caml_float_pcm_to_s32le" external to_audio : string -> int -> buffer -> unit = "caml_float_pcm_convert_s32le" end let add b1 b2 = iter2 Mono.add b1 b2 let add_coeff b1 k b2 = iter2 (fun b1 b2 -> Mono.add_coeff b1 k b2) b1 b2 let amplify k buf = if k <> 1. then iter (fun buf -> Mono.amplify k buf) buf (* x between -1 and 1 *) let pan x buf = if x > 0. then ( let x = 1. -. x in Mono.amplify x buf.(0)) else if x < 0. then ( let x = 1. +. x in Mono.amplify x buf.(1)) (* TODO: we cannot share this with mono, right? *) module Buffer_ext = struct type t = { mutable buffer : buffer } let chans = channels let prepare buf ?channels len = match channels with | Some channels when chans buf.buffer <> channels -> let newbuf = create channels len in buf.buffer <- newbuf; newbuf | _ -> if length buf.buffer >= len then sub buf.buffer 0 len else ( (* TODO: optionally blit the old buffer onto the new one. *) let oldbuf = buf.buffer in let newbuf = create (chans oldbuf) len in buf.buffer <- newbuf; newbuf) let length buf = length buf.buffer let create chans len = { buffer = create chans len } end (* TODO: share code with ringbuffer module! *) module Ringbuffer = struct type t = { size : int; buffer : buffer; mutable rpos : int; (** current read position *) mutable wpos : int; (** current write position *) } let create chans size = { (* size + 1 so we can store full buffers, while keeping rpos and wpos different for implementation matters *) size = size + 1; buffer = create chans (size + 1); rpos = 0; wpos = 0; } let channels t = channels t.buffer let read_space t = if t.wpos >= t.rpos then t.wpos - t.rpos else t.size - (t.rpos - t.wpos) let write_space t = if t.wpos >= t.rpos then t.size - (t.wpos - t.rpos) - 1 else t.rpos - t.wpos - 1 let read_advance t n = assert (n <= read_space t); if t.rpos + n < t.size then t.rpos <- t.rpos + n else t.rpos <- t.rpos + n - t.size let write_advance t n = assert (n <= write_space t); if t.wpos + n < t.size then t.wpos <- t.wpos + n else t.wpos <- t.wpos + n - t.size let peek t buf = let len = length buf in assert (len <= read_space t); let pre = t.size - t.rpos in let extra = len - pre in if extra > 0 then ( blit (sub t.buffer t.rpos pre) (sub buf 0 pre); blit (sub t.buffer 0 extra) (sub buf pre extra)) else blit (sub t.buffer t.rpos len) buf let read t buf = peek t buf; read_advance t (length buf) let write t buf = let len = length buf in assert (len <= write_space t); let pre = t.size - t.wpos in let extra = len - pre in if extra > 0 then ( blit (sub buf 0 pre) (sub t.buffer t.wpos pre); blit (sub buf pre extra) (sub t.buffer 0 extra)) else blit buf (sub t.buffer t.wpos len); write_advance t len let transmit t f = if t.wpos = t.rpos then 0 else ( let len0 = if t.wpos >= t.rpos then t.wpos - t.rpos else t.size - t.rpos in let len = f (sub t.buffer t.rpos len0) in assert (len <= len0); read_advance t len; len) end module Ringbuffer_ext = struct type t = { mutable ringbuffer : Ringbuffer.t } let prepare buf len = if Ringbuffer.write_space buf.ringbuffer >= len then buf.ringbuffer else ( let rb = Ringbuffer.create (Ringbuffer.channels buf.ringbuffer) (Ringbuffer.read_space buf.ringbuffer + len) in while Ringbuffer.read_space buf.ringbuffer <> 0 do ignore (Ringbuffer.transmit buf.ringbuffer (fun buf -> Ringbuffer.write rb buf; length buf)) done; buf.ringbuffer <- rb; rb) let channels rb = Ringbuffer.channels rb.ringbuffer let peek rb = Ringbuffer.peek rb.ringbuffer let read rb = Ringbuffer.read rb.ringbuffer let write rb buf = let rb = prepare rb (length buf) in Ringbuffer.write rb buf let transmit rb = Ringbuffer.transmit rb.ringbuffer let read_space rb = Ringbuffer.read_space rb.ringbuffer let write_space rb = Ringbuffer.write_space rb.ringbuffer let read_advance rb = Ringbuffer.read_advance rb.ringbuffer let write_advance rb = Ringbuffer.write_advance rb.ringbuffer let create chans len = { ringbuffer = Ringbuffer.create chans len } end module Analyze = struct let rms buf = Array.init (channels buf) (fun i -> Mono.Analyze.rms buf.(i)) end module Effect = struct class type t = object method process : buffer -> unit end class chain (e1 : t) (e2 : t) = object method process buf = e1#process buf; e2#process buf end class of_mono chans (g : unit -> Mono.Effect.t) = object val g = Array.init chans (fun _ -> g ()) method process buf = for c = 0 to chans - 1 do g.(c)#process buf.(c) done end class biquad_filter chans samplerate kind ?gain freq q = of_mono chans (fun () -> (new Mono.Effect.biquad_filter samplerate kind ?gain freq q :> Mono.Effect.t)) class type delay_t = object inherit t method set_delay : float -> unit method set_feedback : float -> unit end class delay_only chans sample_rate delay = let delay = int_of_float (float sample_rate *. delay) in object val mutable delay = delay method set_delay d = delay <- int_of_float (float sample_rate *. d) val rb = Ringbuffer_ext.create chans 0 initializer Ringbuffer_ext.write rb (create chans delay) method process buf = Ringbuffer_ext.write rb buf; Ringbuffer_ext.read rb buf end class delay chans sample_rate delay once feedback = let delay = int_of_float (float sample_rate *. delay) in object val mutable delay = delay method set_delay d = delay <- int_of_float (float sample_rate *. d) val mutable feedback = feedback method set_feedback f = feedback <- f val rb = Ringbuffer_ext.create chans 0 val tmpbuf = Buffer_ext.create chans 0 method process buf = if once then Ringbuffer_ext.write rb buf; (* Make sure that we have a past of exactly d samples. *) if Ringbuffer_ext.read_space rb < delay then Ringbuffer_ext.write rb (create chans delay); if Ringbuffer_ext.read_space rb > delay then Ringbuffer_ext.read_advance rb (Ringbuffer_ext.read_space rb - delay); let len = length buf in if len > delay then add_coeff (sub buf delay (len - delay)) feedback (sub buf 0 (len - delay)); let rlen = min delay len in let tmpbuf = Buffer_ext.prepare tmpbuf rlen in Ringbuffer_ext.read rb (sub tmpbuf 0 rlen); add_coeff (sub buf 0 rlen) feedback (sub tmpbuf 0 rlen); if not once then Ringbuffer_ext.write rb buf end class delay_ping_pong chans sample_rate delay once feedback = let r1 = new delay_only 1 sample_rate delay in let d1 = new delay 1 sample_rate (2. *. delay) once feedback in let d1' = new chain (r1 :> t) (d1 :> t) in let d2 = new delay 1 sample_rate (2. *. delay) once feedback in object initializer assert (chans = 2) method set_delay d = r1#set_delay d; d1#set_delay (2. *. d); d2#set_delay (2. *. d) method set_feedback f = d1#set_feedback f; d2#set_feedback f method process buf = assert (channels buf = 2); (* Add original on channel 0. *) d1'#process [| buf.(0) |]; d2#process [| buf.(1) |] end let delay chans sample_rate d ?(once = false) ?(ping_pong = false) feedback = if ping_pong then new delay_ping_pong chans sample_rate d once feedback else new delay chans sample_rate d once feedback (* See http://www.musicdsp.org/archive.php?classid=4#169 *) (* times in sec, ratios in dB, gain linear *) class compress ?(attack = 0.1) ?(release = 0.1) ?(threshold = -10.) ?(ratio = 3.) ?(knee = 1.) ?(rms_window = 0.1) ?(gain = 1.) chans samplerate = (* Number of samples for computing rms. *) let rmsn = samples_of_seconds samplerate rms_window in let samplerate = float samplerate in object val mutable attack = attack method set_attack a = attack <- a val mutable release = release method set_release r = release <- r val mutable threshold = threshold method set_threshold t = threshold <- t val mutable ratio = ratio method set_ratio r = ratio <- r val mutable knee = knee method set_knee k = knee <- k val mutable gain = gain method set_gain g = gain <- g (* [rmsn] last squares. *) val rmsv = Array.make rmsn 0. (* Current position in [rmsv]. *) val mutable rmsp = 0 (* Current squares of RMS. *) val mutable rms = 0. (* Processing variables. *) val mutable amp = 0. (* Envelope. *) val mutable env = 0. (* Current gain. *) val mutable g = 1. method process (buf : buffer) = let ratio = (ratio -. 1.) /. ratio in (* Attack and release "per sample decay". *) let g_attack = if attack = 0. then 0. else exp (-1. /. (samplerate *. attack)) in let ef_a = g_attack *. 0.25 in let g_release = if release = 0. then 0. else exp (-1. /. (samplerate *. release)) in let ef_ai = 1. -. ef_a in (* Knees. *) let knee_min = lin_of_dB (threshold -. knee) in let knee_max = lin_of_dB (threshold +. knee) in for i = 0 to length buf - 1 do (* Input level. *) let lev_in = let ans = ref 0. in for c = 0 to chans - 1 do let x = buf.(c).{i} *. gain in ans := !ans +. (x *. x) done; !ans /. float chans in (* RMS *) rms <- rms -. rmsv.(rmsp) +. lev_in; rms <- abs_float rms; (* Sometimes the rms was -0., avoid that. *) rmsv.(rmsp) <- lev_in; rmsp <- (rmsp + 1) mod rmsn; amp <- sqrt (rms /. float rmsn); (* Dynamic selection: attack or release? *) (* Smoothing with capacitor, envelope extraction... Here be aware of * pIV denormal numbers glitch. *) if amp > env then env <- (env *. g_attack) +. (amp *. (1. -. g_attack)) else env <- (env *. g_release) +. (amp *. (1. -. g_release)); (* Compute the gain. *) let gain_t = if env < knee_min then (* Do not compress. *) 1. else if env < knee_max then ( (* Knee: compress smoothly. *) let x = (knee +. dB_of_lin env -. threshold) /. (2. *. knee) in lin_of_dB (0. -. (knee *. ratio *. x *. x))) else (* Maximal (n:1) compression. *) lin_of_dB ((threshold -. dB_of_lin env) *. ratio) in g <- (g *. ef_a) +. (gain_t *. ef_ai); (* Apply the gain. *) let g = g *. gain in for c = 0 to chans - 1 do buf.(c).{i} <- buf.(c).{i} *. g done (* (* Debug messages. *) count <- count + 1; if count mod 10000 = 0 then self#log#f 4 "RMS:%7.02f Env:%7.02f Gain: %4.02f\r%!" (Audio.dB_of_lin amp) (Audio.dB_of_lin env) gain *) done method reset = rms <- 0.; rmsp <- 0; for i = 0 to rmsn - 1 do rmsv.(i) <- 0. done; g <- 1.; env <- 0.; amp <- 0. end class auto_gain_control channels samplerate rmst (* target RMS *) rms_len (* duration of the RMS collection in seconds *) kup (* speed when volume is going up in coeff per sec *) kdown (* speed when volume is going down *) rms_threshold (* RMS threshold under which the volume should not be changed *) vol_init (* initial volume *) vol_min (* minimal gain *) vol_max (* maximal gain *) = let rms_len = samples_of_seconds samplerate rms_len in let rms_lenf = float rms_len in (* TODO: is this the right conversion? *) let kup = kup ** seconds_of_samples samplerate rms_len in let kdown = kdown ** seconds_of_samples samplerate rms_len in object (** Square of the currently computed rms. *) val mutable rms = Array.make channels 0. (** Number of samples collected so far. *) val mutable rms_collected = 0 (** Current volume. *) val mutable vol = vol_init (** Previous value of volume. *) val mutable vol_old = vol_init (** Is it enabled? (disabled if below the threshold) *) val mutable enabled = true method process (buf : buffer) = for c = 0 to channels - 1 do let bufc = buf.(c) in for i = 0 to length buf - 1 do let bufci = bufc.{i} in if rms_collected >= rms_len then ( let rms_cur = let ans = ref 0. in for c = 0 to channels - 1 do ans := !ans +. rms.(c) done; sqrt (!ans /. float channels) in rms <- Array.make channels 0.; rms_collected <- 0; enabled <- rms_cur >= rms_threshold; if enabled then ( let vol_opt = rmst /. rms_cur in vol_old <- vol; if rms_cur < rmst then vol <- vol +. (kup *. (vol_opt -. vol)) else vol <- vol +. (kdown *. (vol_opt -. vol)); vol <- max vol_min vol; vol <- min vol_max vol)); rms.(c) <- rms.(c) +. (bufci *. bufci); rms_collected <- rms_collected + 1; (* Affine transition between vol_old and vol. *) bufc.{i} <- (vol_old +. (float rms_collected /. rms_lenf *. (vol -. vol_old))) *. bufci done done end (* TODO: check default parameters. *) let auto_gain_control channels samplerate ?(rms_target = 1.) ?(rms_window = 0.2) ?(kup = 0.6) ?(kdown = 0.8) ?(rms_threshold = 0.01) ?(volume_init = 1.) ?(volume_min = 0.1) ?(volume_max = 10.) () = new auto_gain_control channels samplerate rms_target rms_window kup kdown rms_threshold volume_init volume_min volume_max (* module ADSR = struct type t = Mono.Effect.ADSR.t type state = Mono.Effect.ADSR.state end *) end module Generator = struct let white_noise buf = for c = 0 to channels buf - 1 do Mono.Generator.white_noise buf.(c) done class type t = object method set_volume : float -> unit method set_frequency : float -> unit method release : unit method dead : bool method fill : buffer -> unit method fill_add : buffer -> unit end class of_mono (g : Mono.Generator.t) = object val tmpbuf = Mono.Buffer_ext.create 0 method set_volume = g#set_volume method set_frequency = g#set_frequency method fill buf = g#fill buf.(0); for c = 1 to channels buf - 1 do Mono.blit buf.(0) buf.(c) done method fill_add (buf : buffer) = let len = length buf in let tmpbuf = Mono.Buffer_ext.prepare tmpbuf len in g#fill tmpbuf; for c = 0 to channels buf - 1 do Mono.add buf.(c) tmpbuf done method release = g#release method dead = g#dead end class chain (g : t) (e : Effect.t) : t = object method fill buf = g#fill buf; e#process buf val tmpbuf = Buffer_ext.create 0 0 method fill_add buf = let tmpbuf = Buffer_ext.prepare tmpbuf ~channels:(channels buf) (length buf) in g#fill tmpbuf; add buf tmpbuf method set_volume = g#set_volume method set_frequency = g#set_frequency method release = g#release method dead = g#dead end end module IO = struct exception Invalid_file exception Invalid_operation exception End_of_stream module Reader = struct class type t = object method channels : int method sample_rate : int method length : int method duration : float method seek : int -> unit method close : unit method read : buffer -> int end class virtual base = object (self) method virtual channels : int method virtual sample_rate : int method virtual length : int method duration = float self#length /. float self#sample_rate (* method virtual seek : int -> unit method virtual close : unit method virtual read : buffer -> int -> int -> int *) end (* TODO: handle more formats... *) class virtual wav = object (self) inherit IO.helper method virtual private stream_close : unit method virtual private stream_seek : int -> unit method virtual private stream_cur_pos : int val mutable sample_rate = 0 val mutable channels = 0 (* Size of a sample in bits. *) val mutable sample_size = 0 val mutable bytes_per_sample = 0 (* Length in samples. *) val mutable length = 0 val mutable data_offset = 0 method sample_rate = sample_rate method channels = channels method length = length initializer if self#input 4 <> "RIFF" then (* failwith "Bad header: \"RIFF\" not found"; *) raise Invalid_file; (* Ignore the file size *) ignore (self#input 4); if self#input 8 <> "WAVEfmt " then (* failwith "Bad header: \"WAVEfmt \" not found"; *) raise Invalid_file; (* Now we always have the following uninteresting bytes: * 0x10 0x00 0x00 0x00 0x01 0x00 *) ignore (self#really_input 6); channels <- self#input_short; sample_rate <- self#input_int; (* byt_per_sec *) ignore self#input_int; (* byt_per_samp *) ignore self#input_short; sample_size <- self#input_short; let section = self#really_input 4 in if section <> "data" then ( if section = "INFO" then (* failwith "Valid wav file but unread"; *) raise Invalid_file; (* failwith "Bad header : string \"data\" not found" *) raise Invalid_file); let len_dat = self#input_int in data_offset <- self#stream_cur_pos; bytes_per_sample <- sample_size / 8 * channels; length <- len_dat / bytes_per_sample method read (buf : buffer) = let len = buffer_length buf in let sbuflen = len * channels * 2 in let sbuf = self#input sbuflen in let sbuflen = String.length sbuf in let len = sbuflen / (channels * 2) in begin match sample_size with | 16 -> S16LE.to_audio sbuf 0 buf | 8 -> U8.to_audio sbuf 0 buf | _ -> assert false end; len method seek n = let n = data_offset + (n * bytes_per_sample) in self#stream_seek n method close = self#stream_close end class of_wav_file fname = object inherit IO.Unix.rw ~read:true fname inherit base inherit wav end end module Writer = struct class type t = object method write : buffer -> unit method close : unit end class virtual base chans sr = object method private channels : int = chans method private sample_rate : int = sr end class virtual wav = object (self) inherit IO.helper method virtual private stream_write : string -> int -> int -> int method virtual private stream_seek : int -> unit method virtual private stream_close : unit method virtual private channels : int method virtual private sample_rate : int initializer let bits_per_sample = 16 in (* RIFF *) self#output "RIFF"; self#output_int 0; self#output "WAVE"; (* Format *) self#output "fmt "; self#output_int 16; self#output_short 1; self#output_short self#channels; self#output_int self#sample_rate; self#output_int (self#sample_rate * self#channels * bits_per_sample / 8); self#output_short (self#channels * bits_per_sample / 8); self#output_short bits_per_sample; (* Data *) self#output "data"; (* size of the data, to be updated afterwards *) self#output_short 0xffff; self#output_short 0xffff val mutable datalen = 0 method write buf = let s = S16LE.make buf in self#output s; datalen <- datalen + String.length s method close = self#stream_seek 4; self#output_int (36 + datalen); self#stream_seek 40; self#output_int datalen; self#stream_close end class to_wav_file chans sr fname = object inherit base chans sr inherit IO.Unix.rw ~write:true fname inherit wav end end module RW = struct class type t = object method read : buffer -> unit method write : buffer -> unit method close : unit end class virtual bufferized channels ~min_duration ~fill_duration ~max_duration ~drop_duration = object method virtual io_read : buffer -> unit method virtual io_write : buffer -> unit initializer assert (fill_duration <= max_duration); assert (drop_duration <= max_duration) val rb = Ringbuffer.create channels max_duration method read buf = let len = length buf in let rs = Ringbuffer.read_space rb in if rs < min_duration + len then ( let ps = min_duration + len - rs in Ringbuffer.write rb (create channels ps)); Ringbuffer.read rb buf method write buf = let len = length buf in let ws = Ringbuffer.write_space rb in if ws + len > max_duration then Ringbuffer.read_advance rb (ws - drop_duration); Ringbuffer.write rb buf end end end ocaml-mm-0.7.3/src/audio.mli000066400000000000000000000407651415601551300156330ustar00rootroot00000000000000(* * Copyright 2011 The Savonet Team * * This file is part of ocaml-mm. * * ocaml-mm is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * ocaml-mm 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 Lesser General Public License * along with ocaml-mm; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA * * As a special exception to the GNU Library General Public License, you may * link, statically or dynamically, a "work that uses the Library" with a publicly * distributed version of the Library to produce an executable file containing * portions of the Library, and distribute that executable file under terms of * your choice, without any of the additional requirements listed in clause 6 * of the GNU Library General Public License. * By "a publicly distributed version of the Library", we mean either the unmodified * Library as distributed by The Savonet Team, or a modified version of the Library that is * distributed under the conditions defined in clause 3 of the GNU Library General * Public License. This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU Library General Public License. * *) open Mm_base (** Operations on audio data. *) (** At given sample rate, number of samples in given amount of time. *) val samples_of_seconds : int -> float -> int (** At given sample rate, duration of given number of samples. *) val seconds_of_samples : int -> int -> float (** Convert decibels to linear coefficient. *) val lin_of_dB : float -> float (** Convert linear coefficient to decibels. *) val dB_of_lin : float -> float (** Operations on samples. *) module Sample : sig (** A sample. *) type t = float (** Clip a sample (ie ensure that it is between [-1.] and [1.]. *) val clip : t -> t end (** Operations on notes. *) module Note : sig type t = int val a4 : int val c5 : int val c0 : int val create : int -> int -> t val freq : t -> float val of_freq : float -> t val name : t -> int val octave : t -> int (** Returns note number and octave. *) val modulo : t -> int * int val to_string : t -> string val of_string : string -> t end (** Operations on mono buffers (with only one channel). *) module Mono : sig (** A mono buffer. *) type t = (float, Bigarray.float32_elt, Bigarray.c_layout) Bigarray.Array1.t type buffer = t val create : int -> t val make : int -> float -> t val of_array : float array -> t val to_array : t -> float array val sub : t -> int -> int -> t val blit : t -> t -> unit val copy : t -> t (** Length in samples. *) val length : t -> int val append : t -> t -> t (** Clear a portion of a buffer (fill it with zeroes). *) val clear : t -> unit val amplify : float -> t -> unit val resample : ?mode:[ `Nearest | `Linear ] -> float -> t -> t val clip : t -> unit val noise : t -> unit (** Samplewise add two buffers of the same length. *) val add : t -> t -> unit val mult : t -> t -> unit module Ringbuffer_ext : Ringbuffer.R with type buffer = t module Ringbuffer : Ringbuffer.R with type buffer = t (** Buffers of variable size. These are particularly useful for temporary buffers. *) module Buffer_ext : sig type t val create : int -> t val length : t -> int val prepare : t -> int -> buffer end (** Functions for analyzing audio data. *) module Analyze : sig (** Compute the RMS power of a portion of a buffer. *) val rms : t -> float (** Simple implementation of the FFT algorithm. For fastest implementations optimized libraries such as fftw are recommended. *) module FFT : sig (** Internal data for computing FFT. *) type t (** Initialize FFT for an analysis of [2^n] samples. *) val init : int -> t (** Length of the FFT buffer analysis in samples. *) val length : t -> int (** [complex_create buf] create a array of complex numbers by copying data from [buf] (the imaginary part is null). *) val complex_create : buffer -> Complex.t array (** Perform an FFT analysis. *) val fft : t -> Complex.t array -> unit (** Frequency associated to the [k]-th coefficient of an FFT. *) val band_freq : int -> t -> int -> float (** Windowing functions. Thses can be used to on complex buffers in order to improve the quality of the FFT, see http://en.wikipedia.org/wiki/Windowing_functions. *) module Window : sig val cosine : Complex.t array -> unit val hann : Complex.t array -> unit val hamming : Complex.t array -> unit val lanczos : Complex.t array -> unit val triangular : Complex.t array -> unit val bartlett_hann : Complex.t array -> unit val blackman : ?alpha:float -> Complex.t array -> unit val nuttall : Complex.t array -> unit val blackman_harris : Complex.t array -> unit val blackman_nuttall : Complex.t array -> unit end val notes : int -> t -> ?note_min:int -> ?note_max:int -> ?volume_min:float -> ?filter_harmonics:bool -> buffer -> (Note.t * float) list val loudest_note : (Note.t * float) list -> (Note.t * float) option end end module Effect : sig (** A compander following the mu-law (see http://en.wikipedia.org/wiki/Mu-law).*) val compand_mu_law : float -> t -> unit class type t = object method process : buffer -> unit end class amplify : float -> t class clip : float -> t class biquad_filter : int -> [ `Band_pass | `High_pass | `Low_pass | `Notch | `All_pass | `Peaking | `Low_shelf | `High_shelf ] -> ?gain:float -> float -> float -> t (** ADSR (Attack/Decay/Sustain/Release) envelopes. *) module ADSR : sig (** An ADSR enveloppe. *) type t (** Create an envelope with specified Attack/Decay/Sustain/Release times in seconds (excepting sustain which is an amplification coefficient between [0.] and [1.]). Negative sustain means that that notes should be released just after decay. *) val make : int -> float * float * float * float -> t (** Current state in the ADSR envelope. *) type state (** Initial state for processing. *) val init : unit -> state val release : state -> state val dead : state -> bool val process : t -> state -> buffer -> state end end (** Sound generators. *) module Generator : sig (** A sound generator. *) class type t = object method set_volume : float -> unit method set_frequency : float -> unit (** Fill a buffer with generated sound. *) method fill : buffer -> unit (** Same as [fill] but adds the sound to the buffer. *) method fill_add : buffer -> unit (** Release the generator (used for generator with envelopes). *) method release : unit (** Is the generator still producing sound? This should become false soon after release has been triggered. *) method dead : bool end (** Generate a sine waveform. *) class sine : int -> ?volume:float -> ?phase:float -> float -> t (** Generate a square waveform. *) class square : int -> ?volume:float -> ?phase:float -> float -> t (** Generate a saw waveform. *) class saw : int -> ?volume:float -> ?phase:float -> float -> t (** Generate a triangle waveform. *) class triangle : int -> ?volume:float -> ?phase:float -> float -> t class white_noise : ?volume:float -> int -> t class chain : t -> Effect.t -> t class add : t -> t -> t class mult : t -> t -> t (** Apply an ADSR envlope on a generator. *) class adsr : Effect.ADSR.t -> t -> t end end (** An audio buffer. *) type t = Mono.t array type buffer = t (** [create chans len] creates a buffer with [chans] channels and [len] samples as duration. *) val create : int -> int -> t val make : int -> int -> float -> t val of_array : float array array -> t val to_array : t -> float array array (** Create a buffer with the same number of channels and duration as the given buffer. *) val create_same : t -> t (** Clear the buffer (sets all the samples to zero). *) val clear : t -> unit (** Copy the given buffer. *) val copy : t -> t val append : t -> t -> t val channels : t -> int (** Length of a buffer in samples. *) val length : t -> int (** Convert a buffer to a mono buffer by computing the mean of all channels. *) val to_mono : t -> Mono.t (** Convert a mono buffer into a buffer. Notice that the original mono buffer is not copied an might thus be modified afterwards. *) val of_mono : Mono.t -> t val interleave : t -> (float, Bigarray.float32_elt, Bigarray.c_layout) Bigarray.Array1.t val deinterleave : int -> (float, Bigarray.float32_elt, Bigarray.c_layout) Bigarray.Array1.t -> t module U8 : sig val size : int -> int -> int val of_audio : t -> Bytes.t -> int -> unit val to_audio : string -> int -> t -> unit end module S16LE : sig val size : int -> int -> int val length : int -> int -> int val of_audio : t -> Bytes.t -> int -> unit val make : t -> string val to_audio : string -> int -> t -> unit end module S16BE : sig val size : int -> int -> int val length : int -> int -> int val of_audio : t -> Bytes.t -> int -> unit val make : t -> string val to_audio : string -> int -> t -> unit end module S24LE : sig val size : int -> int -> int val of_audio : t -> Bytes.t -> int -> unit val to_audio : string -> int -> t -> unit end module S32LE : sig val size : int -> int -> int val of_audio : t -> Bytes.t -> int -> unit val to_audio : string -> int -> t -> unit end val resample : ?mode:[ `Nearest | `Linear ] -> float -> t -> t val blit : t -> t -> unit val sub : t -> int -> int -> t val clip : t -> unit val noise : t -> unit (** Amplify a portion of the buffer by a given coefficient. *) val amplify : float -> t -> unit (** Pan a stereo buffer from left to right (the buffer should have exactly two channels!). The coefficient should be between [-1.] and [1.]. *) val pan : float -> t -> unit val add : t -> t -> unit val add_coeff : t -> float -> t -> unit (** Buffers of variable size. These are particularly useful for temporary buffers. *) module Buffer_ext : sig type t (** Create an extensible buffer of given channels and initial size in samples. *) val create : int -> int -> t (** Current length (in samples) of the buffer. *) val length : t -> int (** Make sure that the buffer can hold at least a given number of samples. *) val prepare : t -> ?channels:int -> int -> buffer end (** Circular ringbuffers. *) module Ringbuffer : sig (** A ringbuffer. *) type t (** Create a ringbuffer of given number of channels and size (in samples). *) val create : int -> int -> t val channels : t -> int val read_space : t -> int val write_space : t -> int val read_advance : t -> int -> unit val write_advance : t -> int -> unit val peek : t -> buffer -> unit val read : t -> buffer -> unit val write : t -> buffer -> unit val transmit : t -> (buffer -> int) -> int end module Ringbuffer_ext : sig type t val create : int -> int -> t val channels : t -> int val read_space : t -> int val write_space : t -> int val read_advance : t -> int -> unit val write_advance : t -> int -> unit val peek : t -> buffer -> unit val read : t -> buffer -> unit val write : t -> buffer -> unit val transmit : t -> (buffer -> int) -> int end module Analyze : sig val rms : t -> float array end (** Audio effects. *) module Effect : sig (** A possibly stateful audio effect. *) class type t = object (** Apply the effect on a buffer. *) method process : buffer -> unit end class chain : t -> t -> t class of_mono : int -> (unit -> Mono.Effect.t) -> t class type delay_t = object inherit t method set_delay : float -> unit method set_feedback : float -> unit end (** [delay chans samplerate d once feedback] creates a delay operator for buffer with [chans] channels at [samplerate] samplerate with [d] as delay in seconds and [feedback] as feedback. If [once] is set to [true] only one echo will be heard (no feedback). *) val delay : int -> int -> float -> ?once:bool -> ?ping_pong:bool -> float -> delay_t (** Hardknee compressor with RMS look-ahead envelope calculation and adjustable attack/decay. Given parameters are [attack] and [release] in seconds, [ratio] n means n:1 compression, [threshold] and [knee] in dB, and [rms_window] in second is the duration for RMS acquisition. [gain] is an additional pre-gain. *) class compress : ?attack:float -> ?release:float -> ?threshold:float -> ?ratio:float -> ?knee:float -> ?rms_window:float -> ?gain:float -> int -> int -> object inherit t method set_attack : float -> unit method set_gain : float -> unit method set_knee : float -> unit method set_ratio : float -> unit method set_release : float -> unit method set_threshold : float -> unit method reset : unit end (** A biquadratic filter. [gain] in dB is only used by peaking, low and high shelves. *) class biquad_filter : int -> int -> [ `Band_pass | `High_pass | `Low_pass | `Notch | `All_pass | `Peaking | `Low_shelf | `High_shelf ] -> ?gain:float -> float -> float -> t val auto_gain_control : int -> int -> ?rms_target:float -> ?rms_window:float -> ?kup:float -> ?kdown:float -> ?rms_threshold:float -> ?volume_init:float -> ?volume_min:float -> ?volume_max:float -> unit -> t end (** Sound generators. *) module Generator : sig val white_noise : t -> unit class type t = object method set_volume : float -> unit method set_frequency : float -> unit method fill : buffer -> unit method fill_add : buffer -> unit method release : unit method dead : bool end class of_mono : Mono.Generator.t -> t class chain : t -> Effect.t -> t end (** Operation for reading and writing audio data from files, streams or devices. *) module IO : sig (** The file is not valid. *) exception Invalid_file (** The operation is not valid on the file/device. *) exception Invalid_operation (** Trying to read past the end of the stream. *) exception End_of_stream module Reader : sig class type t = object (** Number of channels. *) method channels : int (** Sample rate in samples per second. *) method sample_rate : int (** Length in samples. *) method length : int (** Duration in seconds. *) method duration : float (** Seek to a given sample. *) method seek : int -> unit (** Close the file. This method should only be called once. The members of the object should not be accessed anymore after this method has been called. *) method close : unit method read : buffer -> int end (** Create a reader object from a wav file. *) class of_wav_file : string -> t end module Writer : sig class type t = object method write : buffer -> unit method close : unit end (** Create a writer to a file in WAV format with given number of channels, sample rate and file name.*) class to_wav_file : int -> int -> string -> t end module RW : sig class type t = object method read : buffer -> unit method write : buffer -> unit method close : unit end class virtual bufferized : int -> min_duration:int -> fill_duration:int -> max_duration:int -> drop_duration:int -> object method virtual io_read : buffer -> unit method virtual io_write : buffer -> unit method read : buffer -> unit method write : buffer -> unit end end end ocaml-mm-0.7.3/src/audio_c.c000066400000000000000000000275541415601551300155770ustar00rootroot00000000000000/* * Copyright 2011 The Savonet Team * * This file is part of ocaml-mm. * * ocaml-mm is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * ocaml-mm 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 Lesser General Public License * along with ocaml-mm; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA * * As a special exception to the GNU Library General Public License, you may * link, statically or dynamically, a "work that uses the Library" with a * publicly distributed version of the Library to produce an executable file * containing portions of the Library, and distribute that executable file under * terms of your choice, without any of the additional requirements listed in * clause 6 of the GNU Library General Public License. By "a publicly * distributed version of the Library", we mean either the unmodified Library as * distributed by The Savonet Team, or a modified version of the Library that is * distributed under the conditions defined in clause 3 of the GNU Library * General Public License. This exception does not however invalidate any other * reasons why the executable file might be covered by the GNU Library General * Public License. * */ #include #include #include #include #include #include #include #include #include #define INT24_MAX ((1 << 23) - 1) #define INT24_MIN (-INT24_MAX) #ifndef Bytes_val #define Bytes_val String_val #endif typedef uint8_t int24_t[3]; static inline void int24_of_int32(int32_t x, int24_t d) { d[0] = x; d[1] = x >> 8; d[2] = x >> 16; } static inline int32_t int32_of_int24(int24_t x) { int32_t tmp = x[0] | (x[1] << 8) | (x[2] << 16); return INT24_MAX < tmp ? (0xff000000 | tmp) : tmp; } #define bswap_16(x) \ ((int16_t)((((int16_t)(x)&0xff00) >> 8) | (((int16_t)(x)&0x00ff) << 8))) #define bswap_32(x) \ ((int32_t)( \ (((int32_t)(x)&0xff000000) >> 24) | (((int32_t)(x)&0x00ff0000) >> 8) | \ (((int32_t)(x)&0x0000ff00) << 8) | (((int32_t)(x)&0x000000ff) << 24))) #include #include #include #include "config.h" static inline int16_t clip(double s) { if (s < -1) { #ifdef DEBUG printf("Wrong sample: %f\n", s); #endif return INT16_MIN; } else if (s > 1) { #ifdef DEBUG printf("Wrong sample: %f\n", s); #endif return INT16_MAX; } else return (s * INT16_MAX); } static inline int32_t s32_clip(double s) { if (s < -1) { #ifdef DEBUG printf("Wrong sample: %f\n", s); #endif return INT32_MIN; } else if (s > 1) { #ifdef DEBUG printf("Wrong sample: %f\n", s); #endif return INT32_MAX; } else return (s * INT32_MAX); } static inline void s24_clip(double s, int24_t x) { if (s < -1) { #ifdef DEBUG printf("Wrong sample: %f\n", s); #endif return int24_of_int32(INT24_MIN, x); } else if (s > 1) { #ifdef DEBUG printf("Wrong sample: %f\n", s); #endif return int24_of_int32(INT24_MAX, x); } else return int24_of_int32(s * INT24_MAX, x); } static inline uint8_t u8_clip(double s) { if (s < -1) { #ifdef DEBUG printf("Wrong sample: %f\n", s); #endif return 0; } else if (s > 1) { #ifdef DEBUG printf("Wrong sample: %f\n", s); #endif return 255; } else return (s * 127. + 128.); } #define u8tof(x) (((double)x - INT8_MAX) / INT8_MAX) #define s16tof(x) (((double)x) / INT16_MAX) #define s24tof(x) (((double)int32_of_int24(x)) / INT24_MAX) #define s32tof(x) (((double)x) / INT32_MAX) #define get_u8(src, offset, nc, c, i) \ u8tof(((uint8_t *)src)[offset + i * nc + c]) #define get_s24le(src, offset, nc, c, i) \ s24tof(((int24_t *)src)[offset / 3 + i * nc + c]) #ifdef BIGENDIAN #define get_s16le(src, offset, nc, c, i) \ s16tof(bswap_16(((int16_t *)src)[offset / 2 + i * nc + c])) #define get_s16be(src, offset, nc, c, i) \ s16tof(((int16_t *)src)[offset / 2 + i * nc + c]) #define get_s32le(src, offset, nc, c, i) \ s32tof(bswap_32(((int32_t *)src)[offset / 4 + i * nc + c])) #else #define get_s16le(src, offset, nc, c, i) \ s16tof(((int16_t *)src)[offset / 2 + i * nc + c]) #define get_s16be(src, offset, nc, c, i) \ s16tof(bswap_16(((int16_t *)src)[offset / 2 + i * nc + c])) #define get_s32le(src, offset, nc, c, i) \ s32tof(((int32_t *)src)[offset / 4 + i * nc + c]) #endif CAMLprim value caml_float_pcm_to_s32le(value a, value _dst, value _offs) { CAMLparam3(a, _dst, _offs); int c, i; int offs = Int_val(_offs); int nc = Wosize_val(a); if (nc == 0) CAMLreturn(Val_unit); int len = Caml_ba_array_val(Field(a, 0))->dim[0]; float *src; int32_t *dst = (int32_t *)Bytes_val(_dst); if (caml_string_length(_dst) < offs + len * nc * 4) caml_invalid_argument("pcm_to_s32le: destination buffer too short"); for (c = 0; c < nc; c++) { src = Caml_ba_data_val(Field(a, c)); caml_release_runtime_system(); for (i = 0; i < len; i++) { dst[i * nc + c] = s32_clip(src[i + offs]); #ifdef BIGENDIAN dst[i * nc + c] = bswap_32(dst[i * nc + c]); #endif } caml_acquire_runtime_system(); } CAMLreturn(Val_unit); } CAMLprim value caml_float_pcm_to_s24le(value a, value _dst, value _offs) { CAMLparam3(a, _dst, _offs); int c, i; int offs = Int_val(_offs); int nc = Wosize_val(a); if (nc == 0) CAMLreturn(Val_unit); int len = Caml_ba_array_val(Field(a, 0))->dim[0]; float *src; int24_t *dst = (int24_t *)Bytes_val(_dst); if (caml_string_length(_dst) < offs + len * nc * 3) caml_invalid_argument("pcm_to_s24le: destination buffer too short"); for (c = 0; c < nc; c++) { src = Caml_ba_data_val(Field(a, c)); caml_release_runtime_system(); for (i = 0; i < len; i++) s24_clip(src[offs + i], dst[i * nc + c]); caml_acquire_runtime_system(); } CAMLreturn(Val_unit); } CAMLprim value caml_float_pcm_to_s16(value _le, value a, value _dst, value _dst_offs) { CAMLparam4(_le, a, _dst, _dst_offs); int little_endian = Bool_val(_le); int dst_offs = Int_val(_dst_offs); int nc = Wosize_val(a); if (nc == 0) CAMLreturn(Val_unit); int len = Caml_ba_array_val(Field(a, 0))->dim[0]; float *src; int16_t *dst = (int16_t *)Bytes_val(_dst); int c, i; if (caml_string_length(_dst) < 2 * nc * (dst_offs + len)) caml_invalid_argument("pcm_to_s16: destination buffer too short"); dst = dst + nc * dst_offs; if (little_endian == 1) for (c = 0; c < nc; c++) { src = Caml_ba_data_val(Field(a, c)); for (i = 0; i < len; i++) { dst[i * nc + c] = clip(src[i]); #ifdef BIGENDIAN dst[i * nc + c] = bswap_16(dst[i * nc + c]); #endif } } else for (c = 0; c < nc; c++) { src = Caml_ba_data_val(Field(a, c)); for (i = 0; i < len; i++) { dst[i * nc + c] = clip(src[i]); #ifndef BIGENDIAN dst[i * nc + c] = bswap_16(dst[i * nc + c]); #endif } } CAMLreturn(Val_unit); } CAMLprim value caml_float_pcm_convert_s16(value _le, value _src, value _offset, value _dst) { CAMLparam4(_le, _src, _offset, _dst); int little_endian = Bool_val(_le); const char *src = String_val(_src); int offset = Int_val(_offset); int nc = Wosize_val(_dst); if (nc == 0) CAMLreturn(Val_unit); int len = Caml_ba_array_val(Field(_dst, 0))->dim[0]; float *dstc; int i, c; if ((offset + len) * nc * 2 > caml_string_length(_src)) caml_invalid_argument("convert_native: output buffer too small"); if (little_endian == 1) for (c = 0; c < nc; c++) { dstc = (float *)Caml_ba_data_val(Field(_dst, c)); caml_release_runtime_system(); for (i = 0; i < len; i++) dstc[i] = get_s16le(src, offset, nc, c, i); caml_acquire_runtime_system(); } else for (c = 0; c < nc; c++) { dstc = (float *)Caml_ba_data_val(Field(_dst, c)); caml_release_runtime_system(); for (i = 0; i < len; i++) dstc[i] = get_s16be(src, offset, nc, c, i); caml_acquire_runtime_system(); } CAMLreturn(Val_unit); } CAMLprim value caml_float_pcm_to_u8(value a, value _dst, value _dst_offs) { CAMLparam3(a, _dst, _dst_offs); int c, i; int dst_offs = Int_val(_dst_offs); int nc = Wosize_val(a); if (nc == 0) CAMLreturn(Val_unit); int len = Caml_ba_array_val(Field(a, 0))->dim[0]; float *src; uint8_t *dst = (uint8_t *)Bytes_val(_dst); if (caml_string_length(_dst) < nc * (dst_offs + len)) caml_invalid_argument("pcm_to_s16: destination buffer too short"); dst = dst + nc * dst_offs; for (c = 0; c < nc; c++) { src = (float *)Caml_ba_data_val(Field(a, c)); caml_release_runtime_system(); for (i = 0; i < len; i++) { dst[i * nc + c] = u8_clip(src[i]); } caml_acquire_runtime_system(); } CAMLreturn(Val_unit); } CAMLprim value caml_float_pcm_of_u8(value _src, value _offset, value _dst) { CAMLparam3(_src, _offset, _dst); const char *src = String_val(_src); int offset = Int_val(_offset); int nc = Wosize_val(_dst); if (nc == 0) CAMLreturn(Val_unit); int len = Caml_ba_array_val(Field(_dst, 0))->dim[0]; assert(nc > 0); int i, c; float *dstc; if (len + offset > caml_string_length(_src)) caml_invalid_argument("convert_native: output buffer too small"); for (c = 0; c < nc; c++) { dstc = (float *)Caml_ba_data_val(Field(_dst, c)); caml_release_runtime_system(); for (i = 0; i < len; i++) dstc[i] = get_u8(src, offset, nc, c, i); caml_acquire_runtime_system(); } CAMLreturn(Val_unit); } CAMLprim value caml_float_pcm_convert_s32le(value _src, value _offset, value _dst) { CAMLparam3(_src, _offset, _dst); const char *src = String_val(_src); int offset = Int_val(_offset); int nc = Wosize_val(_dst); if (nc == 0) CAMLreturn(Val_unit); int len = Caml_ba_array_val(Field(_dst, 0))->dim[0]; int i, c; float *dstc; if (caml_string_length(_src) < offset + len * nc * 4) caml_invalid_argument("convert_native: output buffer too small"); for (c = 0; c < nc; c++) { dstc = Caml_ba_data_val(Field(_dst, c)); caml_release_runtime_system(); for (i = 0; i < len; i++) dstc[i] = get_s32le(src, offset, nc, c, i); caml_acquire_runtime_system(); } CAMLreturn(Val_unit); } CAMLprim value caml_float_pcm_convert_s24le(value _src, value _offset, value _dst) { CAMLparam3(_src, _offset, _dst); const char *src = String_val(_src); int nc = Wosize_val(_dst); if (nc == 0) CAMLreturn(Val_unit); int offset = Int_val(_offset); int len = Caml_ba_array_val(Field(_dst, 0))->dim[0]; int i, c; float *dstc; if (caml_string_length(_src) < offset + len * nc * 3) caml_invalid_argument("convert_native: output buffer too small"); for (c = 0; c < nc; c++) { dstc = Caml_ba_data_val(Field(_dst, c)); caml_release_runtime_system(); for (i = 0; i < len; i++) dstc[i] = get_s24le(src, offset, nc, c, i); caml_acquire_runtime_system(); } CAMLreturn(Val_unit); } ocaml-mm-0.7.3/src/config/000077500000000000000000000000001415601551300152605ustar00rootroot00000000000000ocaml-mm-0.7.3/src/config/discover.ml000066400000000000000000000026501415601551300174330ustar00rootroot00000000000000module C = Configurator.V1 external is_big_endian : unit -> bool = "ocaml_mm_is_big_endian" let () = C.main ~name:"mm" (fun c -> let has_aligned_alloc = C.c_test c {| #include int main() { char *data = aligned_alloc(16, 4096); return 0; } |} in let has_memalign = C.c_test c {| #include int main() { char *data = memalign(16, 4096); return 0; } |} in let has_max_align_t = C.c_test c {| #include #include int main() { size_t x = alignof(max_align_t); return 0; } |} in let has_caml_internals = C.c_test c {| #define CAML_INTERNALS 1 #include #include int main() { struct custom_operations *ops = &caml_ba_ops; int x = caml_ba_element_size[0]; return 0; } |} in C.C_define.gen_header_file c ~fname:"config.h" [ ("BIGENDIAN", Switch (is_big_endian ())); ("HAS_ALIGNED_ALLOC", Switch has_aligned_alloc); ("HAS_MEMALIGN", Switch has_memalign); ("HAS_MAX_ALIGN_T", Switch has_max_align_t); ("HAS_CAML_INTERNALS", Switch has_caml_internals); ]) ocaml-mm-0.7.3/src/config/dune000066400000000000000000000021041415601551300161330ustar00rootroot00000000000000(executable (name discover) (modules discover) (foreign_stubs (language c) (names endianess)) (libraries dune.configurator)) (executable (name setup) (modules setup setup_alsa setup_ao setup_mad setup_oss setup_pulseaudio setup_sdl setup_theora) (foreign_stubs (language c) (names endianess_setup)) (libraries (select setup_alsa.ml from (mm.alsa -> setup_alsa.enabled.ml) (-> setup_alsa.disabled.ml)) (select setup_ao.ml from (mm.ao -> setup_ao.enabled.ml) (-> setup_ao.disabled.ml)) (select setup_mad.ml from (mm.mad -> setup_mad.enabled.ml) (-> setup_mad.disabled.ml)) (select setup_oss.ml from (mm.oss -> setup_oss.enabled.ml) (-> setup_oss.disabled.ml)) (select setup_pulseaudio.ml from (mm.pulseaudio -> setup_pulseaudio.enabled.ml) (-> setup_pulseaudio.disabled.ml)) (select setup_sdl.ml from (mm.sdl -> setup_sdl.enabled.ml) (-> setup_sdl.disabled.ml)) (select setup_theora.ml from (mm.theora -> setup_theora.enabled.ml) (-> setup_theora.disabled.ml)))) ocaml-mm-0.7.3/src/config/endianess.c000066400000000000000000000006161415601551300174000ustar00rootroot00000000000000#include #include enum { OCAML_MM_LITTLE_ENDIAN = 0x0100, OCAML_MM_BIG_ENDIAN = 0x0001, }; static const union { unsigned char bytes[2]; uint16_t value; } host_order = { { 0, 1 } }; CAMLprim value ocaml_mm_is_big_endian(value unit) { CAMLparam0(); if (host_order.value == OCAML_MM_BIG_ENDIAN) CAMLreturn(Val_bool(1)); CAMLreturn(Val_bool(0)); } ocaml-mm-0.7.3/src/config/endianess_setup.c000077700000000000000000000000001415601551300227252endianess.custar00rootroot00000000000000ocaml-mm-0.7.3/src/config/setup.ml000066400000000000000000000007631415601551300167600ustar00rootroot00000000000000external is_big_endian : unit -> bool = "ocaml_mm_is_big_endian" let () = Printf.printf {| Big endian host: %b Supported external libraries: - Alsa : %b - AO : %b - Mad : %b - OSS : %b - Pulseaudio: %b - SDL : %b - Theora : %b |} (is_big_endian ()) Setup_alsa.is_set Setup_ao.is_set Setup_mad.is_set Setup_oss.is_set Setup_pulseaudio.is_set Setup_sdl.is_set Setup_theora.is_set; let oc = open_out "config.print" in close_out oc ocaml-mm-0.7.3/src/config/setup_alsa.disabled.ml000077700000000000000000000000001415601551300250342setup_disabled.mlustar00rootroot00000000000000ocaml-mm-0.7.3/src/config/setup_alsa.enabled.ml000077700000000000000000000000001415601551300245022setup_enabled.mlustar00rootroot00000000000000ocaml-mm-0.7.3/src/config/setup_ao.disabled.ml000077700000000000000000000000001415601551300245132setup_disabled.mlustar00rootroot00000000000000ocaml-mm-0.7.3/src/config/setup_ao.enabled.ml000077700000000000000000000000001415601551300241612setup_enabled.mlustar00rootroot00000000000000ocaml-mm-0.7.3/src/config/setup_disabled.alsa.ml000077700000000000000000000000001415601551300250342setup_disabled.mlustar00rootroot00000000000000ocaml-mm-0.7.3/src/config/setup_disabled.ml000066400000000000000000000000231415601551300205740ustar00rootroot00000000000000let is_set = false ocaml-mm-0.7.3/src/config/setup_enabled.alsa.ml000077700000000000000000000000001415601551300245022setup_enabled.mlustar00rootroot00000000000000ocaml-mm-0.7.3/src/config/setup_enabled.ml000066400000000000000000000000221415601551300204160ustar00rootroot00000000000000let is_set = true ocaml-mm-0.7.3/src/config/setup_mad.disabled.ml000077700000000000000000000000001415601551300246552setup_disabled.mlustar00rootroot00000000000000ocaml-mm-0.7.3/src/config/setup_mad.enabled.ml000077700000000000000000000000001415601551300243232setup_enabled.mlustar00rootroot00000000000000ocaml-mm-0.7.3/src/config/setup_ogg.disabled.ml000077700000000000000000000000001415601551300246702setup_disabled.mlustar00rootroot00000000000000ocaml-mm-0.7.3/src/config/setup_ogg.enabled.ml000077700000000000000000000000001415601551300243362setup_enabled.mlustar00rootroot00000000000000ocaml-mm-0.7.3/src/config/setup_oss.disabled.ml000077700000000000000000000000001415601551300247202setup_disabled.mlustar00rootroot00000000000000ocaml-mm-0.7.3/src/config/setup_oss.enabled.ml000077700000000000000000000000001415601551300243662setup_enabled.mlustar00rootroot00000000000000ocaml-mm-0.7.3/src/config/setup_pulseaudio.disabled.ml000077700000000000000000000000001415601551300262662setup_disabled.mlustar00rootroot00000000000000ocaml-mm-0.7.3/src/config/setup_pulseaudio.enabled.ml000077700000000000000000000000001415601551300257342setup_enabled.mlustar00rootroot00000000000000ocaml-mm-0.7.3/src/config/setup_sdl.disabled.ml000077700000000000000000000000001415601551300246762setup_disabled.mlustar00rootroot00000000000000ocaml-mm-0.7.3/src/config/setup_sdl.enabled.ml000077700000000000000000000000001415601551300243442setup_enabled.mlustar00rootroot00000000000000ocaml-mm-0.7.3/src/config/setup_theora.disabled.ml000077700000000000000000000000001415601551300253762setup_disabled.mlustar00rootroot00000000000000ocaml-mm-0.7.3/src/config/setup_theora.enabled.ml000077700000000000000000000000001415601551300250442setup_enabled.mlustar00rootroot00000000000000ocaml-mm-0.7.3/src/config/setup_v4l.disabled.ml000077700000000000000000000000001415601551300246212setup_disabled.mlustar00rootroot00000000000000ocaml-mm-0.7.3/src/config/setup_v4l.enabled.ml000077700000000000000000000000001415601551300242672setup_enabled.mlustar00rootroot00000000000000ocaml-mm-0.7.3/src/dune000066400000000000000000000030141415601551300146670ustar00rootroot00000000000000(library (name mm_base) (public_name mm.base) (libraries unix) (modules ringbuffer iO) (synopsis "High-level APIs to create and manipulate multimedia streams -- base modules")) (library (name mm_audio) (public_name mm.audio) (libraries bigarray mm.base) (modules audio) (foreign_stubs (extra_deps config.h) (language c) (names audio_c)) (synopsis "High-level APIs to create and manipulate multimedia streams -- audio module")) (library (name mm_image) (public_name mm.image) (libraries bigarray) (modules image) (foreign_stubs (extra_deps config.h) (language c) (names image_data image_pixel image_rgb image_yuv420)) (synopsis "High-level APIs to create and manipulate multimedia streams -- image module")) (library (name mm_video) (public_name mm.video) (libraries mm.base mm.image) (modules video) (synopsis "High-level APIs to create and manipulate multimedia streams -- video module")) (library (name mm_midi) (public_name mm.midi) (libraries mm.base mm.audio) (modules mIDI synth) (synopsis "High-level APIs to create and manipulate multimedia streams -- midi module")) (library (name mm) (public_name mm) (libraries mm.audio mm.image mm.video mm.midi) (modules mm) (synopsis "High-level APIs to create and manipulate multimedia streams")) (rule (targets config.h) (action (run ./config/discover.exe))) (rule (targets mm.ml) (mode fallback) (deps config.print) (action (echo "this should not happen"))) (rule (targets config.print) (action (run ./config/setup.exe))) ocaml-mm-0.7.3/src/image.ml000066400000000000000000000732371415601551300154430ustar00rootroot00000000000000(* * Copyright 2011 The Savonet Team * * This file is part of ocaml-mm. * * ocaml-mm is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * ocaml-mm 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 Lesser General Public License * along with ocaml-mm; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA * * As a special exception to the GNU Library General Public License, you may * link, statically or dynamically, a "work that uses the Library" with a publicly * distributed version of the Library to produce an executable file containing * portions of the Library, and distribute that executable file under terms of * your choice, without any of the additional requirements listed in clause 6 * of the GNU Library General Public License. * By "a publicly distributed version of the Library", we mean either the unmodified * Library as distributed by The Savonet Team, or a modified version of the Library that is * distributed under the conditions defined in clause 3 of the GNU Library General * Public License. This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU Library General Public License. * *) let option_value o ~default = match o with Some v -> v | None -> default let option_get = function Some v -> v | None -> invalid_arg "option is None" module Data = struct type t = (int, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t (* Creates an 16-bytes aligned plane. Returns (stride*plane). *) (* external create_rounded_plane : int -> int -> int * t = "caml_data_aligned_plane" *) let alloc n = Bigarray.Array1.create Bigarray.int8_unsigned Bigarray.C_layout n (** [round n k] rounds [n] to the nearest upper multiple of [k]. *) let round k n = (n + (k - 1)) / k * k external aligned : int -> int -> t = "caml_data_aligned" (* Creates an 16-bytes aligned plane. Returns (stride*plane). *) let rounded_plane width height = let align = 16 in let stride = round 16 width in let data = aligned align (height * stride) in (stride, data) external to_string : t -> string = "caml_data_to_string" external to_bytes : t -> bytes = "caml_data_to_string" external of_string : string -> t = "caml_data_of_string" let blit_all src dst = Bigarray.Array1.blit src dst external blit : t -> int -> t -> int -> int -> unit = "caml_data_blit_off" (* [@@noalloc] *) external copy : t -> t = "caml_data_copy" let sub buf ofs len = Bigarray.Array1.sub buf ofs len let length img = Bigarray.Array1.dim img let size img = length img let get = Bigarray.Array1.get let fill buf x = Bigarray.Array1.fill buf x end module Pixel = struct type rgba = int * int * int * int type rgb = int * int * int type yuv = int * int * int type yuva = (int * int * int) * int external yuv_of_rgb : rgb -> yuv = "caml_yuv_of_rgb" external rgb_of_yuv : yuv -> rgb = "caml_rgb_of_yuv" end module Draw = struct (* Besenham algorithm. *) let line p (sx, sy) (dx, dy) = let steep = abs (dy - sy) > abs (dx - sx) in let sx, sy, dx, dy = if steep then (sy, sx, dy, dx) else (sx, sy, dx, dy) in let sx, sy, dx, dy = if sx > dx then (dx, dy, sx, sy) else (sx, sy, dx, dy) in let deltax = dx - sx in let deltay = abs (dy - sy) in let error = ref (deltax / 2) in let ystep = if sy < dy then 1 else -1 in let j = ref sy in for i = sx to dx - 1 do if steep then p !j i else p i !j; error := !error - deltay; if !error < 0 then ( j := !j + ystep; error := !error + deltax) done end module Motion_multi = struct type vectors_data = (int, Bigarray.nativeint_elt, Bigarray.c_layout) Bigarray.Array1.t type vectors = { vectors : vectors_data; vectors_width : int; block_size : int; } external median_denoise : int -> vectors_data -> unit = "caml_rgb_motion_multi_median_denoise" let median_denoise v = median_denoise v.vectors_width v.vectors external mean : int -> vectors_data -> int * int = "caml_rgb_motion_multi_mean" let mean v = mean v.vectors_width v.vectors end module RGB8 = struct module Color = struct type t = int * int * int let of_int n = if n > 0xffffff then raise (Invalid_argument "Not a color"); ((n lsr 16) land 0xff, (n lsr 8) land 0xff, n land 0xff) end end module Gray8 = struct (* TODO: stride ? *) type t = { data : Data.t; width : int } let make w d = { data = d; width = w } (* Don't use create_rounded_plane here since there is not stride.. *) let create w h = make w (Bigarray.Array1.create Bigarray.int8_unsigned Bigarray.c_layout (w * h)) module Motion = struct external compute : int -> int -> Data.t -> Data.t -> int * int = "caml_mm_Gray8_motion_compute" let compute bs o n = compute bs n.width o.data n.data module Multi = struct include Motion_multi external compute : int -> int -> Data.t -> Data.t -> vectors_data = "caml_mm_Gray8_motion_multi_compute" let compute bs o n = { vectors = compute bs n.width o.data n.data; vectors_width = n.width / bs; block_size = bs; } end end end module BGRA = struct type data = Data.t type t = { data : data; width : int; height : int; stride : int } let make ?stride width height data = let stride = match stride with Some v -> v | None -> 4 * width in { data; width; height; stride } let create ?stride width height = let stride = match stride with Some v -> v | None -> 4 * width in let stride, data = Data.rounded_plane stride height in make ~stride width height data let data img = img.data end module RGBA32 = struct module Color = struct type t = int * int * int * int end type data = (int, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t type t = { (* Order matters for C callbacks! *) data : data; width : int; height : int; stride : int; } let width buf = buf.width let height buf = buf.height let dimensions buf = (buf.width, buf.height) let data buf = buf.data let size buf = Bigarray.Array1.dim buf.data let stride buf = buf.stride let make ?stride width height data = let stride = match stride with Some v -> v | None -> 4 * width in { data; width; height; stride } let create ?stride width height = let stride = match stride with Some v -> v | None -> 4 * width in let stride, data = Data.rounded_plane stride height in make ~stride width height data let copy f = let nf = create ~stride:f.stride f.width f.height in Bigarray.Array1.blit f.data nf.data; nf (* Remove the optional stride argument. *) let create width height = create width height external blit : t -> t -> unit = "caml_rgb_blit" external blit_off : t -> t -> int -> int -> bool -> unit = "caml_rgb_blit_off" external blit_off_scale : t -> t -> int * int -> int * int -> bool -> unit = "caml_rgb_blit_off_scale" let blit_all src dst = assert ( src.width = dst.width && src.height = dst.height && src.stride = dst.stride); blit src dst let blit ?(blank = true) ?(x = 0) ?(y = 0) ?w ?h src dst = match (w, h) with | None, None -> blit_off src dst x y blank | Some w, Some h -> blit_off_scale src dst (x, y) (w, h) blank | _, _ -> assert false external fill_all : t -> Color.t -> unit = "caml_rgb_fill" external blank_all : t -> unit = "caml_rgb_blank" let blank = blank_all external fill_alpha : t -> int -> unit = "caml_rgb_fill_alpha" external of_RGB24_string : t -> string -> unit = "caml_rgb_of_rgb8_string" let of_RGB24_string data width = let height = String.length data / 3 / width in let ans = create width height in of_RGB24_string ans data; ans external of_BGRA : t -> BGRA.t -> unit = "caml_rgba_of_bgra" let of_BGRA bgra = let img = create bgra.BGRA.width bgra.BGRA.height in of_BGRA img bgra; img external to_BGRA : BGRA.t -> t -> unit = "caml_rgba_of_bgra" let to_BGRA img = let bgra = BGRA.create img.width img.height in to_BGRA bgra img; bgra external to_Gray8 : t -> Data.t -> unit = "caml_mm_RGBA8_to_Gray8" let to_Gray8 rgb gray = to_Gray8 rgb gray.Gray8.data let to_Gray8_create rgb = let gray = Gray8.create (width rgb) (height rgb) in to_Gray8 rgb gray; gray external get_pixel : t -> int -> int -> Color.t = "caml_rgb_get_pixel" external set_pixel : t -> int -> int -> Color.t -> unit = "caml_rgb_set_pixel" let set_pixel img i j = assert (0 <= i && i < img.width); assert (0 <= j && j < img.height); set_pixel img i j let get_pixel_rgba = get_pixel let set_pixel_rgba = set_pixel external randomize_all : t -> unit = "caml_rgb_randomize" let randomize = randomize_all module Scale = struct type kind = Linear | Bilinear external scale_coef : t -> t -> int * int -> int * int -> unit = "caml_rgb_scale" external bilinear_scale_coef : t -> t -> float -> float -> unit = "caml_rgb_bilinear_scale" let scale_coef_kind k src dst (dw, sw) (dh, sh) = match k with | Linear -> scale_coef src dst (dw, sw) (dh, sh) | Bilinear -> let x = float dw /. float sw in let y = float dh /. float sh in bilinear_scale_coef src dst x y let onto ?(kind = Linear) ?(proportional = false) src dst = let sw, sh = (src.width, src.height) in let dw, dh = (dst.width, dst.height) in if dw = sw && dh = sh then blit_all src dst else if not proportional then scale_coef_kind kind src dst (dw, sw) (dh, sh) else ( let n, d = if dh * sw < sh * dw then (dh, sh) else (dw, sw) in scale_coef_kind kind src dst (n, d) (n, d)) let create ?kind ?(copy = true) ?proportional src w h = if (not copy) && width src = w && height src = h then src else ( let dst = create w h in onto ?kind ?proportional src dst; dst) end let scale ?proportional src dst = Scale.onto ?proportional src dst external to_BMP : t -> string = "caml_rgb_to_bmp" external to_RGB24_string : t -> string = "caml_image_to_rgb24" exception Invalid_format of string let of_PPM ?alpha data = let w, h, d, o = try (* TODO: make it useable without bound checks *) assert (data.[0] = 'P'); assert (data.[1] = '6'); assert (data.[2] = '\n'); let n = ref 3 in let read_int () = let ans = ref 0 in let ( !! ) = int_of_char in while !!'0' <= !!(data.[!n]) && !!(data.[!n]) <= !!'9' do ans := (!ans * 10) + !!(data.[!n]) - !!'0'; incr n done; assert (data.[!n] = ' ' || data.[!n] = '\n'); incr n; !ans in if data.[!n] = '#' then ( incr n; while data.[!n] <> '\n' do incr n done; incr n); let w = read_int () in let h = read_int () in let d = read_int () in (w, h, d, !n) with _ -> raise (Invalid_format "Not a PPM file.") in let datalen = String.length data - o in if d <> 255 then raise (Invalid_format (Printf.sprintf "Files of color depth %d are not handled." d)); if datalen < 3 * w * h then raise (Invalid_format (Printf.sprintf "Got %d bytes of data instead of expected %d." datalen (3 * w * h))); let ans = create w h in for j = 0 to h - 1 do for i = 0 to w - 1 do let r, g, b = ( int_of_char data.[o + (3 * ((j * w) + i)) + 0], int_of_char data.[o + (3 * ((j * w) + i)) + 1], int_of_char data.[o + (3 * ((j * w) + i)) + 2] ) in let a = match alpha with | Some (ra, ga, ba) -> if r = ra && g = ga && b = ba then 0x00 else 0xff | None -> 0xff in set_pixel ans i j (r, g, b, a) done done; ans external to_int_image : t -> int array array = "caml_rgb_to_color_array" (* let to_int_image buf = let w = buf.width in let h = buf.height in Array.init h (fun j -> Array.init w (fun i -> let r,g,b,a = get_pixel buf i j in (r lsl 16) + (g lsl 8) + b ) ) *) external add : t -> t -> unit = "caml_rgb_add" let add_fast = add external add_off : t -> t -> int -> int -> unit = "caml_rgb_add_off" external add_off_scale : t -> t -> int * int -> int * int -> unit = "caml_rgb_add_off_scale" let add ?(x = 0) ?(y = 0) ?w ?h src dst = match (w, h) with | None, None -> if x = 0 && y = 0 && src.width = dst.width && src.height = dst.height then add_fast src dst else add_off src dst x y | Some w, Some h -> add_off_scale src dst (x, y) (w, h) | _, _ -> assert false external swap_rb : t -> unit = "caml_rgba_swap_rb" module Effect = struct external greyscale : t -> bool -> unit = "caml_rgb_greyscale" let sepia buf = greyscale buf true let greyscale buf = greyscale buf false external invert : t -> unit = "caml_rgb_invert" external rotate : t -> float -> unit = "caml_rgb_rotate" external affine : t -> float -> float -> int -> int -> unit = "caml_rgb_affine" (* TODO: faster implementation? *) let translate f x y = affine f 1. 1. x y external flip : t -> unit = "caml_rgb_flip" external mask : t -> t -> unit = "caml_rgb_mask" external lomo : t -> unit = "caml_rgb_lomo" external box_blur : t -> unit = "caml_mm_RGBA8_box_blur" module Alpha = struct external scale : t -> float -> unit = "caml_rgb_scale_opacity" external blur : t -> unit = "caml_rgb_blur_alpha" external disk : t -> int -> int -> int -> unit = "caml_rgb_disk_opacity" external of_color_simple : t -> int * int * int -> int -> unit = "caml_rgb_color_to_alpha_simple" (* TODO: this does not work yet. *) (* external of_color : t -> int * int * int -> float -> float -> unit = "caml_rgb_color_to_alpha" *) let of_color = of_color_simple end end module Draw = struct external line : t -> int * int * int * int -> int * int -> int * int -> unit = "caml_mm_RGBA8_draw_line" end module Motion = struct (* TODO: compute old only once? *) let compute bs o n = Gray8.Motion.compute bs (to_Gray8_create o) (to_Gray8_create n) module Multi = struct include Motion_multi let compute bs o n = Gray8.Motion.Multi.compute bs (to_Gray8_create o) (to_Gray8_create n) external arrows : int -> vectors_data -> t -> unit = "caml_rgb_motion_multi_arrows" let arrows v img = arrows v.block_size v.vectors img end end end module YUV420 = struct type t = { mutable y : Data.t; mutable y_stride : int; mutable u : Data.t; mutable v : Data.t; mutable uv_stride : int; width : int; height : int; mutable alpha : Data.t option; (* alpha stride is y_stride *) } let width img = img.width let height img = img.height let dimensions img = (width img, height img) let y img = img.y let y_stride img = img.y_stride let u img = img.u let v img = img.v let uv_stride img = img.uv_stride let data img = (img.y, img.u, img.v) let alpha img = img.alpha let set_alpha img alpha = img.alpha <- alpha let size img = Data.size img.y + Data.size img.u + Data.size img.v let make width height y y_stride u v uv_stride = { y; y_stride; u; v; uv_stride; width; height; alpha = None } let make_data width height data y_stride uv_stride = assert (Data.length data = height * (y_stride + uv_stride)); let y = Data.sub data 0 (height * y_stride) in let u = Data.sub data (height * y_stride) (height / 2 * uv_stride) in let v = Data.sub data ((height * y_stride) + (height / 2 * uv_stride)) (height / 2 * uv_stride) in make width height y y_stride u v uv_stride let default_stride width y_stride uv_stride = let align = 4 in let y_stride = option_value ~default:(Data.round align width) y_stride in let uv_stride = option_value ~default:(Data.round align ((width + 1) / 2)) uv_stride in (y_stride, uv_stride) let create ?y_stride ?uv_stride width height = let align = 4 in let y_stride, uv_stride = default_stride width y_stride uv_stride in let y = Data.aligned align (height * y_stride) in let u, v = let height = Data.round 2 height in ( Data.aligned align (height / 2 * uv_stride), Data.aligned align (height / 2 * uv_stride) ) in make width height y y_stride u v uv_stride let ensure_alpha img = if img.alpha = None then ( let a = Data.alloc (img.height * img.y_stride) in Data.fill a 0xff; img.alpha <- Some a) let has_alpha img = img.alpha <> None let remove_alpha img = img.alpha <- None let of_YUV420_string ?y_stride ?uv_stride s width height = (* let y_stride, uv_stride = default_stride width y_stride uv_stride in *) let y_stride = option_value ~default:width y_stride in let uv_stride = option_value ~default:(width / 2) uv_stride in let data = Data.of_string s in make_data width height data y_stride uv_stride external of_RGB24_string : t -> string -> unit = "caml_yuv420_of_rgb24_string" let of_RGB24_string s width = let height = String.length s / (3 * width) in let img = create width height in of_RGB24_string img s; img external of_RGBA32 : RGBA32.t -> t -> unit = "caml_yuv420_of_rgba32" let of_RGBA32 rgb = let width = RGBA32.width rgb in let height = RGBA32.height rgb in let img = create width height in ensure_alpha img; of_RGBA32 rgb img; img external to_RGBA32 : t -> RGBA32.t -> unit = "caml_yuv420_to_rgba32" let to_RGBA32 img = let width = img.width in let height = img.height in let rgb = RGBA32.create width height in to_RGBA32 img rgb; rgb let of_PPM s = let img = of_RGBA32 (RGBA32.of_PPM s) in remove_alpha img; img let copy img = let dst = create ~y_stride:img.y_stride ~uv_stride:img.uv_stride img.width img.height in Bigarray.Array1.blit img.y dst.y; Bigarray.Array1.blit img.u dst.u; Bigarray.Array1.blit img.v dst.v; let alpha = match img.alpha with None -> None | Some alpha -> Some (Data.copy alpha) in dst.alpha <- alpha; dst external fill : t -> Pixel.yuv -> unit = "caml_yuv420_fill" let fill_alpha img a = if a = 0xff then img.alpha <- None else ( ensure_alpha img; Bigarray.Array1.fill (option_get img.alpha) a) let blank img = fill img (Pixel.yuv_of_rgb (0, 0, 0)) let blank_all = blank let blit_all src dst = assert (src.width = dst.width); assert (src.height = dst.height); if src.y_stride = dst.y_stride && src.uv_stride = dst.uv_stride then ( Data.blit src.y 0 dst.y 0 (dst.height * dst.y_stride); Data.blit src.u 0 dst.u 0 (dst.height / 2 * dst.uv_stride); Data.blit src.v 0 dst.v 0 (dst.height / 2 * dst.uv_stride); match src.alpha with | None -> dst.alpha <- None | Some alpha -> ( match dst.alpha with | None -> dst.alpha <- Some (Data.copy alpha) | Some alpha' -> Bigarray.Array1.blit alpha alpha')) else ( dst.y <- Data.copy src.y; dst.u <- Data.copy src.u; dst.v <- Data.copy src.v; dst.y_stride <- src.y_stride; dst.uv_stride <- src.uv_stride; match src.alpha with | None -> dst.alpha <- None | Some alpha -> dst.alpha <- Some (Data.copy alpha)) let blit src dst = blit_all src dst external randomize : t -> unit = "caml_yuv_randomize" external add : t -> int -> int -> t -> unit = "caml_yuv420_add" let add src ?(x = 0) ?(y = 0) dst = add src x y dst external set_pixel_rgba : t -> int -> int -> Pixel.rgba -> unit = "caml_yuv420_set_pixel_rgba" (* [@@noalloc] *) let set_pixel_rgba img i j ((_, _, _, a) as p) = assert (0 <= i && i < img.width && 0 <= j && j < img.height); if a <> 0xff then ensure_alpha img; set_pixel_rgba img i j p (* let set_pixel_rgba img i j (r,g,b,a) = let data = img.data in let width = img.width in let height = img.height in if img.alpha <> None || a <> 0xff then ( ensure_alpha img; Bigarray.Array1.set (option_get img.alpha) (j * width + i) a ); let y,u,v = Pixel.yuv_of_rgb (r,g,b) in Bigarray.Array1.set data (j * width + i) y; Bigarray.Array1.set data (height * width + (j / 2) * (width / 2) + i / 2) u; Bigarray.Array1.set data (height * width * 5 / 4 + (j / 2) * (width / 2) + i / 2) v *) let get_pixel_y img i j = Data.get img.y ((j * img.y_stride) + i) let get_pixel_u img i j = Data.get img.u ((j / 2 * img.uv_stride) + (i / 2)) let get_pixel_v img i j = Data.get img.v ((j / 2 * img.uv_stride) + (i / 2)) external get_pixel_rgba : t -> int -> int -> Pixel.rgba = "caml_yuv420_get_pixel_rgba" external to_int_image : t -> int array array = "caml_yuv420_to_int_image" external scale_full : t -> t -> unit = "caml_yuv420_scale" let scale_full src dst = if has_alpha src then ensure_alpha dst; scale_full src dst external scale_coef : t -> t -> int * int -> int * int -> unit = "caml_yuv420_scale_coef" let scale_proportional src dst = if has_alpha src then ensure_alpha dst; let sw, sh = (src.width, src.height) in let dw, dh = (dst.width, dst.height) in if dw = sw && dh = sh then blit_all src dst else ( let n, d = if dh * sw < sh * dw then (dh, sh) else (dw, sw) in scale_coef src dst (n, d) (n, d)) let scale ?(proportional = false) src dst = if proportional then scale_proportional src dst else scale_full src dst external scale_alpha : t -> float -> unit = "caml_yuv_scale_alpha" let scale_alpha img a = if a <> 1. then ( ensure_alpha img; scale_alpha img a) external disk_alpha : t -> int -> int -> int -> unit = "caml_yuv_disk_alpha" let disk_alpha img x y r = ensure_alpha img; disk_alpha img x y r external box_alpha : t -> int -> int -> int -> int -> float -> unit = "caml_yuv_box_alpha_bytecode" "caml_yuv_box_alpha_native" let box_alpha img x y r = ensure_alpha img; box_alpha img x y r module Effect = struct external greyscale : t -> unit = "caml_yuv_greyscale" let sepia _ = failwith "Not implemented: sepia" let invert _ = failwith "Not implemented: invert" let lomo _ = failwith "Not implemented: lomo" module Alpha = struct let scale = scale_alpha let disk = disk_alpha end end end module Generic = struct exception Not_implemented module Pixel = struct type rgb_format = | RGB24 (* 24 bit RGB. Each color is an uint8_t. Color order is RGBRGB *) | BGR24 (* 24 bit BGR. Each color is an uint8_t. Color order is BGRBGR *) | RGB32 (* 32 bit RGB. Each color is an uint8_t. Color order is RGBXRGBX, where X is unused *) | BGR32 (* 32 bit BGR. Each color is an uint8_t. Color order is BGRXBGRX, where X is unused *) | RGBA32 (* 32 bit RGBA. Each color is an uint8_t. Color order is RGBARGBA *) type yuv_format = | YUV422 (* Planar YCbCr 4:2:2. Each component is an uint8_t *) | YUV444 (* Planar YCbCr 4:4:4. Each component is an uint8_t *) | YUV411 (* Planar YCbCr 4:1:1. Each component is an uint8_t *) | YUV410 (* Planar YCbCr 4:1:0. Each component is an uint8_t *) | YUVJ420 (* Planar YCbCr 4:2:0. Each component is an uint8_t, * luma and chroma values are full range (0x00 .. 0xff) *) | YUVJ422 (* Planar YCbCr 4:2:2. Each component is an uint8_t, * luma and chroma values are full range (0x00 .. 0xff) *) | YUVJ444 (* Planar YCbCr 4:4:4. Each component is an uint8_t, luma and * chroma values are full range (0x00 .. 0xff) *) type format = RGB of rgb_format | YUV of yuv_format let size = function | RGB x -> ( match x with RGB24 | BGR24 -> 3 | RGB32 | BGR32 | RGBA32 -> 4) | YUV _ -> raise Not_implemented let string_of_format = function | RGB x -> ( match x with | RGB24 -> "RGB24" | BGR24 -> "BGR24" | RGB32 -> "RGB32" | BGR32 -> "BGR32" | RGBA32 -> "RGBA32") | YUV x -> ( match x with | YUV422 -> "YUV422" | YUV444 -> "YUV444" | YUV411 -> "YUV411" | YUV410 -> "YUV410" | YUVJ420 -> "YUVJ420" | YUVJ422 -> "YUVJ422" | YUVJ444 -> "YUVJ444") end type data = (int, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t type rgb = { rgb_pixel : Pixel.rgb_format; rgb_data : data; rgb_stride : int } type yuv = { yuv_pixel : Pixel.yuv_format; y : data; y_stride : int; u : data; v : data; uv_stride : int; } type t_data = RGB of rgb | YUV of yuv type t = { data : t_data; width : int; height : int } let rgb_data img = match img.data with | RGB rgb -> (rgb.rgb_data, rgb.rgb_stride) | _ -> assert false let yuv_data img = match img.data with | YUV yuv -> ((yuv.y, yuv.y_stride), (yuv.u, yuv.v, yuv.uv_stride)) | _ -> assert false let width img = img.width let height img = img.height let pixel_format img = match img.data with | RGB rgb -> Pixel.RGB rgb.rgb_pixel | YUV yuv -> Pixel.YUV yuv.yuv_pixel let make_rgb pix ?stride width height data = let stride = match stride with | Some s -> s | None -> width * Pixel.size (Pixel.RGB pix) in let rgb_data = { rgb_pixel = pix; rgb_data = data; rgb_stride = stride } in { data = RGB rgb_data; width; height } let of_RGBA32 img = let rgb_data = { rgb_pixel = Pixel.RGBA32; rgb_data = img.RGBA32.data; rgb_stride = img.RGBA32.stride; } in { data = RGB rgb_data; width = img.RGBA32.width; height = img.RGBA32.height; } let to_RGBA32 img = let rgb_data = match img.data with RGB d -> d | _ -> assert false in assert (rgb_data.rgb_pixel = Pixel.RGBA32); { RGBA32.data = rgb_data.rgb_data; width = img.width; height = img.height; stride = rgb_data.rgb_stride; } let of_YUV420 img = let yuv_data = { yuv_pixel = Pixel.YUVJ420; y = img.YUV420.y; y_stride = img.YUV420.y_stride; u = img.YUV420.u; v = img.YUV420.v; uv_stride = img.YUV420.uv_stride; } in { data = YUV yuv_data; width = img.YUV420.width; height = img.YUV420.height; } let to_YUV420 img = let yuv = match img.data with YUV yuv -> yuv | _ -> assert false in assert (yuv.yuv_pixel = Pixel.YUVJ420); YUV420.make img.width img.height yuv.y yuv.y_stride yuv.u yuv.v yuv.uv_stride external rgba32_to_bgr32 : data -> int -> data -> int -> int * int -> unit = "caml_RGBA32_to_BGR32" external rgb24_to_rgba32 : data -> int -> data -> int -> int * int -> unit = "caml_RGB24_to_RGBA32" external rgb32_to_rgba32 : data -> int -> data -> int -> int * int -> unit = "caml_RGB32_to_RGBA32" let blank img = match img.data with | RGB rgb -> ( match rgb.rgb_pixel with | Pixel.RGBA32 -> RGBA32.blank (to_RGBA32 img) | _ -> failwith "Not implemented") | YUV yuv -> ( match yuv.yuv_pixel with | Pixel.YUVJ420 -> YUV420.blank (to_YUV420 img) | _ -> failwith "Not implemented") let convert ?(proportional = true) ?scale_kind src dst = match (src.data, dst.data) with | RGB s, RGB d when s.rgb_pixel = Pixel.RGBA32 && d.rgb_pixel = Pixel.RGBA32 -> let src = to_RGBA32 src in let dst = to_RGBA32 dst in RGBA32.Scale.onto ?kind:scale_kind ~proportional src dst | YUV s, RGB d when s.yuv_pixel = Pixel.YUVJ420 && d.rgb_pixel = Pixel.RGBA32 -> let src = to_YUV420 src in let src = YUV420.to_RGBA32 src in let dst = to_RGBA32 dst in RGBA32.Scale.onto ?kind:scale_kind ~proportional src dst | RGB s, YUV d when s.rgb_pixel = Pixel.RGBA32 && d.yuv_pixel = Pixel.YUVJ420 -> let src = to_RGBA32 src in let src = YUV420.of_RGBA32 src in let dst = to_YUV420 dst in YUV420.scale ~proportional src dst | RGB s, RGB d when s.rgb_pixel = Pixel.RGBA32 && d.rgb_pixel = Pixel.BGR32 -> if src.width = dst.width && src.height = dst.height then rgba32_to_bgr32 s.rgb_data s.rgb_stride d.rgb_data d.rgb_stride (src.width, src.height) else raise Not_implemented | RGB s, RGB d when s.rgb_pixel = Pixel.RGB24 && d.rgb_pixel = Pixel.RGBA32 -> if src.width = dst.width && src.height = dst.height then rgb24_to_rgba32 s.rgb_data s.rgb_stride d.rgb_data d.rgb_stride (src.width, src.height) else raise Not_implemented | RGB s, RGB d when s.rgb_pixel = Pixel.RGB32 && d.rgb_pixel = Pixel.RGBA32 -> if src.width = dst.width && src.height = dst.height then rgb32_to_rgba32 s.rgb_data s.rgb_stride d.rgb_data d.rgb_stride (src.width, src.height) else raise Not_implemented | _ -> raise Not_implemented end ocaml-mm-0.7.3/src/image.mli000066400000000000000000000272071415601551300156100ustar00rootroot00000000000000(* * Copyright 2011 The Savonet Team * * This file is part of ocaml-mm. * * ocaml-mm is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * ocaml-mm 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 Lesser General Public License * along with ocaml-mm; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA * * As a special exception to the GNU Library General Public License, you may * link, statically or dynamically, a "work that uses the Library" with a publicly * distributed version of the Library to produce an executable file containing * portions of the Library, and distribute that executable file under terms of * your choice, without any of the additional requirements listed in clause 6 * of the GNU Library General Public License. * By "a publicly distributed version of the Library", we mean either the unmodified * Library as distributed by The Savonet Team, or a modified version of the Library that is * distributed under the conditions defined in clause 3 of the GNU Library General * Public License. This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU Library General Public License. * *) (** Operations on images. *) module Data : sig type t = (int, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t (** external alloc : int -> t = "caml_data_alloc" *) val alloc : int -> t val of_string : string -> t val to_string : t -> string val to_bytes : t -> bytes val length : t -> int val blit : t -> int -> t -> int -> int -> unit val blit_all : t -> t -> unit val copy : t -> t val round : int -> int -> int end module Pixel : sig type rgba = int * int * int * int type rgb = int * int * int type yuv = int * int * int type yuva = yuv * int val yuv_of_rgb : rgb -> yuv val rgb_of_yuv : yuv -> rgb end module Draw : sig val line : (int -> int -> unit) -> int * int -> int * int -> unit end (** Operations on images stored in RGB8 format, ie RGB channels, one byte each. *) module RGB8 : sig (** Operations on colors. *) module Color : sig (** An RGB8 color (values of components should be between 0 and 255). *) type t = int * int * int (** Decode a color stored as RGB. *) val of_int : int -> t end end module BGRA : sig type t val data : t -> Data.t end (** Operations on images stored in RGBA32 format (ie RGB channels + an alpha channel, one byte for each). *) module RGBA32 : sig module Color : sig type t = int * int * int * int end type data = (int, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t (** An image. *) type t val width : t -> int val height : t -> int val dimensions : t -> int * int val data : t -> data val size : t -> int val stride : t -> int val create : int -> int -> t (* Does not copy the data. Use [copy] for this. *) val make : ?stride:int -> int -> int -> data -> t val get_pixel : t -> int -> int -> Color.t val set_pixel : t -> int -> int -> Color.t -> unit val get_pixel_rgba : t -> int -> int -> Pixel.rgba val set_pixel_rgba : t -> int -> int -> Pixel.rgba -> unit val copy : t -> t val blit : ?blank:bool -> ?x:int -> ?y:int -> ?w:int -> ?h:int -> t -> t -> unit (** [blit_all src dst] copies all the contents of [src] into [dst]. *) val blit_all : t -> t -> unit (** {2 Conversions from/to other formats} *) val of_RGB24_string : string -> int -> t val to_RGB24_string : t -> string val of_BGRA : BGRA.t -> t val to_BGRA : t -> BGRA.t val to_int_image : t -> int array array val to_BMP : t -> string val of_PPM : ?alpha:RGB8.Color.t -> string -> t (** Swap red and blue channels. Useful for quickly handling BGRA formats. *) val swap_rb : t -> unit (** {2 Manipulation of images} *) val add : ?x:int -> ?y:int -> ?w:int -> ?h:int -> t -> t -> unit val fill_all : t -> Color.t -> unit val blank_all : t -> unit val fill_alpha : t -> int -> unit val blank : t -> unit val randomize_all : t -> unit val randomize : t -> unit (** [scale src dst] scales the image [src] to [dst]. *) val scale : ?proportional:bool -> t -> t -> unit module Scale : sig type kind = Linear | Bilinear val onto : ?kind:kind -> ?proportional:bool -> t -> t -> unit val create : ?kind:kind -> ?copy:bool -> ?proportional:bool -> t -> int -> int -> t end module Effect : sig (** Translate image. *) val translate : t -> int -> int -> unit (** Apply an affine transformation to an image. *) val affine : t -> float -> float -> int -> int -> unit (** Flip (mirror across horizontal axis). *) val flip : t -> unit (** Convert to greyscale. *) val greyscale : t -> unit (** Convert to sepia colors. *) val sepia : t -> unit (** Lomo effect on colors (see http://en.wikipedia.org/wiki/Lomo_effect ). *) val lomo : t -> unit (** Invert colors. *) val invert : t -> unit (** Rotate image by a given angle (in radians). *) val rotate : t -> float -> unit val mask : t -> t -> unit val box_blur : t -> unit (** Effects on alpha channel. *) module Alpha : sig val blur : t -> unit (** Scale alpha channel with a given coefficient. *) val scale : t -> float -> unit val disk : t -> int -> int -> int -> unit val of_color : t -> RGB8.Color.t -> int -> unit end end module Draw : sig val line : t -> Color.t -> int * int -> int * int -> unit end module Motion : sig val compute : int -> t -> t -> int * int module Multi : sig type vectors val compute : int -> t -> t -> vectors val median_denoise : vectors -> unit val mean : vectors -> int * int val arrows : vectors -> t -> unit end end end (** Operations on images stored in YUV420 format, ie one luma (Y) and two chrominance (U and V) channels. *) module YUV420 : sig (** An image in YUV420 format. *) type t val make : int -> int -> Data.t -> int -> Data.t -> Data.t -> int -> t val make_data : int -> int -> Data.t -> int -> int -> t val create : ?y_stride:int -> ?uv_stride:int -> int -> int -> t (** Ensure that the image has an alpha channel. *) val ensure_alpha : t -> unit val remove_alpha : t -> unit val of_YUV420_string : ?y_stride:int -> ?uv_stride:int -> string -> int -> int -> t val of_RGB24_string : string -> int -> t val of_RGBA32 : RGBA32.t -> t val to_RGBA32 : t -> RGBA32.t val of_PPM : string -> t (** Width of an image. *) val width : t -> int (** Height of an image. *) val height : t -> int val y : t -> Data.t val y_stride : t -> int val u : t -> Data.t val v : t -> Data.t val uv_stride : t -> int val data : t -> Data.t * Data.t * Data.t val alpha : t -> Data.t option val set_alpha : t -> Data.t option -> unit val dimensions : t -> int * int (** Size in bytes. *) val size : t -> int (** Whether the image has an alpha channel. *) val has_alpha : t -> bool (* (\** Obtaine data with given stride. No copy is made when possible. *\) *) (* val data_stride : t -> int -> int -> Data.t * Data.t * Data.t *) val copy : t -> t val blit_all : t -> t -> unit val blit : t -> t -> unit val scale : ?proportional:bool -> t -> t -> unit val blank_all : t -> unit (** Add the fist image to the second. *) val add : t -> ?x:int -> ?y:int -> t -> unit val blank : t -> unit val fill : t -> Pixel.yuv -> unit val fill_alpha : t -> int -> unit val disk_alpha : t -> int -> int -> int -> unit (* [box_alpha img x y width height alpha] Set alpha value on a given image box. *) val box_alpha : t -> int -> int -> int -> int -> float -> unit val randomize : t -> unit val get_pixel_y : t -> int -> int -> int val get_pixel_u : t -> int -> int -> int val get_pixel_v : t -> int -> int -> int val get_pixel_rgba : t -> int -> int -> Pixel.rgba val set_pixel_rgba : t -> int -> int -> Pixel.rgba -> unit (** Convert to format useable by [Graphics.make_image]. *) val to_int_image : t -> int array array module Effect : sig val greyscale : t -> unit val sepia : t -> unit val invert : t -> unit val lomo : t -> unit (** Effects on alpha channel. *) module Alpha : sig (** Scale alpha channel with a given coefficient. *) val scale : t -> float -> unit val disk : t -> int -> int -> int -> unit end end end (** Operations on images in generic formats (many formats are supported). *) module Generic : sig (** Since the module is very generic, many of the functions are not implemented for particular formats. This exception is raised when it is the case. *) exception Not_implemented (** Generic pixels. *) module Pixel : sig (** Format of an RGB pixel. *) type rgb_format = | RGB24 (** 24 bit RGB. Each color is an uint8_t. Color order is RGBRGB *) | BGR24 (** 24 bit BGR. Each color is an uint8_t. Color order is BGRBGR *) | RGB32 (** 32 bit RGB. Each color is an uint8_t. Color order is RGBXRGBX, where X is unused *) | BGR32 (** 32 bit BGR. Each color is an uint8_t. Color order is BGRXBGRX, where X is unused *) | RGBA32 (** 32 bit RGBA. Each color is an uint8_t. Color order is RGBARGBA *) (** Format of a YUV pixel. *) type yuv_format = | YUV422 (** Planar YCbCr 4:2:2. Each component is an uint8_t *) | YUV444 (** Planar YCbCr 4:4:4. Each component is an uint8_t *) | YUV411 (** Planar YCbCr 4:1:1. Each component is an uint8_t *) | YUV410 (** Planar YCbCr 4:1:0. Each component is an uint8_t *) | YUVJ420 (** Planar YCbCr 4:2:0. Each component is an uint8_t, luma and chroma values are full range (0x00 .. 0xff) *) | YUVJ422 (** Planar YCbCr 4:2:2. Each component is an uint8_t, luma and chroma values are full range (0x00 .. 0xff) *) | YUVJ444 (** Planar YCbCr 4:4:4. Each component is an uint8_t, luma and chroma values are full range (0x00 .. 0xff) *) (** Format of a pixel. *) type format = RGB of rgb_format | YUV of yuv_format (** String representation of the format of a pixel. *) val string_of_format : format -> string end (** Data contents of an image. *) type data = (int, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t (** An image. *) type t (** Width of an image. *) val width : t -> int (** Height of an image. *) val height : t -> int (** Pixel format of an image. *) val pixel_format : t -> Pixel.format (** Create a new image of RGB format. *) val make_rgb : Pixel.rgb_format -> ?stride:int -> int -> int -> data -> t (** Data and stride of an RGB image. *) val rgb_data : t -> data * int (** Data of a YUV image. *) val yuv_data : t -> (data * int) * (data * data * int) (** Create a generic image from an RGBA32 image. *) val of_RGBA32 : RGBA32.t -> t val to_RGBA32 : t -> RGBA32.t (** Create a generic image from a YUV420 image. *) val of_YUV420 : YUV420.t -> t val to_YUV420 : t -> YUV420.t val blank : t -> unit (** Convert a generic image from a format to another. *) val convert : ?proportional:bool -> ?scale_kind:RGBA32.Scale.kind -> t -> t -> unit end ocaml-mm-0.7.3/src/image_data.c000066400000000000000000000101751415601551300162360ustar00rootroot00000000000000#define CAML_INTERNALS 1 #include #include #include #include #include #include #include #include #include #include #include #include "image_data.h" #ifndef Bytes_val #define Bytes_val String_val #endif // See: https://github.com/ocaml/ocaml/pull/10788 #ifdef HAS_CAML_INTERNALS CAMLexport value caml_mm_ba_alloc(int flags, int num_dims, void *data, intnat *dim) { uintnat num_elts, asize, size; int i; value res; struct caml_ba_array *b; intnat dimcopy[CAML_BA_MAX_NUM_DIMS]; CAMLassert(num_dims >= 0 && num_dims <= CAML_BA_MAX_NUM_DIMS); CAMLassert((flags & CAML_BA_KIND_MASK) <= CAML_BA_CHAR); for (i = 0; i < num_dims; i++) dimcopy[i] = dim[i]; size = 0; num_elts = 1; for (i = 0; i < num_dims; i++) { if (caml_umul_overflow(num_elts, dimcopy[i], &num_elts)) caml_raise_out_of_memory(); } if (caml_umul_overflow( num_elts, caml_ba_element_size[flags & CAML_BA_KIND_MASK], &size)) caml_raise_out_of_memory(); if (data == NULL) { data = malloc(size); if (data == NULL && size != 0) caml_raise_out_of_memory(); flags |= CAML_BA_MANAGED; } asize = SIZEOF_BA_ARRAY + num_dims * sizeof(intnat); res = caml_alloc_custom_mem(&caml_ba_ops, asize, size); b = Caml_ba_array_val(res); b->data = data; b->num_dims = num_dims; b->flags = flags; b->proxy = NULL; for (i = 0; i < num_dims; i++) b->dim[i] = dimcopy[i]; return res; } CAMLexport value caml_mm_ba_alloc_dims(int flags, int num_dims, void *data, ...) { va_list ap; intnat dim[CAML_BA_MAX_NUM_DIMS]; int i; value res; CAMLassert(num_dims <= CAML_BA_MAX_NUM_DIMS); va_start(ap, data); for (i = 0; i < num_dims; i++) dim[i] = va_arg(ap, intnat); va_end(ap); res = caml_mm_ba_alloc(flags, num_dims, data, dim); return res; } #endif CAMLprim value caml_data_aligned(value _alignment, value _len) { CAMLparam2(_alignment, _len); CAMLlocal1(ans); int alignment = Int_val(_alignment); int len = Int_val(_len); unsigned char *data; if (alignment < ALIGNMENT_BYTES) { alignment = ALIGNMENT_BYTES; } #ifdef HAS_CAML_INTERNALS ALIGNED_ALLOC(data, alignment, len); ans = caml_mm_ba_alloc_dims( CAML_BA_MANAGED | CAML_BA_C_LAYOUT | CAML_BA_UINT8, 1, data, len); #else ans = caml_mm_ba_alloc_dims( CAML_BA_MANAGED | CAML_BA_C_LAYOUT | CAML_BA_UINT8, 1, NULL, len); ALIGNED_ALLOC(data, alignment, len); free(Caml_ba_data_val(ans)); Caml_ba_array_val(ans)->data = data; #endif CAMLreturn(ans); } CAMLprim value caml_data_of_string(value s) { CAMLparam1(s); CAMLlocal1(ans); long len = caml_string_length(s); unsigned char *data = malloc(len); if (data == NULL) caml_raise_out_of_memory(); memcpy(data, String_val(s), len); ans = caml_mm_ba_alloc_dims( CAML_BA_MANAGED | CAML_BA_C_LAYOUT | CAML_BA_UINT8, 1, data, len); CAMLreturn(ans); } CAMLprim value caml_data_to_string(value _data) { CAMLparam1(_data); CAMLlocal1(ans); unsigned char *data = Caml_ba_data_val(_data); long len = Caml_ba_array_val(_data)->dim[0]; ans = caml_alloc_string(len); memcpy(Bytes_val(ans), data, len); CAMLreturn(ans); } CAMLprim value caml_data_copy(value _src) { CAMLparam1(_src); CAMLlocal1(ans); unsigned char *src = Caml_ba_data_val(_src); long len = Caml_ba_array_val(_src)->dim[0]; unsigned char *dst = malloc(len); if (dst == NULL) caml_raise_out_of_memory(); memcpy(dst, src, len); ans = caml_mm_ba_alloc_dims( CAML_BA_MANAGED | CAML_BA_C_LAYOUT | CAML_BA_UINT8, 1, dst, len); CAMLreturn(ans); } CAMLprim value caml_data_blit_off(value _src, value _soff, value _dst, value _doff, value _len) { CAMLparam5(_src, _soff, _dst, _doff, _len); int soff = Int_val(_soff); int doff = Int_val(_doff); int len = Int_val(_len); unsigned char *src = Caml_ba_data_val(_src); unsigned char *dst = Caml_ba_data_val(_dst); memcpy(dst + doff, src + soff, len); CAMLreturn(Val_unit); } ocaml-mm-0.7.3/src/image_data.h000066400000000000000000000034111415601551300162360ustar00rootroot00000000000000#include "config.h" #ifdef HAS_MAX_ALIGN_T #include #include #define ALIGNMENT_BYTES alignof(max_align_t) #else #define ALIGNMENT_BYTES 16 #endif #if !defined(WIN32) && defined(HAS_ALIGNED_ALLOC) #include #include #define ALIGNED_ALLOC(data, alignment, len) \ { \ data = aligned_alloc(alignment, len); \ if (data == NULL) \ uerror("aligned_alloc", Nothing); \ } #elif defined(HAS_MEMALIGN) #include #include #define ALIGNED_ALLOC(data, alignment, len) \ { \ data = memalign(alignment, len); \ if (data == NULL) \ uerror("memalign", Nothing); \ } #else #define ALIGNED_ALLOC(data, alignment, len) \ { \ data = malloc(len + 0 * alignment); \ if (data == NULL) \ caml_raise_out_of_memory(); \ } #endif #ifdef HAS_CAML_INTERNALS CAMLextern value caml_mm_ba_alloc_dims(int flags, int num_dims, void *data, ...); #else #define caml_mm_ba_alloc_dims caml_ba_alloc_dims #endif ocaml-mm-0.7.3/src/image_pixel.c000066400000000000000000000015441415601551300164460ustar00rootroot00000000000000#include #include #include #include "image_pixel.h" CAMLprim value caml_yuv_of_rgb(value rgb) { CAMLparam1(rgb); CAMLlocal1(ans); int r = Int_val(Field(rgb, 0)); int g = Int_val(Field(rgb, 1)); int b = Int_val(Field(rgb, 2)); ans = caml_alloc_tuple(3); Store_field(ans, 0, Val_int(YofRGB(r, g, b))); Store_field(ans, 1, Val_int(UofRGB(r, g, b))); Store_field(ans, 2, Val_int(VofRGB(r, g, b))); CAMLreturn(ans); } CAMLprim value caml_rgb_of_yuv(value yuv) { CAMLparam1(yuv); CAMLlocal1(ans); int y = Int_val(Field(yuv, 0)); int u = Int_val(Field(yuv, 1)); int v = Int_val(Field(yuv, 2)); ans = caml_alloc_tuple(3); Store_field(ans, 0, Val_int(RofYUV(y, u, v))); Store_field(ans, 1, Val_int(GofYUV(y, u, v))); Store_field(ans, 2, Val_int(BofYUV(y, u, v))); CAMLreturn(ans); } ocaml-mm-0.7.3/src/image_pixel.h000066400000000000000000000024341415601551300164520ustar00rootroot00000000000000#define CLIP(color) \ (unsigned char)(((color) > 0xff) ? 0xff : (((color) < 0) ? 0 : (color))) // studio swing /* #define YofRGB(r,g,b) CLIP(((66 * r + 129 * g + 25 * b + 128) >> 8) + 16) */ /* #define UofRGB(r,g,b) CLIP(((-38 * r - 74 * g + 112 * b + 128) >> 8) + 128) */ /* #define UofRGB(r,g,b) CLIP(((112 * r - 94 * g - 18 * b + 128) >> 8) + 128) */ /* #define RofYUV(y,u,v) CLIP((298 * (y - 16) + 409 * (v - 128) + 128) >> 8) */ /* #define GofYUV(y,u,v) CLIP((298 * (y - 16) - 100 * (u - 128) - 208 * (v - * 128) + 128) >> 8) */ /* #define BofYUV(y,u,v) CLIP((298 * (y - 16) + 516 * (u - 128) + 128) >> 8) */ // full swing #define YofRGB(r, g, b) CLIP((19595 * r + 38470 * g + 7471 * b) >> 16) #define UofRGB(r, g, b) \ CLIP((36962 * (b - CLIP((19595 * r + 38470 * g + 7471 * b) >> 16)) >> 16) + \ 128) #define VofRGB(r, g, b) \ CLIP((46727 * (r - CLIP((19595 * r + 38470 * g + 7471 * b) >> 16)) >> 16) + \ 128) #define RofYUV(y, u, v) CLIP(y + (91881 * v >> 16) - 179) #define GofYUV(y, u, v) CLIP(y - ((22544 * u + 46793 * v) >> 16) + 135) #define BofYUV(y, u, v) CLIP(y + (116129 * u >> 16) - 226) ocaml-mm-0.7.3/src/image_rgb.c000066400000000000000000001260671415601551300161070ustar00rootroot00000000000000/* * Copyright 2011 The Savonet Team * * This file is part of ocaml-mm. * * ocaml-mm is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * ocaml-mm 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 Lesser General Public License * along with ocaml-mm; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA * * As a special exception to the GNU Library General Public License, you may * link, statically or dynamically, a "work that uses the Library" with a * publicly distributed version of the Library to produce an executable file * containing portions of the Library, and distribute that executable file under * terms of your choice, without any of the additional requirements listed in * clause 6 of the GNU Library General Public License. By "a publicly * distributed version of the Library", we mean either the unmodified Library as * distributed by The Savonet Team, or a modified version of the Library that is * distributed under the conditions defined in clause 3 of the GNU Library * General Public License. This exception does not however invalidate any other * reasons why the executable file might be covered by the GNU Library General * Public License. * */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #ifdef WIN32 #include #else #include #endif #include "config.h" #include "image_data.h" #include "image_pixel.h" #include "image_rgb.h" // MMX invert is broken at the moment.. #undef HAVE_MMX #ifdef HAVE_MMX #include #endif // For OCaml < 3.10 #ifndef caml_ba_array #define caml_ba_array caml_bigarray #ifndef Caml_ba_array_val #define Caml_ba_array_val(v) ((struct caml_ba_array *)Data_custom_val(v)) #endif #define Caml_ba_data_val(v) (Caml_ba_array_val(v)->data) #define caml_ba_alloc alloc_bigarray #define CAML_BA_C_LAYOUT BIGARRAY_C_LAYOUT #define CAML_BA_UINT8 BIGARRAY_UINT8 #define CAML_BA_MANAGED BIGARRAY_MANAGED #endif #ifndef WIN32 #define max(a, b) (a > b) ? a : b #define min(a, b) (a < b) ? a : b #endif #ifndef Bytes_val #define Bytes_val String_val #endif /* Remark, this returns an integer, which means that it might be ordered in little-endian... */ static inline int int_rgb8_of_pixel(frame *rgb, int i, int j) { int p = Int_pixel(rgb, i, j); /* Endianness... */ p = ntohl(p); unsigned char a = p & 0xff; if (a == 0xff) return (p >> 8); else if (a == 0) return 0; else { /* TODO: why doesn't this work? */ // return ((p >> 8) * a / 0xff); int r = (p >> 24) & 0xff; int g = (p >> 16) & 0xff; int b = (p >> 8) & 0xff; int c = ((r * a / 0xff) << 16) + ((g * a / 0xff) << 8) + (b * a / 0xff); return c; } } static void rgb_free(frame *f) { free(f->data); } static inline void rgb_blank(frame *rgb) { memset(rgb->data, 0, Rgb_data_size(rgb)); } static frame *rgb_copy(frame *src, frame *dst) { dst->width = src->width; dst->height = src->height; dst->stride = src->stride; ALIGNED_ALLOC(dst->data, ALIGNMENT_BYTES, Rgb_data_size(src)); memcpy(dst->data, src->data, Rgb_data_size(src)); return dst; } CAMLprim value caml_rgb_blank(value _rgb) { frame rgb; rgb_blank(frame_of_value(_rgb, &rgb)); return Val_unit; } CAMLprim value caml_rgb_blit(value _src, value _dst) { frame src, dst; frame_of_value(_src, &src); frame_of_value(_dst, &dst); assert_same_dim(&src, &dst); memcpy(dst.data, src.data, Rgb_data_size(&src)); return Val_unit; } CAMLprim value caml_rgb_blit_off(value _src, value _dst, value _dx, value _dy, value _blank) { CAMLparam2(_src, _dst); frame src, dst; frame_of_value(_src, &src); frame_of_value(_dst, &dst); int dx = Int_val(_dx), dy = Int_val(_dy); int blank = Bool_val(_blank); int i, j, c; int istart = max(0, dx), iend = min(dst.width, src.width + dx), jstart = max(0, dy), jend = min(dst.height, src.height + dy); caml_enter_blocking_section(); /* Blank what's outside src */ if (blank) /* for (j = 0; j < dst.height; j++) { for (i = 0; i < dst.width; i++) { if (j < jend && j > jstart && i == istart) { if (iend == dst.width) break; else i = iend; } for (c = 0; c < Rgb_elems_per_pixel; c++) Color(&dst, c, i, j) = 0; } } */ /* This one seems to be much faster... */ rgb_blank(&dst); /* Copy src to dst for the rest */ for (j = jstart; j < jend; j++) for (i = istart; i < iend; i++) for (c = 0; c < Rgb_elems_per_pixel; c++) Color(&dst, c, i, j) = Color(&src, c, (i - dx), (j - dy)); caml_leave_blocking_section(); CAMLreturn(Val_unit); } CAMLprim value caml_rgb_blit_off_scale(value _src, value _dst, value d, value dim, value _blank) { CAMLparam2(_src, _dst); frame src, dst; frame_of_value(_src, &src); frame_of_value(_dst, &dst); int dx = Int_val(Field(d, 0)), dy = Int_val(Field(d, 1)), w = Int_val(Field(dim, 0)), h = Int_val(Field(dim, 1)); int blank = Bool_val(_blank); int i, j, c; int istart = max(0, dx), iend = min(dst.width, w + dx), jstart = max(0, dy), jend = min(dst.height, h + dy); caml_enter_blocking_section(); if (blank) rgb_blank(&dst); for (j = jstart; j < jend; j++) for (i = istart; i < iend; i++) for (c = 0; c < Rgb_elems_per_pixel; c++) Color(&dst, c, i, j) = Color(&src, c, (i - dx) * src.width / w, (j - dy) * src.height / h); caml_leave_blocking_section(); CAMLreturn(Val_unit); } CAMLprim value caml_rgb_fill(value f, value col) { CAMLparam2(f, col); frame rgb; frame_of_value(f, &rgb); int r = Int_val(Field(col, 0)), g = Int_val(Field(col, 1)), b = Int_val(Field(col, 2)), a = Int_val(Field(col, 3)); int i, j; caml_enter_blocking_section(); for (j = 0; j < rgb.height; j++) for (i = 0; i < rgb.width; i++) { Red(&rgb, i, j) = r; Green(&rgb, i, j) = g; Blue(&rgb, i, j) = b; Alpha(&rgb, i, j) = a; } caml_leave_blocking_section(); CAMLreturn(Val_unit); } CAMLprim value caml_rgb_fill_alpha(value f, value _a) { CAMLparam2(f, _a); frame rgb; frame_of_value(f, &rgb); int a = Int_val(_a); int i, j; caml_enter_blocking_section(); for (j = 0; j < rgb.height; j++) for (i = 0; i < rgb.width; i++) Alpha(&rgb, i, j) = a; caml_leave_blocking_section(); CAMLreturn(Val_unit); } CAMLprim value caml_mm_RGBA8_to_Gray8(value _rgb, value _gray) { CAMLparam2(_rgb, _gray); frame rgb; frame_of_value(_rgb, &rgb); uint8 *gray = Caml_ba_data_val(_gray); int i, j; caml_enter_blocking_section(); for (j = 0; j < rgb.height; j++) for (i = 0; i < rgb.width; i++) gray[j * rgb.width + i] = ((int)Red(&rgb, i, j) + Green(&rgb, i, j) + Blue(&rgb, i, j)) / 3; caml_leave_blocking_section(); CAMLreturn(Val_unit); } CAMLprim value caml_rgb_of_rgb8_string(value _rgb, value _data) { CAMLparam2(_rgb, _data); frame rgb; frame_of_value(_rgb, &rgb); int datalen = rgb.height * rgb.width * 3; char *data; ALIGNED_ALLOC(data, ALIGNMENT_BYTES, datalen); memcpy(data, String_val(_data), datalen); int i, j; caml_enter_blocking_section(); for (j = 0; j < rgb.height; j++) for (i = 0; i < rgb.width; i++) { Red(&rgb, i, j) = data[3 * (j * rgb.width + i) + 0]; Green(&rgb, i, j) = data[3 * (j * rgb.width + i) + 1]; Blue(&rgb, i, j) = data[3 * (j * rgb.width + i) + 2]; Alpha(&rgb, i, j) = 0xff; } caml_leave_blocking_section(); free(data); CAMLreturn(Val_unit); } CAMLprim value caml_rgba_of_bgra(value _rgba, value _bgra) { CAMLparam2(_rgba, _bgra); frame rgba, bgra; frame_of_value(_rgba, &rgba); frame_of_value(_bgra, &bgra); int i, j; caml_enter_blocking_section(); for (j = 0; j < bgra.height; j++) for (i = 0; i < bgra.width; i++) { Red(&rgba, i, j) = Color(&bgra, 2, i, j); Green(&rgba, i, j) = Color(&bgra, 1, i, j); Blue(&rgba, i, j) = Color(&bgra, 0, i, j); Alpha(&rgba, i, j) = Color(&bgra, 3, i, j); } caml_leave_blocking_section(); CAMLreturn(Val_unit); } CAMLprim value caml_rgb_get_pixel(value f, value _x, value _y) { CAMLparam1(f); CAMLlocal1(ans); frame rgb; frame_of_value(f, &rgb); int x = Int_val(_x); int y = Int_val(_y); unsigned char pix[Rgb_elems_per_pixel] = Pixel(&rgb, x, y); int i; ans = caml_alloc_tuple(Rgb_elems_per_pixel); for (i = 0; i < Rgb_elems_per_pixel; i++) Store_field(ans, i, Val_int(pix[i])); CAMLreturn(ans); } CAMLprim value caml_rgb_set_pixel(value f, value _x, value _y, value _rgb) { frame rgb; frame_of_value(f, &rgb); int x = Int_val(_x), y = Int_val(_y); int r = Int_val(Field(_rgb, 0)); int g = Int_val(Field(_rgb, 1)); int b = Int_val(Field(_rgb, 2)); int a = Int_val(Field(_rgb, 3)); Red(&rgb, x, y) = r; Green(&rgb, x, y) = g; Blue(&rgb, x, y) = b; Alpha(&rgb, x, y) = a; return Val_unit; } CAMLprim value caml_rgb_randomize(value f) { CAMLparam1(f); frame rgb; frame_of_value(f, &rgb); int i, j, c; caml_enter_blocking_section(); for (j = 0; j < rgb.height; j++) for (i = 0; i < rgb.width; i++) { Alpha(&rgb, i, j) = 0xff; for (c = 0; c < Rgb_colors; c++) Color(&rgb, c, i, j) = rand(); } caml_leave_blocking_section(); CAMLreturn(Val_unit); } CAMLprim value caml_rgb_scale(value _src, value _dst, value xscale, value yscale) { CAMLparam4(_dst, _src, xscale, yscale); frame src, dst; frame_of_value(_src, &src); frame_of_value(_dst, &dst); int i, j; int xn = Int_val(Field(xscale, 0)), xd = Int_val(Field(xscale, 1)), yn = Int_val(Field(yscale, 0)), yd = Int_val(Field(yscale, 1)); int ox = (dst.width - src.width * xn / xd) / 2, oy = (dst.height - src.height * yn / yd) / 2; assert(ox >= 0 && oy >= 0); caml_enter_blocking_section(); if (ox != 0 || oy != 0) rgb_blank(&dst); for (j = oy; j < dst.height - oy; j++) for (i = ox; i < dst.width - ox; i++) // for (c = 0; c < Rgb_elems_per_pixel; c++) // Color(&dst, c, i, j) = Color(&src, c, (i - ox) * xd / xn, (j - oy) * yd // / yn); Copy_pixel(&dst, i, j, &src, (i - ox) * xd / xn, (j - oy) * yd / yn); caml_leave_blocking_section(); CAMLreturn(Val_unit); } CAMLprim value caml_rgb_bilinear_scale(value _src, value _dst, value xscale, value yscale) { CAMLparam2(_src, _dst); frame src, dst; frame_of_value(_src, &src); frame_of_value(_dst, &dst); int i, j, c, i2, j2; /* Scaling coefficients. */ float ax = Double_val(xscale), ay = Double_val(yscale); /* Since the scaled image might not fill dst, we center it. These are the offsets of the scaled image in dst. */ int ox = (dst.width - src.width * ax) / 2, oy = (dst.height - src.height * ay) / 2; float dx, dy; int p00, p01, p10, p11; assert(ox >= 0 && oy >= 0); caml_enter_blocking_section(); /* TODO: only blank what is necessary. */ if (ox != 0 || oy != 0) rgb_blank(&dst); for (j = oy; j < dst.height + oy; j++) for (i = ox; i < dst.width + ox; i++) { dx = (i - ox) / ax; // Corresponding pixel in src i2 = floor(dx); // Nearest pixel on the left dx -= i2; // Distance to the nearest pixel on the left dy = (j - oy) / ay; j2 = floor(dy); dy -= j2; if (i2 + 1 < src.width && j2 + 1 < src.height) for (c = 0; c < Rgb_elems_per_pixel; c++) { p00 = Color(&src, c, i2, j2); p10 = Color(&src, c, i2 + 1, j2); p01 = Color(&src, c, i2, j2 + 1); p11 = Color(&src, c, i2 + 1, j2 + 1); Color(&dst, c, i, j) = CLIP(p00 * (1 - dx) * (1 - dy) + p10 * dx * (1 - dy) + p01 * (1 - dx) * dy + p11 * dx * dy); } else for (c = 0; c < Rgb_elems_per_pixel; c++) Color(&dst, c, i, j) = (i2 < src.width && j2 < src.height) ? Color(&src, c, i2, j2) : 0; } caml_leave_blocking_section(); CAMLreturn(Val_unit); } /* CAMLprim value caml_rgb_scale(value _dst, value _src) { CAMLparam2(_src,_dst); frame src,dst; frame_of_value(_src, &src); frame_of_value(_dst, &dst); int i, j, c; caml_enter_blocking_section(); for (j = 0; j < dst.height; j++) for (i = 0; i < dst.width; i++) for (c = 0; c < Rgb_elems_per_pixel; c++) Color(&dst, c, i, j) = Color(&src, c, i * src.width / dst.width, j * src.height / dst.height); caml_leave_blocking_section(); CAMLreturn(Val_unit); } CAMLprim value caml_rgb_proportional_scale(value _dst, value _src) { CAMLparam2(_src,_dst); frame src,dst; frame_of_value(_src, &src); frame_of_value(_dst, &dst); int i, j, c; int cn, cd, ox, oy; if (dst.height * src.width < src.height * dst.width) { cn = dst.height; cd = src.height; ox = (dst.width - src.width * cn / cd) / 2; oy = 0; } else { cn = dst.width; cd = src.width; ox = 0; oy = (dst.height - src.height * cn / cd) / 2; } caml_enter_blocking_section(); rgb_blank(&dst); for (j = oy; j < dst.height - oy; j++) for (i = ox; i < dst.width - ox; i++) for (c = 0; c < Rgb_elems_per_pixel; c++) Color(&dst, c, i, j) = Color(&src, c, (i - ox) * cd / cn, (j - oy) * cd / cn); caml_leave_blocking_section(); CAMLreturn(Val_unit); } */ static void bmp_pint32(char *dst, int n) { dst[0] = n & 0xff; dst[1] = (n >> 8) & 0xff; dst[2] = (n >> 16) & 0xff; dst[3] = (n >> 24) & 0xff; } static void bmp_pint16(char *dst, int n) { dst[0] = n & 0xff; dst[1] = (n >> 8) & 0xff; } /* See http://en.wikipedia.org/wiki/BMP_file_format */ CAMLprim value caml_rgb_to_bmp(value _rgb) { CAMLparam1(_rgb); CAMLlocal1(ans); frame rgb; frame_of_value(_rgb, &rgb); int len = Rgb_num_pix(&rgb); char *bmp = malloc(122 + 4 * len); if (bmp == NULL) caml_raise_out_of_memory(); int i, j; caml_enter_blocking_section(); bmp[0] = 'B'; /* Magic number */ bmp[1] = 'M'; bmp_pint32(bmp + 2, 122 + 4 * len); /* File size */ bmp_pint16(bmp + 6, 0); /* Reserved */ bmp_pint16(bmp + 8, 0); /* Reserved */ bmp_pint32(bmp + 10, 122); /* Data offset */ bmp_pint32(bmp + 14, 108); /* Second header size */ bmp_pint32(bmp + 18, rgb.width); /* Width */ bmp_pint32(bmp + 22, rgb.height); /* Height */ bmp_pint16(bmp + 26, 1); /* Nb of color planes */ bmp_pint16(bmp + 28, 32); /* BPP */ bmp_pint32(bmp + 30, 3); /* Compression: bitfields */ bmp_pint32(bmp + 34, 4 * len); /* Image size */ bmp_pint32(bmp + 38, 2835); /* Horizontal resolution */ bmp_pint32(bmp + 42, 2835); /* Vertical resolution */ bmp_pint32(bmp + 46, 0); /* Number of colors */ bmp_pint32(bmp + 50, 0); /* Number of important colors */ bmp_pint32(bmp + 54, 0x00ff0000); /* Red mask */ bmp_pint32(bmp + 58, 0x0000ff00); /* Green mask */ bmp_pint32(bmp + 62, 0x000000ff); /* Blue mask */ bmp_pint32(bmp + 66, 0xff000000); /* Alpha mask */ bmp_pint32(bmp + 70, 0x57696e20); /* Type of color space */ for (i = 0; i < 12; i++) bmp_pint32(bmp + 74 + 4 * i, 0); /* Unused */ for (j = 0; j < rgb.height; j++) for (i = 0; i < rgb.width; i++) { bmp[4 * ((rgb.height - j - 1) * rgb.width + i) + 0 + 122] = Blue(&rgb, i, j); bmp[4 * ((rgb.height - j - 1) * rgb.width + i) + 1 + 122] = Green(&rgb, i, j); bmp[4 * ((rgb.height - j - 1) * rgb.width + i) + 2 + 122] = Red(&rgb, i, j); bmp[4 * ((rgb.height - j - 1) * rgb.width + i) + 3 + 122] = Alpha(&rgb, i, j); } caml_leave_blocking_section(); ans = caml_alloc_string(122 + 4 * len); memcpy(Bytes_val(ans), bmp, 122 + 4 * len); free(bmp); CAMLreturn(ans); } /* TODO: share code with to_bmp */ CAMLprim value caml_image_to_rgb24(value _rgb) { CAMLparam1(_rgb); CAMLlocal1(ans); frame rgb; frame_of_value(_rgb, &rgb); int len = Rgb_num_pix(&rgb); char *bmp = malloc(3 * len); if (bmp == NULL) caml_raise_out_of_memory(); int i, j; unsigned char a; caml_enter_blocking_section(); for (j = 0; j < rgb.height; j++) for (i = 0; i < rgb.width; i++) { a = Alpha(&rgb, i, j); bmp[3 * ((rgb.height - j - 1) * rgb.width + i) + 0] = Red(&rgb, i, j) * a / 0xff; bmp[3 * ((rgb.height - j - 1) * rgb.width + i) + 1] = Green(&rgb, i, j) * a / 0xff; bmp[3 * ((rgb.height - j - 1) * rgb.width + i) + 2] = Blue(&rgb, i, j) * a / 0xff; } caml_leave_blocking_section(); ans = caml_alloc_string(3 * len); memcpy(Bytes_val(ans), bmp, 3 * len); free(bmp); CAMLreturn(ans); } CAMLprim value caml_rgb_to_color_array(value _rgb) { CAMLparam1(_rgb); CAMLlocal2(ans, line); frame rgb; frame_of_value(_rgb, &rgb); int i, j, c; // unsigned char a; ans = caml_alloc_tuple(rgb.height); for (j = 0; j < rgb.height; j++) { line = caml_alloc_tuple(rgb.width); for (i = 0; i < rgb.width; i++) { /* a = Alpha(&rgb, i, j); c = ((Red(&rgb,i,j) * a / 0xff) << 16) + ((Green(&rgb,i,j) * a / 0xff) << 8) + (Blue(&rgb,i,j) * a / 0xff); */ c = int_rgb8_of_pixel(&rgb, i, j); Store_field(line, i, Val_int(c)); } Store_field(ans, j, line); } CAMLreturn(ans); } CAMLprim value caml_mm_RGBA8_box_blur(value _rgb) { CAMLparam1(_rgb); frame rgb; frame_of_value(_rgb, &rgb); int i, j; caml_enter_blocking_section(); for (j = 1; j < rgb.height - 1; j++) for (i = 1; i < rgb.width - 1; i++) { Red(&rgb, i, j) = (Red(&rgb, i - 1, j) + Red(&rgb, i + 1, j) + Red(&rgb, i, j - 1) + Red(&rgb, i, j + 1)) / 4; Green(&rgb, i, j) = (Green(&rgb, i - 1, j) + Green(&rgb, i + 1, j) + Green(&rgb, i, j - 1) + Green(&rgb, i, j + 1)) / 4; Blue(&rgb, i, j) = (Blue(&rgb, i - 1, j) + Blue(&rgb, i + 1, j) + Blue(&rgb, i, j - 1) + Blue(&rgb, i, j + 1)) / 4; } caml_leave_blocking_section(); CAMLreturn(Val_unit); } CAMLprim value caml_rgb_greyscale(value _rgb, value _sepia) { CAMLparam1(_rgb); frame rgb; frame_of_value(_rgb, &rgb); int sepia = Bool_val(_sepia); int i, j; unsigned char c; caml_enter_blocking_section(); for (j = 0; j < rgb.height; j++) for (i = 0; i < rgb.width; i++) { c = (Red(&rgb, i, j) + Green(&rgb, i, j) + Blue(&rgb, i, j)) / 3; if (sepia) { Red(&rgb, i, j) = c; Green(&rgb, i, j) = c * 201 / 0xff; Blue(&rgb, i, j) = c * 158 / 0xff; } else { Red(&rgb, i, j) = c; Green(&rgb, i, j) = c; Blue(&rgb, i, j) = c; } } caml_leave_blocking_section(); CAMLreturn(Val_unit); } CAMLprim value caml_rgb_flip(value _rgb) { CAMLparam1(_rgb); frame rgb; frame_of_value(_rgb, &rgb); int i, j, jj; uint32_t p; caml_enter_blocking_section(); for (j = 0; j < rgb.height / 2; j++) for (i = 0; i < rgb.width; i++) { jj = rgb.height - j - 1; p = Int_pixel(&rgb, i, j); Int_pixel(&rgb, i, j) = Int_pixel(&rgb, i, jj); Int_pixel(&rgb, i, jj) = p; } caml_leave_blocking_section(); CAMLreturn(Val_unit); } CAMLprim value caml_rgba_swap_rb(value _rgba) { CAMLparam1(_rgba); frame rgba; frame_of_value(_rgba, &rgba); int i, j; unsigned char c; caml_enter_blocking_section(); for (j = 0; j < rgba.height; j++) for (i = 0; i < rgba.width; i++) { c = Red(&rgba, i, j); Red(&rgba, i, j) = Blue(&rgba, i, j); Blue(&rgba, i, j) = c; } caml_leave_blocking_section(); CAMLreturn(Val_unit); } CAMLprim value caml_rgb_add(value _src, value _dst) { CAMLparam2(_src, _dst); frame src, dst; frame_of_value(_src, &src); frame_of_value(_dst, &dst); int i, j, c; unsigned char sa; assert_same_dim(&src, &dst); caml_enter_blocking_section(); for (j = 0; j < dst.height; j++) for (i = 0; i < dst.width; i++) { sa = Alpha(&src, i, j); if (sa == 0xff) { for (c = 0; c < Rgb_colors; c++) Color(&dst, c, i, j) = Color(&src, c, i, j); Alpha(&dst, i, j) = 0xff; } else if (sa != 0) { for (c = 0; c < Rgb_colors; c++) Color(&dst, c, i, j) = CLIP(Color(&src, c, i, j) * sa / 0xff + Color(&dst, c, i, j) * (0xff - sa) / 0xff); Alpha(&dst, i, j) = CLIP(sa + (0xff - sa) * Alpha(&dst, i, j)); } } caml_leave_blocking_section(); CAMLreturn(Val_unit); } CAMLprim value caml_rgb_add_off(value _src, value _dst, value _dx, value _dy) { CAMLparam2(_src, _dst); frame src, dst; frame_of_value(_src, &src); frame_of_value(_dst, &dst); int dx = Int_val(_dx), dy = Int_val(_dy); int i, j, c; unsigned char sa; int istart = max(0, dx), iend = min(dst.width, src.width + dx), jstart = max(0, dy), jend = min(dst.height, src.height + dy); caml_enter_blocking_section(); for (j = jstart; j < jend; j++) for (i = istart; i < iend; i++) { sa = Alpha(&src, (i - dx), (j - dy)); if (sa == 0xff) { for (c = 0; c < Rgb_colors; c++) Color(&dst, c, i, j) = Color(&src, c, (i - dx), (j - dy)); Alpha(&dst, i, j) = 0xff; } else if (sa != 0) { for (c = 0; c < Rgb_colors; c++) Color(&dst, c, i, j) = CLIP(Color(&src, c, (i - dx), (j - dy)) * sa / 0xff + Color(&dst, c, i, j) * (0xff - sa) / 0xff); Alpha(&dst, i, j) = CLIP(sa + (0xff - sa) * Alpha(&dst, i, j)); } } caml_leave_blocking_section(); CAMLreturn(Val_unit); } CAMLprim value caml_rgb_add_off_scale(value _src, value _dst, value d, value dim) { CAMLparam2(_src, _dst); frame src, dst; frame_of_value(_src, &src); frame_of_value(_dst, &dst); int dx = Int_val(Field(d, 0)), dy = Int_val(Field(d, 1)), w = Int_val(Field(dim, 0)), h = Int_val(Field(dim, 1)); int i, j, c; unsigned char sa; int istart = max(0, dx), iend = min(dst.width, w + dx), jstart = max(0, dy), jend = min(dst.height, h + dy); caml_enter_blocking_section(); for (j = jstart; j < jend; j++) for (i = istart; i < iend; i++) { sa = Alpha(&src, (i - dx) * src.width / w, (j - dy) * src.height / h); if (sa == 0xff) { for (c = 0; c < Rgb_colors; c++) Color(&dst, c, i, j) = Color(&src, c, (i - dx) * src.width / w, (j - dy) * src.height / h); Alpha(&dst, i, j) = 0xff; } else if (sa != 0) { for (c = 0; c < Rgb_colors; c++) Color(&dst, c, i, j) = CLIP(Color(&src, c, (i - dx) * src.width / w, (j - dy) * src.height / h) * sa / 0xff + Color(&dst, c, i, j) * (0xff - sa) / 0xff); Alpha(&dst, i, j) = CLIP(sa + (0xff - sa) * Alpha(&dst, i, j)); } } caml_leave_blocking_section(); CAMLreturn(Val_unit); } CAMLprim value caml_rgb_invert(value _rgb) { CAMLparam1(_rgb); frame rgb; frame_of_value(_rgb, &rgb); caml_enter_blocking_section(); #ifdef HAVE_MMX /* See http://www.codeproject.com/KB/recipes/mmxintro.aspx?display=Print * http://msdn.microsoft.com/en-us/library/698bxz2w(VS.80).aspx */ unsigned char a1, a2; int i, j; __m64 *data = (__m64 *)rgb.data; __m64 tmp; _mm_empty(); __m64 f = _mm_set_pi8(0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff); for (j = 0; j < rgb.height; j++) for (i = 0; i < rgb.width / 2; i++) { tmp = _mm_subs_pu8(f, *data); a1 = rgb.data[3]; a2 = rgb.data[7]; *data = tmp; rgb.data[3] = a1; rgb.data[7] = a2; if (2 * i == rgb.width - 1) data += rgb.stride - 4 * rgb.width + 1; else data += 8; } _mm_empty(); #else int i, j, c; for (j = 0; j < rgb.height; j++) for (i = 0; i < rgb.width; i++) for (c = 0; c < Rgb_colors; c++) Color(&rgb, c, i, j) = 0xff - Color(&rgb, c, i, j); #endif caml_leave_blocking_section(); CAMLreturn(Val_unit); } #define SO_PREC 0x10000 CAMLprim value caml_rgb_scale_opacity(value _rgb, value _x) { CAMLparam1(_rgb); frame rgb; frame_of_value(_rgb, &rgb); int x = Double_val(_x) * SO_PREC; int i, j; caml_enter_blocking_section(); for (j = 0; j < rgb.height; j++) for (i = 0; i < rgb.width; i++) Alpha(&rgb, i, j) = CLIP(Alpha(&rgb, i, j) * x / SO_PREC); caml_leave_blocking_section(); CAMLreturn(Val_unit); } CAMLprim value caml_rgb_disk_opacity(value _rgb, value _x, value _y, value _r) { CAMLparam1(_rgb); frame rgb; frame_of_value(_rgb, &rgb); int x = Int_val(_x); int y = Int_val(_y); int radius = Int_val(_r); int i, j, r; caml_enter_blocking_section(); for (j = 0; j < rgb.height; j++) for (i = 0; i < rgb.width; i++) { r = sqrt((double)(i - x) * (i - x) + (j - y) * (j - y)); if (r > radius) Alpha(&rgb, i, j) = 0; } caml_leave_blocking_section(); CAMLreturn(Val_unit); } CAMLprim value caml_rgb_rotate(value _rgb, value _angle) { CAMLparam1(_rgb); frame rgb; frame_of_value(_rgb, &rgb); frame old; rgb_copy(&rgb, &old); double a = Double_val(_angle); double sina = sin(a); double cosa = cos(a); int ox = rgb.width / 2, oy = rgb.height / 2; int i, j, c, i2, j2; caml_enter_blocking_section(); for (j = 0; j < rgb.height; j++) for (i = 0; i < rgb.width; i++) { i2 = (i - ox) * cosa + (j - oy) * sina + ox; j2 = -(i - ox) * sina + (j - oy) * cosa + oy; if (!Is_outside(&old, i2, j2)) for (c = 0; c < Rgb_elems_per_pixel; c++) Color(&rgb, c, i, j) = Color(&old, c, i2, j2); else Alpha(&rgb, i, j) = 0; } caml_leave_blocking_section(); rgb_free(&old); CAMLreturn(Val_unit); } CAMLprim value caml_rgb_affine(value _rgb, value _ax, value _ay, value _ox, value _oy) { CAMLparam1(_rgb); frame rgb; frame_of_value(_rgb, &rgb); frame old; rgb_copy(&rgb, &old); double ax = Double_val(_ax), ay = Double_val(_ay); int i, j, i2, j2, c; int ox = Int_val(_ox), oy = Int_val(_oy); int istart = max(0, ox), iend = min(rgb.width, rgb.width * ax + ox), jstart = max(0, oy), jend = min(rgb.height, rgb.height * ay + oy); caml_enter_blocking_section(); rgb_blank(&rgb); for (j = jstart; j < jend; j++) for (i = istart; i < iend; i++) { i2 = (i - ox) / ax; j2 = (j - oy) / ay; /* TODO: this test shouldn't be needed */ /* if (!Is_outside(&old, i2, j2)) */ for (c = 0; c < Rgb_elems_per_pixel; c++) Color(&rgb, c, i, j) = Color(&old, c, i2, j2); } caml_leave_blocking_section(); rgb_free(&old); CAMLreturn(Val_unit); } CAMLprim value caml_rgb_mask(value _rgb, value _mask) { CAMLparam2(_rgb, _mask); frame rgb; frame_of_value(_rgb, &rgb); frame mask; frame_of_value(_mask, &mask); int i, j; assert_same_dim(&rgb, &mask); caml_enter_blocking_section(); for (j = 0; j < rgb.height; j++) for (i = 0; i < rgb.width; i++) Alpha(&rgb, i, j) = CLIP(sqrt(Red(&mask, i, j) * Red(&mask, i, j) + Green(&mask, i, j) * Green(&mask, i, j) + Blue(&mask, i, j) * Blue(&mask, i, j))) * Alpha(&mask, i, j) / 0xff; caml_leave_blocking_section(); CAMLreturn(Val_unit); } CAMLprim value caml_rgb_lomo(value _rgb) { CAMLparam1(_rgb); frame rgb; frame_of_value(_rgb, &rgb); int i, j, c; caml_enter_blocking_section(); for (j = 0; j < rgb.height; j++) for (i = 0; i < rgb.width; i++) for (c = 0; c < Rgb_colors; c++) Color(&rgb, c, i, j) = CLIP((1 - cos(Color(&rgb, c, i, j) * 3.1416 / 255)) * 255); caml_leave_blocking_section(); CAMLreturn(Val_unit); } CAMLprim value caml_rgb_color_to_alpha_simple(value _rgb, value color, value _prec) { CAMLparam2(_rgb, color); frame rgb; frame_of_value(_rgb, &rgb); int r = Int_val(Field(color, 0)), g = Int_val(Field(color, 1)), b = Int_val(Field(color, 2)); int prec = Int_val(_prec); int i, j; caml_enter_blocking_section(); for (j = 0; j < rgb.height; j++) for (i = 0; i < rgb.width; i++) if (abs(Red(&rgb, i, j) - r) <= prec && abs(Green(&rgb, i, j) - g) <= prec && abs(Blue(&rgb, i, j) - b) <= prec) Alpha(&rgb, i, j) = 0; caml_leave_blocking_section(); CAMLreturn(Val_unit); } CAMLprim value caml_rgb_color_to_alpha(value _rgb, value color, value _prec, value _sharp) { CAMLparam2(_rgb, color); frame rgb; frame_of_value(_rgb, &rgb); int r = Int_val(Field(color, 0)), g = Int_val(Field(color, 1)), b = Int_val(Field(color, 2)); float prec = Double_val(_prec); // float sharp = Double_val(_sharp); int i, j; double rr, gg, bb, aa; double d; caml_enter_blocking_section(); for (j = 0; j < rgb.height; j++) for (i = 0; i < rgb.width; i++) { rr = Red(&rgb, i, j); gg = Green(&rgb, i, j); bb = Blue(&rgb, i, j); aa = Alpha(&rgb, i, j); d = sqrt((rr * rr + gg * gg + bb * bb) / (double)(0xff * 0xff)); /* We only change if we are in the radius */ /* if(d <= prec) Alpha(&rgb,i,j) = (int)(0xff) */ /* TODO */ assert(0); if (abs(Red(&rgb, i, j) - r) <= prec && abs(Green(&rgb, i, j) - g) <= prec && abs(Blue(&rgb, i, j) - b) <= prec) Alpha(&rgb, i, j) = 0; } caml_leave_blocking_section(); CAMLreturn(Val_unit); } CAMLprim value caml_rgb_blur_alpha(value _rgb) { CAMLparam1(_rgb); frame rgb; frame_of_value(_rgb, &rgb); frame old; rgb_copy(&rgb, &old); int w = 1; int i, j, k, l; int a; caml_enter_blocking_section(); for (j = w; j < rgb.height - w; j++) for (i = w; i < rgb.width - w; i++) { a = 0; for (l = -w; l <= w; l++) for (k = -w; k <= w; k++) a += Alpha(&old, i + k, j + l); Alpha(&rgb, i, j) = a / ((2 * w + 1) * (2 * w + 1)); } rgb_free(&old); caml_leave_blocking_section(); CAMLreturn(Val_unit); } static inline int compare_images(int width, int height, uint8 *old, uint8 *new, int dx, int dy) { int s = 0; int i, j; int adx = abs(dx); int ady = abs(dy); for (j = adx; j < height - adx; j++) for (i = ady; i < width - ady; i++) s += abs((int)new[j * width + i] - (int)old[(j - dy) * width + (i - dx)]); return s; } CAMLprim value caml_mm_Gray8_motion_compute(value _bs, value _width, value _old, value _new) { CAMLparam2(_old, _new); // Block size int bs = Int_val(_bs); // Previous and current image int len = Caml_ba_array_val(_new)->dim[0]; uint8 *old = Caml_ba_data_val(_old); uint8 *new = Caml_ba_data_val(_new); // Dimensions of the image int w = Int_val(_width); int h = len / w; // Offsets of blocks int dx, dy; // Iterators over offsets: radius, angle (parametrize a diamond) int dr, da; // Scores int s00, s10, s01, s11; // Best score int best; // Motion int mx = 0, my = 0; caml_enter_blocking_section(); best = INT_MAX; for (dr = 0; dr <= bs; dr++) { if (best == 0) break; for (da = 0; da <= dr; da++) { if (best == 0) break; dx = da; dy = dr - da; // TODO: compute only once for dx = dy = 0 s00 = compare_images(w, h, old, new, dx, dy); s01 = compare_images(w, h, old, new, dx, -dy); s10 = compare_images(w, h, old, new, -dx, dy); s11 = compare_images(w, h, old, new, -dx, -dy); if (s00 < best) { mx = dx; my = dy; best = s00; } if (s01 < best) { mx = dx; my = -dy; best = s01; } if (s10 < best) { mx = -dx; my = dy; best = s10; } if (s11 < best) { mx = -dx; my = -dy; best = s11; } } } caml_leave_blocking_section(); CAMLlocal1(ans); ans = caml_alloc_tuple(2); Store_field(ans, 0, Val_int(mx)); Store_field(ans, 1, Val_int(my)); CAMLreturn(ans); } static inline int compare_blocks(int width, int height, uint8 *old, uint8 *new, int bs, int x, int y, int dx, int dy) { int s = 0; int i, j; for (j = 0; j < bs; j++) for (i = 0; i < bs; i++) s += abs((int)new[(y + j) * width + (x + i)] - (int)old[(y + j - dy) * width + (x + i - dx)]); return s; } static inline void swap_int(int *x, int *y) { int t; t = *x; *x = *y; *y = t; } CAMLprim value caml_mm_RGBA8_draw_line(value _img, value c, value src, value dst) { CAMLparam1(_img); frame img; frame_of_value(_img, &img); int sx = Int_val(Field(src, 0)); int sy = Int_val(Field(src, 1)); int dx = Int_val(Field(dst, 0)); int dy = Int_val(Field(dst, 1)); uint8 cr = Int_val(Field(c, 0)); uint8 cg = Int_val(Field(c, 1)); uint8 cb = Int_val(Field(c, 2)); uint8 ca = Int_val(Field(c, 3)); int i, j; caml_enter_blocking_section(); int steep = (abs(dy - sy) > abs(dx - sx)); if (steep) { swap_int(&sx, &sy); swap_int(&dx, &dy); } if (sx > dx) { swap_int(&sx, &dx); swap_int(&sy, &dy); } int deltax = dx - sx; int deltay = abs(dy - sy); int error = deltax / 2; int ystep = (sy < dy) ? 1 : -1; j = sy; for (i = sx; i < dx; i++) { if (steep) { Red(&img, j, i) = cr; Green(&img, j, i) = cg; Blue(&img, j, i) = cb; Alpha(&img, j, i) = ca; } else { Red(&img, i, j) = cr; Green(&img, i, j) = cg; Blue(&img, i, j) = cb; Alpha(&img, i, j) = ca; } error -= deltay; if (error < 0) { j += ystep; error += deltax; } } caml_leave_blocking_section(); CAMLreturn(Val_unit); } CAMLprim value caml_mm_Gray8_motion_multi_compute(value _bs, value _width, value _old, value _new) { CAMLparam2(_old, _new); // Block size int bs = Int_val(_bs); // Previous and current image int len = Caml_ba_array_val(_new)->dim[0]; uint8 *old = Caml_ba_data_val(_old); uint8 *new = Caml_ba_data_val(_new); // Iterators over blocks int i, j; // Dimensions of the image int w = Int_val(_width); int h = len / w; // Offsets of blocks int dx, dy; // Iterators over offsets: radius, angle (parametrize a diamond) int dr, da; // Vector table width and height int vw = w / bs; int vh = h / bs; // Size of vector table long vlen = vw * vh * 2; // Vector table of size vw*vh int *v = malloc(vlen * sizeof(int)); if (v == NULL) caml_raise_out_of_memory(); // Current score int s00, s10, s01, s11; // Best score int best; caml_enter_blocking_section(); memset(v, 0, vlen * sizeof(int)); for (j = 1; j < vh - 1; j++) for (i = 1; i < vw - 1; i++) { best = INT_MAX; for (dr = 0; dr <= bs; dr++) { if (best == 0) break; for (da = 0; da <= dr; da++) { if (best == 0) break; dx = da; dy = dr - da; s00 = compare_blocks(w, h, old, new, bs, i * bs, j * bs, dx, dy); s01 = compare_blocks(w, h, old, new, bs, i * bs, j * bs, dx, -dy); s10 = compare_blocks(w, h, old, new, bs, i * bs, j * bs, -dx, dy); s11 = compare_blocks(w, h, old, new, bs, i * bs, j * bs, -dx, -dy); if (s00 < best) { v[2 * (j * vw + i)] = dx; v[2 * (j * vw + i) + 1] = dy; best = s00; } if (s01 < best) { v[2 * (j * vw + i)] = dx; v[2 * (j * vw + i) + 1] = -dy; best = s01; } if (s10 < best) { v[2 * (j * vw + i)] = -dx; v[2 * (j * vw + i) + 1] = dy; best = s10; } if (s11 < best) { v[2 * (j * vw + i)] = -dx; v[2 * (j * vw + i) + 1] = -dy; best = s11; } } } // if (!best) // printf("found %03d %03d: %03d %03d @ // %d\n",i,j,v[2*(j*vw+i)],v[2*(j*vw+i)+1],best); } caml_leave_blocking_section(); value ans = caml_mm_ba_alloc_dims( CAML_BA_MANAGED | CAML_BA_C_LAYOUT | CAML_BA_NATIVE_INT, 1, v, vlen); CAMLreturn(ans); } CAMLprim value caml_rgb_motion_multi_median_denoise(value _vw, value _v) { CAMLparam1(_v); int *v = Caml_ba_data_val(_v); int len = Caml_ba_array_val(_v)->dim[0] / 2; int vw = Int_val(_vw); int vh = len / vw; int i, j, c; int *oldv; caml_enter_blocking_section(); oldv = malloc(len * 2 * sizeof(int)); if (oldv == NULL) caml_raise_out_of_memory(); memcpy(oldv, v, len * 2 * sizeof(int)); for (j = 1; j < vh - 1; j++) for (i = 1; i < vw - 1; i++) for (c = 0; c < 2; c++) { v[2 * (j * vw + i) + c] = (oldv[2 * (j * vw + i) + c] + oldv[2 * (j * vw + i - 1) + c] + oldv[2 * (j * vw + i + 1) + c] + oldv[2 * ((j - 1) * vw + i) + c] + oldv[2 * ((j + 1) * vw + i) + c]) / 5; } free(oldv); caml_leave_blocking_section(); CAMLreturn(Val_unit); } CAMLprim value caml_rgb_motion_multi_mean(value _width, value _v) { CAMLparam1(_v); CAMLlocal1(ans); int *v = Caml_ba_data_val(_v); int len = Caml_ba_array_val(_v)->dim[0] / 2; int w = Int_val(_width); int h = len / w; int mx = 0, my = 0; int i, j; caml_enter_blocking_section(); for (j = 1; j < h - 1; j++) for (i = 1; i < w - 1; i++) { mx += v[2 * (j * w + i)]; my += v[2 * (j * w + i) + 1]; } len = (w - 2) * (h - 2); mx += len / 2; my += len / 2; mx /= len; my /= len; caml_leave_blocking_section(); ans = caml_alloc_tuple(2); Store_field(ans, 0, Val_int(mx)); Store_field(ans, 1, Val_int(my)); CAMLreturn(ans); } static inline void motion_plot(frame *img, int i, int j) { // Int_pixel(img, i, j) = 0xffffffff; Red(img, i, j) = 255; /* Green(img, i, j) = 255; Blue(img, i, j) = 255; */ } static inline void motion_besenham(frame *img, int sx, int sy, int dx, int dy) { int i, j; int steep = (abs(dy - sy) > abs(dx - sx)); if (steep) { swap_int(&sx, &sy); swap_int(&dx, &dy); } if (sx > dx) { swap_int(&sx, &dx); swap_int(&sy, &dy); } int deltax = dx - sx; int deltay = abs(dy - sy); int error = deltax / 2; int ystep = (sy < dy) ? 1 : -1; j = sy; for (i = sx; i < dx; i++) { if (steep) motion_plot(img, j, i); else motion_plot(img, i, j); error -= deltay; if (error < 0) { j += ystep; error += deltax; } } } CAMLprim value caml_rgb_motion_multi_arrows(value _bs, value _v, value _img) { CAMLparam2(_v, _img); int bs = Int_val(_bs); frame img; frame_of_value(_img, &img); int i, j; int w = img.width; int h = img.height; int vw = w / bs; int vh = h / bs; int x, y; int dx, dy; int ax, ay; int *v = Caml_ba_data_val(_v); caml_enter_blocking_section(); for (j = 0; j < vh - 1; j++) for (i = 0; i < vw - 1; i++) { x = i * bs + bs / 2; y = j * bs + bs / 2; dx = v[2 * (j * vw + i)]; dy = v[2 * (j * vw + i + 1)]; ax = x + dx; ay = y + dy; /* ax = max(0,ax); ay = max(0,ay); ax = min(w,ax); ay = min(h,ay); */ motion_besenham(&img, x, y, ax, ay); Green(&img, x, y) = 0xff; } caml_leave_blocking_section(); CAMLreturn(Val_unit); } CAMLprim value caml_RGBA32_to_BGR32(value _src, value _src_stride, value _dst, value _dst_stride, value dim) { CAMLparam2(_src, _dst); unsigned char *src = Caml_ba_data_val(_src); unsigned char *dst = Caml_ba_data_val(_dst); int src_stride = Int_val(_src_stride); int dst_stride = Int_val(_dst_stride); int width = Int_val(Field(dim, 0)); int height = Int_val(Field(dim, 1)); int i, j; int a; caml_enter_blocking_section(); for (j = 0; j < height; j++) for (i = 0; i < width; i++) { a = src[j * src_stride + i * 4 + 3]; if (a == 0xff) { dst[j * dst_stride + i * 4 + 0] = src[j * src_stride + i * 4 + 2]; dst[j * dst_stride + i * 4 + 1] = src[j * src_stride + i * 4 + 1]; dst[j * dst_stride + i * 4 + 2] = src[j * src_stride + i * 4 + 0]; } else if (a == 0) { dst[j * dst_stride + i * 4 + 0] = 0; dst[j * dst_stride + i * 4 + 1] = 0; dst[j * dst_stride + i * 4 + 2] = 0; } else { dst[j * dst_stride + i * 4 + 0] = src[j * src_stride + i * 4 + 2] * a / 0xff; dst[j * dst_stride + i * 4 + 1] = src[j * src_stride + i * 4 + 1] * a / 0xff; dst[j * dst_stride + i * 4 + 2] = src[j * src_stride + i * 4 + 0] * a / 0xff; } } caml_leave_blocking_section(); CAMLreturn(Val_unit); } CAMLprim value caml_RGB24_to_RGBA32(value _src, value _src_stride, value _dst, value _dst_stride, value dim) { CAMLparam2(_src, _dst); unsigned char *src = Caml_ba_data_val(_src); unsigned char *dst = Caml_ba_data_val(_dst); int src_stride = Int_val(_src_stride); int dst_stride = Int_val(_dst_stride); int width = Int_val(Field(dim, 0)); int height = Int_val(Field(dim, 1)); int i, j; caml_enter_blocking_section(); for (j = 0; j < height; j++) for (i = 0; i < width; i++) { dst[j * dst_stride + i * 4 + 0] = src[j * src_stride + i * 3 + 0]; dst[j * dst_stride + i * 4 + 1] = src[j * src_stride + i * 3 + 1]; dst[j * dst_stride + i * 4 + 2] = src[j * src_stride + i * 3 + 2]; dst[j * dst_stride + i * 4 + 3] = 0xff; } caml_leave_blocking_section(); CAMLreturn(Val_unit); } CAMLprim value caml_RGB32_to_RGBA32(value _src, value _src_stride, value _dst, value _dst_stride, value dim) { CAMLparam2(_src, _dst); unsigned char *src = Caml_ba_data_val(_src); unsigned char *dst = Caml_ba_data_val(_dst); int src_stride = Int_val(_src_stride); int dst_stride = Int_val(_dst_stride); int width = Int_val(Field(dim, 0)); int height = Int_val(Field(dim, 1)); int i, j; caml_enter_blocking_section(); if (src_stride == dst_stride) { memcpy(dst, src, width * src_stride); for (j = 0; j < height; j++) for (i = 0; i < width; i++) dst[j * dst_stride + i * 4 + 3] = 0xff; } else for (j = 0; j < height; j++) for (i = 0; i < width; i++) { dst[j * dst_stride + i * 4 + 0] = src[j * src_stride + i * 4 + 0]; dst[j * dst_stride + i * 4 + 1] = src[j * src_stride + i * 4 + 1]; dst[j * dst_stride + i * 4 + 2] = src[j * src_stride + i * 4 + 2]; dst[j * dst_stride + i * 4 + 3] = 0xff; } caml_leave_blocking_section(); CAMLreturn(Val_unit); } ocaml-mm-0.7.3/src/image_rgb.h000066400000000000000000000044741415601551300161110ustar00rootroot00000000000000#include #include typedef struct { int width; /* Width in pixels */ int height; /* Height in pixels */ int stride; /* Bytes per line */ unsigned char *data; } frame; #define Rgb_num_pix(rgb) (rgb)->width *(rgb)->height #define Rgb_colors 3 #define Rgb_elems_per_pixel 4 #define Rgb_num_elem(rgb) Rgb_elems_per_pixel *Rgb_num_pix(rgb) #define Rgb_plane_size(rgb) (rgb)->stride *(rgb)->height #define Rgb_data_size(rgb) Rgb_plane_size(rgb) * sizeof(unsigned char) #define Color(rgb, c, i, j) \ (rgb)->data[(j) * (rgb)->stride + Rgb_elems_per_pixel * (i) + (c)] #define Red(rgb, i, j) Color(rgb, 0, i, j) #define Green(rgb, i, j) Color(rgb, 1, i, j) #define Blue(rgb, i, j) Color(rgb, 2, i, j) #define Alpha(rgb, i, j) Color(rgb, 3, i, j) #define Pixel(rgb, i, j) \ { Red(rgb, i, j), Green(rgb, i, j), Blue(rgb, i, j), Alpha(rgb, i, j) } #define Is_outside(rgb, i, j) \ (i < 0 || j < 0 || i >= (rgb)->width || j >= (rgb)->height) #define Space_clip_color(rgb, c, i, j) \ (Is_outside(rgb, i, j)) ? 0 : Color(rgb, c, i, j) // For copying pixel by pixel #define Int_pixel(rgb, i, j) \ (((uint32_t *)(rgb)->data)[i + j * ((rgb)->stride / 4)]) #ifndef BIGENDIAN #define rshift 0 #define gshift 8 #define bshift 16 #define ashift 24 #else #define rshift 24 #define gshift 16 #define bshift 8 #define ashift 0 #endif #define Copy_pixel(dst, di, dj, src, si, sj) \ (Int_pixel(dst, di, dj) = Int_pixel(src, si, sj)) #define assert_same_dim(src, dst) \ { \ assert((dst)->width == (src)->width); \ assert((dst)->height == (src)->height); \ } #define Rgb_data_val(v) Caml_ba_data_val(Field(v, 0)) #define Rgb_width_val(v) Int_val(Field(v, 1)) static frame *frame_of_value(value v, frame *f) { f->data = Rgb_data_val(v); f->width = Rgb_width_val(v); f->height = Int_val(Field(v, 2)); f->stride = Int_val(Field(v, 3)); return f; } ocaml-mm-0.7.3/src/image_yuv420.c000066400000000000000000000251331415601551300163760ustar00rootroot00000000000000#include #include #include #include #include #include #include #include #include #include #include "image_pixel.h" #include "image_rgb.h" #include "image_yuv420.h" #define max(a, b) (a > b) ? a : b #define min(a, b) (a < b) ? a : b #define round(r, n) (((n + (r - 1)) / r) * r) CAMLprim value caml_yuv420_fill(value img, value p) { CAMLparam2(img, p); int y = Int_val(Field(p, 0)); int u = Int_val(Field(p, 1)); int v = Int_val(Field(p, 2)); int height = YUV420_height(img); int y_stride = YUV420_y_stride(img); int uv_stride = YUV420_uv_stride(img); memset(YUV420_y(img), y, height * y_stride); memset(YUV420_u(img), u, round(2, height / 2) * uv_stride); memset(YUV420_v(img), v, round(2, height / 2) * uv_stride); CAMLreturn(Val_unit); } CAMLprim value caml_yuv420_to_int_image(value img) { CAMLparam1(img); CAMLlocal2(ans, tmp); yuv420 yuv; yuv420_of_value(&yuv, img); int i, j; int y, u, v, r, g, b, a; ans = caml_alloc_tuple(yuv.height); for (j = 0; j < yuv.height; j++) { tmp = caml_alloc_tuple(yuv.width); for (i = 0; i < yuv.width; i++) { y = Y(yuv, i, j); u = U(yuv, i, j); v = V(yuv, i, j); r = RofYUV(y, u, v); g = GofYUV(y, u, v); b = BofYUV(y, u, v); if (yuv.alpha) { a = A(yuv, i, j); r = r * a / 0xff; g = g * a / 0xff; b = b * a / 0xff; } Store_field(tmp, i, Val_int((r << 16) + (g << 8) + b)); } Store_field(ans, j, tmp); } CAMLreturn(ans); } CAMLprim value caml_yuv420_of_rgb24_string(value img, value s) { CAMLparam2(img, s); yuv420 yuv; yuv420_of_value(&yuv, img); // We don't copy so we cannot release the lock unsigned char *data = (unsigned char *)String_val(s); int i, j; for (j = 0; j < yuv.height; j++) for (i = 0; i < yuv.width; i++) { int r = data[3 * (j * yuv.width + i) + 0]; int g = data[3 * (j * yuv.width + i) + 1]; int b = data[3 * (j * yuv.width + i) + 2]; Y(yuv, i, j) = YofRGB(r, g, b); // TODO: don't do u/v twice U(yuv, i, j) = UofRGB(r, g, b); V(yuv, i, j) = VofRGB(r, g, b); } CAMLreturn(Val_unit); } CAMLprim value caml_yuv420_of_rgba32(value _rgb, value img) { CAMLparam2(_rgb, img); frame rgb; frame_of_value(_rgb, &rgb); yuv420 yuv; yuv420_of_value(&yuv, img); int i, j; caml_enter_blocking_section(); for (j = 0; j < rgb.height; j++) for (i = 0; i < rgb.width; i++) { int r = Red(&rgb, i, j); int g = Green(&rgb, i, j); int b = Blue(&rgb, i, j); Y(yuv, i, j) = YofRGB(r, g, b); // TODO: don't do u/v twice U(yuv, i, j) = UofRGB(r, g, b); V(yuv, i, j) = VofRGB(r, g, b); A(yuv, i, j) = Alpha(&rgb, i, j); } caml_leave_blocking_section(); CAMLreturn(Val_unit); } CAMLprim value caml_yuv420_to_rgba32(value img, value _rgb) { CAMLparam2(img, _rgb); frame rgb; frame_of_value(_rgb, &rgb); yuv420 yuv; yuv420_of_value(&yuv, img); int i, j; caml_enter_blocking_section(); for (j = 0; j < yuv.height; j++) for (i = 0; i < yuv.width; i++) { int y = Y(yuv, i, j); int u = U(yuv, i, j); int v = V(yuv, i, j); Red(&rgb, i, j) = RofYUV(y, u, v); Green(&rgb, i, j) = GofYUV(y, u, v); Blue(&rgb, i, j) = BofYUV(y, u, v); Alpha(&rgb, i, j) = yuv.alpha ? A(yuv, i, j) : 0xff; } caml_leave_blocking_section(); CAMLreturn(Val_unit); } CAMLprim value caml_yuv420_scale(value _src, value _dst) { CAMLparam2(_src, _dst); yuv420 src, dst; yuv420_of_value(&src, _src); yuv420_of_value(&dst, _dst); int i, j, is, js; assert(!src.alpha || dst.alpha); caml_enter_blocking_section(); for (j = 0; j < dst.height; j++) for (i = 0; i < dst.width; i++) { is = i * src.width / dst.width; js = j * src.height / dst.height; Y(dst, i, j) = Y(src, is, js); // TODO: don't do u/v twice U(dst, i, j) = U(src, is, js); V(dst, i, j) = V(src, is, js); if (src.alpha) A(dst, i, j) = A(src, is, js); } caml_leave_blocking_section(); CAMLreturn(Val_unit); } CAMLprim value caml_yuv420_scale_coef(value _src, value _dst, value xscale, value yscale) { CAMLparam4(_src, _dst, xscale, yscale); yuv420 src, dst; yuv420_of_value(&src, _src); yuv420_of_value(&dst, _dst); // x scaling (xn: numerator, xd: denominator) int xn = Int_val(Field(xscale, 0)); int xd = Int_val(Field(xscale, 1)); // y scaling int yn = Int_val(Field(yscale, 0)); int yd = Int_val(Field(yscale, 1)); // offsets int ox = (dst.width - src.width * xn / xd) / 2; int oy = (dst.height - src.height * yn / yd) / 2; int i, j; assert(ox >= 0 && oy >= 0); caml_enter_blocking_section(); // TODO: blank /* if (ox != 0 || oy != 0) rgb_blank(&dst); */ for (j = oy; j < dst.height - oy; j++) for (i = ox; i < dst.width - ox; i++) { int is = (i - ox) * xd / xn; int js = (j - oy) * yd / yn; Y(dst, i, j) = Y(src, is, js); // TODO: don't do u/v twice U(dst, i, j) = U(src, is, js); V(dst, i, j) = V(src, is, js); if (src.alpha) A(dst, i, j) = A(src, is, js); } caml_leave_blocking_section(); CAMLreturn(Val_unit); } CAMLprim value caml_yuv420_add(value _src, value _x, value _y, value _dst) { CAMLparam4(_src, _x, _y, _dst); int x = Int_val(_x); int y = Int_val(_y); yuv420 src, dst; yuv420_of_value(&src, _src); yuv420_of_value(&dst, _dst); int ia = max(x, 0); int ib = min(x + src.width, dst.width); int ja = max(y, 0); int jb = min(y + src.height, dst.height); int i, j; caml_enter_blocking_section(); if (src.alpha == NULL) for (j = ja; j < jb; j++) for (i = ia; i < ib; i++) { int is = i - x; int js = j - y; Y(dst, i, j) = Y(src, is, js); // TODO: don't do u/v twice U(dst, i, j) = U(src, is, js); V(dst, i, j) = V(src, is, js); if (dst.alpha) A(dst, i, j) = 0xff; } else for (j = ja; j < jb; j++) for (i = ia; i < ib; i++) { int is = i - x; int js = j - y; int a = A(src, is, js); if (a == 0) { } else if (a == 0xff) { Y(dst, i, j) = Y(src, is, js); U(dst, i, j) = U(src, is, js); V(dst, i, j) = V(src, is, js); if (dst.alpha) A(dst, i, j) = 0xff; } else { Y(dst, i, j) = CLIP((Y(src, is, js) * a + Y(dst, i, j) * (0xff - a)) / 0xff); // TODO: don't do u/v twice U(dst, i, j) = CLIP((U(src, is, js) * a + U(dst, i, j) * (0xff - a)) / 0xff); V(dst, i, j) = CLIP((V(src, is, js) * a + V(dst, i, j) * (0xff - a)) / 0xff); if (dst.alpha) A(dst, i, j) = 0xff - ((0xff - a) * (0xff - A(dst, i, j))) / 0xff; } } caml_leave_blocking_section(); CAMLreturn(Val_unit); } CAMLprim value caml_yuv420_get_pixel_rgba(value img, value _i, value _j) { CAMLparam3(img, _i, _j); CAMLlocal1(ans); yuv420 yuv; yuv420_of_value(&yuv, img); int i = Int_val(_i); int j = Int_val(_j); int y = Y(yuv, i, j); int u = U(yuv, i, j); int v = V(yuv, i, j); int a = yuv.alpha ? A(yuv, i, j) : 0xff; int r = RofYUV(y, u, v); int g = GofYUV(y, u, v); int b = BofYUV(y, u, v); ans = caml_alloc_tuple(4); Store_field(ans, 0, Val_int(r)); Store_field(ans, 1, Val_int(g)); Store_field(ans, 2, Val_int(b)); Store_field(ans, 3, Val_int(a)); CAMLreturn(ans); } CAMLprim value caml_yuv420_set_pixel_rgba(value img, value _i, value _j, value c) { CAMLparam4(img, _i, _j, c); yuv420 yuv; yuv420_of_value(&yuv, img); int i = Int_val(_i); int j = Int_val(_j); int r = Int_val(Field(c, 0)); int g = Int_val(Field(c, 1)); int b = Int_val(Field(c, 2)); int a = Int_val(Field(c, 3)); Y(yuv, i, j) = YofRGB(r, g, b); U(yuv, i, j) = UofRGB(r, g, b); V(yuv, i, j) = VofRGB(r, g, b); if (yuv.alpha) A(yuv, i, j) = a; CAMLreturn(Val_unit); } CAMLprim value caml_yuv_randomize(value img) { CAMLparam1(img); yuv420 yuv; yuv420_of_value(&yuv, img); int i, j; caml_enter_blocking_section(); for (j = 0; j < yuv.height; j++) for (i = 0; i < yuv.width; i++) { Y(yuv, i, j) = rand(); U(yuv, i, j) = rand(); V(yuv, i, j) = rand(); } caml_leave_blocking_section(); CAMLreturn(Val_unit); } CAMLprim value caml_yuv_greyscale(value img) { CAMLparam1(img); yuv420 yuv; yuv420_of_value(&yuv, img); int i, j; caml_enter_blocking_section(); for (j = 0; j < yuv.height; j++) for (i = 0; i < yuv.width; i++) { /* int y = Y(yuv,i,j); */ U(yuv, i, j) = 0x7f; V(yuv, i, j) = 0x7f; } caml_leave_blocking_section(); CAMLreturn(Val_unit); } #define PIXEL_PRECISON 0x10000 CAMLprim value caml_yuv_scale_alpha(value img, value _a) { CAMLparam2(img, _a); yuv420 yuv; yuv420_of_value(&yuv, img); int a = Double_val(_a) * PIXEL_PRECISON; int i, j; caml_enter_blocking_section(); for (j = 0; j < yuv.height; j++) for (i = 0; i < yuv.width; i++) A(yuv, i, j) = CLIP(A(yuv, i, j) * a / PIXEL_PRECISON); caml_leave_blocking_section(); CAMLreturn(Val_unit); } CAMLprim value caml_yuv_disk_alpha(value img, value _x, value _y, value _r) { CAMLparam4(img, _x, _y, _r); yuv420 yuv; yuv420_of_value(&yuv, img); int x = Int_val(_x); int y = Int_val(_y); int radius = Int_val(_r); radius = radius * radius; int i, j; caml_enter_blocking_section(); for (j = 0; j < yuv.height; j++) for (i = 0; i < yuv.width; i++) { int r = (i - x) * (i - x) + (j - y) * (j - y); if (r > radius) A(yuv, i, j) = 0; } caml_leave_blocking_section(); CAMLreturn(Val_unit); } #define crop(x, m) (x > m ? m : (x < 0 ? 0 : x)) CAMLprim value caml_yuv_box_alpha_native(value img, value _x, value _y, value _w, value _h, value _a) { CAMLparam1(img); yuv420 yuv; yuv420_of_value(&yuv, img); int x = crop(Int_val(_x), yuv.width); int y = crop(Int_val(_y), yuv.height); int w = crop(Int_val(_w), yuv.width); int h = max(Int_val(_h), yuv.height); int a = CLIP(Double_val(_a) * PIXEL_PRECISON); int i, j; caml_enter_blocking_section(); for (j = y; j < h; j++) for (i = x; i < w; i++) A(yuv, i, j) = a; caml_leave_blocking_section(); CAMLreturn(Val_unit); } CAMLprim value caml_yuv_box_alpha_bytecode(value *argv, int argn) { return caml_yuv_box_alpha_native(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); } ocaml-mm-0.7.3/src/image_yuv420.h000066400000000000000000000022721415601551300164020ustar00rootroot00000000000000#define YUV420_y(v) (Caml_ba_data_val(Field(v, 0))) #define YUV420_y_stride(v) (Int_val(Field(v, 1))) #define YUV420_u(v) (Caml_ba_data_val(Field(v, 2))) #define YUV420_v(v) (Caml_ba_data_val(Field(v, 3))) #define YUV420_uv_stride(v) (Int_val(Field(v, 4))) #define YUV420_width(v) (Int_val(Field(v, 5))) #define YUV420_height(v) (Int_val(Field(v, 6))) #define YUV420_alpha(v) \ (Is_block(Field(v, 7)) ? Caml_ba_data_val(Field(Field(v, 7), 0)) : NULL) typedef struct { int width; int height; unsigned char *y; int y_stride; unsigned char *u; unsigned char *v; int uv_stride; unsigned char *alpha; } yuv420; static void yuv420_of_value(yuv420 *yuv, value v) { yuv->y = YUV420_y(v); yuv->y_stride = YUV420_y_stride(v); yuv->u = YUV420_u(v); yuv->v = YUV420_v(v); yuv->uv_stride = YUV420_uv_stride(v); yuv->width = YUV420_width(v); yuv->height = YUV420_height(v); yuv->alpha = YUV420_alpha(v); } #define Y(yuv, i, j) yuv.y[j * yuv.y_stride + i] #define U(yuv, i, j) yuv.u[(j / 2) * yuv.uv_stride + (i / 2)] #define V(yuv, i, j) yuv.v[(j / 2) * yuv.uv_stride + (i / 2)] #define A(yuv, i, j) yuv.alpha[j * yuv.y_stride + i] ocaml-mm-0.7.3/src/mm.ml000066400000000000000000000033141415601551300147570ustar00rootroot00000000000000(* * Copyright 2011 The Savonet Team * * This file is part of ocaml-mm. * * ocaml-mm is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * ocaml-mm 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 Lesser General Public License * along with ocaml-mm; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA * * As a special exception to the GNU Library General Public License, you may * link, statically or dynamically, a "work that uses the Library" with a publicly * distributed version of the Library to produce an executable file containing * portions of the Library, and distribute that executable file under terms of * your choice, without any of the additional requirements listed in clause 6 * of the GNU Library General Public License. * By "a publicly distributed version of the Library", we mean either the unmodified * Library as distributed by The Savonet Team, or a modified version of the Library that is * distributed under the conditions defined in clause 3 of the GNU Library General * Public License. This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU Library General Public License. * *) include Mm_audio include Mm_image include Mm_video include Mm_midi ocaml-mm-0.7.3/src/mm.mli000066400000000000000000000034101415601551300151250ustar00rootroot00000000000000(* * Copyright 2011 The Savonet Team * * This file is part of ocaml-mm. * * ocaml-mm is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * ocaml-mm 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 Lesser General Public License * along with ocaml-mm; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA * * As a special exception to the GNU Library General Public License, you may * link, statically or dynamically, a "work that uses the Library" with a publicly * distributed version of the Library to produce an executable file containing * portions of the Library, and distribute that executable file under terms of * your choice, without any of the additional requirements listed in clause 6 * of the GNU Library General Public License. * By "a publicly distributed version of the Library", we mean either the unmodified * Library as distributed by The Savonet Team, or a modified version of the Library that is * distributed under the conditions defined in clause 3 of the GNU Library General * Public License. This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU Library General Public License. * *) include module type of Mm_audio include module type of Mm_image include module type of Mm_video include module type of Mm_midi ocaml-mm-0.7.3/src/ringbuffer.ml000066400000000000000000000117631415601551300165060ustar00rootroot00000000000000(* * Copyright 2011 The Savonet Team * * This file is part of ocaml-mm. * * ocaml-mm is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * ocaml-mm 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 Lesser General Public License * along with ocaml-mm; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA * * As a special exception to the GNU Library General Public License, you may * link, statically or dynamically, a "work that uses the Library" with a publicly * distributed version of the Library to produce an executable file containing * portions of the Library, and distribute that executable file under terms of * your choice, without any of the additional requirements listed in clause 6 * of the GNU Library General Public License. * By "a publicly distributed version of the Library", we mean either the unmodified * Library as distributed by The Savonet Team, or a modified version of the Library that is * distributed under the conditions defined in clause 3 of the GNU Library General * Public License. This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU Library General Public License. * *) module type Buffer = sig type t val create : int -> t val blit : t -> int -> t -> int -> int -> unit end module type R = sig type buffer type t val create : int -> t val read_space : t -> int val write_space : t -> int val read_advance : t -> int -> unit val write_advance : t -> int -> unit val read : t -> buffer -> int -> int -> unit val peek : t -> buffer -> int -> int -> unit val write : t -> buffer -> int -> int -> unit val transmit : t -> (buffer -> int -> int -> int) -> int end module Make (B : Buffer) = struct type buffer = B.t type t = { size : int; buffer : buffer; mutable rpos : int; (** current read position *) mutable wpos : int; (** current write position *) } let create size = { (* size + 1 so we can store full buffers, while keeping rpos and wpos different for implementation matters *) size = size + 1; buffer = B.create (size + 1); rpos = 0; wpos = 0; } let read_space t = if t.wpos >= t.rpos then t.wpos - t.rpos else t.size - (t.rpos - t.wpos) let write_space t = if t.wpos >= t.rpos then t.size - (t.wpos - t.rpos) - 1 else t.rpos - t.wpos - 1 let read_advance t n = assert (n <= read_space t); if t.rpos + n < t.size then t.rpos <- t.rpos + n else t.rpos <- t.rpos + n - t.size let write_advance t n = assert (n <= write_space t); if t.wpos + n < t.size then t.wpos <- t.wpos + n else t.wpos <- t.wpos + n - t.size let peek t buff off len = assert (len <= read_space t); let pre = t.size - t.rpos in let extra = len - pre in if extra > 0 then ( B.blit t.buffer t.rpos buff off pre; B.blit t.buffer 0 buff (off + pre) extra) else B.blit t.buffer t.rpos buff off len let read t buff off len = peek t buff off len; read_advance t len let write t buff off len = assert (len <= write_space t); let pre = t.size - t.wpos in let extra = len - pre in if extra > 0 then ( B.blit buff off t.buffer t.wpos pre; B.blit buff (off + pre) t.buffer 0 extra) else B.blit buff off t.buffer t.wpos len; write_advance t len let transmit t f = if t.wpos = t.rpos then 0 else ( let len0 = if t.wpos >= t.rpos then t.wpos - t.rpos else t.size - t.rpos in let len = f t.buffer t.rpos len0 in assert (len <= len0); read_advance t len; len) end module Make_ext (B : Buffer) = struct module R = Make (B) type buffer = R.buffer type t = { mutable ringbuffer : R.t } let prepare buf len = if R.write_space buf.ringbuffer >= len then buf.ringbuffer else ( let rb = R.create (R.read_space buf.ringbuffer + len) in while R.read_space buf.ringbuffer <> 0 do ignore (R.transmit buf.ringbuffer (fun buf ofs len -> R.write rb buf ofs len; len)) done; buf.ringbuffer <- rb; rb) let peek rb = R.peek rb.ringbuffer let read rb = R.read rb.ringbuffer let write rb buf ofs len = let rb = prepare rb len in R.write rb buf ofs len let transmit rb = R.transmit rb.ringbuffer let read_space rb = R.read_space rb.ringbuffer let write_space rb = R.write_space rb.ringbuffer let read_advance rb = R.read_advance rb.ringbuffer let write_advance rb = R.write_advance rb.ringbuffer let create len = { ringbuffer = R.create len } end ocaml-mm-0.7.3/src/ringbuffer.mli000066400000000000000000000060331415601551300166510ustar00rootroot00000000000000(* * Copyright 2011 The Savonet Team * * This file is part of ocaml-mm. * * ocaml-mm is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * ocaml-mm 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 Lesser General Public License * along with ocaml-mm; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA * * As a special exception to the GNU Library General Public License, you may * link, statically or dynamically, a "work that uses the Library" with a publicly * distributed version of the Library to produce an executable file containing * portions of the Library, and distribute that executable file under terms of * your choice, without any of the additional requirements listed in clause 6 * of the GNU Library General Public License. * By "a publicly distributed version of the Library", we mean either the unmodified * Library as distributed by The Savonet Team, or a modified version of the Library that is * distributed under the conditions defined in clause 3 of the GNU Library General * Public License. This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU Library General Public License. * *) (** Operations on ringbuffers. *) (** Underlying buffers of ringbuffers. *) module type Buffer = sig (** Type of a buffer. *) type t (** Create a buffer of given length. *) val create : int -> t (** Blitting function. *) val blit : t -> int -> t -> int -> int -> unit end (** Signature for ringbuffer modules. *) module type R = sig (** A buffer of elements. *) type buffer (** A ringbuffer. *) type t (** Create a ringbuffer of given size. *) val create : int -> t (** Size of data available for reading. *) val read_space : t -> int (** Size of space available for writing. *) val write_space : t -> int (** Drop data. *) val read_advance : t -> int -> unit (** Advance the write pointer. *) val write_advance : t -> int -> unit (** Read data. *) val read : t -> buffer -> int -> int -> unit (** Same as [read] but does not advance the read pointer. *) val peek : t -> buffer -> int -> int -> unit (** Write data. *) val write : t -> buffer -> int -> int -> unit (** Read all the data in the ringbuffer. *) val transmit : t -> (buffer -> int -> int -> int) -> int end (** Create a ringbuffer. *) module Make : functor (B : Buffer) -> R with type buffer = B.t (** Create an extensible ringbuffer: the size of the ringbuffer is extended if write space is too small at some point. *) module Make_ext : functor (B : Buffer) -> R with type buffer = B.t ocaml-mm-0.7.3/src/synth.ml000066400000000000000000000132351415601551300155160ustar00rootroot00000000000000(* * Copyright 2011 The Savonet Team * * This file is part of ocaml-mm. * * ocaml-mm is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * ocaml-mm 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 Lesser General Public License * along with ocaml-mm; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA * * As a special exception to the GNU Library General Public License, you may * link, statically or dynamically, a "work that uses the Library" with a publicly * distributed version of the Library to produce an executable file containing * portions of the Library, and distribute that executable file under terms of * your choice, without any of the additional requirements listed in clause 6 * of the GNU Library General Public License. * By "a publicly distributed version of the Library", we mean either the unmodified * Library as distributed by The Savonet Team, or a modified version of the Library that is * distributed under the conditions defined in clause 3 of the GNU Library General * Public License. This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU Library General Public License. * *) open Mm_audio class type t = object method set_volume : float -> unit method note_on : int -> float -> unit method note_off : int -> float -> unit method fill_add : Audio.buffer -> unit method play_add : MIDI.buffer -> int -> Audio.buffer -> unit method play : MIDI.buffer -> int -> Audio.buffer -> unit method reset : unit end type synth = t type note = { note : int; volume : float; generator : Audio.Generator.t } class virtual base = object (self) method virtual private generator : float -> float -> Audio.Generator.t val mutable vol : float = 1. method set_volume v = vol <- v val mutable notes : note list = [] method note_on n v = let note = { note = n; volume = v; (* TODO: we could want to change the volume after a not has begun to be played *) generator = self#generator (Audio.Note.freq n) (v *. vol); } in notes <- note :: notes method note_off n _ = (* TODO: remove only one note *) (* TODO: merge the two iterations on the list *) List.iter (fun note -> if note.note = n then note.generator#release) notes; notes <- List.filter (fun note -> not note.generator#dead) notes method fill_add buf = List.iter (fun note -> note.generator#fill_add buf) notes method private fill buf = Audio.clear buf; self#fill_add buf method private event = function | MIDI.Note_off (n, v) -> self#note_off n v | MIDI.Note_on (n, v) -> self#note_on n v | MIDI.Control_change (0x7, v) -> self#set_volume (float v /. 127.) | _ -> () (* TODO: add offset for evs *) method play_add evs eofs buf = let len = Audio.length buf in let rec play o evs ofs = match evs with | (t, _) :: _ when t >= eofs + len -> () | (t, _) :: tl when t < eofs -> play t tl ofs | (t, e) :: tl -> let delta = t - max eofs o in self#fill_add (Audio.sub buf ofs delta); self#event e; play t tl (ofs + delta) | [] -> self#fill_add (Audio.sub buf ofs (len - o)) in play 0 (MIDI.data evs) 0 method play evs eofs buf = Audio.clear buf; self#play_add evs eofs buf method reset = notes <- [] end class create g = object inherit base method private generator f v = g f v end class create_mono g = create (fun f v -> new Audio.Generator.of_mono (g f v)) let might_adsr adsr g = match adsr with None -> g | Some a -> new Audio.Mono.Generator.adsr a g class sine ?adsr sr = create_mono (fun f v -> might_adsr adsr (new Audio.Mono.Generator.sine sr ~volume:v f)) class square ?adsr sr = create_mono (fun f v -> might_adsr adsr (new Audio.Mono.Generator.square sr ~volume:v f)) class saw ?adsr sr = create_mono (fun f v -> might_adsr adsr (new Audio.Mono.Generator.saw sr ~volume:v f)) class monophonic (g : Audio.Generator.t) = object (self) method set_volume v = g#set_volume v method note_on n v = g#set_frequency (Audio.Note.freq n); g#set_volume v method note_off (_ : int) (_ : float) = (* TODO: check for the last note? *) g#release method fill_add buf = g#fill_add buf method play_add (_ : MIDI.buffer) (_ : int) (_ : Audio.buffer) : unit = assert false method play evs eofs buf : unit = self#play_add evs eofs buf; assert false method reset = g#set_volume 0. end module Multitrack = struct class type t = object method play_add : MIDI.Multitrack.buffer -> int -> Audio.buffer -> unit method play : MIDI.Multitrack.buffer -> int -> Audio.buffer -> unit end class create n (f : int -> synth) = object (self) val synth = Array.init n f method play_add (evs : MIDI.Multitrack.buffer) eofs buf = for c = 0 to Array.length synth - 1 do synth.(c)#play_add evs.(c) eofs buf done method play evs eofs buf = Audio.clear buf; self#play_add evs eofs buf end end ocaml-mm-0.7.3/src/synth.mli000066400000000000000000000073711415601551300156730ustar00rootroot00000000000000(* * Copyright 2011 The Savonet Team * * This file is part of ocaml-mm. * * ocaml-mm is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * ocaml-mm 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 Lesser General Public License * along with ocaml-mm; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA * * As a special exception to the GNU Library General Public License, you may * link, statically or dynamically, a "work that uses the Library" with a publicly * distributed version of the Library to produce an executable file containing * portions of the Library, and distribute that executable file under terms of * your choice, without any of the additional requirements listed in clause 6 * of the GNU Library General Public License. * By "a publicly distributed version of the Library", we mean either the unmodified * Library as distributed by The Savonet Team, or a modified version of the Library that is * distributed under the conditions defined in clause 3 of the GNU Library General * Public License. This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU Library General Public License. * *) open Mm_audio (** Operations on synthesizers. *) (** A synthesizer. *) class type t = object (** Set the global volume of the synth. *) method set_volume : float -> unit (** Play a note. *) method note_on : int -> float -> unit (** Stop playing a note. *) method note_off : int -> float -> unit (** Fill a buffer with synthesized data adding to the original data of the buffer. *) method fill_add : Audio.buffer -> unit (** Synthesize into an audio buffer. Notice that the delta times in the track should be in samples (so they do depend on the samplerate). *) method play : MIDI.buffer -> int -> Audio.buffer -> unit (** Same as [play] but keeps data originally present in the buffer. *) method play_add : MIDI.buffer -> int -> Audio.buffer -> unit (** Reset the synthesizer (sets all notes off in particular). *) method reset : unit end (** A synthesizer. *) type synth = t (** Create a synthesizer from a function which creates a generator at given frequency and volume. *) class create : (float -> float -> Audio.Generator.t) -> t (** Same as [create] with a mono generator. *) class create_mono : (float -> float -> Audio.Mono.Generator.t) -> t (** Sine synthesizer. *) class sine : ?adsr:Audio.Mono.Effect.ADSR.t -> int -> t (** Square synthesizer. *) class square : ?adsr:Audio.Mono.Effect.ADSR.t -> int -> t (** Saw synthesizer. *) class saw : ?adsr:Audio.Mono.Effect.ADSR.t -> int -> t (** Synths with only one note at a time. *) class monophonic : Audio.Generator.t -> t (** Multichannel synthesizers. *) module Multitrack : sig (** A multichannel synthesizer. *) class type t = object (** Synthesize into an audio buffer. *) method play : MIDI.Multitrack.buffer -> int -> Audio.buffer -> unit (** Same as [play] but keeps data originally present in the buffer. *) method play_add : MIDI.Multitrack.buffer -> int -> Audio.buffer -> unit end (** Create a multichannel synthesizer with given number of channels and a function returning the synthesizer on each channel. *) class create : int -> (int -> synth) -> t end ocaml-mm-0.7.3/src/video.ml000066400000000000000000000205371415601551300154620ustar00rootroot00000000000000(* * Copyright 2011 The Savonet Team * * This file is part of ocaml-mm. * * ocaml-mm is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * ocaml-mm 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 Lesser General Public License * along with ocaml-mm; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA * * As a special exception to the GNU Library General Public License, you may * link, statically or dynamically, a "work that uses the Library" with a publicly * distributed version of the Library to produce an executable file containing * portions of the Library, and distribute that executable file under terms of * your choice, without any of the additional requirements listed in clause 6 * of the GNU Library General Public License. * By "a publicly distributed version of the Library", we mean either the unmodified * Library as distributed by The Savonet Team, or a modified version of the Library that is * distributed under the conditions defined in clause 3 of the GNU Library General * Public License. This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU Library General Public License. * *) open Mm_base open Mm_image module Image = struct include Image.YUV420 let create w h = create w h end type t = Image.t array type buffer = t let make len width height = Array.init len (fun _ -> Image.create width height) let single img = [| img |] let blit sbuf sofs dbuf dofs len = for i = 0 to len - 1 do Image.blit_all sbuf.(sofs + i) dbuf.(dofs + i) done let copy vid = Array.map Image.copy vid let length vid = Array.length vid let size vid = let n = ref 0 in for i = 0 to Array.length vid - 1 do n := !n + Image.size vid.(i) done; !n let get vid i = vid.(i) let set vid i img = vid.(i) <- img let iter f vid off len = for i = off to off + len - 1 do f vid.(i) done let blank vid off len = iter Image.blank vid off len let randomize vid off len = iter Image.randomize vid off len (* module RE = struct type t = Image.t let create () = Image.create 0 0 let blit = blit end *) (* module Ringbuffer_ext = Ringbuffer.Make_ext (RE) *) (* module Ringbuffer = Ringbuffer.Make (RE) *) module FPS = struct type t = float (* TODO: improve this! *) let to_frac f = let n = floor ((f *. 100.) +. 0.5) in let n = int_of_float n in if n mod 100 = 0 then (n / 100, 1) else (n, 100) end module IO = struct exception Invalid_file module Reader = struct class type t = object method width : int method height : int method frame_rate : float (* method set_target_size : int -> int -> unit *) method read : buffer -> int -> int -> int (* method read_audio : Audio.buffer -> int -> int -> int *) method close : unit end end module Writer = struct class type t = object method write : buffer -> int -> int -> unit (* method write_audio : Audio.buffer -> int -> int -> unit *) method close : unit end class virtual avi frame_rate w h = let frames_per_chunk = int_of_float (frame_rate +. 0.5) in let frame_size = w * h * 3 in object (self) inherit IO.helper method virtual private stream_write : string -> int -> int -> int method virtual private stream_seek : int -> unit method virtual private stream_close : unit initializer self#output "RIFF"; self#output_int 0; (* TOFILL: file size *) self#output "AVI "; (* file type *) (* Headers *) self#output "LIST"; self#output_int 192; (* size of the list *) self#output "hdrl"; (* AVI header *) self#output "avih"; self#output_int 56; (* AVI header size *) self#output_int (int_of_float (1000000. /. frame_rate)); (* microseconds per frame *) self#output_int 0; (* max bytes per sec *) self#output_int 0; (* pad to multiples of this size *) self#output_byte 0; (* flags *) self#output_byte 1; (* flags (interleaved) *) self#output_byte 0; (* flags *) self#output_byte 0; (* flags *) self#output_int 0; (* TOFILL: total number of frames *) self#output_int 0; (* initial frame *) self#output_int 1; (* number of streams (TODO: change if audio) *) self#output_int 0; (* suggested buffer size *) self#output_int w; (* width *) self#output_int h; (* height *) self#output_int 0; (* scale *) self#output_int 0; (* rate *) self#output_int 0; (* start *) self#output_int 0; (* length *) (* Stream headers *) self#output "LIST"; self#output_int 116; self#output "strl"; (* Stream header *) self#output "strh"; self#output_int 56; self#output "vids"; self#output "RGB "; (* codec *) self#output_int 0; (* flags *) self#output_int 0; (* stream priority and language *) self#output_int 0; (* initial frames *) self#output_int 10; (* scale : rate / scale = frames / second or samples / second *) self#output_int (int_of_float (frame_rate *. 10.)); (* rate *) self#output_int 0; (* stream start time (in frames). *) self#output_int 0; (* TOFILL: stream length (= number of frames) *) self#output_int (frames_per_chunk * frame_size); (* suggested buffer size *) self#output_int 0; (* stream quality *) self#output_int 0; (* size of samples *) self#output_short 0; (* destination rectangle: left *) self#output_short 0; (* top *) self#output_short w; (* right *) self#output_short h; (* bottom *) (* Stream format *) self#output "strf"; self#output_int 40; self#output_int 40; (* video size (????) *) self#output_int w; (* width *) self#output_int h; (* height *) self#output_short 1; (* panes *) self#output_short 24; (* color depth *) self#output_int 0; (* tag1 (????) *) self#output_int frame_size; (* image size *) self#output_int 0; (* X pixels per meter *) self#output_int 0; (* Y pixels per meter *) self#output_int 0; (* colors used *) self#output_int 0; (* important colors *) (* movie data *) self#output "LIST"; self#output_int 0; (* TOFILL: movie size *) self#output "movi"; (* video chunks follow *) self#output "00dc"; self#output_int 0 (* TOFILL: size *) val mutable datalen = 0 val mutable dataframes = 0 method write (_ : buffer) ofs len = for _ = ofs to ofs + len - 1 do (* let s = Image.to_RGB24_string buf.(i) in *) let s = failwith "TODO: output YUV420 avi" in self#output s; datalen <- datalen + String.length s done; dataframes <- dataframes + len method close = Printf.printf "completing... (%d frames)\n%!" dataframes; self#stream_seek 4; self#output_int (datalen + (56 * 4)); self#stream_seek (12 * 4); self#output_int dataframes; self#stream_seek (35 * 4); self#output_int dataframes; self#stream_seek (54 * 4); self#output_int (datalen + (3 * 4)); self#stream_seek (57 * 4); self#output_int datalen; self#stream_close end class to_avi_file fname fr w h = object inherit avi fr w h inherit IO.Unix.rw ~write:true fname end end end ocaml-mm-0.7.3/src/video.mli000066400000000000000000000105041415601551300156240ustar00rootroot00000000000000(* * Copyright 2011 The Savonet Team * * This file is part of ocaml-mm. * * ocaml-mm is free software; you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * ocaml-mm 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 Lesser General Public License * along with ocaml-mm; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA * * As a special exception to the GNU Library General Public License, you may * link, statically or dynamically, a "work that uses the Library" with a publicly * distributed version of the Library to produce an executable file containing * portions of the Library, and distribute that executable file under terms of * your choice, without any of the additional requirements listed in clause 6 * of the GNU Library General Public License. * By "a publicly distributed version of the Library", we mean either the unmodified * Library as distributed by The Savonet Team, or a modified version of the Library that is * distributed under the conditions defined in clause 3 of the GNU Library General * Public License. This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU Library General Public License. * *) (** Operations on video data. *) open Mm_image (** Images of videos. *) module Image : sig type t = Image.YUV420.t val create : int -> int -> t val of_RGB24_string : string -> int -> t (** Convert to format useable by [Graphics.make_image]. *) val to_int_image : t -> int array array val copy : t -> t val width : t -> int val height : t -> int val dimensions : t -> int * int (** Size in bytes. *) val size : t -> int val blank : t -> unit val fill_alpha : t -> int -> unit val scale : ?proportional:bool -> t -> t -> unit val randomize : t -> unit (** [blit_all src dst] blits an entire image. *) val blit : t -> t -> unit val get_pixel_rgba : t -> int -> int -> int * int * int * int val set_pixel_rgba : t -> int -> int -> int * int * int * int -> unit (** Add the fist image to the second. *) val add : t -> ?x:int -> ?y:int -> t -> unit module Effect : sig val greyscale : t -> unit val sepia : t -> unit val invert : t -> unit val lomo : t -> unit module Alpha : sig val scale : t -> float -> unit val disk : t -> int -> int -> int -> unit end end end (** A video buffer. *) type t = Image.t array type buffer = t (** Create a buffer with a given number of frames of given size. *) val make : int -> int -> int -> t (** Video with a single image. *) val single : Image.t -> t val blit : t -> int -> t -> int -> int -> unit (** Create a fresh copy of a buffer. *) val copy : t -> t (** Length in images. *) val length : t -> int (** Size in bytes. *) val size : t -> int (** Obtaine the i-th image of a video. *) val get : t -> int -> Image.t val set : t -> int -> Image.t -> unit val iter : (Image.t -> unit) -> t -> int -> int -> unit val blank : t -> int -> int -> unit val randomize : t -> int -> int -> unit (* module Ringbuffer_ext : Ringbuffer.R with type elt = frame *) (* module Ringbuffer : Ringbuffer.R with type elt = frame *) (** Operations on frame rates. *) module FPS : sig type t = float (** Convert a frame rate to a fraction. *) val to_frac : t -> int * int end module IO : sig exception Invalid_file module Reader : sig class type t = object method width : int method height : int (** Number of frames per second. *) method frame_rate : FPS.t (* method set_target_size : int -> int -> unit *) (** Read a given number of frames. *) method read : buffer -> int -> int -> int method close : unit end end module Writer : sig class type t = object method write : buffer -> int -> int -> unit method close : unit end class to_avi_file : string -> FPS.t -> int -> int -> t end end