New Upstream Release - ocaml-mm
Ready changes
Summary
Merged new upstream version: 0.8.4 (was: 0.8.1).
Diff
diff --git a/.github/workflows/doc.yml b/.github/workflows/doc.yml
index 258ac20..d3d6fed 100644
--- a/.github/workflows/doc.yml
+++ b/.github/workflows/doc.yml
@@ -1,4 +1,4 @@
-name: Build doc
+name: Documentation
on:
push:
@@ -13,6 +13,8 @@ jobs:
uses: actions/checkout@v2
- name: Setup OCaml
uses: avsm/setup-ocaml@v2
+ with:
+ ocaml-compiler: 4.14.0
- name: Pin locally
run: opam pin -y add -n .
- name: Install locally
diff --git a/.ocamlformat b/.ocamlformat
index ff63c58..857030a 100644
--- a/.ocamlformat
+++ b/.ocamlformat
@@ -1,4 +1,4 @@
-version=0.19.0
+version=0.25.1
profile = conventional
break-separators = after
space-around-lists = false
diff --git a/CHANGES.md b/CHANGES.md
index 19435a2..a52a2e1 100644
--- a/CHANGES.md
+++ b/CHANGES.md
@@ -1,8 +1,24 @@
+0.8.4 (2023-07-01)
+=====
+- Add `Image.ARGB8.*`.
+- Add conversion functions to/from int16 big arrays.
+
+0.8.3 (2023-03-01)
+=====
+- Add `Image.RGB8.Color.to_int`.
+- Add `Image.Canvas.planes`.
+- Add `Image.Invalid_position` and `Image.Invalid_dimensions` exceptions.
+
+0.8.2 (2023-02-08)
+=====
+- Add ReplayGain computation.
+
0.8.1 (24-05-2022)
=====
- Add support for bitmaps and bitmap fonts.
- Working AVI video output.
- Compile with OCaml 5.
+- Clarify license by switching to plain LGPL 2.1 (#16).
0.8.0 (13-03-2022)
=====
diff --git a/COPYING b/COPYING
index 12d3ede..4362b49 100644
--- a/COPYING
+++ b/COPYING
@@ -1,29 +1,8 @@
-This 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
+ 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
+ 51 Franklin Street, 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.
@@ -31,7 +10,7 @@ Public License.
as the successor of the GNU Library Public License, version 2, hence
the version number 2.1.]
- Preamble
+ Preamble
The licenses for most software are designed to take away your
freedom to share and change it. By contrast, the GNU General Public
@@ -133,7 +112,7 @@ modification follow. Pay close attention to the difference between a
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
+ GNU LESSER GENERAL PUBLIC LICENSE
TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
0. This License Agreement applies to any software library or other
@@ -167,7 +146,7 @@ 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
@@ -453,7 +432,7 @@ 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
+ 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.
@@ -476,7 +455,7 @@ 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
+ END OF TERMS AND CONDITIONS
How to Apply These Terms to Your New Libraries
@@ -506,7 +485,7 @@ convey the exclusion of warranty; and each file should have at least the
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
+ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
Also add information on how to contact you by electronic and paper mail.
@@ -521,5 +500,3 @@ necessary. Here is a sample; alter the names:
Ty Coon, President of Vice
That's all there is to it!
-
-
diff --git a/debian/changelog b/debian/changelog
index 3158b35..d18292b 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,9 @@
+ocaml-mm (0.8.4-1) UNRELEASED; urgency=low
+
+ * New upstream release.
+
+ -- Debian Janitor <janitor@jelmer.uk> Tue, 11 Jul 2023 17:20:48 -0000
+
ocaml-mm (0.8.1-1) unstable; urgency=medium
[ Kyle Robbertze ]
diff --git a/debian/patches/0001-Remove-enable_if-directive.patch b/debian/patches/0001-Remove-enable_if-directive.patch
index f618050..fd4eeb2 100644
--- a/debian/patches/0001-Remove-enable_if-directive.patch
+++ b/debian/patches/0001-Remove-enable_if-directive.patch
@@ -13,10 +13,10 @@ Bug-Debian: https://bugs.debian.org/1000983
external/dune | 2 --
1 file changed, 2 deletions(-)
-diff --git a/external/dune b/external/dune
-index 15fb821..fa561ed 100644
---- a/external/dune
-+++ b/external/dune
+Index: ocaml-mm.git/external/dune
+===================================================================
+--- ocaml-mm.git.orig/external/dune
++++ ocaml-mm.git/external/dune
@@ -63,8 +63,6 @@
(foreign_stubs
(language c)
diff --git a/dune-project b/dune-project
index b6242a3..47cded3 100644
--- a/dune-project
+++ b/dune-project
@@ -1,8 +1,8 @@
-(lang dune 2.8)
-(version 0.8.1)
+(lang dune 3.6)
+(version 0.8.4)
(name mm)
(source (github savonet/ocaml-mm))
-(license GPL-2.0)
+(license LGPL-2.1-or-later)
(authors "Samuel Mimram <smimram@gmail.com>")
(maintainers "The Savonet Team <savonet-users@lists.sourceforge.net>")
@@ -10,7 +10,7 @@
(package
(name mm)
- (synopsis "The mm library contains high-level to create and manipulate multimedia streams (audio, video, MIDI)")
+ (synopsis "The mm library contains high-level APIs to create and manipulate multimedia streams (audio, video, MIDI)")
(depends
(ocaml (>= 4.08))
(ocaml (and :with-test (>= 4.12)))
diff --git a/examples/drums.ml b/examples/drums.ml
index de82893..c2d4a3e 100644
--- a/examples/drums.ml
+++ b/examples/drums.ml
@@ -55,7 +55,7 @@ let () =
let buf = Audio.append bd 0 blen sd 0 blen in
while true do
(* wav#write buf 0 blen; *)
- oss#write buf 0 (2*blen)
+ oss#write buf 0 (2 * blen)
done;
(* wav#close; *)
oss#close
diff --git a/examples/dune b/examples/dune
index d3bb262..0b43b5e 100644
--- a/examples/dune
+++ b/examples/dune
@@ -58,6 +58,12 @@
(optional)
(libraries graphics mm))
+(executable
+ (name replaygain)
+ (modules replaygain)
+ (optional)
+ (libraries mm.audio))
+
(executable
(name test)
(modules test)
diff --git a/examples/fft.ml b/examples/fft.ml
index 1614b36..7dc5470 100644
--- a/examples/fft.ml
+++ b/examples/fft.ml
@@ -21,8 +21,7 @@ let () =
oss#write buf blen n;
for o = 0 to fft_times_per_buf - 1 do
let c =
- FFT.complex_create
- (Audio.to_mono buf 0 blen)
+ FFT.complex_create (Audio.to_mono buf 0 blen)
(o * blen / fft_times_per_buf)
blen
in
diff --git a/examples/replaygain b/examples/replaygain
new file mode 100755
index 0000000..ca4c9b2
--- /dev/null
+++ b/examples/replaygain
@@ -0,0 +1,2 @@
+#!/bin/sh
+dune exec ./replaygain.exe $*
diff --git a/examples/replaygain.ml b/examples/replaygain.ml
new file mode 100644
index 0000000..441a75d
--- /dev/null
+++ b/examples/replaygain.ml
@@ -0,0 +1,25 @@
+open Mm_audio
+module RG = Audio.Analyze.ReplayGain
+
+let () =
+ let fname = Sys.argv.(1) in
+ Printf.printf "Computing replaygain for %s.\n%!" fname;
+ let f = new Audio.IO.Reader.of_wav_file fname in
+ let channels = f#channels in
+ let rg = RG.create ~channels ~samplerate:f#sample_rate in
+ let len = 1024 in
+ let buf = Audio.create channels len in
+ let total = f#length in
+ let processed = ref 0 in
+ let loop = ref true in
+ while !loop do
+ let n = f#read buf 0 len in
+ processed := !processed + n;
+ Printf.printf "\rProcessing: %d%%%!" (!processed * 100 / total);
+ if n = 0 then loop := false;
+ RG.process rg buf 0 n
+ done;
+ Printf.printf "\rProcessing done.\n%!";
+ f#close;
+ Printf.printf "- peak: %f\n%!" (RG.peak rg);
+ Printf.printf "- gain: %f dB\n%!" (RG.gain rg)
diff --git a/examples/test.ml b/examples/test.ml
index 54f512e..190ff04 100644
--- a/examples/test.ml
+++ b/examples/test.ml
@@ -9,8 +9,9 @@ let () =
(fun _ -> ())
"test [options]"
+let () = if not (Sys.file_exists "out") then Sys.mkdir "out" 0o755
+
let write fname s =
- if not (Sys.file_exists "out") then Sys.mkdir "out" 0o755;
let fname = "out/" ^ fname in
let oc = open_out fname in
output_string oc s;
@@ -41,6 +42,21 @@ let () =
Printf.printf "- word size: %d\n%!" Sys.word_size;
Printf.printf "\n%!"
+let () =
+ Printf.printf "## Testing basic functions\n\n%!";
+ assert (
+ try
+ ignore (Image.RGB8.Color.of_int 0xff00ff);
+ true
+ with _ -> false);
+ assert (
+ try
+ ignore
+ (Image.RGB8.Color.of_int
+ (Option.get (Int32.unsigned_to_int 0xaaff00ffl)));
+ false
+ with _ -> true)
+
module A = Audio
let () =
@@ -68,8 +84,7 @@ let () =
A.U8.of_audio src 0 buf 0 len;
A.U8.to_audio (Bytes.unsafe_to_string buf) 0 dst 0 len
done;
- assert (dst.(1).(len - 1) = 1.)
- );
+ assert (dst.(1).(len - 1) = 1.));
let src = A.make 2 len 1. in
let buf = Bytes.create (A.S16LE.size 2 len) in
let dst = A.create 2 len in
@@ -79,8 +94,7 @@ let () =
A.S16LE.to_audio (Bytes.unsafe_to_string buf) 0 dst 0 len
done;
assert (dst.(1).(len - 1) = 1.);
- assert (dst.(1).(len - 1) = 1.)
- );
+ assert (dst.(1).(len - 1) = 1.));
let src = A.make 2 len 1. in
let buf = Bytes.create (A.S16BE.size 2 len) in
let dst = A.create 2 len in
@@ -90,8 +104,7 @@ let () =
A.S16BE.to_audio (Bytes.unsafe_to_string buf) 0 dst 0 len
done;
assert (dst.(1).(len - 1) = 1.);
- assert (dst.(1).(len - 1) = 1.)
- );
+ assert (dst.(1).(len - 1) = 1.));
let src = A.make 2 len 1. in
let buf = Bytes.create (A.S24LE.size 2 len) in
let dst = A.create 2 len in
@@ -101,8 +114,7 @@ let () =
A.S24LE.to_audio (Bytes.unsafe_to_string buf) 0 dst 0 len
done;
assert (dst.(1).(len - 1) = 1.);
- assert (dst.(1).(len - 1) = 1.)
- );
+ assert (dst.(1).(len - 1) = 1.));
let src = A.make 2 len 1. in
let buf = Bytes.create (A.S32LE.size 2 len) in
let dst = A.create 2 len in
@@ -111,17 +123,47 @@ let () =
A.S32LE.of_audio src 0 buf 0 len;
A.S32LE.to_audio (Bytes.unsafe_to_string buf) 0 dst 0 len
done;
- assert (dst.(1).(len - 1) = 1.)
- );
+ assert (dst.(1).(len - 1) = 1.));
test "s16le with offset" (fun () ->
let chans = 2 in
let src = A.create chans len in
let off = 21 in
let buf = Bytes.create (off + A.S16LE.size chans len) in
- A.S16LE.of_audio src 5 buf off (len-5);
- A.S16LE.to_audio (Bytes.unsafe_to_string buf) off src 0 len
- );
- Printf.printf "\n"
+ A.S16LE.of_audio src 5 buf off (len - 5);
+ A.S16LE.to_audio (Bytes.unsafe_to_string buf) off src 0 len);
+ test "generate sine" (fun () ->
+ let chans = 2 in
+ let samplerate = 44100 in
+ let sl = new A.Mono.Generator.sine samplerate 440. in
+ let sr = new A.Mono.Generator.sine samplerate 880. in
+ let len = samplerate in
+ let buf = A.create chans len in
+ let f = new A.IO.Writer.to_wav_file chans samplerate "out/sine.wav" in
+ for _ = 0 to 9 do
+ sl#fill buf.(0) 0 len;
+ sr#fill buf.(1) 0 len;
+ f#write buf 0 len
+ done;
+ f#close);
+ time "compute replaygain" (fun () ->
+ let f = new A.IO.Reader.of_wav_file "out/sine.wav" in
+ let channels = f#channels in
+ let rg =
+ A.Analyze.ReplayGain.create ~channels ~samplerate:f#sample_rate
+ in
+ let loop = ref true in
+ let len = 1024 in
+ let buf = A.create channels len in
+ while !loop do
+ let n = f#read buf 0 len in
+ if n = 0 then loop := false
+ else A.Analyze.ReplayGain.process rg buf 0 len
+ done;
+ let gain = A.Analyze.ReplayGain.gain rg in
+ (* Printf.printf "[%.02f dB] %!" gain; *)
+ assert (abs_float (gain -. -14.56) < 0.05))
+
+let () = Printf.printf "\n"
module I = Image
@@ -194,6 +236,25 @@ let () =
let img = I.CanvasYUV420.make ~x:150 ~y:200 ~width:600 ~height:600 r in
let img = I.CanvasYUV420.render img in
write "canvas.bmp" (I.YUV420.to_BMP img));
+ test "scale grid proportionally" (fun () ->
+ let d = 100 in
+ let s = 10 in
+ let img = I.YUV420.create d d in
+ for j = 0 to d - 1 do
+ for i = 0 to d - 1 do
+ let c =
+ if ((i / s) + (j / s)) mod 2 = 0 then (0xff, 0xff, 0xff, 0xff)
+ else (0x00, 0x00, 0x00, 0xff)
+ in
+ I.YUV420.set_pixel_rgba img i j c
+ done
+ done;
+ let img =
+ I.CanvasYUV420.make img
+ |> I.CanvasYUV420.resize 640 362
+ |> I.CanvasYUV420.render
+ in
+ write "scale-grid.bmp" (I.YUV420.to_BMP img));
test "scale canvas" (fun () ->
let img = I.YUV420.create 1000 1000 in
I.YUV420.gradient_uv img (0, 0) (0xff, 0) (0, 0xff);
@@ -235,6 +296,12 @@ let () =
assert (not (I.YUV420.is_opaque img));
I.YUV420.set_pixel_rgba img 10 10 (0, 0, 0, 0xff);
assert (I.YUV420.is_opaque img));
+ test "add" (fun () ->
+ let a = I.YUV420.create 1280 480 in
+ let b = I.YUV420.create 640 480 in
+ let x = 1280 in
+ let y = 0 in
+ I.YUV420.add a ~x ~y b);
time "many adds" (fun () ->
let r = I.YUV420.create 500 500 in
I.YUV420.fill r (I.Pixel.yuv_of_rgb (0xff, 0, 0));
@@ -281,8 +348,7 @@ let () =
write "scale.bmp" (I.YUV420.to_BMP img2));
test "font" (fun () ->
let img = I.Bitmap.Font.render ~size:30 "Hello, world!\nHow are you?" in
- write "hello-world.bmp" (I.YUV420.to_BMP (I.YUV420.of_bitmap img))
- );
+ write "hello-world.bmp" (I.YUV420.to_BMP (I.YUV420.of_bitmap img)));
time "sliding font" (fun () ->
let width = 1280 in
let height = 720 in
@@ -292,18 +358,16 @@ let () =
let txt = I.YUV420.of_bitmap txt in
let fname = "out/hello-world.avi" in
let oc = open_out fname in
- output_string oc (Video.AVI.Writer.header ~width ~height ~framerate:fps ());
+ output_string oc
+ (Video.AVI.Writer.header ~width ~height ~framerate:fps ());
for i = 0 to duration * fps do
let img = I.YUV420.create width height in
- I.YUV420.fill img (I.Pixel.yuv_of_rgb (2*i,0,0xff));
- I.YUV420.add txt ~x:(3*i) ~y:(2*i) img;
+ I.YUV420.fill img (I.Pixel.yuv_of_rgb (2 * i, 0, 0xff));
+ I.YUV420.add txt ~x:(3 * i) ~y:(2 * i) img;
output_string oc (Video.AVI.Writer.Chunk.video_yuv420 img)
done;
- close_out oc
- );
- test "empty text" (fun () ->
- ignore (I.Bitmap.Font.render ~size:20 "")
- );
+ close_out oc);
+ test "empty text" (fun () -> ignore (I.Bitmap.Font.render ~size:20 ""));
time "increasing saw" (fun () ->
let width = 640 in
let height = 360 in
@@ -313,7 +377,9 @@ let () =
let channels = 2 in
let samplerate = 44100 in
let oc = open_out fname in
- output_string oc (Video.AVI.Writer.header ~width ~height ~framerate:fps ~channels ~samplerate ());
+ output_string oc
+ (Video.AVI.Writer.header ~width ~height ~framerate:fps ~channels
+ ~samplerate ());
let fmin = 20. in
let fmax = 20000. in
let duration = 20. in
@@ -324,24 +390,27 @@ let () =
let buf = Audio.create channels (samplerate / fps) in
let osc = ref (-1.) in
while !t <= duration do
- let f = fmin +. 2. ** (!t /. a) in
- let txt = I.Bitmap.Font.render ~size:fontsize (Printf.sprintf "%.2f Hz" f) in
+ let f = fmin +. (2. ** (!t /. a)) in
+ let txt =
+ I.Bitmap.Font.render ~size:fontsize (Printf.sprintf "%.2f Hz" f)
+ in
let txt = I.YUV420.of_bitmap txt in
let img = I.YUV420.create width height in
I.YUV420.blank img;
- I.YUV420.add txt ~y:((height-fontsize)/2) img;
+ I.YUV420.add txt ~y:((height - fontsize) / 2) img;
output_string oc (Video.AVI.Writer.Chunk.video_yuv420 img);
for i = 0 to Audio.length buf - 1 do
for c = 0 to Audio.channels buf - 1 do
buf.(c).(i) <- !osc
done;
- osc := !osc +. 2. *. f /. float samplerate;
- while !osc > 1. do osc := !osc -. 1.; done;
+ osc := !osc +. (2. *. f /. float samplerate);
+ while !osc > 1. do
+ osc := !osc -. 1.
+ done;
t := !t +. dt
done;
output_string oc (Video.AVI.Writer.Chunk.audio_s16le buf)
done;
- close_out oc
- )
+ close_out oc)
let () = Gc.full_major ()
diff --git a/external/mm_alsa.ml b/external/mm_alsa.ml
index b6af14e..8bbfe6a 100644
--- a/external/mm_alsa.ml
+++ b/external/mm_alsa.ml
@@ -51,16 +51,16 @@ let rw channels samplerate ?(device = "default") ?(playback = false)
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)
+ 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 = Alsa.Pcm.readn_float dev
method write = Alsa.Pcm.writen_float dev
diff --git a/external/mm_mad.ml b/external/mm_mad.ml
index e8d9690..9997d89 100644
--- a/external/mm_mad.ml
+++ b/external/mm_mad.ml
@@ -51,14 +51,14 @@ class virtual reader =
method private mf = match mf with Some mf -> mf | _ -> assert false
initializer
- let f = Mad.openstream self#stream_read 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
+ let f = Mad.openstream self#stream_read 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 self#mf
method close = self#stream_close
diff --git a/external/mm_oss.ml b/external/mm_oss.ml
index c5a94d5..66423e9 100644
--- a/external/mm_oss.ml
+++ b/external/mm_oss.ml
@@ -49,9 +49,9 @@ class writer ?(device = "/dev/dsp") channels sample_rate =
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)
+ 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
@@ -71,9 +71,9 @@ class reader ?(device = "/dev/dsp") channels sample_rate =
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)
+ 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
diff --git a/external/mm_sdl.ml b/external/mm_sdl.ml
index a192851..7b99a3f 100644
--- a/external/mm_sdl.ml
+++ b/external/mm_sdl.ml
@@ -179,10 +179,10 @@ let from_32 surface =
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])
+ 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 ()
@@ -192,9 +192,9 @@ class writer_to_screen w h =
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)
+ (* | 16 -> to_16 rgb surface *)
+ | 32 -> to_32 rgb surface
+ | i -> failwith (Printf.sprintf "Unsupported format %dbpp" i)
end;
Sdlvideo.flip surface)
@@ -259,12 +259,12 @@ class midi_keyboard : MIDI.IO.Reader.t =
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 [])
+ 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
diff --git a/mm.opam b/mm.opam
index e77370e..6173df1 100644
--- a/mm.opam
+++ b/mm.opam
@@ -1,17 +1,17 @@
# This file is generated by dune, edit dune-project instead
opam-version: "2.0"
-version: "0.8.1"
+version: "0.8.4"
synopsis:
- "The mm library contains high-level to create and manipulate multimedia streams (audio, video, MIDI)"
+ "The mm library contains high-level APIs to create and manipulate multimedia streams (audio, video, MIDI)"
maintainer: ["The Savonet Team <savonet-users@lists.sourceforge.net>"]
authors: ["Samuel Mimram <smimram@gmail.com>"]
-license: "GPL-2.0"
+license: "LGPL-2.1-or-later"
homepage: "https://github.com/savonet/ocaml-mm"
bug-reports: "https://github.com/savonet/ocaml-mm/issues"
depends: [
"ocaml" {>= "4.08"}
"ocaml" {with-test & >= "4.12"}
- "dune" {>= "2.8"}
+ "dune" {>= "3.6"}
"dune-configurator"
"odoc" {with-doc}
]
diff --git a/src/MIDI.ml b/src/MIDI.ml
index 34ea2d0..067d1fc 100644
--- a/src/MIDI.ml
+++ b/src/MIDI.ml
@@ -38,9 +38,12 @@ 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). *)
+ | 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 *)
+ | Control_change of
+ int * int (* TODO: specific type for common control changes *)
| Patch of int
| Channel_aftertouch of int
| Pitch of int
@@ -396,41 +399,41 @@ module IO = struct
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
+ (* 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
- 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
+ track <- trk
(* We store here the track with delta-times in samples. TODO: this way of
doing things is messy but simpler to implement *)
@@ -515,23 +518,23 @@ module IO = struct
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 "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
+ (* fist track *)
+ self#output "MTrk";
+ (* track length *)
+ self#output_int 0
method put chan e =
let d = delta curdelta in
diff --git a/src/audio.ml b/src/audio.ml
index b14474f..ff96658 100644
--- a/src/audio.ml
+++ b/src/audio.ml
@@ -117,6 +117,34 @@ module Sample = struct
let x = max (-1.) x in
let x = min 1. x in
x
+
+ let iir a b =
+ let na = Array.length a in
+ let nb = Array.length b in
+ assert (a.(0) = 1.);
+ let x = Array.make nb 0. in
+ let y = Array.make na 0. in
+ let ka = ref 0 in
+ let kb = ref 0 in
+ fun x0 ->
+ let y0 = ref 0. in
+ x.(!kb) <- x0;
+ for i = 0 to nb - 1 do
+ y0 := !y0 +. (b.(i) *. x.((!kb + i) mod nb))
+ done;
+ for i = 1 to na - 1 do
+ y0 := !y0 -. (a.(i) *. y.((!ka + i) mod na))
+ done;
+ if na > 0 then y.(!ka) <- !y0;
+ let decr n k =
+ decr k;
+ if !k < 0 then k := !k + n
+ in
+ decr na ka;
+ decr nb kb;
+ !y0
+
+ let fir b = iir [||] b
end
module Mono = struct
@@ -161,6 +189,33 @@ module Mono = struct
copy_to_ba buf ofs len ba;
ba
+ external copy_from_int16_ba :
+ (int, Bigarray.int16_signed_elt, Bigarray.c_layout) Bigarray.Array1.t ->
+ float array ->
+ int ->
+ int ->
+ unit = "caml_mm_audio_copy_from_int16_ba"
+
+ external copy_to_int16_ba :
+ float array ->
+ int ->
+ int ->
+ (int, Bigarray.int16_signed_elt, Bigarray.c_layout) Bigarray.Array1.t ->
+ unit = "caml_mm_audio_copy_to_int16_ba"
+
+ let of_int16_ba buf =
+ let len = Bigarray.Array1.dim buf in
+ let dst = Array.create_float len in
+ copy_from_int16_ba buf dst 0 len;
+ dst
+
+ let to_int16_ba buf ofs len =
+ let ba =
+ Bigarray.Array1.create Bigarray.int16_signed Bigarray.c_layout len
+ in
+ copy_to_int16_ba buf ofs len ba;
+ ba
+
let append b1 ofs1 len1 b2 ofs2 len2 =
assert (length b1 - ofs1 >= len1);
assert (length b2 - ofs2 >= len2);
@@ -210,9 +265,9 @@ module Mono = struct
let s = Array.unsafe_get b (ofs + i) in
Array.unsafe_set b (ofs + i)
(if Float.is_nan s then 0.
- else if s < -1. then -1.
- else if 1. < s then 1.
- else s)
+ else if s < -1. then -1.
+ else if 1. < s then 1.
+ else s)
done
let squares b ofs len =
@@ -957,6 +1012,17 @@ let copy_to_ba buf ofs len ba =
let of_ba = Array.map Mono.of_ba
let to_ba buf ofs len = Array.map (fun b -> Mono.to_ba b ofs len) buf
+let copy_from_int16_ba ba buf ofs len =
+ Array.iteri (fun i b -> Mono.copy_from_int16_ba ba.(i) b ofs len) buf
+
+let copy_to_int16_ba buf ofs len ba =
+ Array.iteri (fun i b -> Mono.copy_to_int16_ba buf.(i) ofs len b) ba
+
+let of_int16_ba = Array.map Mono.of_int16_ba
+
+let to_int16_ba buf ofs len =
+ Array.map (fun b -> Mono.to_int16_ba b ofs len) buf
+
module U8 = struct
let size channels samples = channels * samples
@@ -1178,6 +1244,195 @@ end
module Analyze = struct
let rms buf ofs len =
Array.init (channels buf) (fun i -> Mono.Analyze.rms buf.(i) ofs len)
+
+ (* See https://github.com/FFmpeg/FFmpeg/blob/master/libavfilter/af_replaygain.c *)
+ (* See https://wiki.hydrogenaud.io/index.php?title=ReplayGain_specification *)
+
+ (** Replaygain computations. *)
+ module ReplayGain = struct
+ type t = {
+ channels : int;
+ mutable frame_pos : int;
+ frame_length : int;
+ prefilter : float array -> float array;
+ mutable peak : float;
+ mutable rms : float;
+ histogram : int array;
+ }
+
+ exception Not_supported
+
+ let histogram_slots = 12000
+
+ (** Create internal state. *)
+ let create =
+ let coeffs =
+ [
+ ( 48000,
+ ( [|
+ 1.00000000000000;
+ -3.84664617118067;
+ 7.81501653005538;
+ -11.34170355132042;
+ 13.05504219327545;
+ -12.28759895145294;
+ 9.48293806319790;
+ -5.87257861775999;
+ 2.75465861874613;
+ -0.86984376593551;
+ 0.13919314567432;
+ |],
+ [|
+ 0.03857599435200;
+ -0.02160367184185;
+ -0.00123395316851;
+ -0.00009291677959;
+ -0.01655260341619;
+ 0.02161526843274;
+ -0.02074045215285;
+ 0.00594298065125;
+ 0.00306428023191;
+ 0.00012025322027;
+ 0.00288463683916;
+ |],
+ [| 1.00000000000000; -1.97223372919527; 0.97261396931306 |],
+ [| 0.98621192462708; -1.97242384925416; 0.98621192462708 |] ) );
+ ( 44100,
+ ( [|
+ 1.00000000000000;
+ -3.47845948550071;
+ 6.36317777566148;
+ -8.54751527471874;
+ 9.47693607801280;
+ -8.81498681370155;
+ 6.85401540936998;
+ -4.39470996079559;
+ 2.19611684890774;
+ -0.75104302451432;
+ 0.13149317958808;
+ |],
+ [|
+ 0.05418656406430;
+ -0.02911007808948;
+ -0.00848709379851;
+ -0.00851165645469;
+ -0.00834990904936;
+ 0.02245293253339;
+ -0.02596338512915;
+ 0.01624864962975;
+ -0.00240879051584;
+ 0.00674613682247;
+ -0.00187763777362;
+ |],
+ [| 1.00000000000000; -1.96977855582618; 0.97022847566350 |],
+ [| 0.98500175787242; -1.97000351574484; 0.98500175787242 |] ) );
+ ( 22050,
+ ( [|
+ 1.00000000000000;
+ -1.49858979367799;
+ 0.87350271418188;
+ 0.12205022308084;
+ -0.80774944671438;
+ 0.47854794562326;
+ -0.12453458140019;
+ -0.04067510197014;
+ 0.08333755284107;
+ -0.04237348025746;
+ 0.02977207319925;
+ |],
+ [|
+ 0.33642304856132;
+ -0.25572241425570;
+ -0.11828570177555;
+ 0.11921148675203;
+ -0.07834489609479;
+ -0.00469977914380;
+ -0.00589500224440;
+ 0.05724228140351;
+ 0.00832043980773;
+ -0.01635381384540;
+ -0.01760176568150;
+ |],
+ [| 1.00000000000000; -1.94561023566527; 0.94705070426118 |],
+ [| 0.97316523498161; -1.94633046996323; 0.97316523498161 |] ) );
+ ]
+ in
+ fun ~channels ~samplerate ->
+ (* Frame length in samples (a frame is 50 ms). *)
+ let frame_length = samplerate * 50 / 1000 in
+ (* Coefficients of the Yulewalk and Butterworth filters. *)
+ let yule_a, yule_b, butter_a, butter_b =
+ match List.assoc_opt samplerate coeffs with
+ | Some c -> c
+ | None -> raise Not_supported
+ in
+ let yulewalk =
+ Array.init channels (fun _ -> Sample.iir yule_a yule_b)
+ in
+ let butterworth =
+ Array.init channels (fun _ -> Sample.iir butter_a butter_b)
+ in
+ let prefilter x =
+ Array.mapi (fun i x -> x |> yulewalk.(i) |> butterworth.(i)) x
+ in
+ {
+ channels;
+ frame_pos = 0;
+ frame_length;
+ prefilter;
+ peak = 0.;
+ rms = 0.;
+ histogram = Array.make histogram_slots 0;
+ }
+
+ (** Process a sample. *)
+ let process_sample rg x =
+ Array.iter
+ (fun x ->
+ let x = abs_float x in
+ if x > rg.peak then rg.peak <- x)
+ x;
+ let x = rg.prefilter x in
+ Array.iter (fun x -> rg.rms <- rg.rms +. (x *. x)) x;
+ rg.frame_pos <- rg.frame_pos + 1;
+ if rg.frame_pos >= rg.frame_length then (
+ (* Minimum value is about -100 dB for digital silence. The 90 dB
+ offset is to compensate for the normalized float range and 3 dB is
+ for stereo samples. *)
+ let rms =
+ (10. *. log10 (rg.rms /. float (rg.frame_length * rg.channels)))
+ +. 90.
+ in
+ let level =
+ int_of_float (100. *. rms) |> max 0 |> min (histogram_slots - 1)
+ in
+ rg.histogram.(level) <- rg.histogram.(level) + 1;
+ rg.rms <- 0.;
+ rg.frame_pos <- 0)
+
+ (** Process a buffer. *)
+ let process rg buf off len =
+ assert (channels buf = rg.channels);
+ for i = off to off + len - 1 do
+ let x = Array.init rg.channels (fun c -> buf.(c).(i)) in
+ process_sample rg x
+ done
+
+ (** Computed peak. *)
+ let peak rg = rg.peak
+
+ (** Compute gain. *)
+ let gain rg =
+ let windows = Array.fold_left ( + ) 0 rg.histogram in
+ let i = ref (histogram_slots - 1) in
+ let loud_count = ref 0 in
+ (* Find i below the top 5% *)
+ while !i > 0 && !loud_count * 20 < windows do
+ loud_count := !loud_count + rg.histogram.(!i);
+ decr i
+ done;
+ 64.54 -. (float !i /. 100.) |> max (-24.) |> min 64.
+ end
end
module Effect = struct
@@ -1595,35 +1850,35 @@ module IO = struct
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"; *)
+ if self#input 4 <> "RIFF" then
+ (* failwith "Bad header: \"RIFF\" not found"; *)
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
+ (* 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) ofs len =
let sbuflen = len * channels * 2 in
@@ -1632,9 +1887,9 @@ module IO = struct
let len = sbuflen / (channels * 2) in
begin
match sample_size with
- | 16 -> S16LE.to_audio sbuf 0 buf ofs len
- | 8 -> U8.to_audio sbuf 0 buf ofs len
- | _ -> assert false
+ | 16 -> S16LE.to_audio sbuf 0 buf ofs len
+ | 8 -> U8.to_audio sbuf 0 buf ofs len
+ | _ -> assert false
end;
len
@@ -1676,27 +1931,28 @@ module IO = struct
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
+ 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
@@ -1736,8 +1992,8 @@ module IO = struct
method virtual io_write : buffer -> unit
initializer
- assert (fill_duration <= max_duration);
- assert (drop_duration <= max_duration)
+ assert (fill_duration <= max_duration);
+ assert (drop_duration <= max_duration)
val rb = Ringbuffer.create channels max_duration
diff --git a/src/audio.mli b/src/audio.mli
index 6ecb1e5..bf4e7e1 100644
--- a/src/audio.mli
+++ b/src/audio.mli
@@ -54,6 +54,12 @@ module Sample : sig
(** Clip a sample (ie ensure that it is between [-1.] and [1.]. *)
val clip : t -> t
+
+ (** An IIR filter with given b coefficients. *)
+ val fir : float array -> t -> t
+
+ (** An IIR filter with given a and b coefficients. *)
+ val iir : float array -> float array -> t -> t
end
(** Operations on notes. *)
@@ -112,6 +118,29 @@ module Mono : sig
int ->
(float, Bigarray.float32_elt, Bigarray.c_layout) Bigarray.Array1.t
+ val copy_to_int16_ba :
+ t ->
+ int ->
+ int ->
+ (int, Bigarray.int16_signed_elt, Bigarray.c_layout) Bigarray.Array1.t ->
+ unit
+
+ val copy_from_int16_ba :
+ (int, Bigarray.int16_signed_elt, Bigarray.c_layout) Bigarray.Array1.t ->
+ t ->
+ int ->
+ int ->
+ unit
+
+ val of_int16_ba :
+ (int, Bigarray.int16_signed_elt, Bigarray.c_layout) Bigarray.Array1.t -> t
+
+ val to_int16_ba :
+ t ->
+ int ->
+ int ->
+ (int, Bigarray.int16_signed_elt, Bigarray.c_layout) Bigarray.Array1.t
+
(** Length in samples. *)
val length : t -> int
@@ -400,6 +429,30 @@ val to_ba :
int ->
(float, Bigarray.float32_elt, Bigarray.c_layout) Bigarray.Array1.t array
+val copy_to_int16_ba :
+ t ->
+ int ->
+ int ->
+ (int, Bigarray.int16_signed_elt, Bigarray.c_layout) Bigarray.Array1.t array ->
+ unit
+
+val copy_from_int16_ba :
+ (int, Bigarray.int16_signed_elt, Bigarray.c_layout) Bigarray.Array1.t array ->
+ t ->
+ int ->
+ int ->
+ unit
+
+val of_int16_ba :
+ (int, Bigarray.int16_signed_elt, Bigarray.c_layout) Bigarray.Array1.t array ->
+ t
+
+val to_int16_ba :
+ t ->
+ int ->
+ int ->
+ (int, Bigarray.int16_signed_elt, Bigarray.c_layout) Bigarray.Array1.t array
+
(** Amplify a portion of the buffer by a given coefficient. *)
val amplify : float -> t -> int -> int -> unit
@@ -434,17 +487,34 @@ module Ringbuffer : sig
(** Create a ringbuffer of given number of channels and size (in samples). *)
val create : int -> int -> t
+ (** Number of channels of the ringbuffr. *)
val channels : t -> int
+
+ (** Number of samples available for reading. *)
val read_space : t -> int
+
+ (** Number of samples available for writing. *)
val write_space : t -> int
+
+ (** Advance the read pointer.*)
val read_advance : t -> int -> unit
+
+ (** Advance the write pointer. *)
val write_advance : t -> int -> unit
+
+ (** Fill in a buffer without changing read pointer. *)
val peek : t -> buffer -> unit
+
+ (** Fill in a buffer and advance read pointer. *)
val read : t -> buffer -> unit
+
+ (** Write a buffer into the ringbuffer. *)
val write : t -> buffer -> unit
+
val transmit : t -> (buffer -> int) -> int
end
+(** Extensible ringbuffers.*)
module Ringbuffer_ext : sig
type t
@@ -462,6 +532,25 @@ end
module Analyze : sig
val rms : t -> int -> int -> float array
+
+ module ReplayGain : sig
+ type t
+
+ exception Not_supported
+
+ (** Create internal state for computing ReplayGain. Raises [Not_supported]
+ if the samplerate is not supported. *)
+ val create : channels:int -> samplerate:int -> t
+
+ (** Process a buffer. *)
+ val process : t -> buffer -> int -> int -> unit
+
+ (** Peak of processed samples. *)
+ val peak : t -> float
+
+ (** Replaygain for processed samples. *)
+ val gain : t -> float
+ end
end
(** Audio effects. *)
diff --git a/src/audio_c.c b/src/audio_c.c
index c33581d..bce5610 100644
--- a/src/audio_c.c
+++ b/src/audio_c.c
@@ -250,7 +250,7 @@ CAMLprim value caml_mm_audio_to_s16(value _le, value _src, value _src_offs,
if (caml_string_length(_dst) < dst_offs + 2 * nc * len)
caml_invalid_argument("pcm_to_s16: destination buffer too short");
- dst = (void*)dst + dst_offs;
+ dst = (void *)dst + dst_offs;
if (little_endian == 1)
for (c = 0; c < nc; c++) {
@@ -456,3 +456,32 @@ CAMLprim value caml_mm_audio_copy_to_ba(value _src, value _ofs, value _len,
}
CAMLreturn(Val_unit);
}
+
+CAMLprim value caml_mm_audio_copy_from_int16_ba(value _src, value _dst,
+ value _ofs, value _len) {
+ CAMLparam2(_src, _dst);
+ int16_t *src = Caml_ba_data_val(_src);
+ int ofs = Int_val(_ofs);
+ int len = Int_val(_len);
+ int i;
+
+ for (i = 0; i < len; i++) {
+ Store_double_field(_dst, i + ofs, ((double)src[i]) / INT16_MAX);
+ }
+
+ CAMLreturn(_dst);
+}
+
+CAMLprim value caml_mm_audio_copy_to_int16_ba(value _src, value _ofs,
+ value _len, value _dst) {
+ CAMLparam2(_src, _dst);
+ int16_t *dst = Caml_ba_data_val(_dst);
+ int len = Int_val(_len);
+ int ofs = Int_val(_ofs);
+ long i;
+
+ for (i = 0; i < len; i++) {
+ dst[i] = Double_field(_src, i + ofs) * INT16_MAX;
+ }
+ CAMLreturn(Val_unit);
+}
diff --git a/src/dune b/src/dune
index c489a3f..ebe5313 100644
--- a/src/dune
+++ b/src/dune
@@ -1,3 +1,8 @@
+(env
+ (dev
+ (flags
+ (:standard -w -69))))
+
(library
(name mm_base)
(public_name mm.base)
diff --git a/src/image.mli b/src/image.mli
index 8d84137..5dc19f6 100644
--- a/src/image.mli
+++ b/src/image.mli
@@ -33,6 +33,12 @@
(** Operations on images. *)
+(** Trying to access a pixel outside the boundaries of the image. *)
+exception Invalid_position
+
+(** The image does not have the expected dimensions. *)
+exception Invalid_dimensions
+
module Data : sig
type t =
(int, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t
@@ -88,15 +94,10 @@ module Bitmap : sig
type bitmap = t
val create : int -> int -> t
-
val width : t -> int
-
val height : t -> int
-
val get_pixel : t -> int -> int -> bool
-
val set_pixel : t -> int -> int -> bool -> unit
-
val scale : t -> t -> unit
(** Operations on bitmap fonts. *)
@@ -125,6 +126,16 @@ module RGB8 : sig
(** Decode a color stored as RGB. *)
val of_int : int -> t
+
+ val to_int : t -> int
+ end
+end
+
+module ARGB8 : sig
+ module Color : sig
+ type t = int * RGB8.Color.t
+
+ val of_int : int -> t
end
end
@@ -375,6 +386,7 @@ module YUV420 : sig
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_a : t -> int -> int -> int
val get_pixel_rgba : t -> int -> int -> Pixel.rgba
val set_pixel_rgba : t -> int -> int -> Pixel.rgba -> unit
@@ -550,6 +562,9 @@ module Canvas (I : CanvasImage) : sig
(** Size of a canvas in bytes. *)
val size : t -> int
+ (** Number of planes in the image. *)
+ val planes : t -> int
+
(** Add two canvas. The first one is on top of the second one. *)
val add : t -> t -> t
diff --git a/src/imageBase.ml b/src/imageBase.ml
index eac4dc7..4ab5a69 100644
--- a/src/imageBase.ml
+++ b/src/imageBase.ml
@@ -31,6 +31,9 @@
*
*)
+exception Invalid_position
+exception Invalid_dimensions
+
module List = struct
include List
@@ -92,11 +95,9 @@ module Pixel = struct
module RGBA = struct
type t = RGBA
- let black = (0,0,0,0xff)
-
- let white = (0xff,0xff,0xff,0xff)
-
- let transparent = (0,0,0,0)
+ let black = (0, 0, 0, 0xff)
+ let white = (0xff, 0xff, 0xff, 0xff)
+ let transparent = (0, 0, 0, 0)
end
external yuv_of_rgb : rgb -> yuv = "caml_yuv_of_rgb"
@@ -167,8 +168,18 @@ module RGB8 = struct
type t = int * int * int
let of_int n =
- if n > 0xffffff then raise (Invalid_argument "Not a color");
+ if n land lnot 0xffffff <> 0 then raise (Invalid_argument "Not a color");
((n lsr 16) land 0xff, (n lsr 8) land 0xff, n land 0xff)
+
+ let to_int (r, g, b) = (r lsl 16) + (g lsl 8) + b
+ end
+end
+
+module ARGB8 = struct
+ module Color = struct
+ type t = int * RGB8.Color.t
+
+ let of_int n : t = (n lsr 24, RGB8.Color.of_int (n land 0xffffff))
end
end
diff --git a/src/imageBitmap.ml b/src/imageBitmap.ml
index 6a7e12d..f58fe01 100644
--- a/src/imageBitmap.ml
+++ b/src/imageBitmap.ml
@@ -32,25 +32,19 @@
*)
type t = bool array array
-
type bitmap = t
let create c width height : t = Array.init height (fun _ -> Array.make width c)
-
let create_white = create true
-
let create = create false
-
let make data : t = data
-let init width height f = make (Array.init height (fun j -> Array.init width (fun i -> f i j)))
+let init width height f =
+ make (Array.init height (fun j -> Array.init width (fun i -> f i j)))
let width (img : t) = if Array.length img = 0 then 0 else Array.length img.(0)
-
let height (img : t) = Array.length img
-
let get_pixel img i j = img.(j).(i)
-
let set_pixel img i j c = img.(j).(i) <- c
let fill img f =
@@ -72,7 +66,7 @@ let rescale p q img =
scale img img2;
img2
-let blit src ?(x=0) ?(y=0) dst =
+let blit src ?(x = 0) ?(y = 0) dst =
let width = min (width src) (width dst - x) in
let height = min (height src) (height dst - y) in
for j = 0 to height - 1 do
@@ -83,19 +77,22 @@ let blit src ?(x=0) ?(y=0) dst =
(** Bitmap fonts. *)
module Font = struct
- module CharMap = Map.Make(struct type t = char let compare (c:t) (d:t) = Stdlib.compare c d end)
+ module CharMap = Map.Make (struct
+ type t = char
+
+ let compare (c : t) (d : t) = Stdlib.compare c d
+ end)
(** A fixed-size font. *)
- type nonrec t =
- {
- map : t CharMap.t Lazy.t;
- width : int; (** width of a char in pixels *)
- height : int; (** height of a char in pixels *)
- default : t; (** default displayed character when not supported *)
- uppercase : bool; (** whether only uppercase caracters are supported *)
- char_space : int;
- line_space : int;
- }
+ type nonrec t = {
+ map : t CharMap.t Lazy.t;
+ width : int; (** width of a char in pixels *)
+ height : int; (** height of a char in pixels *)
+ default : t; (** default displayed character when not supported *)
+ uppercase : bool; (** whether only uppercase caracters are supported *)
+ char_space : int;
+ line_space : int;
+ }
let height font = font.height
@@ -155,34 +152,47 @@ module Font = struct
let width = 3 in
let height = 5 in
let map =
- Lazy.from_fun
- (fun () ->
- List.fold_left
- (fun f (c, b) ->
- let bmp = init width height (fun i j -> b.(j).[i] <> ' ') in
- CharMap.add c bmp f
- ) CharMap.empty prebitmap
- )
+ Lazy.from_fun (fun () ->
+ List.fold_left
+ (fun f (c, b) ->
+ let bmp = init width height (fun i j -> b.(j).[i] <> ' ') in
+ CharMap.add c bmp f)
+ CharMap.empty prebitmap)
in
let default = create_white width height in
- { map; width; height; default; uppercase = true; char_space = 1; line_space = 2 }
+ {
+ map;
+ width;
+ height;
+ default;
+ uppercase = true;
+ char_space = 1;
+ line_space = 2;
+ }
- let render ?(font=native) ?size text =
+ let render ?(font = native) ?size text =
let height = Option.value ~default:font.height size in
let text_height, text_width =
let h = ref 1 in
let max = ref 0 in
let cur = ref 0 in
for i = 0 to String.length text - 1 do
- if text.[i] = '\n' then (max := Stdlib.max !max !cur; cur := 0; incr h)
+ if text.[i] = '\n' then (
+ max := Stdlib.max !max !cur;
+ cur := 0;
+ incr h)
else incr cur
done;
max := Stdlib.max !max !cur;
- !h, !max
+ (!h, !max)
in
let img =
- let width = text_width * font.width + (text_width-1) * font.char_space in
- let height = text_height * font.height + (text_height-1) * font.line_space in
+ let width =
+ (text_width * font.width) + ((text_width - 1) * font.char_space)
+ in
+ let height =
+ (text_height * font.height) + ((text_height - 1) * font.line_space)
+ in
let width = max width 0 in
let height = max height 0 in
create width height
@@ -191,12 +201,18 @@ module Font = struct
let yoff = ref 0 in
for i = 0 to String.length text - 1 do
let c = text.[i] in
- if c = '\n' then (xoff := 0; yoff := !yoff + font.height + font.line_space)
- else
+ if c = '\n' then (
+ xoff := 0;
+ yoff := !yoff + font.height + font.line_space)
+ else (
let c = if font.uppercase then Char.uppercase_ascii c else c in
- let c = match CharMap.find_opt c (Lazy.force font.map) with Some c -> c | None -> font.default in
+ let c =
+ match CharMap.find_opt c (Lazy.force font.map) with
+ | Some c -> c
+ | None -> font.default
+ in
blit c ~x:!xoff ~y:!yoff img;
- xoff := !xoff + font.width + font.char_space
+ xoff := !xoff + font.width + font.char_space)
done;
rescale height font.height img
end
diff --git a/src/imageCanvas.ml b/src/imageCanvas.ml
index 4d7633e..fa8761f 100644
--- a/src/imageCanvas.ml
+++ b/src/imageCanvas.ml
@@ -70,6 +70,7 @@ module Canvas (I : CanvasImage) = struct
let width c = c.width
let height c = c.height
let size c = List.fold_left (fun n e -> n + E.size e) 0 c.elements
+ let planes c = List.length c.elements
let make ?width ?height ?(x = 0) ?(y = 0) image =
let width = Option.value ~default:(I.width image) width in
@@ -165,8 +166,8 @@ module Canvas (I : CanvasImage) = struct
else ((w', w), (h', h))
in
let x, y =
- if proportional then (0, 0)
- else ((w' - (w * nx / dx)) / 2, (h' - (h * ny / dy)) / 2)
+ if proportional then ((w' - (w * nx / dx)) / 2, (h' - (h * ny / dy)) / 2)
+ else (0, 0)
in
scale ?scaler (nx, dx) (ny, dy) img |> translate x y |> viewport w' h'
diff --git a/src/imageGeneric.ml b/src/imageGeneric.ml
index c87663c..f9398f6 100644
--- a/src/imageGeneric.ml
+++ b/src/imageGeneric.ml
@@ -40,8 +40,10 @@ 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 *)
+ | 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 *)
@@ -51,10 +53,12 @@ module Pixel = struct
| 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) *)
+ | 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
diff --git a/src/imageYUV420.ml b/src/imageYUV420.ml
index 576147a..8f6a654 100644
--- a/src/imageYUV420.ml
+++ b/src/imageYUV420.ml
@@ -172,8 +172,8 @@ let copy img =
dst
let blit_all src dst =
- assert (src.width = dst.width);
- assert (src.height = dst.height);
+ if src.width <> dst.width then raise Invalid_dimensions;
+ if src.height <> dst.height then raise Invalid_dimensions;
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);
@@ -199,14 +199,17 @@ 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
+let add src ?(x = 0) ?(y = 0) dst =
+ (* Printf.printf "add %dx%d with %dx%d at %d,%d\n%!" (width src) (height src) (width dst) (height dst) x y; *)
+ 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 not (0 <= i && i < img.width && 0 <= j && j < img.height) then
+ raise Invalid_position;
if a <> 0xff then ensure_alpha img;
set_pixel_rgba img i j p
@@ -230,10 +233,15 @@ 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))
+let get_pixel_a img i j =
+ match img.alpha with
+ | Some alpha -> Data.get alpha ((j * img.y_stride) + i)
+ | None -> 0xff
+
external get_pixel_rgba : t -> int -> int -> Pixel.rgba
= "caml_yuv420_get_pixel_rgba"
-let of_bitmap ?(fg=Pixel.RGBA.white) ?(bg=Pixel.RGBA.transparent) bmp =
+let of_bitmap ?(fg = Pixel.RGBA.white) ?(bg = Pixel.RGBA.transparent) bmp =
let width = Bitmap.width bmp in
let height = Bitmap.height bmp in
let img = create width height in
@@ -289,7 +297,7 @@ 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)
+ if a = 0. then fill_alpha img 0 else scale_alpha img a)
external disk_alpha : t -> int -> int -> int -> unit = "caml_yuv_disk_alpha"
diff --git a/src/image_rgb.c b/src/image_rgb.c
index c439e26..f9a1293 100644
--- a/src/image_rgb.c
+++ b/src/image_rgb.c
@@ -1077,8 +1077,8 @@ CAMLprim value caml_rgb_blur_alpha(value _rgb) {
CAMLreturn(Val_unit);
}
-static inline int compare_images(int width, int height, uint8_t *old, uint8_t *new,
- int dx, int dy) {
+static inline int compare_images(int width, int height, uint8_t *old,
+ uint8_t *new, int dx, int dy) {
int s = 0;
int i, j;
int adx = abs(dx);
@@ -1161,8 +1161,9 @@ CAMLprim value caml_mm_Gray8_motion_compute(value _bs, value _width, value _old,
CAMLreturn(ans);
}
-static inline int compare_blocks(int width, int height, uint8_t *old, uint8_t *new,
- int bs, int x, int y, int dx, int dy) {
+static inline int compare_blocks(int width, int height, uint8_t *old,
+ uint8_t *new, int bs, int x, int y, int dx,
+ int dy) {
int s = 0;
int i, j;
diff --git a/src/image_yuv420.c b/src/image_yuv420.c
index 228c2cd..549403a 100644
--- a/src/image_yuv420.c
+++ b/src/image_yuv420.c
@@ -164,8 +164,8 @@ CAMLprim value caml_yuv420_scale(value _src, value _dst) {
}
for (j = 0; j < dst.height / 2; j++)
for (i = 0; i < dst.width / 2; i++) {
- is = i * src.width / dst.width;
- js = j * src.height / dst.height;
+ is = i * (src.width / 2) / (dst.width / 2);
+ js = j * (src.height / 2) / (dst.height / 2);
U2(dst, i, j) = U2(src, is, js);
V2(dst, i, j) = V2(src, is, js);
}
@@ -235,6 +235,9 @@ CAMLprim value caml_yuv420_add(value _src, value _x, value _y, value _dst) {
int ja = max(y, 0);
int jb = min(y + src.height, dst.height);
+ if (!(ia < ib))
+ CAMLreturn(Val_unit);
+
caml_enter_blocking_section();
if (src.alpha == NULL) {
int il = ib - ia;
@@ -408,17 +411,25 @@ CAMLprim value caml_yuv_greyscale(value img) {
}
#define PIXEL_PRECISON 0x10000
-CAMLprim value caml_yuv_scale_alpha(value img, value _a) {
- CAMLparam2(img, _a);
+CAMLprim value caml_yuv_scale_alpha(value img, value _c) {
+ CAMLparam2(img, _c);
yuv420 yuv;
yuv420_of_value(&yuv, img);
- int a = Double_val(_a) * PIXEL_PRECISON;
+ int c = Double_val(_c) * PIXEL_PRECISON;
+ int amax = CLIP(0xff * c / 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);
+ for (i = 0; i < yuv.width; i++) {
+ int a = A(yuv, i, j);
+ if (a != 0) {
+ if (a == 0xff)
+ A(yuv, i, j) = amax;
+ else
+ A(yuv, i, j) = CLIP(a * c / PIXEL_PRECISON);
+ }
+ }
caml_leave_blocking_section();
CAMLreturn(Val_unit);
diff --git a/src/video.ml b/src/video.ml
index 0a09d0c..d947eac 100644
--- a/src/video.ml
+++ b/src/video.ml
@@ -32,9 +32,9 @@
*)
open Mm_base
+
(* open Mm_image *)
open Mm_audio
-
module YUV420 = Mm_image.Image.YUV420
(** Images from which are made videos. *)
@@ -98,7 +98,7 @@ include Make (Image)
(* Canvas are not in place so that we have to make a slightly different
implementation. *)
-module Canvas = struct
+module MakeCanvas (BaseImage : Mm_image.Image.CanvasImage) = struct
module Image = Mm_image.Image.Canvas (Image)
type image = Image.t
@@ -122,7 +122,7 @@ module Canvas = struct
let get v i = v.(i)
let set v i img = v.(i) <- img
let map_image f v i = v.(i) <- f v.(i)
- let render v i = Image.render v.(i)
+ let render ?transparent v i = Image.render ?transparent v.(i)
let put v i img = v.(i) <- Image.make img
let blit sbuf sofs dbuf dofs len =
@@ -146,6 +146,8 @@ module Canvas = struct
done
end
+module Canvas = MakeCanvas (Image)
+
(*
module RE = struct
type t = Image.t
@@ -221,7 +223,9 @@ module AVI = struct
let v = Image.Data.to_string v in
let y_stride = Image.YUV420.y_stride img in
let uv_stride = Image.YUV420.uv_stride img in
- let s = create "00db" (width * height + 2 * (width / 2) * (height / 2)) in
+ let s =
+ create "00db" ((width * height) + (2 * (width / 2) * (height / 2)))
+ in
let o = ref 8 in
let add_sub data off len =
Bytes.blit_string data off s !o len;
@@ -248,114 +252,102 @@ module AVI = struct
let list = make "LIST"
end
- let header ?(format=`YUV420) ~width ~height ~framerate ?channels ?samplerate ?vendor () =
+ let header ?(format = `YUV420) ~width ~height ~framerate ?channels
+ ?samplerate ?vendor () =
ignore format;
let has_audio = channels <> None in
let channels = Option.value ~default:0 channels in
let samplerate = Option.value ~default:0 samplerate in
- assert (not has_audio || samplerate > 0);
+ assert ((not has_audio) || samplerate > 0);
(* Writing in two steps because 0xffffffff cannot be represented on 32 bits
architectures. *)
let dword_max () = word 0xffff ^ word 0xffff in
let avi_header =
Chunk.make "avih"
(dword (1000000 / framerate) (* microsec per frame *)
- ^ dword 0 (* maximum bytes per second *)
- ^ dword 0 (* reserved *)
- ^ dword 0x0100 (* flags (interleaved) *)
- ^ dword_max () (* number of frames *)
- ^ dword 0 (* initial frame *)
- ^ dword (1 + if has_audio then 1 else 0) (* number of streams *)
- ^ dword 0 (* suggested buffer size *)
- ^ dword width (* width *)
- ^ dword height (* height *)
- ^ dword 0 (* reserved *)
- ^ dword 0 (* reserved *)
- ^ dword 0 (* reserved *)
- ^ dword 0 (* reserved *)
- )
+ ^ dword 0 (* maximum bytes per second *)
+ ^ dword 0 (* reserved *)
+ ^ dword 0x0100 (* flags (interleaved) *)
+ ^ dword_max () (* number of frames *)
+ ^ dword 0 (* initial frame *)
+ ^ dword (1 + if has_audio then 1 else 0) (* number of streams *)
+ ^ dword 0 (* suggested buffer size *)
+ ^ dword width (* width *) ^ dword height (* height *)
+ ^ dword 0 (* reserved *) ^ dword 0 (* reserved *)
+ ^ dword 0 (* reserved *) ^ dword 0 (* reserved *))
in
let video_header =
let stream_header =
Chunk.make "strh"
- ("vids" (* stream type *)
- ^ "I420" (* fourcc (codec) *)
- ^ dword 0 (* flags *)
- ^ word 0 (* priority *)
- ^ word 0 (* language *)
- ^ dword 0 (* initial frames *)
- ^ dword 1 (* scale *)
- ^ dword framerate (* rate *)
- ^ dword 0 (* start time *)
- ^ dword_max () (* stream length *)
- ^ dword 0 (* suggested buffer size *)
- ^ dword_max () (* quality *)
- ^ dword 0 (* sample size *)
- ^ word 0 (* left *)
- ^ word 0 (* top *)
- ^ word width (* right *)
- ^ word height (* bottom *)
- )
+ ("vids" (* stream type *) ^ "I420" (* fourcc (codec) *)
+ ^ dword 0 (* flags *) ^ word 0
+ (* priority *) ^ word 0 (* language *)
+ ^ dword 0 (* initial frames *)
+ ^ dword 1 (* scale *) ^ dword framerate (* rate *)
+ ^ dword 0 (* start time *)
+ ^ dword_max () (* stream length *)
+ ^ dword 0 (* suggested buffer size *)
+ ^ dword_max () (* quality *) ^ dword 0 (* sample size *)
+ ^ word 0 (* left *) ^ word 0
+ (* top *) ^ word width (* right *)
+ ^ word height (* bottom *))
in
let stream_format =
(* see BITMAPINFO *)
Chunk.make "strf"
(dword 40 (* size of this structure *)
- ^ dword width (* width *)
- ^ dword height (* height *)
- ^ word 1 (* panes *)
- ^ word 12 (* depth *)
- ^ "I420" (* codec *)
- ^ dword (width * height * 6 / 4) (* image size *)
- ^ dword 0 (* pixels / x meter *)
- ^ dword 0 (* pixels / y meter *)
- ^ dword 0 (* colors used *)
- ^ dword 0 (* important colors *)
- )
+ ^ dword width (* width *) ^ dword height (* height *)
+ ^ word 1 (* panes *) ^ word 12
+ (* depth *) ^ "I420" (* codec *)
+ ^ dword (width * height * 6 / 4) (* image size *)
+ ^ dword 0 (* pixels / x meter *)
+ ^ dword 0 (* pixels / y meter *)
+ ^ dword 0 (* colors used *)
+ ^ dword 0 (* important colors *))
in
Chunk.list ("strl" ^ stream_header ^ stream_format)
in
let audio_header =
- if not has_audio then "" else
+ if not has_audio then ""
+ else (
let stream_header =
Chunk.make "strh"
- ("auds" (* stream type *)
- ^ dword 0 (* stream *)
- ^ dword 0 (* flags *)
- ^ word 0 (* priority *)
- ^ word 0 (* language *)
- ^ dword 0 (* initial frames *)
- ^ dword 1 (* scale *)
- ^ dword samplerate (* rate *)
- ^ dword 0 (* start time *)
- ^ dword_max () (* stream length *)
- ^ dword 0 (* suggested buffer size *)
- ^ dword_max () (* quality *)
- ^ dword (2 * channels) (* sample size *)
- ^ word 0 (* left *)
- ^ word 0 (* top *)
- ^ word 0 (* right *)
- ^ word 0 (* bottom *))
+ ("auds" (* stream type *) ^ dword 0 (* stream *)
+ ^ dword 0 (* flags *) ^ word 0 (* priority *)
+ ^ word 0 (* language *)
+ ^ dword 0 (* initial frames *)
+ ^ dword 1 (* scale *)
+ ^ dword samplerate (* rate *)
+ ^ dword 0 (* start time *)
+ ^ dword_max () (* stream length *)
+ ^ dword 0 (* suggested buffer size *)
+ ^ dword_max () (* quality *)
+ ^ dword (2 * channels) (* sample size *)
+ ^ word 0 (* left *) ^ word 0
+ (* top *) ^ word 0 (* right *)
+ ^ word 0 (* bottom *))
in
let stream_format =
Chunk.make "strf"
(word 1 (* stream type (PCM) *)
- ^ word channels (* channels *)
- ^ dword samplerate (* rate *)
- ^ dword (2 * channels * samplerate) (* byte rate *)
- ^ word (2 * channels) (* block align *)
- ^ word 16 (* bits per sample *)
- ^ word 0 (* size of extra information *))
+ ^ word channels (* channels *)
+ ^ dword samplerate (* rate *)
+ ^ dword (2 * channels * samplerate) (* byte rate *)
+ ^ word (2 * channels) (* block align *)
+ ^ word 16 (* bits per sample *)
+ ^ word 0 (* size of extra information *))
in
- Chunk.list ("strl" ^ stream_header ^ stream_format)
+ Chunk.list ("strl" ^ stream_header ^ stream_format))
+ in
+ let headers =
+ Chunk.list ("hdrl" ^ avi_header ^ video_header ^ audio_header)
in
- let headers = Chunk.list ("hdrl" ^ avi_header ^ video_header ^ audio_header) in
let info =
match vendor with
- | Some vendor ->
- let producer = Chunk.make "ISFT" vendor in
- Chunk.list ("INFO" ^ producer)
- | None -> ""
+ | Some vendor ->
+ let producer = Chunk.make "ISFT" vendor in
+ Chunk.list ("INFO" ^ producer)
+ | None -> ""
in
"RIFF"
^ dword_max () (* file size *)
@@ -401,86 +393,136 @@ module IO = struct
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
+ 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
diff --git a/src/video.mli b/src/video.mli
index 1200841..4f63369 100644
--- a/src/video.mli
+++ b/src/video.mli
@@ -35,7 +35,6 @@
open Mm_audio
open Mm_image
-
module YUV420 = Image.YUV420
(** Images of videos. *)
@@ -115,7 +114,7 @@ val blank : t -> int -> int -> unit
val randomize : t -> int -> int -> unit
(** Videos with canvas images. *)
-module Canvas : sig
+module MakeCanvas (_ : Mm_image.Image.CanvasImage) : sig
module Image : module type of Mm_image.Image.Canvas (Image)
(** An image. *)
@@ -153,7 +152,7 @@ module Canvas : sig
val map_image : (image -> image) -> t -> int -> unit
(** Render the nth image of the video. *)
- val render : t -> int -> Mm_image.Image.YUV420.t
+ val render : ?transparent:bool -> t -> int -> Mm_image.Image.YUV420.t
(** Change the contents of the nth image of the video (like [set] but takes an
image instead of a canvas as argument). *)
@@ -173,6 +172,8 @@ module Canvas : sig
val iter : (Mm_image.Image.YUV420.t -> unit) -> t -> int -> int -> unit
end
+module Canvas : module type of MakeCanvas (Image)
+
(* module Ringbuffer_ext : Ringbuffer.R with type elt = frame *)
(* module Ringbuffer : Ringbuffer.R with type elt = frame *)
@@ -190,12 +191,20 @@ module AVI : sig
(** Writing AVI files. *)
module Writer : sig
(** Generate a header for the AVI file. *)
- val header : ?format:[> `YUV420 ] -> width:int -> height:int -> framerate:int -> ?channels:int -> ?samplerate:int -> ?vendor:string -> unit -> string
+ val header :
+ ?format:[> `YUV420 ] ->
+ width:int ->
+ height:int ->
+ framerate:int ->
+ ?channels:int ->
+ ?samplerate:int ->
+ ?vendor:string ->
+ unit ->
+ string
(** Operations on chunks, which are blocks of (audio / video) data. *)
module Chunk : sig
val audio_s16le : Audio.t -> string
-
val video_yuv420 : YUV420.t -> string
end
end