diff -Nru ocaml-mm-0.7.5/CHANGES.md ocaml-mm-0.8.1/CHANGES.md --- ocaml-mm-0.7.5/CHANGES.md 2022-02-03 12:20:47.000000000 +0000 +++ ocaml-mm-0.8.1/CHANGES.md 2022-05-24 14:23:18.000000000 +0000 @@ -1,3 +1,14 @@ +0.8.1 (24-05-2022) +===== +- Add support for bitmaps and bitmap fonts. +- Working AVI video output. +- Compile with OCaml 5. + +0.8.0 (13-03-2022) +===== +- Add support for image and video canvas. +- Switch audio data type to `float array` + 0.7.5 (03-02-2022) ===== * Add `alpha_of_color` in YUV. diff -Nru ocaml-mm-0.7.5/debian/changelog ocaml-mm-0.8.1/debian/changelog --- ocaml-mm-0.7.5/debian/changelog 2022-05-02 06:15:39.000000000 +0000 +++ ocaml-mm-0.8.1/debian/changelog 2022-05-27 15:17:41.000000000 +0000 @@ -1,8 +1,13 @@ -ocaml-mm (0.7.5-1build1) kinetic; urgency=medium +ocaml-mm (0.8.1-1) unstable; urgency=medium - * Rebuild against new OCAML ABI. + [ Kyle Robbertze ] + * Bump standards-version to 4.6.1 (no change) + * New upstream version 0.8.1 - -- Gianfranco Costamagna Mon, 02 May 2022 08:15:39 +0200 + [ Janitor ] + * Remove constraints unnecessary since buster + + -- Kyle Robbertze Fri, 27 May 2022 17:17:41 +0200 ocaml-mm (0.7.5-1) unstable; urgency=medium diff -Nru ocaml-mm-0.7.5/debian/control ocaml-mm-0.8.1/debian/control --- ocaml-mm-0.7.5/debian/control 2022-03-04 08:37:52.000000000 +0000 +++ ocaml-mm-0.8.1/debian/control 2022-05-27 15:16:46.000000000 +0000 @@ -5,7 +5,7 @@ Uploaders: Kyle Robbertze Build-Depends: debhelper-compat (= 13), dh-buildinfo, - dh-ocaml (>= 0.9), + dh-ocaml, dune (>= 2.8.0), libalsa-ocaml-dev, libao-ocaml-dev, @@ -17,9 +17,9 @@ libpulse-ocaml-dev, libsdl-ocaml-dev, libtheora-ocaml-dev, - ocaml-findlib (>= 1.2.4), + ocaml-findlib, ocaml -Standards-Version: 4.6.0 +Standards-Version: 4.6.1 Homepage: https://github.com/savonet/ocaml-mm Vcs-Git: https://salsa.debian.org/ocaml-team/ocaml-mm.git Vcs-Browser: https://salsa.debian.org/ocaml-team/ocaml-mm diff -Nru ocaml-mm-0.7.5/dune-project ocaml-mm-0.8.1/dune-project --- ocaml-mm-0.7.5/dune-project 2022-02-03 12:20:47.000000000 +0000 +++ ocaml-mm-0.8.1/dune-project 2022-05-24 14:23:18.000000000 +0000 @@ -1,5 +1,5 @@ (lang dune 2.8) -(version 0.7.5) +(version 0.8.1) (name mm) (source (github savonet/ocaml-mm)) (license GPL-2.0) @@ -12,7 +12,8 @@ (name mm) (synopsis "The mm library contains high-level to create and manipulate multimedia streams (audio, video, MIDI)") (depends - (ocaml (and :with-test (>= 4.07))) + (ocaml (>= 4.08)) + (ocaml (and :with-test (>= 4.12))) dune dune-configurator) (depopts diff -Nru ocaml-mm-0.7.5/examples/autotune.ml ocaml-mm-0.8.1/examples/autotune.ml --- ocaml-mm-0.7.5/examples/autotune.ml 2022-02-03 12:20:47.000000000 +0000 +++ ocaml-mm-0.8.1/examples/autotune.ml 2022-05-24 14:23:18.000000000 +0000 @@ -29,12 +29,12 @@ (* gen#fill buf 0 blen; *) (try assert (alsa_out#wait 1000); - let w = alsa_out#write buf in + let w = alsa_out#write buf 0 blen 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 + ignore (alsa_out#write buf 0 blen)); + let _ = alsa_in#read buf 0 blen in (* Printf.printf "Read: %d\n%!" r *) () done; alsa_in#close; diff -Nru ocaml-mm-0.7.5/examples/dictee.ml ocaml-mm-0.8.1/examples/dictee.ml --- ocaml-mm-0.7.5/examples/dictee.ml 2022-02-03 12:20:47.000000000 +0000 +++ ocaml-mm-0.8.1/examples/dictee.ml 2022-05-24 14:23:18.000000000 +0000 @@ -39,12 +39,12 @@ let prevnotes = ref [] in synth#set_volume 0.1; while !loop do - let r = f#read buf in - agc#process buf; + let r = f#read buf 0 blen in + agc#process buf 0 blen; 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) + ~volume_min:0.01 ~filter_harmonics:false (Audio.to_mono buf 0 blen) in let notes = List.sort (fun (_, v1) (_, v2) -> if v1 < v2 then 1 else -1) notes @@ -63,11 +63,11 @@ mid#note_on mchan n (10. *. v)) (list_diff ncmp notes !prevnotes); prevnotes := notes; - synth#fill_add buf; + synth#fill_add buf 0 blen; mid#advance blen; - Audio.amplify 2. buf; - wav#write buf; - if oss_out then oss#write buf + Audio.amplify 2. buf 0 blen; + wav#write buf 0 blen; + if oss_out then oss#write buf 0 blen done; wav#close; mid#close; diff -Nru ocaml-mm-0.7.5/examples/drums.ml ocaml-mm-0.8.1/examples/drums.ml --- ocaml-mm-0.7.5/examples/drums.ml 2022-02-03 12:20:47.000000000 +0000 +++ ocaml-mm-0.8.1/examples/drums.ml 2022-05-24 14:23:18.000000000 +0000 @@ -36,7 +36,7 @@ let gen i = let buf = Audio.create channels blen in - (i 440. 1.)#fill buf; + (i 440. 1.)#fill buf 0 blen; buf let bd = gen bd @@ -52,10 +52,10 @@ (* 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 + let buf = Audio.append bd 0 blen sd 0 blen in while true do (* wav#write buf 0 blen; *) - oss#write buf + oss#write buf 0 (2*blen) done; (* wav#close; *) oss#close diff -Nru ocaml-mm-0.7.5/examples/dune ocaml-mm-0.8.1/examples/dune --- ocaml-mm-0.7.5/examples/dune 2022-02-03 12:20:47.000000000 +0000 +++ ocaml-mm-0.8.1/examples/dune 2022-05-24 14:23:18.000000000 +0000 @@ -53,13 +53,18 @@ (libraries gstreamer mm.audio mm.video mm.sdl mm.oss)) (executable + (name graphics_test) + (modules graphics_test) + (optional) + (libraries graphics mm)) + +(executable (name test) (modules test) (optional) - (libraries mm.audio mm.image)) + (libraries mm)) (rule (alias runtest) (action (run ./test.exe))) - diff -Nru ocaml-mm-0.7.5/examples/fft.ml ocaml-mm-0.8.1/examples/fft.ml --- ocaml-mm-0.7.5/examples/fft.ml 2022-02-03 12:20:47.000000000 +0000 +++ ocaml-mm-0.8.1/examples/fft.ml 2022-05-24 14:23:18.000000000 +0000 @@ -16,15 +16,15 @@ 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); + Audio.blit buf blen buf 0 blen; + let n = f#read buf blen blen in + oss#write 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) + (Audio.to_mono buf 0 blen) + (o * blen / fft_times_per_buf) + blen in FFT.Window.cosine c; FFT.fft fft c; diff -Nru ocaml-mm-0.7.5/examples/.gitignore ocaml-mm-0.8.1/examples/.gitignore --- ocaml-mm-0.7.5/examples/.gitignore 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-mm-0.8.1/examples/.gitignore 2022-05-24 14:23:18.000000000 +0000 @@ -0,0 +1,5 @@ +out +test.mp3 +test.wav +test.ppm +test.mid \ No newline at end of file diff -Nru ocaml-mm-0.7.5/examples/graphics_test.ml ocaml-mm-0.8.1/examples/graphics_test.ml --- ocaml-mm-0.7.5/examples/graphics_test.ml 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-mm-0.8.1/examples/graphics_test.ml 2022-05-24 14:23:18.000000000 +0000 @@ -0,0 +1,32 @@ +open Mm + +let show img = + let width = Image.YUV420.width img in + let height = Image.YUV420.height img in + let img = Image.YUV420.to_int_image img in + Graphics.open_graph ""; + Graphics.resize_window width height; + let img = Graphics.make_image img in + Graphics.draw_image img 0 0; + Graphics.synchronize (); + Graphics.loop_at_exit [] (fun _ -> ()) + +let () = + let width = 640 in + let height = 480 in + let img = Image.YUV420.create width height in + Image.YUV420.blank img; + Image.YUV420.fill img (Image.Pixel.yuv_of_rgb (0, 0, 0xff)); + Image.YUV420.fill_alpha img 0; + let r = Image.YUV420.create 200 100 in + Image.YUV420.fill r (Image.Pixel.yuv_of_rgb (0xff, 0, 0)); + Image.YUV420.add r ~x:10 ~y:70 img; + if false then show img + +let () = + let module C = Image.CanvasYUV420 in + let r = Image.YUV420.create 200 200 in + Image.YUV420.fill r (Image.Pixel.yuv_of_rgb (0xff, 0, 0)); + let img = C.make ~x:150 ~y:200 ~width:600 ~height:600 r in + let img = C.render ~transparent:true img in + show img diff -Nru ocaml-mm-0.7.5/examples/gstreamer_test.ml ocaml-mm-0.8.1/examples/gstreamer_test.ml --- ocaml-mm-0.7.5/examples/gstreamer_test.ml 2022-02-03 12:20:47.000000000 +0000 +++ ocaml-mm-0.8.1/examples/gstreamer_test.ml 2022-05-24 14:23:18.000000000 +0000 @@ -46,7 +46,7 @@ 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 + Audio.S16LE.to_audio b 0 buf 0 (Audio.length buf); + oss#write buf 0 (Audio.length buf) done; ignore (Element.set_state bin State_null) diff -Nru ocaml-mm-0.7.5/examples/id.ml ocaml-mm-0.8.1/examples/id.ml --- ocaml-mm-0.7.5/examples/id.ml 2022-02-03 12:20:47.000000000 +0000 +++ ocaml-mm-0.8.1/examples/id.ml 2022-05-24 14:23:18.000000000 +0000 @@ -15,14 +15,14 @@ let buf = Audio.create read#channels blen in let loop = ref true in while !loop do - let n = read#read buf in + let n = read#read buf 0 blen in if n = 0 then loop := false; - let c = FFT.complex_create (Audio.to_mono buf) in + let c = FFT.complex_create (Audio.to_mono buf 0 n) 0 n 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 + let buf = Array.make read#channels c in + write#write buf 0 (Audio.length buf) done; write#close; read#close diff -Nru ocaml-mm-0.7.5/examples/Makefile ocaml-mm-0.8.1/examples/Makefile --- ocaml-mm-0.7.5/examples/Makefile 2022-02-03 12:20:47.000000000 +0000 +++ ocaml-mm-0.8.1/examples/Makefile 2022-05-24 14:23:18.000000000 +0000 @@ -27,8 +27,14 @@ sine_wav: @dune exec ./sine_wav.exe +graphics: + @dune exec ./graphics_test.exe + test: @dune exec ./test.exe +quick-test: + @dune exec ./test.exe -- --skip-long + valgrind: build valgrind ../_build/default/examples/test.exe --skip-long diff -Nru ocaml-mm-0.7.5/examples/midiplayer.ml ocaml-mm-0.8.1/examples/midiplayer.ml --- ocaml-mm-0.7.5/examples/midiplayer.ml 2022-02-03 12:20:47.000000000 +0000 +++ ocaml-mm-0.8.1/examples/midiplayer.ml 2022-05-24 14:23:18.000000000 +0000 @@ -14,11 +14,11 @@ in let loop = ref true in while !loop do - let r = f#read buf in + let r = f#read buf 0 blen in loop := r <> 0; (* delay#process buf 0 r; *) (* bqf#process buf 0 r; *) - oss#write (Audio.sub buf 0 r) + oss#write buf 0 r done; oss#close; f#close diff -Nru ocaml-mm-0.7.5/examples/sine_wav.ml ocaml-mm-0.8.1/examples/sine_wav.ml --- ocaml-mm-0.7.5/examples/sine_wav.ml 2022-02-03 12:20:47.000000000 +0000 +++ ocaml-mm-0.8.1/examples/sine_wav.ml 2022-05-24 14:23:18.000000000 +0000 @@ -13,9 +13,9 @@ 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 + sine#fill buf 0 blen; + wav#write buf 0 blen; + ao#write buf 0 blen done; wav#close; ao#close diff -Nru ocaml-mm-0.7.5/examples/test.ml ocaml-mm-0.8.1/examples/test.ml --- ocaml-mm-0.7.5/examples/test.ml 2022-02-03 12:20:47.000000000 +0000 +++ ocaml-mm-0.8.1/examples/test.ml 2022-05-24 14:23:18.000000000 +0000 @@ -1,101 +1,347 @@ -open Mm_audio -open Mm_image +open Mm let skip_long = ref false let () = Printexc.record_backtrace true; Arg.parse - [ - "--skip-long", Arg.Set skip_long, "Skip long tests." - ] + [("--skip-long", Arg.Set skip_long, "Skip long tests.")] (fun _ -> ()) "test [options]" -let test ?(skip=false) name f = +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; + close_out oc + +let test ?(skip = false) name f = Printf.printf "- %s... %!" name; - if skip then Printf.printf "skipped\n%!" else - ( - f (); - Printf.printf "ok\n%!" - ) + if skip then Printf.printf "skipped\n%!" + else ( + f (); + Printf.printf "ok\n%!") -let time ?(skip=false) name f = +let time ?skip name f = + let skip = Option.value ~default:!skip_long skip in Printf.printf "- %s... %!" name; - if skip then Printf.printf "skipped\n%!" else + if skip then Printf.printf "skipped\n%!" + else ( let t0 = Sys.time () in f (); let t1 = Sys.time () in - Printf.printf "%.02f s\n%!" (t1 -. t0) + Printf.printf "%.02f s\n%!" (t1 -. t0)); + Gc.full_major () -let () = - Printf.printf "\n# Testing MM library\n\n%!" +let () = Printf.printf "\n# Testing MM library\n\n%!" let () = Printf.printf "## Architecture\n\n%!"; Printf.printf "- word size: %d\n%!" Sys.word_size; Printf.printf "\n%!" +module A = Audio + let () = Printf.printf "## Testing audio\n\n%!"; + let len = 44100 in + let iter = 10000 in test "basic functions" (fun () -> - let a = Audio.create 2 44100 in - Audio.noise a; - Audio.pan 0.4 a; - ignore (Audio.squares a); - Audio.amplify 0.5 a - ); - time ~skip:!skip_long "adding many buffers" (fun () -> - let a = Audio.create 2 44100 in + let a = A.create 2 len in + A.noise a 0 len; + A.pan 0.4 a 0 len; + ignore (A.squares a 0 len); + assert (A.length a = len); + A.amplify 0.5 a 0 len); + let b = A.create 2 len in + let a = A.create 2 len in + time "adding many buffers" (fun () -> for _ = 1 to 10000 do - let b = Audio.create 2 44100 in - Audio.add b a - done + A.add b 0 a 0 len + done); + let src = A.make 2 len 1. in + let buf = Bytes.create (A.U8.size 2 len) in + let dst = A.create 2 len in + time "u8 conversion" (fun () -> + for _ = 1 to iter do + 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.) + ); + 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 + time "s16le conversion" (fun () -> + for _ = 1 to iter do + A.S16LE.of_audio src 0 buf 0 len; + 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.) + ); + 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 + time "s16be conversion" (fun () -> + for _ = 1 to iter do + A.S16BE.of_audio src 0 buf 0 len; + 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.) + ); + 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 + time "s24le conversion" (fun () -> + for _ = 1 to iter do + A.S24LE.of_audio src 0 buf 0 len; + 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.) + ); + 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 + time "s32le conversion" (fun () -> + for _ = 1 to iter do + 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.) + ); + 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" +module I = Image + let () = - Printf.printf "## Testing video\n\n%!"; + Printf.printf "## Testing images\n\n%!"; test "rounding" (fun () -> for k = 1 to 5 do for n = 0 to 33 do - assert (Image.Data.round k n = Float.to_int (float k *. Float.ceil (float n /. float k))) + assert ( + I.Data.round k n + = Float.to_int (float k *. Float.ceil (float n /. float k))) done - done - ); + done); test "fill buffer" (fun () -> - let a = Image.YUV420.create 10 10 in - Image.YUV420.fill a (0,0,0) - ); + let a = I.YUV420.create 10 10 in + I.YUV420.fill a (0, 0, 0)); test "various sizes" (fun () -> for i = 0 to 7 do for j = 0 to 7 do - let w = 16+i in - let h = 16+j in - let a = Image.YUV420.create w h in - Image.YUV420.set_pixel_rgba a (w-1) (h-1) (0,0,0,0); - Image.YUV420.fill a (0,0,0); - Image.YUV420.randomize a + let w = 16 + i in + let h = 16 + j in + let a = I.YUV420.create w h in + I.YUV420.set_pixel_rgba a (w - 1) (h - 1) (0, 0, 0, 0); + I.YUV420.fill a (0, 0, 0); + I.YUV420.randomize a done - done - ); + done); test "adding images" (fun () -> - let a = Image.YUV420.create 640 480 in - Image.YUV420.blank a; - Image.YUV420.fill a (10, 10, 10); - let b = Image.YUV420.create 64 64 in - Image.YUV420.fill b (10, 10, 10); - Image.YUV420.add b a; - Image.YUV420.add b ~x:10 ~y:10 a; - Image.YUV420.add b ~x:(-10) ~y:(-10) a; - Image.YUV420.add b ~x:1000 ~y:1000 a; - ); + let a = I.YUV420.create 640 480 in + I.YUV420.blank a; + I.YUV420.fill a (10, 10, 10); + let b = I.YUV420.create 64 64 in + I.YUV420.fill b (10, 10, 10); + I.YUV420.add b a; + I.YUV420.add b ~x:10 ~y:10 a; + I.YUV420.add b ~x:(-10) ~y:(-10) a; + I.YUV420.add b ~x:1000 ~y:1000 a); test "converting" (fun () -> - let a = Image.YUV420.create 640 480 in - let b = Image.YUV420.of_RGBA32 (Image.YUV420.to_RGBA32 a) in - ignore b + let a = I.YUV420.create 640 480 in + let b = I.YUV420.of_RGBA32 (I.YUV420.to_RGBA32 a) in + ignore b); + test "blank" (fun () -> + let img = I.YUV420.create 640 480 in + I.YUV420.blank img; + write "blank.bmp" (I.YUV420.to_BMP img)); + test "add" (fun () -> + let img = I.YUV420.create 640 480 in + I.YUV420.blank img; + I.YUV420.fill_alpha img 0; + let r = I.YUV420.create 200 100 in + I.YUV420.fill r (I.Pixel.yuv_of_rgb (0xff, 0, 0)); + I.YUV420.add r ~x:10 ~y:70 img; + I.YUV420.rotate (I.YUV420.copy img) 200 200 0.7 img; + write "add.bmp" (I.YUV420.to_BMP img)); + test "canvas line" (fun () -> + for _ = 1 to 100 do + let l = + I.CanvasYUV420.Draw.line (0xff, 0xff, 0xff, 0xff) (15, 24) (59, 78) + in + ignore l + done); + test "hmirror" (fun () -> + let img = I.YUV420.create 1000 1000 in + I.YUV420.gradient_uv img (0, 0) (0xff, 0) (0, 0xff); + I.YUV420.hmirror img; + write "hmirror.bmp" (I.YUV420.to_BMP img)); + test "render canvas" (fun () -> + let r = I.YUV420.create 200 200 in + I.YUV420.fill r (I.Pixel.yuv_of_rgb (0xff, 0, 0)); + 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 canvas" (fun () -> + let img = I.YUV420.create 1000 1000 in + I.YUV420.gradient_uv img (0, 0) (0xff, 0) (0, 0xff); + let img = I.CanvasYUV420.make img in + let img' = I.CanvasYUV420.scale (200, 1000) (300, 1000) img in + let img = I.CanvasYUV420.add img' img in + let img = I.CanvasYUV420.render img in + write "scale-canvas.bmp" (I.YUV420.to_BMP img)); + test "gradient" (fun () -> + let img = I.YUV420.create 640 480 in + I.YUV420.gradient_uv img (0, 0) (100, 200) (200, 150); + write "gradient.bmp" (I.YUV420.to_BMP img)); + test "manual gradient" (fun () -> + let d = 400 in + let img = I.YUV420.create d d in + for j = 0 to d - 1 do + for i = 0 to d - 1 do + I.YUV420.set_pixel_rgba img i j (0xff, 0, 0, (i + j) * 0xff / (2 * d)) + done + done; + let bg = I.YUV420.create d d in + I.YUV420.fill bg (0, 0, 0); + I.YUV420.add img ~x:50 ~y:50 bg; + write "mgradient.bmp" (I.YUV420.to_BMP bg)); + test "color to alpha" (fun () -> + let d = 500 in + let img = I.YUV420.create d d in + I.YUV420.fill img (0, 0, 0); + let c = (0xff, 0xff, 20) in + let r = I.YUV420.create 200 200 in + I.YUV420.fill r c; + I.YUV420.add r ~x:100 ~y:150 img; + I.YUV420.alpha_of_color img c 5; + write "c2a.bmp" (I.YUV420.to_BMP img)); + test "is_opaque" (fun () -> + let img = I.YUV420.create 1000 1000 in + assert (I.YUV420.is_opaque img); + I.YUV420.set_pixel_rgba img 10 10 (0, 0, 0, 10); + 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)); + time "many adds" (fun () -> + let r = I.YUV420.create 500 500 in + I.YUV420.fill r (I.Pixel.yuv_of_rgb (0xff, 0, 0)); + let img = ref (I.CanvasYUV420.create 2000 2000) in + for i = 1 to 100000 do + (* only the first 2000 are relevant *) + let r = I.CanvasYUV420.make r |> I.CanvasYUV420.translate i i in + img := I.CanvasYUV420.add r !img + done; + let img = I.CanvasYUV420.render !img in + write "adds.bmp" (I.YUV420.to_BMP img)); + test "mean cannot clip" (fun () -> + (* Ensure that we don't have to clip when computing the mean of two pixels + in bytes. *) + for s = 0 to 0xff do + for t = 0 to 0xff do + for a = 0 to 0xff do + let p = ((s * a) + (t * (0xff - a))) / 0xff in + assert (0 <= p && p <= 0xff) + done + done + done); + time "many adds with alpha" (fun () -> + let r = I.YUV420.create 500 500 in + for j = 0 to 499 do + for i = 0 to 499 do + let a = match i mod 3 with 0 -> 0 | 1 -> 0x7f | _ -> 0xff in + I.YUV420.set_pixel_rgba r i j (0xff, 0, 0, a) + done + done; + let img = ref (I.CanvasYUV420.create 2000 2000) in + for i = 1 to 100000 do + (* only the first 2000 are relevant *) + let r = I.CanvasYUV420.make r |> I.CanvasYUV420.translate i i in + img := I.CanvasYUV420.add r !img + done; + let img = I.CanvasYUV420.render !img in + write "adds-alpha.bmp" (I.YUV420.to_BMP img)); + time "scale" (fun () -> + let img = I.YUV420.create 1000 1000 in + I.YUV420.gradient_uv img (0, 0) (0xff, 0) (0, 0xff); + let img2 = I.YUV420.create 10000 10000 in + I.YUV420.scale img img2; + 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)) ); - Printf.printf "\n" + time "sliding font" (fun () -> + let width = 1280 in + let height = 720 in + let fps = 24 in + let duration = 10 in + let txt = I.Bitmap.Font.render ~size:30 "Hello, world!\nHow are you?" in + 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 ()); + 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; + 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 "") + ); + time "increasing saw" (fun () -> + let width = 640 in + let height = 360 in + let fontsize = 70 in + let fps = 24 in + let fname = "out/saw.avi" in + 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 ()); + let fmin = 20. in + let fmax = 20000. in + let duration = 20. in + let t = ref 0. in + let dt = 1. /. float samplerate in + (* fmin + 2^(duration/a) = fmax => a = duration / log2 (fmax - fmin) *) + let a = duration /. (log (fmax -. fmin) /. log 2.) in + 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 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; + 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; + t := !t +. dt + done; + output_string oc (Video.AVI.Writer.Chunk.audio_s16le buf) + done; + close_out oc + ) -let () = - Gc.full_major () +let () = Gc.full_major () diff -Nru ocaml-mm-0.7.5/external/deprecated/ffmpeg_stubs.c ocaml-mm-0.8.1/external/deprecated/ffmpeg_stubs.c --- ocaml-mm-0.7.5/external/deprecated/ffmpeg_stubs.c 2022-02-03 12:20:47.000000000 +0000 +++ ocaml-mm-0.8.1/external/deprecated/ffmpeg_stubs.c 2022-05-24 14:23:18.000000000 +0000 @@ -18,16 +18,17 @@ * 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. + * 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. * */ @@ -59,23 +60,21 @@ AVCodec *av_codec; struct SwsContext *convert_ctx; int video_stream; - AVFrame* av_frame; - AVFrame* av_frame_rgb; - uint8_t* buffer; + AVFrame *av_frame; + AVFrame *av_frame_rgb; + uint8_t *buffer; } ffmpeg_dec_t; -#define Dec_val(v) ((ffmpeg_dec_t*)v) +#define Dec_val(v) ((ffmpeg_dec_t *)v) -CAMLprim value caml_ffmpeg_init(value unit) -{ +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) -{ +CAMLprim value caml_ffmpeg_dec_openfile(value fname) { CAMLparam1(fname); ffmpeg_dec_t *ffd = malloc(sizeof(ffmpeg_dec_t)); int i; @@ -83,14 +82,15 @@ int width, height; /* Open the file */ - assert(av_open_input_file(&ffd->av_format_ctx, String_val(fname), NULL, 0, NULL) == 0); + 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) { + for (i = 0; i < ffd->av_format_ctx->nb_streams; i++) + if (ffd->av_format_ctx->streams[i]->codec->codec_type == CODEC_TYPE_VIDEO) { ffd->video_stream = i; break; } @@ -111,20 +111,22 @@ 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)); + 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); + 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); + 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) -{ +CAMLprim value caml_ffmpeg_dec_dump_format(value _ffd, value _fname) { CAMLparam2(_ffd, _fname); - ffmpeg_dec_t* ffd = Dec_val(_ffd); + 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); @@ -132,86 +134,85 @@ CAMLreturn(Val_unit); } -CAMLprim value caml_ffmpeg_dec_set_target_size(value _ffd, value _w, value _h) -{ +CAMLprim value caml_ffmpeg_dec_set_target_size(value _ffd, value _w, value _h) { CAMLparam1(_ffd); - ffmpeg_dec_t* ffd = Dec_val(_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); + 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) -{ +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) -{ +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) -{ +CAMLprim value caml_ffmpeg_dec_fps(value _ffd) { CAMLparam1(_ffd); - ffmpeg_dec_t* ffd = Dec_val(_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)); + CAMLreturn(caml_copy_double(d / n)); } -CAMLprim value caml_ffmpeg_dec_read_frame(value _ffd, value _rgb) -{ +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); + 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 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); + 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) -{ +CAMLprim value caml_ffmpeg_dec_close(value _ffd) { CAMLparam1(_ffd); - ffmpeg_dec_t* ffd = Dec_val(_ffd); + ffmpeg_dec_t *ffd = Dec_val(_ffd); sws_freeContext(ffd->convert_ctx); av_free(ffd->buffer); @@ -222,7 +223,9 @@ CAMLreturn(Val_unit); } -/* See http://cekirdek.pardus.org.tr/~ismail/ffmpeg-docs/output-example_8c-source.html */ +/* See + * http://cekirdek.pardus.org.tr/~ismail/ffmpeg-docs/output-example_8c-source.html + */ typedef struct { AVFormatContext *format_ctx; @@ -234,10 +237,9 @@ struct SwsContext *convert_ctx; } ffmpeg_enc_t; -#define Enc_val(v) ((ffmpeg_enc_t*)v) +#define Enc_val(v) ((ffmpeg_enc_t *)v) -static AVFrame *alloc_picture(int pix_fmt, int width, int height) -{ +static AVFrame *alloc_picture(int pix_fmt, int width, int height) { AVFrame *picture; uint8_t *picture_buf; int size; @@ -251,12 +253,12 @@ av_free(picture); return NULL; } - avpicture_fill((AVPicture*)picture, picture_buf, pix_fmt, width, height); + 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) -{ +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; @@ -270,7 +272,7 @@ output_format = av_guess_format("mpeg", NULL, NULL); assert(output_format); - //printf("Found format: %s\n", output_format->name); + // printf("Found format: %s\n", output_format->name); /* Allocate the output media context */ ffe->format_ctx = avformat_alloc_context(); @@ -280,7 +282,8 @@ /* 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 = 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; @@ -300,20 +303,22 @@ /* 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 */ + /* 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; + 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")) + 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); + // 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 */ @@ -323,11 +328,10 @@ 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); - } + 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); @@ -338,11 +342,14 @@ 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); + 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); + 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); @@ -350,10 +357,9 @@ CAMLreturn((value)ffe); } -CAMLprim value caml_ffmpeg_enc_dump_format(value _ffe, value _fname) -{ +CAMLprim value caml_ffmpeg_enc_dump_format(value _ffe, value _fname) { CAMLparam2(_ffe, _fname); - ffmpeg_enc_t* ffe = Enc_val(_ffe); + ffmpeg_enc_t *ffe = Enc_val(_ffe); /* Dump info about the file on stderr */ dump_format(ffe->format_ctx, 0, String_val(_fname), 1); @@ -361,16 +367,15 @@ CAMLreturn(Val_unit); } -static void fill_picture(AVFrame *pict, frame *rgb) -{ +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); + 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) -{ +CAMLprim value caml_ffmpeg_enc_write_frame(value _ffe, value _f) { CAMLparam2(_ffe, _f); frame rgb; frame_of_value(_f, &rgb); @@ -382,58 +387,54 @@ 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 + 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 */ + 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.flags |= PKT_FLAG_KEY; - pkt.stream_index= ffe->video_stream->index; - pkt.data= (uint8_t*)ffe->frame; - pkt.size= sizeof(AVPicture); + 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); } - 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) -{ +CAMLprim value caml_ffmpeg_enc_close(value _ffe) { CAMLparam1(_ffe); ffmpeg_enc_t *ffe = Enc_val(_ffe); int i; @@ -442,18 +443,17 @@ 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); - } + 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++) { + 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]); } @@ -478,7 +478,9 @@ 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); + 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); } @@ -495,8 +497,8 @@ 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(); + 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); } diff -Nru ocaml-mm-0.7.5/external/deprecated/v4l_stubs.c ocaml-mm-0.8.1/external/deprecated/v4l_stubs.c --- ocaml-mm-0.7.5/external/deprecated/v4l_stubs.c 2022-02-03 12:20:47.000000000 +0000 +++ ocaml-mm-0.8.1/external/deprecated/v4l_stubs.c 2022-05-24 14:23:18.000000000 +0000 @@ -18,45 +18,45 @@ * 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. + * 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 #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) -{ +static int xioctl(int fh, int request, void *arg) { int r; do { @@ -68,9 +68,7 @@ return r; } - -CAMLprim value caml_v4l2_open(value device, value w, value h, value stride) -{ +CAMLprim value caml_v4l2_open(value device, value w, value h, value stride) { CAMLparam1(device); // TODO: error codes @@ -79,14 +77,14 @@ assert(fd >= 0); // TODO: different formats ? - struct v4l2_format fmt; + 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); + 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); @@ -112,8 +110,7 @@ } */ -CAMLprim value caml_v4l2_grab(value _fd, value data) -{ +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)); @@ -135,13 +132,14 @@ xioctl(fd, VIDIOC_REQBUFS, &req); memset(&vbuf, 0, sizeof(vbuf)); - vbuf.type = V4L2_BUF_TYPE_VIDEO_CAPTURE; + vbuf.type = V4L2_BUF_TYPE_VIDEO_CAPTURE; vbuf.memory = V4L2_MEMORY_MMAP; - vbuf.index = 0; + 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); + mbuf = v4l2_mmap(NULL, mbuflen, PROT_READ | PROT_WRITE, MAP_SHARED, fd, + vbuf.m.offset); assert(mbuf != MAP_FAILED); memset(&vbuf, 0, sizeof(vbuf)); @@ -183,8 +181,7 @@ CAMLreturn(Val_unit); } -CAMLprim value caml_v4l2_close(value fd) -{ +CAMLprim value caml_v4l2_close(value fd) { CAMLparam0(); v4l2_close(Int_val(fd)); @@ -192,8 +189,7 @@ CAMLreturn(Val_unit); } -CAMLprim value caml_v4l1_open(value device, value w, value h, value stride) -{ +CAMLprim value caml_v4l1_open(value device, value w, value h, value stride) { CAMLparam1(device); int fd; struct video_capability cap; @@ -207,35 +203,34 @@ 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"); + 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; + } 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); } @@ -249,8 +244,7 @@ CAMLreturn(Val_int(fd)); } -CAMLprim value caml_v4l1_grab(value fd, value data) -{ +CAMLprim value caml_v4l1_grab(value fd, value data) { CAMLparam1(data); int len = caml_ba_byte_size(Caml_ba_array_val(data)); int ret; @@ -266,8 +260,7 @@ CAMLreturn(Val_unit); } -CAMLprim value caml_v4l1_close(value fd) -{ +CAMLprim value caml_v4l1_close(value fd) { CAMLparam0(); close(Int_val(fd)); diff -Nru ocaml-mm-0.7.5/external/mm_alsa.ml ocaml-mm-0.8.1/external/mm_alsa.ml --- ocaml-mm-0.7.5/external/mm_alsa.ml 2022-02-03 12:20:47.000000000 +0000 +++ ocaml-mm-0.8.1/external/mm_alsa.ml 2022-05-24 14:23:18.000000000 +0000 @@ -62,7 +62,7 @@ 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 read = Alsa.Pcm.readn_float dev + method write = Alsa.Pcm.writen_float dev method close = Alsa.Pcm.close dev end diff -Nru ocaml-mm-0.7.5/external/mm_alsa.mli ocaml-mm-0.8.1/external/mm_alsa.mli --- ocaml-mm-0.7.5/external/mm_alsa.mli 2022-02-03 12:20:47.000000000 +0000 +++ ocaml-mm-0.8.1/external/mm_alsa.mli 2022-05-24 14:23:18.000000000 +0000 @@ -15,6 +15,6 @@ ; prepare : unit ; wait : int -> bool ; recover : exn -> unit - ; read : Audio.t -> int - ; write : Audio.t -> int + ; read : Audio.t -> int -> int -> int + ; write : Audio.t -> int -> int -> int ; close : unit > diff -Nru ocaml-mm-0.7.5/external/mm_ao.ml ocaml-mm-0.8.1/external/mm_ao.ml --- ocaml-mm-0.7.5/external/mm_ao.ml 2022-02-03 12:20:47.000000000 +0000 +++ ocaml-mm-0.8.1/external/mm_ao.ml 2022-05-24 14:23:18.000000000 +0000 @@ -38,8 +38,8 @@ object val dev = Ao.open_live ~channels ~rate ~byte_format:`LITTLE_ENDIAN () - method write buf = - let s = Audio.S16LE.make buf in + method write buf ofs len = + let s = Audio.S16LE.make buf ofs len in Ao.play dev s method close = Ao.close dev diff -Nru ocaml-mm-0.7.5/external/mm_mad.ml ocaml-mm-0.8.1/external/mm_mad.ml --- ocaml-mm-0.7.5/external/mm_mad.ml 2022-02-03 12:20:47.000000000 +0000 +++ ocaml-mm-0.8.1/external/mm_mad.ml 2022-05-24 14:23:18.000000000 +0000 @@ -51,7 +51,7 @@ 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 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... *) @@ -60,11 +60,10 @@ channels <- c; rb <- Audio.Ringbuffer_ext.create channels 0 - method private decode = Mad.decode_frame_float_ba self#mf + method private decode = Mad.decode_frame_float self#mf method close = self#stream_close - method read buf = - let len = Audio.length buf in + method read buf ofs len = let r = ref (-1) in while !r <> 0 && Audio.Ringbuffer_ext.read_space rb < len do let data = @@ -76,7 +75,7 @@ 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); + Audio.Ringbuffer_ext.read rb (Audio.sub buf ofs len); len (* TODO *) diff -Nru ocaml-mm-0.7.5/external/mm_oss.ml ocaml-mm-0.8.1/external/mm_oss.ml --- ocaml-mm-0.7.5/external/mm_oss.ml 2022-02-03 12:20:47.000000000 +0000 +++ ocaml-mm-0.8.1/external/mm_oss.ml 2022-05-24 14:23:18.000000000 +0000 @@ -59,8 +59,8 @@ w := !w + self#stream_write buf (ofs + !w) (len - !w) done - method write buf = - let s = Audio.S16LE.make buf in + method write buf ofs len = + let s = Audio.S16LE.make buf ofs len in self#stream_really_write s 0 (String.length s) method close = self#stream_close @@ -80,13 +80,12 @@ method length : int = assert false method duration : float = assert false - method read buf = - let len = Audio.length buf in + method read buf ofs len = 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); + Audio.S16LE.to_audio (Bytes.unsafe_to_string s) 0 buf ofs len; len method seek (_ : int) : unit = assert false diff -Nru ocaml-mm-0.7.5/external/mm_pulseaudio.ml ocaml-mm-0.8.1/external/mm_pulseaudio.ml --- ocaml-mm-0.7.5/external/mm_pulseaudio.ml 2022-02-03 12:20:47.000000000 +0000 +++ ocaml-mm-0.8.1/external/mm_pulseaudio.ml 2022-05-24 14:23:18.000000000 +0000 @@ -31,7 +31,6 @@ * *) -open Mm_audio open Pulseaudio class writer client_name stream_name channels rate = @@ -46,8 +45,6 @@ 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 write = Simple.write dev method close = Simple.free dev end diff -Nru ocaml-mm-0.7.5/external/oss_stubs.c ocaml-mm-0.8.1/external/oss_stubs.c --- ocaml-mm-0.7.5/external/oss_stubs.c 2022-02-03 12:20:47.000000000 +0000 +++ ocaml-mm-0.8.1/external/oss_stubs.c 2022-05-24 14:23:18.000000000 +0000 @@ -18,16 +18,17 @@ * 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. + * 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. * */ @@ -38,12 +39,11 @@ #include #include -#include -#include #include +#include +#include -CAMLprim value caml_oss_dsp_setfmt(value fd, value fmt) -{ +CAMLprim value caml_oss_dsp_setfmt(value fd, value fmt) { int f = Int_val(fmt); /* TODO: raise errors */ @@ -53,8 +53,7 @@ return Val_int(f); } -CAMLprim value caml_oss_dsp_channels(value fd, value chans) -{ +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); @@ -62,8 +61,7 @@ return Val_int(c); } -CAMLprim value caml_oss_dsp_speed(value fd, value speed) -{ +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); diff -Nru ocaml-mm-0.7.5/external/sdl_stubs.c ocaml-mm-0.8.1/external/sdl_stubs.c --- ocaml-mm-0.7.5/external/sdl_stubs.c 2022-02-03 12:20:47.000000000 +0000 +++ ocaml-mm-0.8.1/external/sdl_stubs.c 2022-05-24 14:23:18.000000000 +0000 @@ -18,16 +18,17 @@ * 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. + * 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. * */ @@ -45,8 +46,7 @@ #include "image_rgb.h" -CAMLprim value caml_sdl_rgb_to32(value _rgb, value _surf, value shift) -{ +CAMLprim value caml_sdl_rgb_to32(value _rgb, value _surf, value shift) { CAMLparam3(_rgb, _surf, shift); /* int sr = Int_val(Field(shift, 0)); @@ -62,7 +62,7 @@ for (j = 0; j < h; j++) for (i = 0; i < w; i++) - surf[j*w+i] = htonl(Int_pixel(&rgb,i,j)) >> 8; + surf[j * w + i] = htonl(Int_pixel(&rgb, i, j)) >> 8; CAMLreturn(Val_unit); } diff -Nru ocaml-mm-0.7.5/Makefile ocaml-mm-0.8.1/Makefile --- ocaml-mm-0.7.5/Makefile 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-mm-0.8.1/Makefile 2022-05-24 14:23:18.000000000 +0000 @@ -0,0 +1,7 @@ +all: build + +build: + @dune build + +clean: + @dune clean diff -Nru ocaml-mm-0.7.5/mm.opam ocaml-mm-0.8.1/mm.opam --- ocaml-mm-0.7.5/mm.opam 2022-02-03 12:20:47.000000000 +0000 +++ ocaml-mm-0.8.1/mm.opam 2022-05-24 14:23:18.000000000 +0000 @@ -1,6 +1,6 @@ # This file is generated by dune, edit dune-project instead opam-version: "2.0" -version: "0.7.5" +version: "0.8.1" synopsis: "The mm library contains high-level to create and manipulate multimedia streams (audio, video, MIDI)" maintainer: ["The Savonet Team "] @@ -9,7 +9,8 @@ homepage: "https://github.com/savonet/ocaml-mm" bug-reports: "https://github.com/savonet/ocaml-mm/issues" depends: [ - "ocaml" {with-test & >= "4.07"} + "ocaml" {>= "4.08"} + "ocaml" {with-test & >= "4.12"} "dune" {>= "2.8"} "dune-configurator" "odoc" {with-doc} diff -Nru ocaml-mm-0.7.5/.ocamlformat ocaml-mm-0.8.1/.ocamlformat --- ocaml-mm-0.7.5/.ocamlformat 2022-02-03 12:20:47.000000000 +0000 +++ ocaml-mm-0.8.1/.ocamlformat 2022-05-24 14:23:18.000000000 +0000 @@ -1,3 +1,4 @@ +version=0.19.0 profile = conventional break-separators = after space-around-lists = false diff -Nru ocaml-mm-0.7.5/src/audio_c.c ocaml-mm-0.8.1/src/audio_c.c --- ocaml-mm-0.7.5/src/audio_c.c 2022-02-03 12:20:47.000000000 +0000 +++ ocaml-mm-0.8.1/src/audio_c.c 2022-05-24 14:23:18.000000000 +0000 @@ -148,9 +148,9 @@ #ifdef DEBUG printf("Wrong sample: %f\n", s); #endif - return 255; + return INT8_MAX; } else - return (s * 127. + 128.); + return (s * INT8_MAX + INT8_MAX); } #define u8tof(x) (((double)x - INT8_MAX) / INT8_MAX) @@ -179,83 +179,84 @@ s32tof(((int32_t *)src)[offset / 4 + i * nc + c]) #endif -CAMLprim value caml_mm_audio_to_s32le(value a, value _dst, value _offs) { - CAMLparam3(a, _dst, _offs); +CAMLprim value caml_mm_audio_to_s32le(value _src, value _src_offs, value _dst, + value _dst_offs, value _len) { + CAMLparam2(_src, _dst); + CAMLlocal1(src); int c, i; - int offs = Int_val(_offs); - int nc = Wosize_val(a); + int dst_offs = Int_val(_dst_offs); + int src_offs = Int_val(_src_offs); + int nc = Wosize_val(_src); if (nc == 0) CAMLreturn(Val_unit); - int len = Caml_ba_array_val(Field(a, 0))->dim[0]; - float *src; + int len = Int_val(_len); int32_t *dst = (int32_t *)Bytes_val(_dst); - if (caml_string_length(_dst) < offs + len * nc * 4) + if (caml_string_length(_dst) < 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(); + src = Field(_src, c); for (i = 0; i < len; i++) { - dst[i * nc + c] = s32_clip(src[i + offs]); + dst[i * nc + c + dst_offs] = s32_clip(Double_field(src, i + src_offs)); #ifdef BIGENDIAN - dst[i * nc + c] = bswap_32(dst[i * nc + c]); + dst[i * nc + c + dst_offs] = bswap_32(dst[i * nc + c + dst_offs]); #endif } - caml_acquire_runtime_system(); } CAMLreturn(Val_unit); } -CAMLprim value caml_mm_audio_to_s24le(value a, value _dst, value _offs) { - CAMLparam3(a, _dst, _offs); +CAMLprim value caml_mm_audio_to_s24le(value _src, value _src_offs, value _dst, + value _dst_offs, value _len) { + CAMLparam2(_src, _dst); + CAMLlocal1(src); int c, i; - int offs = Int_val(_offs); - int nc = Wosize_val(a); + int dst_offs = Int_val(_dst_offs); + int src_offs = Int_val(_src_offs); + int nc = Wosize_val(_src); if (nc == 0) CAMLreturn(Val_unit); - int len = Caml_ba_array_val(Field(a, 0))->dim[0]; - float *src; + int len = Int_val(_len); int24_t *dst = (int24_t *)Bytes_val(_dst); - if (caml_string_length(_dst) < offs + len * nc * 3) + if (caml_string_length(_dst) < 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(); + src = Field(_src, c); for (i = 0; i < len; i++) - s24_clip(src[offs + i], dst[i * nc + c]); - caml_acquire_runtime_system(); + s24_clip(Double_field(src, i + src_offs), dst[i * nc + c + dst_offs]); } CAMLreturn(Val_unit); } -CAMLprim value caml_mm_audio_to_s16(value _le, value a, value _dst, - value _dst_offs) { - CAMLparam4(_le, a, _dst, _dst_offs); +CAMLprim value caml_mm_audio_to_s16(value _le, value _src, value _src_offs, + value _dst, value _dst_offs, value _len) { + CAMLparam2(_src, _dst); + CAMLlocal1(src); int little_endian = Bool_val(_le); int dst_offs = Int_val(_dst_offs); - int nc = Wosize_val(a); + int src_offs = Int_val(_src_offs); + int nc = Wosize_val(_src); if (nc == 0) CAMLreturn(Val_unit); - int len = Caml_ba_array_val(Field(a, 0))->dim[0]; - float *src; + int len = Int_val(_len); int16_t *dst = (int16_t *)Bytes_val(_dst); int c, i; - if (caml_string_length(_dst) < 2 * nc * (dst_offs + len)) + if (caml_string_length(_dst) < dst_offs + 2 * nc * len) caml_invalid_argument("pcm_to_s16: destination buffer too short"); - dst = dst + nc * dst_offs; + dst = (void*)dst + dst_offs; if (little_endian == 1) for (c = 0; c < nc; c++) { - src = Caml_ba_data_val(Field(a, c)); + src = Field(_src, c); for (i = 0; i < len; i++) { - dst[i * nc + c] = s16_clip(src[i]); + dst[i * nc + c] = s16_clip(Double_field(src, i + src_offs)); #ifdef BIGENDIAN dst[i * nc + c] = bswap_16(dst[i * nc + c]); #endif @@ -263,9 +264,9 @@ } else for (c = 0; c < nc; c++) { - src = Caml_ba_data_val(Field(a, c)); + src = Field(_src, c); for (i = 0; i < len; i++) { - dst[i * nc + c] = s16_clip(src[i]); + dst[i * nc + c] = s16_clip(Double_field(src, i + src_offs)); #ifndef BIGENDIAN dst[i * nc + c] = bswap_16(dst[i * nc + c]); #endif @@ -275,51 +276,63 @@ CAMLreturn(Val_unit); } -CAMLprim value caml_mm_audio_convert_s16(value _le, value _src, value _offset, - value _dst) { - CAMLparam4(_le, _src, _offset, _dst); +CAMLprim value caml_mm_audio_to_s16_byte(value *argv, int argn) { + return caml_mm_audio_to_s16(argv[0], argv[1], argv[2], argv[3], argv[4], + argv[5]); +} + +CAMLprim value caml_mm_audio_convert_s16(value _le, value _src, value _src_offs, + value _dst, value _dst_offs, + value _len) { + CAMLparam2(_src, _dst); + CAMLlocal1(dst); int little_endian = Bool_val(_le); const char *src = String_val(_src); - int offset = Int_val(_offset); + int src_offs = Int_val(_src_offs); + int dst_offs = Int_val(_dst_offs); 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 len = Int_val(_len); int i, c; - if ((offset + len) * nc * 2 > caml_string_length(_src)) + if (src_offs + 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(); + dst = Field(_dst, c); for (i = 0; i < len; i++) - dstc[i] = get_s16le(src, offset, nc, c, i); - caml_acquire_runtime_system(); + Store_double_field(dst, i + dst_offs, + get_s16le(src, src_offs, nc, c, i)); } else for (c = 0; c < nc; c++) { - dstc = (float *)Caml_ba_data_val(Field(_dst, c)); - caml_release_runtime_system(); + dst = Field(_dst, c); for (i = 0; i < len; i++) - dstc[i] = get_s16be(src, offset, nc, c, i); - caml_acquire_runtime_system(); + Store_double_field(dst, i + dst_offs, + get_s16be(src, src_offs, nc, c, i)); } CAMLreturn(Val_unit); } -CAMLprim value caml_mm_audio_to_u8(value a, value _dst, value _dst_offs) { - CAMLparam3(a, _dst, _dst_offs); +CAMLprim value caml_mm_audio_convert_s16_byte(value *argv, int argn) { + return caml_mm_audio_convert_s16(argv[0], argv[1], argv[2], argv[3], argv[4], + argv[5]); +} + +CAMLprim value caml_mm_audio_to_u8(value _src, value _src_offs, value _dst, + value _dst_offs, value _len) { + CAMLparam2(_src, _dst); + CAMLlocal1(src); int c, i; int dst_offs = Int_val(_dst_offs); - int nc = Wosize_val(a); + int src_offs = Int_val(_src_offs); + int nc = Wosize_val(_src); if (nc == 0) CAMLreturn(Val_unit); - int len = Caml_ba_array_val(Field(a, 0))->dim[0]; - float *src; + int len = Int_val(_len); uint8_t *dst = (uint8_t *)Bytes_val(_dst); if (caml_string_length(_dst) < nc * (dst_offs + len)) @@ -328,179 +341,118 @@ dst = dst + nc * dst_offs; for (c = 0; c < nc; c++) { - src = (float *)Caml_ba_data_val(Field(a, c)); - caml_release_runtime_system(); + src = Field(_src, c); for (i = 0; i < len; i++) { - dst[i * nc + c] = u8_clip(src[i]); + dst[i * nc + c + dst_offs] = u8_clip(Double_field(src, i + src_offs)); } - caml_acquire_runtime_system(); } CAMLreturn(Val_unit); } -CAMLprim value caml_mm_audio_of_u8(value _src, value _offset, value _dst) { - CAMLparam3(_src, _offset, _dst); +CAMLprim value caml_mm_audio_of_u8(value _src, value _src_offs, value _dst, + value _dst_offs, value _len) { + CAMLparam2(_src, _dst); + CAMLlocal1(dst); const char *src = String_val(_src); - int offset = Int_val(_offset); + int src_offs = Int_val(_src_offs); + int dst_offs = Int_val(_dst_offs); int nc = Wosize_val(_dst); if (nc == 0) CAMLreturn(Val_unit); - int len = Caml_ba_array_val(Field(_dst, 0))->dim[0]; + int len = Int_val(_len); assert(nc > 0); int i, c; - float *dstc; - if (len + offset > caml_string_length(_src)) + if (len + src_offs > 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(); + dst = Field(_dst, c); for (i = 0; i < len; i++) - dstc[i] = get_u8(src, offset, nc, c, i); - caml_acquire_runtime_system(); + Store_double_field(dst, i + dst_offs, get_u8(src, src_offs, nc, c, i)); } CAMLreturn(Val_unit); } -CAMLprim value caml_mm_audio_convert_s32le(value _src, value _offset, - value _dst) { - CAMLparam3(_src, _offset, _dst); +CAMLprim value caml_mm_audio_convert_s32le(value _src, value _src_offs, + value _dst, value _dst_offs, + value _len) { + CAMLparam2(_src, _dst); + CAMLlocal1(dst); const char *src = String_val(_src); - int offset = Int_val(_offset); + int src_offs = Int_val(_src_offs); + int dst_offs = Int_val(_dst_offs); int nc = Wosize_val(_dst); if (nc == 0) CAMLreturn(Val_unit); - int len = Caml_ba_array_val(Field(_dst, 0))->dim[0]; + int len = Int_val(_len); int i, c; - float *dstc; - if (caml_string_length(_src) < offset + len * nc * 4) + if (caml_string_length(_src) < src_offs + 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(); + dst = Field(_dst, c); for (i = 0; i < len; i++) - dstc[i] = get_s32le(src, offset, nc, c, i); - caml_acquire_runtime_system(); + Store_double_field(dst, i + dst_offs, get_s32le(src, src_offs, nc, c, i)); } CAMLreturn(Val_unit); } -CAMLprim value caml_mm_audio_convert_s24le(value _src, value _offset, - value _dst) { - CAMLparam3(_src, _offset, _dst); +CAMLprim value caml_mm_audio_convert_s24le(value _src, value _src_offs, + value _dst, value _dst_offs, + value _len) { + CAMLparam2(_src, _dst); + CAMLlocal1(dst); const char *src = String_val(_src); + int src_offs = Int_val(_src_offs); + int dst_offs = Int_val(_dst_offs); 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 len = Int_val(_len); int i, c; - float *dstc; - if (caml_string_length(_src) < offset + len * nc * 3) + if (caml_string_length(_src) < src_offs + 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(); + dst = Field(_dst, c); for (i = 0; i < len; i++) - dstc[i] = get_s24le(src, offset, nc, c, i); - caml_acquire_runtime_system(); + Store_double_field(dst, i + dst_offs, get_s24le(src, src_offs, nc, c, i)); } CAMLreturn(Val_unit); } -CAMLprim value caml_mm_audio_add(value _src, value _to_add) { - CAMLparam2(_src, _to_add); +CAMLprim value caml_mm_audio_copy_from_ba(value _src, value _dst, value _ofs, + value _len) { + CAMLparam2(_src, _dst); float *src = Caml_ba_data_val(_src); - float *to_add = Caml_ba_data_val(_to_add); - int len = Caml_ba_array_val(_src)->dim[0]; + int ofs = Int_val(_ofs); + int len = Int_val(_len); int i; - caml_release_runtime_system(); - for (i = 0; i < len; i++) - src[i] = src[i] + to_add[i]; - caml_acquire_runtime_system(); - - CAMLreturn(Val_unit); -} - -CAMLprim value caml_mm_audio_add_coef(value _src, double coef, value _to_add) { - CAMLparam2(_src, _to_add); - float *src = Caml_ba_data_val(_src); - float *to_add = Caml_ba_data_val(_to_add); - int len = Caml_ba_array_val(_src)->dim[0]; - int i; - - caml_release_runtime_system(); - for (i = 0; i < len; i++) - src[i] = src[i] + coef * to_add[i]; - caml_acquire_runtime_system(); - - CAMLreturn(Val_unit); -} - -CAMLprim value caml_mm_audio_add_coef_bytes(value _src, value _coef, - value _to_add) { - double coef = Double_val(_coef); - return caml_mm_audio_add_coef(_src, coef, _to_add); -} - -CAMLprim value caml_mm_audio_amplify(double coef, value _src) { - CAMLparam1(_src); - float *src = Caml_ba_data_val(_src); - int len = Caml_ba_array_val(_src)->dim[0]; - int i; - - caml_release_runtime_system(); - for (i = 0; i < len; i++) - src[i] = coef * src[i]; - caml_acquire_runtime_system(); - - CAMLreturn(Val_unit); -} + for (i = 0; i < len; i++) { + Store_double_field(_dst, i + ofs, src[i]); + } -CAMLprim value caml_mm_audio_amplify_bytes(value _coef, value _src) { - double coef = Double_val(_coef); - return caml_mm_audio_amplify(coef, _src); + CAMLreturn(_dst); } -CAMLprim value caml_mm_audio_clip(value _src) { - CAMLparam1(_src); - float *src = Caml_ba_data_val(_src); - int len = Caml_ba_array_val(_src)->dim[0]; - int i; - - caml_release_runtime_system(); - for (i = 0; i < len; i++) - src[i] = clip(src[i]); - caml_acquire_runtime_system(); +CAMLprim value caml_mm_audio_copy_to_ba(value _src, value _ofs, value _len, + value _dst) { + CAMLparam2(_src, _dst); + float *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); + } CAMLreturn(Val_unit); } - -CAMLprim double caml_mm_audio_squares(value _src) { - CAMLparam1(_src); - float *src = Caml_ba_data_val(_src); - int len = Caml_ba_array_val(_src)->dim[0]; - int i; - float square = 0; - - caml_release_runtime_system(); - for (i = 0; i < len; i++) - square += src[i] * src[i]; - caml_acquire_runtime_system(); - - CAMLreturn(square); -} - -CAMLprim value caml_mm_audio_squares_bytes(value _src) { - return caml_copy_double(caml_mm_audio_squares(_src)); -} diff -Nru ocaml-mm-0.7.5/src/audio.ml ocaml-mm-0.8.1/src/audio.ml --- ocaml-mm-0.7.5/src/audio.ml 2022-02-03 12:20:47.000000000 +0000 +++ ocaml-mm-0.8.1/src/audio.ml 2022-05-24 14:23:18.000000000 +0000 @@ -120,99 +120,125 @@ end module Mono = struct - type t = (float, Bigarray.float32_elt, Bigarray.c_layout) Bigarray.Array1.t + type t = float array 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 create = Array.create_float + let length = Array.length 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 + let clear data ofs len = Array.fill data ofs len 0. + let make n (x : float) = Array.make n x + let sub = Array.sub + let blit = Array.blit + + let copy src ofs len = + let dst = create len in + blit src ofs dst 0 len; + dst + + external copy_from_ba : + (float, Bigarray.float32_elt, Bigarray.c_layout) Bigarray.Array1.t -> + float array -> + int -> + int -> + unit = "caml_mm_audio_copy_from_ba" + + external copy_to_ba : + float array -> + int -> + int -> + (float, Bigarray.float32_elt, Bigarray.c_layout) Bigarray.Array1.t -> + unit = "caml_mm_audio_copy_to_ba" + + let of_ba buf = + let len = Bigarray.Array1.dim buf in + let dst = Array.create_float len in + copy_from_ba buf dst 0 len; + dst + + let to_ba buf ofs len = + let ba = Bigarray.Array1.create Bigarray.float32 Bigarray.c_layout len in + copy_to_ba buf ofs len ba; + ba + + let append b1 ofs1 len1 b2 ofs2 len2 = + assert (length b1 - ofs1 >= len1); + assert (length b2 - ofs2 >= len2); + let data = Array.create_float (len1 + len2) in + Array.blit b1 ofs1 data 0 len1; + Array.blit b2 ofs2 data len1 len2; + data + + let add b1 ofs1 b2 ofs2 len = + assert (length b1 - ofs1 >= len); + assert (length b2 - ofs2 >= len); for i = 0 to len - 1 do - unsafe_set buf i a.(i) - done; - buf + Array.unsafe_set b1 (ofs1 + i) + (Array.unsafe_get b1 (ofs1 + i) +. Array.unsafe_get b2 (ofs2 + i)) + done - 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 add_coeff b1 ofs1 k b2 ofs2 len = + assert (length b1 - ofs1 >= len); + assert (length b2 - ofs2 >= len); + for i = 0 to len - 1 do + Array.unsafe_set b1 (ofs1 + i) + (Array.unsafe_get b1 (ofs1 + i) +. (k *. Array.unsafe_get b2 (ofs2 + i))) + done - 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 - - external add : t -> t -> unit = "caml_mm_audio_add" - - let add b1 b2 = - let len = length b1 in - assert (length b2 = len); - add b1 b2 - - external add_coef : t -> (float[@unboxed]) -> t -> unit - = "caml_mm_audio_add_coef_bytes" "caml_mm_audio_add_coef" - - let add_coeff b1 k b2 = - let len = length b1 in - assert (length b2 = len); - add_coef b1 k b2 - - 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); + let add_coeff b1 ofs1 k b2 ofs2 len = + if k = 0. then () + else if k = 1. then add b1 ofs1 b2 ofs2 len + else add_coeff b1 ofs1 k b2 ofs2 len + + let mult b1 ofs1 b2 ofs2 len = + assert (length b1 - ofs1 >= len); + assert (length b2 - ofs2 >= len); for i = 0 to len - 1 do - b1.{i} <- b1.{i} *. b2.{i} + Array.unsafe_set b1 (ofs1 + i) + (Array.unsafe_get b1 (ofs1 + i) *. Array.unsafe_get b2 (ofs2 + i)) done - external amplify : (float[@unboxed]) -> t -> unit - = "caml_mm_audio_amplify_bytes" "caml_mm_audio_amplify" + let amplify c b ofs len = + assert (length b - ofs >= len); + for i = 0 to len - 1 do + Array.unsafe_set b (ofs + i) (Array.unsafe_get b (ofs + i) *. c) + done - external clip : t -> unit = "caml_mm_audio_clip" + let clip b ofs len = + assert (length b - ofs >= len); + for i = 0 to len - 1 do + 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) + done - external squares : t -> (float[@unboxed]) - = "caml_mm_audio_squares_bytes" "caml_mm_audio_squares" + let squares b ofs len = + assert (length b - ofs >= len); + let ret = ref 0. in + for i = 0 to len - 1 do + let s = Array.unsafe_get b (ofs + i) in + ret := !ret +. (s *. s) + done; + !ret - let noise buf = - for i = 0 to length buf - 1 do - buf.{i} <- Random.float 2. -. 1. + let noise b ofs len = + assert (length b - ofs >= len); + for i = 0 to len - 1 do + Array.unsafe_set b (ofs + 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) + let resample ?(mode = `Linear) ratio inbuf ofs len = + assert (length inbuf - ofs >= len); + if ratio = 1. then copy inbuf ofs len 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) + Array.unsafe_set outbuf i (Array.unsafe_get inbuf (ofs + pos)) done; outbuf) else ( @@ -222,11 +248,12 @@ 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) + Array.unsafe_set outbuf i (Array.unsafe_get inbuf (ofs + pos)) else ( let a = ir -. float pos in - outbuf.{i} <- (inbuf.{pos} *. (1. -. a)) +. (inbuf.{pos + 1} *. a)) + Array.unsafe_set outbuf i + ((Array.unsafe_get inbuf (ofs + pos) *. (1. -. a)) + +. (Array.unsafe_get inbuf (ofs + pos + 1) *. a))) done; outbuf) @@ -234,7 +261,7 @@ type t = buffer let create = create - let blit src soff dst doff len = blit (sub src soff len) (sub dst doff len) + let blit = blit end module Ringbuffer_ext = Ringbuffer.Make_ext (B) @@ -258,11 +285,10 @@ end module Analyze = struct - let rms buf = - let len = length buf in + let rms buf ofs len = let r = ref 0. in for i = 0 to len - 1 do - let x = buf.{i} in + let x = buf.(i + ofs) in r := !r +. (x *. x) done; sqrt (!r /. float len) @@ -290,9 +316,9 @@ let length f = f.n - let complex_create buf = - Array.init (buffer_length buf) (fun i -> - { Complex.re = buf.{i}; Complex.im = 0. }) + let complex_create buf ofs len = + Array.init len (fun i -> + { Complex.re = buf.(ofs + i); Complex.im = 0. }) let ccoef k c = { Complex.re = k *. c.Complex.re; Complex.im = k *. c.Complex.im } @@ -401,7 +427,7 @@ assert (len = length f); let bdur = float len /. float sr in let fdf = float (length f) in - let c = complex_create buf in + let c = complex_create buf 0 len in fft f c; let ans = ref [] in let kstart = max 0 (int_of_float (Note.freq note_min *. bdur)) in @@ -448,16 +474,17 @@ end module Effect = struct - let compand_mu_law mu buf = - for i = 0 to length buf - 1 do - let bufi = buf.{i} in + let compand_mu_law mu buf ofs len = + for i = 0 to len - 1 do + let bufi = buf.(i + ofs) in let sign = if bufi < 0. then -1. else 1. in - buf.{i} <- sign *. log (1. +. (mu *. abs_float bufi)) /. log (1. +. mu) + buf.(i + ofs) <- + sign *. log (1. +. (mu *. abs_float bufi)) /. log (1. +. mu) done class type t = object - method process : buffer -> unit + method process : buffer -> int -> int -> unit end class amplify k : t = @@ -467,9 +494,10 @@ 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))) + method process buf ofs len = + for i = 0 to len - 1 do + Array.unsafe_set buf (i + ofs) + (max (-.c) (min c (Array.unsafe_get buf (i + ofs)))) done end @@ -557,13 +585,13 @@ 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 + method process (buf : buffer) ofs len = + for i = 0 to len - 1 do + let x0 = buf.(i + ofs) in let y0 = (p0 *. x0) +. (p1 *. x1) +. (p2 *. x2) -. (q1 *. y1) -. (q2 *. y2) in - buf.{i} <- y0; + buf.(i + ofs) <- y0; x2 <- x1; x1 <- x0; y2 <- y1; @@ -588,49 +616,54 @@ let release (_, p) = (3, p) let dead (s, _) = s = 4 - let rec process adsr st (buf : buffer) = + let rec process adsr st (buf : buffer) ofs len = 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} + buf.(i + ofs) <- float (state_pos + i) /. fa *. buf.(i + ofs) 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))) + process adsr (1, 0) buf + (ofs + 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} + buf.(i + ofs) <- + (1. -. (float (state_pos + i) /. fd *. (1. -. s))) + *. buf.(i + ofs) 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))) + process adsr (2, 0) buf + (ofs + d - state_pos) + (len - (d - state_pos)) else - process adsr (3, 0) - (sub buf (d - state_pos) (len - (d - state_pos))) + process adsr (3, 0) buf + (ofs + d - state_pos) + (len - (d - state_pos)) | 2 -> - amplify s buf; + amplify s buf ofs len; 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} + buf.(i + ofs) <- + s *. (1. -. (float (state_pos + i) /. fr)) *. buf.(i + ofs) 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))) + process adsr (4, 0) buf + (ofs + r - state_pos) + (len - (r - state_pos)) | 4 -> - clear buf; + clear buf ofs len; st | _ -> assert false end @@ -643,8 +676,8 @@ object method set_volume : float -> unit method set_frequency : float -> unit - method fill : buffer -> unit - method fill_add : buffer -> unit + method fill : buffer -> int -> int -> unit + method fill_add : buffer -> int -> int -> unit method release : unit method dead : bool end @@ -664,23 +697,23 @@ method private volume : float = vol method set_volume v = vol <- v method set_frequency f = freq <- f - method virtual fill : buffer -> unit + method virtual fill : buffer -> int -> int -> 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 + method fill_add (buf : buffer) ofs len = + let tmp = create len in + self#fill tmp 0 len; + add buf ofs tmp 0 len end class white_noise ?volume sr = object (self) inherit base sr ?volume 0. - method fill buf = + method fill buf ofs len = let volume = self#volume in - for i = 0 to length buf - 1 do - buf.{i} <- volume *. (Random.float 2. -. 1.) + for i = 0 to len - 1 do + buf.(i + ofs) <- volume *. (Random.float 2. -. 1.) done end @@ -689,13 +722,12 @@ inherit base sr ?volume freq val mutable phase = phase - method fill buf = - let len = length buf in + method fill buf ofs len = 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) + buf.(i + ofs) <- volume *. sin ((float i *. omega) +. phase) done; phase <- mod_float (phase +. (float len *. omega)) (2. *. pi) end @@ -705,14 +737,13 @@ inherit base sr ?volume freq val mutable phase = phase - method fill buf = - let len = length buf in + method fill buf ofs len = 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) + buf.(i + ofs) <- (if t < 0.5 then volume else -.volume) done; phase <- mod_float (phase +. (float len *. omega)) 1. end @@ -722,14 +753,13 @@ inherit base sr ?volume freq val mutable phase = phase - method fill buf = - let len = length buf in + method fill buf ofs len = 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.) + buf.(i + ofs) <- volume *. ((2. *. t) -. 1.) done; phase <- mod_float (phase +. (float len *. omega)) 1. end @@ -739,14 +769,13 @@ inherit base sr ?volume freq val mutable phase = phase - method fill buf = - let len = length buf in + method fill buf ofs len = 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} <- + buf.(i + ofs) <- (volume *. if t < 0.5 then (4. *. t) -. 1. else (4. *. (1. -. t)) -. 1.) done; @@ -755,16 +784,16 @@ class chain (g : t) (e : Effect.t) : t = object - method fill buf = - g#fill buf; - e#process buf + method fill buf ofs len = + g#fill buf ofs len; + e#process buf ofs len 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 fill_add (buf : buffer) ofs len = + let tmpbuf = Buffer_ext.prepare tmpbuf len in + g#fill tmpbuf 0 len; + add buf ofs tmpbuf 0 len method set_volume = g#set_volume method set_frequency = g#set_frequency @@ -777,20 +806,19 @@ 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 buf ofs len = + g1#fill buf ofs len; + let tmpbuf = Buffer_ext.prepare tmpbuf len in + g2#fill tmpbuf 0 len; + f buf ofs tmpbuf 0 len - method fill_add buf = - let len = length buf in + method fill_add buf ofs len = let tmpbuf = Buffer_ext.prepare tmpbuf len in - g1#fill tmpbuf; + g1#fill tmpbuf 0 len; let tmpbuf2 = Buffer_ext.prepare tmpbuf2 len in - g2#fill tmpbuf2; - f tmpbuf tmpbuf2; - add buf tmpbuf + g2#fill tmpbuf2 0 len; + f tmpbuf 0 tmpbuf2 0 len; + add buf ofs tmpbuf 0 len method set_volume v = g1#set_volume v; @@ -824,15 +852,14 @@ 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 buf ofs len = + g#fill buf ofs len; + adsr_st <- Effect.ADSR.process adsr adsr_st buf ofs len - method fill_add buf = - let len = length buf in + method fill_add buf ofs len = let tmpbuf = Buffer_ext.prepare tmpbuf len in - self#fill tmpbuf; - blit tmpbuf buf + self#fill tmpbuf 0 len; + blit tmpbuf 0 buf ofs len method release = adsr_st <- Effect.ADSR.release adsr_st; @@ -849,176 +876,169 @@ 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 iter f data offset length = Array.iter (fun b -> f b offset length) data -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 channels data = Array.length data +let length = function [||] -> 0 | a -> Array.length a.(0) 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 +let interleave data length offset = + let chans = Array.length data in + let ibuf = Mono.create (chans * length) 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) + let bufc = data.(c) in + for i = 0 to length - 1 do + ibuf.((chans * i) + c) <- bufc.(offset + 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 +let deinterleave chans ibuf ofs len = + let len = len / chans in + let buf = create 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 bufc i - (Bigarray.Array1.unsafe_get ibuf ((chans * i) + c)) + bufc.(i) <- ibuf.((chans * i) + c + ofs) done done; buf -let append b1 b2 = Array.mapi (fun i b1 -> Mono.append b1 b2.(i)) b1 +let append b1 ofs1 len1 b2 ofs2 len2 = + Array.mapi (fun i b -> Mono.append b ofs1 len2 b2.(i) ofs2 len1) 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 squares = - Array.fold_left (fun squares buf -> squares +. Mono.squares buf) 0. +let copy b ofs len = + Array.init (Array.length b) (fun i -> Mono.copy b.(i) ofs len) + +let blit b1 ofs1 b2 ofs2 len = + Array.iteri (fun i b -> Mono.blit b ofs1 b2.(i) ofs2 len) b1 -let to_mono b = +let sub b ofs len = Array.map (fun b -> Array.sub b ofs len) b + +let squares data offset length = + Array.fold_left + (fun squares buf -> squares +. Mono.squares buf offset length) + 0. data + +let to_mono b ofs len = let channels = channels b in - if channels = 1 then b.(0) + if channels = 1 then Array.sub b.(0) ofs len else ( - let len = length b in let chans = float channels in let ans = Mono.create len in - Mono.clear ans; + Mono.clear ans 0 len; for i = 0 to len - 1 do for c = 0 to channels - 1 do - ans.{i} <- ans.{i} +. b.(c).{i} + ans.(i) <- ans.(i) +. b.(c).(i + ofs) done; - ans.{i} <- ans.{i} /. chans + 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 +let resample ?mode ratio data offset length = + Array.map (fun buf -> Mono.resample ?mode ratio buf offset length) data + +let copy_from_ba ba buf ofs len = + Array.iteri (fun i b -> Mono.copy_from_ba ba.(i) b ofs len) buf + +let copy_to_ba buf ofs len ba = + Array.iteri (fun i b -> Mono.copy_to_ba buf.(i) ofs len b) 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 module U8 = struct let size channels samples = channels * samples - external of_audio : buffer -> Bytes.t -> int -> unit = "caml_mm_audio_to_u8" - external to_audio : string -> int -> buffer -> unit = "caml_mm_audio_of_u8" + external of_audio : buffer -> int -> Bytes.t -> int -> int -> unit + = "caml_mm_audio_to_u8" + + external to_audio : string -> int -> buffer -> int -> int -> unit + = "caml_mm_audio_of_u8" end +external to_s16 : bool -> buffer -> int -> Bytes.t -> int -> int -> unit + = "caml_mm_audio_to_s16_byte" "caml_mm_audio_to_s16" + +external convert_s16 : bool -> string -> int -> buffer -> int -> int -> unit + = "caml_mm_audio_convert_s16_byte" "caml_mm_audio_convert_s16" + module S16LE = struct let size channels samples = channels * samples * 2 let length channels len = len / (2 * channels) + let of_audio = to_s16 true - external of_audio : bool -> buffer -> Bytes.t -> int -> unit - = "caml_mm_audio_to_s16" - - let of_audio = of_audio true - - let make buf = - let len = buffer_length buf in + let make buf ofs len = let slen = size (channels buf) len in let sbuf = Bytes.create slen in - of_audio buf sbuf 0; + of_audio buf ofs sbuf 0 len; Bytes.unsafe_to_string sbuf - external to_audio : bool -> string -> int -> buffer -> unit - = "caml_mm_audio_convert_s16" - - let to_audio = to_audio true + let to_audio = convert_s16 true end module S16BE = struct let size channels samples = channels * samples * 2 let length channels len = len / (2 * channels) + let of_audio = to_s16 false - external of_audio : bool -> buffer -> Bytes.t -> int -> unit - = "caml_mm_audio_to_s16" - - let of_audio = of_audio false - - let make buf = - let len = buffer_length buf in + let make buf ofs len = let slen = size (channels buf) len in let sbuf = Bytes.create slen in - of_audio buf sbuf 0; + of_audio buf ofs sbuf 0 len; Bytes.unsafe_to_string sbuf - external to_audio : bool -> string -> int -> buffer -> unit - = "caml_mm_audio_convert_s16" - - let to_audio = to_audio false + let to_audio = convert_s16 false end module S24LE = struct let size channels samples = channels * samples * 3 - external of_audio : buffer -> Bytes.t -> int -> unit + external of_audio : buffer -> int -> Bytes.t -> int -> int -> unit = "caml_mm_audio_to_s24le" - external to_audio : string -> int -> buffer -> unit + external to_audio : string -> int -> buffer -> int -> int -> unit = "caml_mm_audio_convert_s24le" end module S32LE = struct let size channels samples = channels * samples * 4 - external of_audio : buffer -> Bytes.t -> int -> unit + external of_audio : buffer -> int -> Bytes.t -> int -> int -> unit = "caml_mm_audio_to_s32le" - external to_audio : string -> int -> buffer -> unit + external to_audio : string -> int -> buffer -> int -> int -> unit = "caml_mm_audio_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 +let add b1 ofs1 b2 ofs2 len = + Array.iteri (fun i b -> Mono.add b ofs1 b2.(i) ofs2 len) b1 + +let add_coeff b1 ofs1 k b2 ofs2 len = + Array.iteri (fun i b -> Mono.add_coeff b ofs1 k b2.(i) ofs2 len) b1 + +let amplify k data offset length = + if k <> 1. then + Array.iter (fun data -> Mono.amplify k data offset length) data (* x between -1 and 1 *) -let pan x buf = +let pan x buf offset length = if x > 0. then ( let x = 1. -. x in - Mono.amplify x buf.(0)) + Mono.amplify x buf.(0) offset length) else if x < 0. then ( let x = 1. +. x in - Mono.amplify x buf.(1)) + Mono.amplify x buf.(1) offset length) (* TODO: we cannot share this with mono, right? *) module Buffer_ext = struct @@ -1041,7 +1061,6 @@ buf.buffer <- newbuf; newbuf) - let length buf = length buf.buffer let create chans len = { buffer = create chans len } end @@ -1089,9 +1108,9 @@ 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 + blit t.buffer t.rpos buf 0 pre; + blit t.buffer 0 buf pre extra) + else blit t.buffer t.rpos buf 0 len let read t buf = peek t buf; @@ -1103,9 +1122,9 @@ 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); + blit buf 0 t.buffer t.wpos pre; + blit buf pre t.buffer 0 extra) + else blit buf 0 t.buffer t.wpos len; write_advance t len let transmit t f = @@ -1157,29 +1176,30 @@ end module Analyze = struct - let rms buf = Array.init (channels buf) (fun i -> Mono.Analyze.rms buf.(i)) + let rms buf ofs len = + Array.init (channels buf) (fun i -> Mono.Analyze.rms buf.(i) ofs len) end module Effect = struct class type t = object - method process : buffer -> unit + method process : buffer -> int -> int -> unit end class chain (e1 : t) (e2 : t) = object - method process buf = - e1#process buf; - e2#process buf + method process buf ofs len = + e1#process buf ofs len; + e2#process buf ofs len end class of_mono chans (g : unit -> Mono.Effect.t) = object val g = Array.init chans (fun _ -> g ()) - method process buf = + method process buf ofs len = for c = 0 to chans - 1 do - g.(c)#process buf.(c) + g.(c)#process buf.(c) ofs len done end @@ -1205,9 +1225,9 @@ 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 + method process buf ofs len = + Ringbuffer_ext.write rb (sub buf ofs len); + Ringbuffer_ext.read rb (sub buf ofs len) end class delay chans sample_rate delay once feedback = @@ -1220,23 +1240,18 @@ val rb = Ringbuffer_ext.create chans 0 val tmpbuf = Buffer_ext.create chans 0 - method process buf = + method process buf ofs len = 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)); + if len > delay then add_coeff buf delay feedback buf ofs (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); + add_coeff buf 0 feedback tmpbuf 0 rlen; if not once then Ringbuffer_ext.write rb buf end @@ -1257,11 +1272,11 @@ d1#set_feedback f; d2#set_feedback f - method process buf = + method process buf ofs len = assert (channels buf = 2); (* Add original on channel 0. *) - d1'#process [| buf.(0) |]; - d2#process [| buf.(1) |] + d1'#process [| buf.(0) |] ofs len; + d2#process [| buf.(1) |] ofs len end let delay chans sample_rate d ?(once = false) ?(ping_pong = false) feedback = @@ -1308,7 +1323,7 @@ (* Current gain. *) val mutable g = 1. - method process (buf : buffer) = + method process (buf : buffer) ofs len = let ratio = (ratio -. 1.) /. ratio in (* Attack and release "per sample decay". *) @@ -1324,12 +1339,12 @@ (* 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 + for i = 0 to len - 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 + let x = buf.(c).(i + ofs) *. gain in ans := !ans +. (x *. x) done; !ans /. float chans @@ -1366,7 +1381,7 @@ (* Apply the gain. *) let g = g *. gain in for c = 0 to chans - 1 do - buf.(c).{i} <- buf.(c).{i} *. g + buf.(c).(i + ofs) <- buf.(c).(i + ofs) *. g done (* (* Debug messages. *) @@ -1417,11 +1432,11 @@ (** Is it enabled? (disabled if below the threshold) *) val mutable enabled = true - method process (buf : buffer) = + method process (buf : buffer) ofs len = 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 + for i = 0 to len - 1 do + let bufci = bufc.(ofs + i) in if rms_collected >= rms_len then ( let rms_cur = let ans = ref 0. in @@ -1443,7 +1458,7 @@ rms.(c) <- rms.(c) +. (bufci *. bufci); rms_collected <- rms_collected + 1; (* Affine transition between vol_old and vol. *) - bufc.{i} <- + bufc.(i) <- (vol_old +. (float rms_collected /. rms_lenf *. (vol -. vol_old))) *. bufci done @@ -1468,9 +1483,9 @@ end module Generator = struct - let white_noise buf = + let white_noise buf ofs len = for c = 0 to channels buf - 1 do - Mono.Generator.white_noise buf.(c) + Mono.Generator.white_noise buf.(c) ofs len done class type t = @@ -1479,8 +1494,8 @@ method set_frequency : float -> unit method release : unit method dead : bool - method fill : buffer -> unit - method fill_add : buffer -> unit + method fill : buffer -> int -> int -> unit + method fill_add : buffer -> int -> int -> unit end class of_mono (g : Mono.Generator.t) = @@ -1489,18 +1504,17 @@ method set_volume = g#set_volume method set_frequency = g#set_frequency - method fill buf = - g#fill buf.(0); + method fill buf ofs len = + g#fill buf.(0) ofs len; for c = 1 to channels buf - 1 do - Mono.blit buf.(0) buf.(c) + Mono.blit buf.(0) ofs buf.(c) ofs len done - method fill_add (buf : buffer) = - let len = length buf in + method fill_add (buf : buffer) ofs len = let tmpbuf = Mono.Buffer_ext.prepare tmpbuf len in - g#fill tmpbuf; + g#fill tmpbuf 0 len; for c = 0 to channels buf - 1 do - Mono.add buf.(c) tmpbuf + Mono.add buf.(c) ofs tmpbuf 0 len done method release = g#release @@ -1509,18 +1523,16 @@ class chain (g : t) (e : Effect.t) : t = object - method fill buf = - g#fill buf; - e#process buf + method fill buf ofs len = + g#fill buf ofs len; + e#process buf ofs len 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 fill_add buf ofs len = + let tmpbuf = Buffer_ext.prepare tmpbuf ~channels:(channels buf) len in + g#fill tmpbuf 0 len; + add buf ofs tmpbuf 0 len method set_volume = g#set_volume method set_frequency = g#set_frequency @@ -1543,7 +1555,7 @@ method duration : float method seek : int -> unit method close : unit - method read : buffer -> int + method read : buffer -> int -> int -> int end class virtual base = @@ -1613,16 +1625,15 @@ bytes_per_sample <- sample_size / 8 * channels; length <- len_dat / bytes_per_sample - method read (buf : buffer) = - let len = buffer_length buf in + method read (buf : buffer) ofs len = 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 + | 16 -> S16LE.to_audio sbuf 0 buf ofs len + | 8 -> U8.to_audio sbuf 0 buf ofs len | _ -> assert false end; len @@ -1645,7 +1656,7 @@ module Writer = struct class type t = object - method write : buffer -> unit + method write : buffer -> int -> int -> unit method close : unit end @@ -1670,6 +1681,7 @@ self#output "RIFF"; self#output_int 0; self#output "WAVE"; + (* Format *) self#output "fmt "; self#output_int 16; @@ -1679,6 +1691,7 @@ 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 *) @@ -1687,8 +1700,8 @@ val mutable datalen = 0 - method write buf = - let s = S16LE.make buf in + method write buf ofs len = + let s = S16LE.make buf ofs len in self#output s; datalen <- datalen + String.length s @@ -1711,8 +1724,8 @@ module RW = struct class type t = object - method read : buffer -> unit - method write : buffer -> unit + method read : buffer -> int -> int -> unit + method write : buffer -> int -> int -> unit method close : unit end diff -Nru ocaml-mm-0.7.5/src/audio.mli ocaml-mm-0.8.1/src/audio.mli --- ocaml-mm-0.7.5/src/audio.mli 2022-02-03 12:20:47.000000000 +0000 +++ ocaml-mm-0.8.1/src/audio.mli 2022-05-24 14:23:18.000000000 +0000 @@ -79,39 +79,60 @@ (** 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 t = float array 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 + val blit : t -> int -> t -> int -> int -> unit + val copy : t -> int -> int -> t + + val copy_to_ba : + t -> + int -> + int -> + (float, Bigarray.float32_elt, Bigarray.c_layout) Bigarray.Array1.t -> + unit + + val copy_from_ba : + (float, Bigarray.float32_elt, Bigarray.c_layout) Bigarray.Array1.t -> + t -> + int -> + int -> + unit + + val of_ba : + (float, Bigarray.float32_elt, Bigarray.c_layout) Bigarray.Array1.t -> t + + val to_ba : + t -> + int -> + int -> + (float, Bigarray.float32_elt, Bigarray.c_layout) Bigarray.Array1.t (** Length in samples. *) val length : t -> int - val append : t -> t -> t + val append : t -> int -> int -> t -> int -> int -> t (** Clear a portion of a buffer (fill it with zeroes). *) - val clear : t -> unit + val clear : t -> int -> int -> unit - val amplify : float -> t -> unit - val resample : ?mode:[ `Nearest | `Linear ] -> float -> t -> t - val clip : t -> unit - val noise : t -> unit - val squares : t -> float + val amplify : float -> t -> int -> int -> unit + val resample : ?mode:[ `Nearest | `Linear ] -> float -> t -> int -> int -> t + val clip : t -> int -> int -> unit + val noise : t -> int -> int -> unit + val squares : t -> int -> int -> float - (** Samplewise add two buffers of the same length, storing the result in the + (** Samplewise add two buffers, storing the result in the first one. *) - val add : t -> t -> unit + val add : t -> int -> t -> int -> int -> unit (** Samplewise multiply two buffers of the same length, storing the result in the first one. *) - val mult : t -> t -> unit + val mult : t -> int -> t -> int -> int -> unit module Ringbuffer_ext : Ringbuffer.R with type buffer = t module Ringbuffer : Ringbuffer.R with type buffer = t @@ -129,7 +150,7 @@ (** Functions for analyzing audio data. *) module Analyze : sig (** Compute the RMS power of a portion of a buffer. *) - val rms : t -> float + val rms : t -> int -> int -> float (** Simple implementation of the FFT algorithm. For fastest implementations optimized libraries such as fftw are recommended. *) @@ -143,9 +164,9 @@ (** 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 + (** [complex_create buf off len] create a array of complex numbers by + copying data from [buf] (the imaginary part is null). *) + val complex_create : buffer -> int -> int -> Complex.t array (** Perform an FFT analysis. *) val fft : t -> Complex.t array -> unit @@ -186,11 +207,11 @@ module Effect : sig (** A compander following the mu-law (see http://en.wikipedia.org/wiki/Mu-law).*) - val compand_mu_law : float -> t -> unit + val compand_mu_law : float -> t -> int -> int -> unit class type t = object - method process : buffer -> unit + method process : buffer -> int -> int -> unit end class amplify : float -> t @@ -230,7 +251,7 @@ val release : state -> state val dead : state -> bool - val process : t -> state -> buffer -> state + val process : t -> state -> buffer -> int -> int -> state end end @@ -243,10 +264,10 @@ method set_frequency : float -> unit (** Fill a buffer with generated sound. *) - method fill : buffer -> unit + method fill : buffer -> int -> int -> unit (** Same as [fill] but adds the sound to the buffer. *) - method fill_add : buffer -> unit + method fill_add : buffer -> int -> int -> unit (** Release the generator (used for generator with envelopes). *) method release : unit @@ -279,7 +300,7 @@ end (** An audio buffer. *) -type t = Mono.t array +type t = float array array type buffer = t @@ -288,91 +309,109 @@ 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 + +(** Length in samples. *) +val length : t -> int (** 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 +val clear : t -> int -> int -> unit (** Copy the given buffer. *) -val copy : t -> t +val copy : t -> int -> int -> t -val append : t -> t -> t +val append : t -> int -> int -> t -> int -> int -> 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 +val to_mono : t -> int -> int -> 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 +val interleave : t -> int -> int -> Mono.t +val deinterleave : int -> Mono.t -> int -> int -> t module U8 : sig val size : int -> int -> int - val of_audio : t -> Bytes.t -> int -> unit - val to_audio : string -> int -> t -> unit + val of_audio : t -> int -> Bytes.t -> int -> int -> unit + val to_audio : string -> int -> t -> int -> int -> 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 + val of_audio : t -> int -> Bytes.t -> int -> int -> unit + val make : t -> int -> int -> string + val to_audio : string -> int -> t -> int -> int -> 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 + val of_audio : t -> int -> Bytes.t -> int -> int -> unit + val make : t -> int -> int -> string + val to_audio : string -> int -> t -> int -> int -> 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 + val of_audio : t -> int -> Bytes.t -> int -> int -> unit + val to_audio : string -> int -> t -> int -> int -> 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 + val of_audio : t -> int -> Bytes.t -> int -> int -> unit + val to_audio : string -> int -> t -> int -> int -> unit end -val resample : ?mode:[ `Nearest | `Linear ] -> float -> t -> t -val blit : t -> t -> unit +val resample : ?mode:[ `Nearest | `Linear ] -> float -> t -> int -> int -> t +val blit : t -> int -> t -> int -> int -> unit val sub : t -> int -> int -> t -val clip : t -> unit -val noise : t -> unit -val squares : t -> float +val clip : t -> int -> int -> unit +val noise : t -> int -> int -> unit +val squares : t -> int -> int -> float + +val copy_to_ba : + t -> + int -> + int -> + (float, Bigarray.float32_elt, Bigarray.c_layout) Bigarray.Array1.t array -> + unit + +val copy_from_ba : + (float, Bigarray.float32_elt, Bigarray.c_layout) Bigarray.Array1.t array -> + t -> + int -> + int -> + unit + +val of_ba : + (float, Bigarray.float32_elt, Bigarray.c_layout) Bigarray.Array1.t array -> t + +val to_ba : + t -> + int -> + int -> + (float, Bigarray.float32_elt, Bigarray.c_layout) Bigarray.Array1.t array (** Amplify a portion of the buffer by a given coefficient. *) -val amplify : float -> t -> unit +val amplify : float -> t -> int -> int -> 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 pan : float -> t -> int -> int -> unit (** Add two buffers of the same length, storing the result in the first one. *) -val add : t -> t -> unit +val add : t -> int -> t -> int -> int -> unit (** Add to the first buffer, the second buffer multiplied by a coefficient. *) -val add_coeff : t -> float -> t -> unit +val add_coeff : t -> int -> float -> t -> int -> int -> unit (** Buffers of variable size. These are particularly useful for temporary buffers. *) @@ -383,9 +422,6 @@ 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 @@ -425,7 +461,7 @@ end module Analyze : sig - val rms : t -> float array + val rms : t -> int -> int -> float array end (** Audio effects. *) @@ -434,7 +470,7 @@ class type t = object (** Apply the effect on a buffer. *) - method process : buffer -> unit + method process : buffer -> int -> int -> unit end class chain : t -> t -> t @@ -514,14 +550,14 @@ (** Sound generators. *) module Generator : sig - val white_noise : t -> unit + val white_noise : t -> int -> int -> 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 fill : buffer -> int -> int -> unit + method fill_add : buffer -> int -> int -> unit method release : unit method dead : bool end @@ -565,7 +601,7 @@ called. *) method close : unit - method read : buffer -> int + method read : buffer -> int -> int -> int end (** Create a reader object from a wav file. *) @@ -575,7 +611,7 @@ module Writer : sig class type t = object - method write : buffer -> unit + method write : buffer -> int -> int -> unit method close : unit end @@ -587,8 +623,8 @@ module RW : sig class type t = object - method read : buffer -> unit - method write : buffer -> unit + method read : buffer -> int -> int -> unit + method write : buffer -> int -> int -> unit method close : unit end diff -Nru ocaml-mm-0.7.5/src/config/endianess.c ocaml-mm-0.8.1/src/config/endianess.c --- ocaml-mm-0.7.5/src/config/endianess.c 2022-02-03 12:20:47.000000000 +0000 +++ ocaml-mm-0.8.1/src/config/endianess.c 2022-05-24 14:23:18.000000000 +0000 @@ -1,14 +1,15 @@ #include #include -enum -{ - OCAML_MM_LITTLE_ENDIAN = 0x0100, - OCAML_MM_BIG_ENDIAN = 0x0001, +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 } }; +static const union { + unsigned char bytes[2]; + uint16_t value; +} host_order = {{0, 1}}; CAMLprim value ocaml_mm_is_big_endian(value unit) { CAMLparam0(); diff -Nru ocaml-mm-0.7.5/src/config/endianess_setup.c ocaml-mm-0.8.1/src/config/endianess_setup.c --- ocaml-mm-0.7.5/src/config/endianess_setup.c 2022-02-03 12:20:47.000000000 +0000 +++ ocaml-mm-0.8.1/src/config/endianess_setup.c 2022-05-24 14:23:18.000000000 +0000 @@ -1,14 +1,15 @@ #include #include -enum -{ - OCAML_MM_LITTLE_ENDIAN = 0x0100, - OCAML_MM_BIG_ENDIAN = 0x0001, +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 } }; +static const union { + unsigned char bytes[2]; + uint16_t value; +} host_order = {{0, 1}}; CAMLprim value ocaml_mm_is_big_endian(value unit) { CAMLparam0(); diff -Nru ocaml-mm-0.7.5/src/dune ocaml-mm-0.8.1/src/dune --- ocaml-mm-0.7.5/src/dune 2022-02-03 12:20:47.000000000 +0000 +++ ocaml-mm-0.8.1/src/dune 2022-05-24 14:23:18.000000000 +0000 @@ -9,7 +9,7 @@ (library (name mm_audio) (public_name mm.audio) - (libraries bigarray mm.base) + (libraries mm.base) (modules audio) (foreign_stubs (extra_deps config.h) @@ -21,8 +21,16 @@ (library (name mm_image) (public_name mm.image) - (libraries bigarray) - (modules image) + (libraries unix) + (modules + imageBase + imageBitmap + imageBGRA + imageRGBA32 + imageYUV420 + imageGeneric + imageCanvas + image) (foreign_stubs (extra_deps config.h) (language c) @@ -33,7 +41,7 @@ (library (name mm_video) (public_name mm.video) - (libraries mm.base mm.image) + (libraries mm.base mm.image mm.audio) (modules video) (synopsis "High-level APIs to create and manipulate multimedia streams -- video module")) @@ -42,7 +50,7 @@ (name mm_midi) (public_name mm.midi) (libraries mm.base mm.audio) - (modules mIDI synth) + (modules MIDI synth) (synopsis "High-level APIs to create and manipulate multimedia streams -- midi module")) diff -Nru ocaml-mm-0.7.5/src/imageBase.ml ocaml-mm-0.8.1/src/imageBase.ml --- ocaml-mm-0.7.5/src/imageBase.ml 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-mm-0.8.1/src/imageBase.ml 2022-05-24 14:23:18.000000000 +0000 @@ -0,0 +1,206 @@ +(* + * 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 List = struct + include List + + let rec iter_right f = function + | x :: l -> + iter_right f l; + f x + | [] -> () +end + +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 + + (** [aligned k n] allocates [n] bytes at a multiple of [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 + + module RGBA = struct + type t = RGBA + + 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" + external rgb_of_yuv : yuv -> rgb = "caml_rgb_of_yuv" +end + +module Point = struct + type t = int * int + + let min (x, y) (x', y') = (min x x', min y y') + let max (x, y) (x', y') = (max x x', max y y') + let lt (x, y) (x', y') = x < x' && y < y' + let le (x, y) (x', y') = x <= x' && y <= y' + let neg (x, y) = (-x, -y) +end + +module Fraction = struct + type t = int * int + + let min (a, b) (a', b') = if a * b' < a' * b then (a, b) else (a', b') +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 diff -Nru ocaml-mm-0.7.5/src/imageBGRA.ml ocaml-mm-0.8.1/src/imageBGRA.ml --- ocaml-mm-0.7.5/src/imageBGRA.ml 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-mm-0.8.1/src/imageBGRA.ml 2022-05-24 14:23:18.000000000 +0000 @@ -0,0 +1,48 @@ +(* + * 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 ImageBase + +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 diff -Nru ocaml-mm-0.7.5/src/imageBitmap.ml ocaml-mm-0.8.1/src/imageBitmap.ml --- ocaml-mm-0.7.5/src/imageBitmap.ml 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-mm-0.8.1/src/imageBitmap.ml 2022-05-24 14:23:18.000000000 +0000 @@ -0,0 +1,202 @@ +(* + * 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. + * + *) + +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 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 = + for j = 0 to height img - 1 do + for i = 0 to width img - 1 do + set_pixel img i j (f i j) + done + done + +let scale src tgt = + let ws = width src in + let wt = width tgt in + let hs = height src in + let ht = height tgt in + fill tgt (fun i j -> get_pixel src (i * ws / wt) (j * hs / ht)) + +let rescale p q img = + let img2 = create (width img * p / q) (height img * p / q) in + scale img img2; + img2 + +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 + for i = 0 to width - 1 do + set_pixel dst (x + i) (y + j) (get_pixel src i j) + done + done + +(** Bitmap fonts. *) +module Font = struct + 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; + } + + let height font = font.height + + (** Our native font. *) + let native : t = + let prebitmap = + [ + ('A', [| " * "; "* *"; "***"; "* *"; "* *" |]); + ('B', [| "** "; "* *"; "** "; "* *"; "** " |]); + ('C', [| " **"; "* "; "* "; "* "; " **" |]); + ('D', [| "** "; "* *"; "* *"; "* *"; "** " |]); + ('E', [| "***"; "* "; "** "; "* "; "***" |]); + ('F', [| "***"; "* "; "** "; "* "; "* " |]); + ('G', [| " **"; "* "; "* *"; "* *"; " **" |]); + ('H', [| "* *"; "* *"; "***"; "* *"; "* *" |]); + ('I', [| " * "; " * "; " * "; " * "; " * " |]); + ('J', [| " *"; " *"; " *"; "* *"; " * " |]); + ('K', [| "* *"; "** "; "* "; "** "; "* *" |]); + ('L', [| "* "; "* "; "* "; "* "; "***" |]); + ('M', [| "* *"; "***"; "* *"; "* *"; "* *" |]); + ('N', [| "* *"; "***"; "***"; "***"; "* *" |]); + ('O', [| " * "; "* *"; "* *"; "* *"; " * " |]); + ('P', [| "** "; "* *"; "** "; "* "; "* " |]); + ('Q', [| " * "; "* *"; "* *"; "* *"; " **" |]); + ('R', [| "** "; "* *"; "** "; "* *"; "* *" |]); + ('S', [| " **"; "* "; " * "; " *"; "** " |]); + ('T', [| "***"; " * "; " * "; " * "; " * " |]); + ('U', [| "* *"; "* *"; "* *"; "* *"; "***" |]); + ('V', [| "* *"; "* *"; "* *"; "* *"; " * " |]); + ('W', [| "* *"; "* *"; "* *"; "***"; "* *" |]); + ('X', [| "* *"; "* *"; " * "; "* *"; "* *" |]); + ('Y', [| "* *"; "* *"; " * "; " * "; " * " |]); + ('Z', [| "***"; " *"; " * "; "* "; "***" |]); + ('0', [| " * "; "* *"; "* *"; "* *"; " * " |]); + ('1', [| " * "; "** "; " * "; " * "; " * " |]); + ('2', [| " * "; "* *"; " *"; " * "; "***" |]); + ('3', [| "** "; " *"; " * "; " *"; "** " |]); + ('4', [| " *"; " **"; "***"; " *"; " *" |]); + ('5', [| "***"; "* "; "** "; " *"; "** " |]); + ('6', [| " **"; "* "; "** "; "* *"; " * " |]); + ('7', [| "***"; " *"; " * "; " * "; " * " |]); + ('8', [| " * "; "* *"; " * "; "* *"; " * " |]); + ('9', [| " * "; "* *"; " **"; " *"; " * " |]); + (' ', [| " "; " "; " "; " "; " " |]); + ('.', [| " "; " "; " "; " "; " * " |]); + (',', [| " "; " "; " "; " * "; " * " |]); + ('!', [| " * "; " * "; " * "; " "; " * " |]); + ('?', [| " * "; "* *"; " **"; " * "; " * " |]); + ('-', [| " "; " "; "***"; " "; " " |]); + ('+', [| " "; " * "; "***"; " * "; " " |]); + ('=', [| " "; "***"; " "; "***"; " " |]); + (':', [| " "; " * "; " "; " * "; " " |]); + ('<', [| " *"; " * "; "* "; " * "; " *" |]); + ('>', [| "* "; " * "; " *"; " * "; "* " |]); + ] + in + 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 + ) + in + let default = create_white width height in + { map; width; height; default; uppercase = true; char_space = 1; line_space = 2 } + + 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) + else incr cur + done; + max := Stdlib.max !max !cur; + !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 = max width 0 in + let height = max height 0 in + create width height + in + let xoff = ref 0 in + 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 + 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 + blit c ~x:!xoff ~y:!yoff img; + xoff := !xoff + font.width + font.char_space + done; + rescale height font.height img +end diff -Nru ocaml-mm-0.7.5/src/imageCanvas.ml ocaml-mm-0.8.1/src/imageCanvas.ml --- ocaml-mm-0.7.5/src/imageCanvas.ml 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-mm-0.8.1/src/imageCanvas.ml 2022-05-24 14:23:18.000000000 +0000 @@ -0,0 +1,197 @@ +(* + * 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 ImageBase + +module type CanvasImage = sig + type t + + val width : t -> int + val height : t -> int + val size : t -> int + val create : int -> int -> t + val blank : t -> unit + val copy : t -> t + val add : t -> ?x:int -> ?y:int -> t -> unit + val has_alpha : t -> bool + val fill_alpha : t -> int -> unit + val set_pixel_rgba : t -> int -> int -> Pixel.rgba -> unit + val randomize : t -> unit + val scale : t -> t -> unit +end + +(** A canvas of images. The structure is immutable but its elements might be + returned and therefore should not be used in place. *) +module Canvas (I : CanvasImage) = struct + module Element = struct + type t = Image of (int * int) * I.t (** An image at given offset. *) + + let size = function Image (_, img) -> I.size img + + let translate dx dy = function + | Image ((x, y), img) -> Image ((x + dx, y + dy), img) + end + + module E = Element + + type t = { width : int; height : int; elements : E.t list } + + let create width height = { width; height; elements = [] } + 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 make ?width ?height ?(x = 0) ?(y = 0) image = + let width = Option.value ~default:(I.width image) width in + let height = Option.value ~default:(I.height image) height in + { width; height; elements = [E.Image ((x, y), image)] } + + let add c c' = + (* assert ((c.width < 0 || c.width = c'.width) && (c.height < 0 || c.height = c'.height)); *) + { + width = c'.width; + height = c'.height; + elements = c.elements @ c'.elements; + } + + (* TODO: improve precision with something like this: + https://stackoverflow.com/questions/2628118/rectangles-covering *) + let covering c = + let width = width c in + let height = height c in + let covering_element = function + | E.Image ((x, y), img) -> + let w = I.width img in + let h = I.height img in + x <= 0 && y <= 0 + && x + w >= width + && y + h >= height + && not (I.has_alpha img) + in + List.exists covering_element c.elements + + let render ?(fresh = false) ?(transparent = true) c = + assert (width c >= 0 && height c >= 0); + match c.elements with + | [Image ((0, 0), img)] + when (not fresh) && I.width img = width c && I.height img = height c -> + img + | elements -> + let r = I.create (width c) (height c) in + if not (covering c) then ( + I.blank r; + if transparent then I.fill_alpha r 0); + let add = function E.Image ((x, y), img) -> I.add img ~x ~y r in + List.iter_right add elements; + r + + let rendered ?transparent c = make (render ?transparent c) + let map f c = make (f (render c)) + + let iter f c = + let img = render ~fresh:true c in + f img; + make img + + let translate dx dy c = + if dx = 0 && dy = 0 then c + else { c with elements = List.map (E.translate dx dy) c.elements } + + let viewport ?(x = 0) ?(y = 0) width height c = + translate (-x) (-y) { c with width; height } + + let bounding_box c = + let p = (width c, height c) in + let d = (0, 0) in + List.fold_left + (fun (p, d) -> function + | E.Image ((x, y), img) -> + (Point.min p (x, y), Point.max d (I.width img, I.height img))) + (p, d) c.elements + + let scale ?(scaler = I.scale) (nx, dx) (ny, dy) c = + if nx = dx && ny = dy then c + else ( + let elements = + List.map + (function + | E.Image ((x, y), img) -> + let scl = + I.create (I.width img * nx / dx) (I.height img * ny / dy) + in + scaler img scl; + E.Image ((x * nx / dx, y * ny / dy), scl)) + c.elements + in + { width = c.width; height = c.height; elements }) + + let resize ?(proportional = true) ?scaler w' h' img = + let w = width img in + let h = height img in + let (nx, dx), (ny, dy) = + if proportional then ( + let f = Fraction.min (w', w) (h', h) in + (f, f)) + 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) + in + scale ?scaler (nx, dx) (ny, dy) img |> translate x y |> viewport w' h' + + module Draw = struct + let line color (x1, y1) (x2, y2) = + let dx = min x1 x2 in + let dy = min y1 y2 in + let w = abs (x2 - x1) in + let h = abs (y2 - y1) in + let buf = I.create w h in + I.blank buf; + I.fill_alpha buf 0; + Draw.line + (fun i j -> + if 0 <= i && i < w && 0 <= j && j < h then + I.set_pixel_rgba buf i j color) + (x1 - dx, y1 - dy) + (x2 - dx, y2 - dy); + make ~x:dx ~y:dy ~width:(-1) ~height:(-1) buf + end +end + +module CanvasYUV420 = Canvas (struct + include ImageYUV420 + + let create w h = create w h + let scale = scale ~proportional:false +end) diff -Nru ocaml-mm-0.7.5/src/imageGeneric.ml ocaml-mm-0.8.1/src/imageGeneric.ml --- ocaml-mm-0.7.5/src/imageGeneric.ml 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-mm-0.8.1/src/imageGeneric.ml 2022-05-24 14:23:18.000000000 +0000 @@ -0,0 +1,226 @@ +(* + * 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 RGBA32 = ImageRGBA32 +module YUV420 = ImageYUV420 + +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 diff -Nru ocaml-mm-0.7.5/src/image.ml ocaml-mm-0.8.1/src/image.ml --- ocaml-mm-0.7.5/src/image.ml 2022-02-03 12:20:47.000000000 +0000 +++ ocaml-mm-0.8.1/src/image.ml 2022-05-24 14:23:18.000000000 +0000 @@ -31,930 +31,10 @@ * *) -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 - - (** [aligned k n] allocates [n] bytes at a multiple of [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 - - (* Default alignment. *) - let align = Sys.word_size / 8 - - let default_stride width y_stride uv_stride = - 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 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 + 1) / 2) in - ( Data.aligned align (height * uv_stride), - Data.aligned align (height * 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 - - (** [scale_coef src dst (xn,xd) (yn,yd)] scales [src] into [dst] multiplying x - dimension by xn/xd and y dimension by yn/yd. *) - 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 - - external alpha_of_color : t -> int -> int -> int -> int -> unit = "caml_yuv_alpha_of_color" - - let alpha_of_color img (y,u,v) d = - ensure_alpha img; - alpha_of_color img y u v d - - 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 +include ImageBase +module Bitmap = ImageBitmap +module BGRA = ImageBGRA +module RGBA32 = ImageRGBA32 +module YUV420 = ImageYUV420 +module Generic = ImageGeneric +include ImageCanvas diff -Nru ocaml-mm-0.7.5/src/image.mli ocaml-mm-0.8.1/src/image.mli --- ocaml-mm-0.7.5/src/image.mli 2022-02-03 12:20:47.000000000 +0000 +++ ocaml-mm-0.8.1/src/image.mli 2022-05-24 14:23:18.000000000 +0000 @@ -60,10 +60,62 @@ val rgb_of_yuv : yuv -> rgb end +module Point : sig + type t = int * int + + val min : t -> t -> t + val max : t -> t -> t + val lt : t -> t -> bool + val le : t -> t -> bool + val neg : t -> t +end + +module Fraction : sig + type t = int * int + + val min : t -> t -> t +end + module Draw : sig val line : (int -> int -> unit) -> int * int -> int * int -> unit end +(** Operation on bitmaps, which are black and white images. *) +module Bitmap : sig + (** A bitmap. *) + type t + + 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. *) + module Font : sig + (** A font. *) + type t + + (** Our native font. *) + val native : t + + (** Height in pixels of characters. *) + val height : t -> int + + (** Render text with given font, at given size (height of characters in + pixels). *) + val render : ?font:t -> ?size:int -> string -> bitmap + end +end + (** Operations on images stored in RGB8 format, ie RGB channels, one byte each. *) module RGB8 : sig (** Operations on colors. *) @@ -213,11 +265,16 @@ (** 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 + type t = ImageYUV420.t + + (** Create an image with given width, height, alpha channel, Y (with given + stride) U and V (with given stride). The strides of U and V are the same, + the stride of the alpha channel is the same as Y. *) + val make : + int -> int -> ?alpha:Data.t -> Data.t -> int -> Data.t -> Data.t -> int -> 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 + val create : ?blank:bool -> ?y_stride:int -> ?uv_stride:int -> int -> int -> t (** Ensure that the image has an alpha channel. *) val ensure_alpha : t -> unit @@ -230,6 +287,8 @@ val of_RGB24_string : string -> int -> t val of_RGBA32 : RGBA32.t -> t val to_RGBA32 : t -> RGBA32.t + val of_bitmap : ?fg:Pixel.rgba -> ?bg:Pixel.rgba -> Bitmap.t -> t + val to_BMP : t -> string val of_PPM : string -> t (** Width of an image. *) @@ -260,7 +319,11 @@ val copy : t -> t val blit_all : t -> t -> unit val blit : t -> t -> unit + + (** Scale one image in order to fill the other. By default, proportions are + not preserved. *) val scale : ?proportional:bool -> t -> t -> unit + val blank_all : t -> unit (** Add the fist image to the second at given offset. *) @@ -268,14 +331,47 @@ val blank : t -> unit val fill : t -> Pixel.yuv -> unit + + (** Flip image horizontally. *) + val hmirror : t -> unit + + (** Whether the image is opaque (it has no transparent or semi-transparent + pixel). *) + val is_opaque : t -> bool + + (** Optimize the α channel by removing it in the case the image is opaque. *) + val optimize_alpha : t -> unit + val fill_alpha : t -> int -> unit val disk_alpha : t -> int -> int -> int -> unit val alpha_of_color : t -> Pixel.yuv -> int -> unit - (* [box_alpha img x y width height alpha] Set alpha value - on a given image box. *) + (** Takes a reference image and an image, and make similar portions + transparent on the second (the last parameter controls the tolerance). This + is useful to make bluescreens withtout bluescreens. *) + val alpha_of_sameness : t -> t -> int -> unit + + (** [alpha_of_diff prev curr level speed] takes a previous image and a current + image and make parts of the current image more transparent if they were the + same. [level] is the distance at which we consider two colors to be the + same and [speed] is the inverse of the convergence speed. *) + val alpha_of_diff : t -> t -> int -> int -> unit + + (** [box_alpha img x y width height alpha] sets alpha value on a given image + box. *) val box_alpha : t -> int -> int -> int -> int -> float -> unit + + (** Remove alpha channel and set it as Y channel. Useful to inspect the alpha + channel. *) + val alpha_to_y : t -> unit + val randomize : t -> unit + val rotate : t -> int -> int -> float -> t -> unit + + (** Fill the image with a gradient. It takes as argument the (U,V) at pixel + (0,0), at pixel (xmax,0) and at pixel (0,ymax). *) + val gradient_uv : t -> int * int -> int * int -> int * int -> 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 @@ -386,3 +482,123 @@ val convert : ?proportional:bool -> ?scale_kind:RGBA32.Scale.kind -> t -> t -> unit end + +(** Type of image module expected to build canvas. *) +module type CanvasImage = sig + (** An image. *) + type t + + (** Width of the image. *) + val width : t -> int + + (** Height of the image. *) + val height : t -> int + + (** Size of the image in bytes. *) + val size : t -> int + + (** Create an image with given dimensions. *) + val create : int -> int -> t + + (** Clear the image. *) + val blank : t -> unit + + (** Create a copy of the image. *) + val copy : t -> t + + (** Add source image at given offset to the target image. *) + val add : t -> ?x:int -> ?y:int -> t -> unit + + (** Whether the image has alpha channel. *) + val has_alpha : t -> bool + + (** Fill the alpha channel of the image. *) + val fill_alpha : t -> int -> unit + + (** Set the RGBA value of a pixel. *) + val set_pixel_rgba : t -> int -> int -> Pixel.rgba -> unit + + (** Fill the image with random data. *) + val randomize : t -> unit + + (** Scale the source image to the destination image. *) + val scale : t -> t -> unit +end + +(** Canvas of images, i.e. formal sums of images of various dimensions with + various offsets. *) +module Canvas (I : CanvasImage) : sig + (** A canvas. *) + type t + + (** Create an empty canvas. *) + val create : int -> int -> t + + (** Create a canvas containing a given image. Negative dimensions are + ignored, default ones are those of the image. *) + val make : ?width:int -> ?height:int -> ?x:int -> ?y:int -> I.t -> t + + (** Width of the image. *) + val width : t -> int + + (** Height of the image. *) + val height : t -> int + + (** Change the width and height of the viewport of the canvas. *) + val viewport : ?x:int -> ?y:int -> int -> int -> t -> t + + (** Size of a canvas in bytes. *) + val size : t -> int + + (** Add two canvas. The first one is on top of the second one. *) + val add : t -> t -> t + + (** Whether the canvas covers the whole area with images (this function is + imprecise: it might have false negatives). *) + val covering : t -> bool + + (** Render the canvas as an image. If [fresh] is set to true, the resulting + can be modified in place. If [transparent] is set to true, the non-covered + portions are made transparent. *) + val render : ?fresh:bool -> ?transparent:bool -> t -> I.t + + (** Rendered canvas. *) + val rendered : ?transparent:bool -> t -> t + + (** Map a function on the underlying image. This of course triggers a render + of the canvas. *) + val map : (I.t -> I.t) -> t -> t + + (** Execute a function on the rendering of the canvas. *) + val iter : (I.t -> unit) -> t -> t + + (** Translate the image. *) + val translate : int -> int -> t -> t + + (** Bouding box (smallest box enclosing all images contained in the canavs): + returns the lower-left corner and the dimensions. *) + val bounding_box : t -> (int * int) * (int * int) + + (** Scale the image proportionally by fractional coefficients with given + numerator and denominator in the x and y directions. The viewport is left + untouched. The [scaler] parameter can be specified in order to use a + particular function to scale individual images. The viewport is left + unchanged. *) + val scale : ?scaler:(I.t -> I.t -> unit) -> Fraction.t -> Fraction.t -> t -> t + + (** Resize the image, scaling and changing the viewport. *) + val resize : + ?proportional:bool -> ?scaler:(I.t -> I.t -> unit) -> int -> int -> t -> t + + module Draw : sig + (** Draw a line (the result is typically added to another image). *) + val line : Pixel.rgba -> int * int -> int * int -> t + end +end + +module CanvasYUV420 : module type of Canvas (struct + include ImageYUV420 + + let create w h = create w h + let scale = scale ~proportional:false +end) diff -Nru ocaml-mm-0.7.5/src/imageRGBA32.ml ocaml-mm-0.8.1/src/imageRGBA32.ml --- ocaml-mm-0.7.5/src/imageRGBA32.ml 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-mm-0.8.1/src/imageRGBA32.ml 2022-05-24 14:23:18.000000000 +0000 @@ -0,0 +1,339 @@ +(* + * 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 ImageBase +module BGRA = ImageBGRA + +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 diff -Nru ocaml-mm-0.7.5/src/image_rgb.c ocaml-mm-0.8.1/src/image_rgb.c --- ocaml-mm-0.7.5/src/image_rgb.c 2022-02-03 12:20:47.000000000 +0000 +++ ocaml-mm-0.8.1/src/image_rgb.c 2022-05-24 14:23:18.000000000 +0000 @@ -65,21 +65,6 @@ #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 @@ -260,7 +245,7 @@ CAMLparam2(_rgb, _gray); frame rgb; frame_of_value(_rgb, &rgb); - uint8 *gray = Caml_ba_data_val(_gray); + uint8_t *gray = Caml_ba_data_val(_gray); int i, j; caml_enter_blocking_section(); @@ -1092,7 +1077,7 @@ CAMLreturn(Val_unit); } -static inline int compare_images(int width, int height, uint8 *old, uint8 *new, +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; @@ -1113,8 +1098,8 @@ 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); + uint8_t *old = Caml_ba_data_val(_old); + uint8_t *new = Caml_ba_data_val(_new); // Dimensions of the image int w = Int_val(_width); int h = len / w; @@ -1176,7 +1161,7 @@ CAMLreturn(ans); } -static inline int compare_blocks(int width, int height, uint8 *old, uint8 *new, +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; @@ -1205,10 +1190,10 @@ 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)); + uint8_t cr = Int_val(Field(c, 0)); + uint8_t cg = Int_val(Field(c, 1)); + uint8_t cb = Int_val(Field(c, 2)); + uint8_t ca = Int_val(Field(c, 3)); int i, j; @@ -1258,8 +1243,8 @@ 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); + uint8_t *old = Caml_ba_data_val(_old); + uint8_t *new = Caml_ba_data_val(_new); // Iterators over blocks int i, j; // Dimensions of the image diff -Nru ocaml-mm-0.7.5/src/image_yuv420.c ocaml-mm-0.8.1/src/image_yuv420.c --- ocaml-mm-0.7.5/src/image_yuv420.c 2022-02-03 12:20:47.000000000 +0000 +++ ocaml-mm-0.8.1/src/image_yuv420.c 2022-05-24 14:23:18.000000000 +0000 @@ -7,6 +7,7 @@ #include #include +#include #include #include @@ -14,8 +15,8 @@ #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 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) { @@ -76,9 +77,10 @@ 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); + if (i % 2 == 0 && j % 2 == 0) { + U(yuv, i, j) = UofRGB(r, g, b); + V(yuv, i, j) = VofRGB(r, g, b); + } } CAMLreturn(Val_unit); @@ -99,10 +101,11 @@ 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); + if (i % 2 == 0 && j % 2 == 0) { + U(yuv, i, j) = UofRGB(r, g, b); + V(yuv, i, j) = VofRGB(r, g, b); + } } caml_leave_blocking_section(); @@ -143,17 +146,36 @@ 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); } + */ + 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); + } + 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; + U2(dst, i, j) = U2(src, is, js); + V2(dst, i, j) = V2(src, is, js); + } + if (src.alpha) + 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; + A(dst, i, j) = A(src, is, js); + } caml_leave_blocking_section(); CAMLreturn(Val_unit); @@ -186,9 +208,10 @@ 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 (i % 2 == 0 && j % 2 == 0) { + 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); } @@ -204,25 +227,74 @@ yuv420 src, dst; yuv420_of_value(&src, _src); yuv420_of_value(&dst, _dst); + + int i, j; + // The portion of dst which will actually get modified 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++) + if (src.alpha == NULL) { + int il = ib - ia; + 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 + } + */ + int is = ia - x; + int js = j - y; + memcpy(dst.y + (j * dst.y_stride + ia), src.y + (js * src.y_stride + is), + il); + } + /* U and V only have to be done once every two times */ + /* + for (j = ja; j < jb; j+=2) + for (i = ia; i < ib; i+=2) { + int is = i - x; + int js = j - y; U(dst, i, j) = U(src, is, js); V(dst, i, j) = V(src, is, js); - if (dst.alpha) + } + */ + for (j = ja; j < jb; j += 2) { + int is = ia - x; + int js = j - y; + memcpy(dst.u + (j / 2 * dst.uv_stride + ia / 2), + src.u + (js / 2 * src.uv_stride + is / 2), il / 2); + memcpy(dst.v + (j / 2 * dst.uv_stride + ia / 2), + src.v + (js / 2 * src.uv_stride + is / 2), il / 2); + } + if (dst.alpha) + for (j = ja; j < jb; j++) + /* + for (i = ia; i < ib; i++) A(dst, i, j) = 0xff; + */ + memset(dst.alpha + (j * dst.y_stride + ia), 0xff, il); + } + /* + else if (src.alpha == NULL) { + int il = ib - ia; + 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); + U(dst, i, j) = U(src, is, js); + V(dst, i, j) = V(src, is, js); } + } + if (dst.alpha) + for (j = ja; j < jb; j++) + for (i = ia; i < ib; i++) + A(dst, i, j) = 0xff; + } + */ else for (j = ja; j < jb; j++) for (i = ia; i < ib; i++) { @@ -239,14 +311,15 @@ 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); + (Y(src, is, js) * a + Y(dst, i, j) * (0xff - a)) / 0xff; if (dst.alpha) A(dst, i, j) = 0xff - ((0xff - a) * (0xff - A(dst, i, j))) / 0xff; + if (i % 2 == 0 && j % 2 == 0) { + U(dst, i, j) = + (U(src, is, js) * a + U(dst, i, j) * (0xff - a)) / 0xff; + V(dst, i, j) = + (V(src, is, js) * a + V(dst, i, j) * (0xff - a)) / 0xff; + } } } caml_leave_blocking_section(); @@ -324,9 +397,8 @@ 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); */ + for (j = 0; j < yuv.height; j += 2) + for (i = 0; i < yuv.width; i += 2) { U(yuv, i, j) = 0x7f; V(yuv, i, j) = 0x7f; } @@ -402,8 +474,8 @@ argv[5]); } -CAMLprim value caml_yuv_alpha_of_color(value img, value _y, value _u, value _v, value _d) -{ +CAMLprim value caml_yuv_alpha_of_color(value img, value _y, value _u, value _v, + value _d) { CAMLparam5(img, _y, _u, _v, _d); yuv420 yuv; yuv420_of_value(&yuv, img); @@ -412,16 +484,273 @@ int v = Int_val(_v); int d = Int_val(_d); int i, j; + int yy, uu, vv; + + d = d * d * 3; caml_enter_blocking_section(); for (j = 0; j < yuv.height; j++) - for (i = 0; i < yuv.width; i++) + for (i = 0; i < yuv.width; i++) { + yy = Y(yuv, i, j) - y; + uu = U(yuv, i, j) - u; + vv = V(yuv, i, j) - v; + if (yy * yy + uu * uu + vv * vv <= d) + A(yuv, i, j) = 0; + } + caml_leave_blocking_section(); + + CAMLreturn(Val_unit); +} + +CAMLprim value caml_yuv_rotate(value _src, value _ox, value _oy, value _angle, + value _dst) { + CAMLparam5(_src, _ox, _oy, _angle, _dst); + yuv420 src, dst; + yuv420_of_value(&src, _src); + yuv420_of_value(&dst, _dst); + int ox = Int_val(_ox); + int oy = Int_val(_oy); + double a = Double_val(_angle); + double sina = sin(a); + double cosa = cos(a); + int i, j, i2, j2; + + caml_enter_blocking_section(); + for (j = 0; j < dst.height; j++) + for (i = 0; i < dst.width; i++) { + i2 = (i - ox) * cosa + (j - oy) * sina + ox; + j2 = -(i - ox) * sina + (j - oy) * cosa + oy; + if (0 <= i2 && i2 < src.width && 0 <= j2 && j2 < src.height) { + Y(dst, i, j) = Y(src, i2, j2); + U(dst, i, j) = U(src, i2, j2); + V(dst, i, j) = V(dst, i2, j2); + A(dst, i, j) = src.alpha ? A(src, i2, j2) : 0xff; + } else + A(dst, i, j) = 0; + } + caml_leave_blocking_section(); + + CAMLreturn(Val_unit); +} + +CAMLprim value caml_yuv_gradient_uv(value _img, value uv, value duvx, + value duvy) { + CAMLparam4(_img, uv, duvx, duvy); + yuv420 img; + yuv420_of_value(&img, _img); + int u = Int_val(Field(uv, 0)); + int v = Int_val(Field(uv, 1)); + int ux = Int_val(Field(duvx, 0)) - u; + int vx = Int_val(Field(duvx, 1)) - v; + int uy = Int_val(Field(duvy, 0)) - u; + int vy = Int_val(Field(duvy, 1)) - v; + + int i, j; + + caml_enter_blocking_section(); + for (j = 0; j < img.height; j++) + for (i = 0; i < img.width; i++) { + Y(img, i, j) = 0xff; + U(img, i, j) = u + ux * i / img.width + uy * j / img.height; + V(img, i, j) = v + vx * i / img.width + vy * j / img.height; + if (img.alpha) + A(img, i, j) = 0xff; + } + caml_leave_blocking_section(); + + CAMLreturn(Val_unit); +} + +CAMLprim value caml_yuv_invert(value _img) { + CAMLparam1(_img); + yuv420 img; + yuv420_of_value(&img, _img); + + int i, j; + + caml_enter_blocking_section(); + for (j = 0; j < img.height; j++) + for (i = 0; i < img.width; i++) { + Y(img, i, j) = 0xff - Y(img, i, j); + U(img, i, j) = 0xff - U(img, i, j); + V(img, i, j) = 0xff - V(img, i, j); + } + caml_leave_blocking_section(); + + CAMLreturn(Val_unit); +} + +CAMLprim value caml_yuv_sepia(value _img) { + CAMLparam1(_img); + yuv420 img; + yuv420_of_value(&img, _img); + + int i, j; + int y, u, v; + int r, g, b; + int c; + + caml_enter_blocking_section(); + for (j = 0; j < img.height; j++) + for (i = 0; i < img.width; i++) { + // TODO: avoid converting back and forth + y = Y(img, i, j); + u = U(img, i, j); + v = V(img, i, j); + r = RofYUV(y, u, v); + g = GofYUV(y, u, v); + b = BofYUV(y, u, v); + c = (r + g + b) / 3; + r = c; + g = c * 201 / 0xff; + b = c * 201 / 0xff; + Y(img, i, j) = YofRGB(r, g, b); + U(img, i, j) = UofRGB(r, g, b); + V(img, i, j) = VofRGB(r, g, b); + } + caml_leave_blocking_section(); + + CAMLreturn(Val_unit); +} + +CAMLprim value caml_yuv_lomo(value _img) { + CAMLparam1(_img); + yuv420 img; + yuv420_of_value(&img, _img); + + int i, j; + + caml_enter_blocking_section(); + for (j = 0; j < img.height; j++) + for (i = 0; i < img.width; i++) { + U(img, i, j) = V(img, i, j); + V(img, i, j) = U(img, i, j); + } + caml_leave_blocking_section(); + + CAMLreturn(Val_unit); +} + +CAMLprim value caml_yuv_is_opaque(value _img) { + CAMLparam1(_img); + yuv420 img; + yuv420_of_value(&img, _img); + + int i, j; + int ans = 1; + + caml_enter_blocking_section(); + for (j = 0; j < img.height; j++) { + if (!ans) + break; + for (i = 0; i < img.width; i++) + if (A(img, i, j) != 0xff) { + ans = 0; + break; + } + } + caml_leave_blocking_section(); + + CAMLreturn(Val_bool(ans)); +} + +CAMLprim value caml_yuv_alpha_of_sameness(value _ref, value _img, value _d) { + CAMLparam3(_ref, _img, _d); + yuv420 ref, img; + yuv420_of_value(&ref, _ref); + yuv420_of_value(&img, _img); + int d = Int_val(_d); + + int i, j; + int y, u, v; + + d = d * d * 3; + + caml_enter_blocking_section(); + for (j = 0; j < img.height; j++) + for (i = 0; i < img.width; i++) { + { + y = Y(img, i, j) - Y(ref, i, j); + u = U(img, i, j) - U(ref, i, j); + v = V(img, i, j) - V(ref, i, j); + if (y * y + u * u + v * v <= d) + A(img, i, j) = 0; + } + } + caml_leave_blocking_section(); + + CAMLreturn(Val_unit); +} + +CAMLprim value caml_yuv_alpha_of_diff(value _ref, value _img, value _level, + value _speed) { + CAMLparam4(_ref, _img, _level, _speed); + yuv420 ref, img; + yuv420_of_value(&ref, _ref); + yuv420_of_value(&img, _img); + int level = Int_val(_level); + int speed = Int_val(_speed); + int i, j; + int y, u, v; + int d; + + if (speed < 1) + speed = 1; + level = level * level * 3; + + caml_enter_blocking_section(); + for (j = 0; j < img.height; j++) + for (i = 0; i < img.width; i++) { { - if (abs(Y(yuv, i, j) - y) <= d && - abs(U(yuv, i, j) - u) <= d && - abs(V(yuv, i, j) - v) <= d) - A(yuv, i, j) = 0; + y = Y(img, i, j) - Y(ref, i, j); + u = U(img, i, j) - U(ref, i, j); + v = V(img, i, j) - V(ref, i, j); + d = y * y + u * u + v * v; + if (d <= level) + A(img, i, j) = + A(img, i, j) * (speed * level - (level - d)) / (speed * level); + else + d = level - min(level, d - level); + A(img, i, j) = 0xff - (0xff - A(img, i, j)) * + (speed * level - (level - d)) / + (speed * level); } + } + caml_leave_blocking_section(); + + CAMLreturn(Val_unit); +} + +CAMLprim value caml_yuv_hmirror(value _img) { + CAMLparam1(_img); + yuv420 img; + yuv420_of_value(&img, _img); + int w = img.width; + int i, j; + int y, u, v; + + caml_enter_blocking_section(); + for (j = 0; j < img.height; j++) { + for (i = 0; i < w / 2; i++) { + y = Y(img, i, j); + Y(img, i, j) = Y(img, w - 1 - i, j); + Y(img, w - 1 - i, j) = y; + } + } + for (j = 0; j < img.height / 2; j++) + for (i = 0; i < w / 4; i++) { + u = U2(img, i, j); + U2(img, i, j) = U2(img, w / 2 - 1 - i, j); + U2(img, w / 2 - 1 - i, j) = u; + v = V2(img, i, j); + V2(img, i, j) = V2(img, w / 2 - 1 - i, j); + V2(img, w / 2 - 1 - i, j) = v; + } + + if (img.alpha) + for (j = 0; j < img.height; j++) + for (i = 0; i < w / 2; i++) + A(img, i, j) = A(img, w - i, j); caml_leave_blocking_section(); CAMLreturn(Val_unit); diff -Nru ocaml-mm-0.7.5/src/image_yuv420.h ocaml-mm-0.8.1/src/image_yuv420.h --- ocaml-mm-0.7.5/src/image_yuv420.h 2022-02-03 12:20:47.000000000 +0000 +++ ocaml-mm-0.8.1/src/image_yuv420.h 2022-05-24 14:23:18.000000000 +0000 @@ -31,6 +31,8 @@ } #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 U2(yuv, i, j) yuv.u[j * yuv.uv_stride + i] +#define V2(yuv, i, j) yuv.v[j * yuv.uv_stride + i] +#define U(yuv, i, j) U2(yuv, i / 2, j / 2) +#define V(yuv, i, j) V2(yuv, i / 2, j / 2) #define A(yuv, i, j) yuv.alpha[j * yuv.y_stride + i] diff -Nru ocaml-mm-0.7.5/src/imageYUV420.ml ocaml-mm-0.8.1/src/imageYUV420.ml --- ocaml-mm-0.7.5/src/imageYUV420.ml 1970-01-01 00:00:00.000000000 +0000 +++ ocaml-mm-0.8.1/src/imageYUV420.ml 2022-05-24 14:23:18.000000000 +0000 @@ -0,0 +1,342 @@ +(* + * 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 ImageBase +module Bitmap = ImageBitmap +module RGBA32 = ImageRGBA32 + +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 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) + +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 make width height ?alpha y y_stride u v uv_stride = + { y; y_stride; u; v; uv_stride; width; height; alpha } + +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 + +(* Default alignment. *) +let align = Sys.word_size / 8 + +let default_stride width y_stride uv_stride = + 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 ?(blank = false) ?y_stride ?uv_stride width height = + 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 + 1) / 2) in + ( Data.aligned align (height * uv_stride), + Data.aligned align (height * uv_stride) ) + in + let img = make width height y y_stride u v uv_stride in + if blank then blank_all img; + img + +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 to_BMP img = + let img = to_RGBA32 img in + RGBA32.to_BMP 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 + +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" + +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 + for j = 0 to height - 1 do + for i = 0 to width - 1 do + set_pixel_rgba img i j (if Bitmap.get_pixel bmp i j then fg else bg) + done + done; + img + +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 + +(** [scale_coef src dst (xn,xd) (yn,yd)] scales [src] into [dst] multiplying x + dimension by xn/xd and y dimension by yn/yd. *) +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 rotate : t -> int -> int -> float -> t -> unit = "caml_yuv_rotate" + +let rotate src x y a dst = + ensure_alpha dst; + rotate src x y a dst + +external is_opaque : t -> bool = "caml_yuv_is_opaque" + +let is_opaque img = if img.alpha = None then true else is_opaque img +let optimize_alpha img = if is_opaque img then img.alpha <- None + +let alpha_to_y img = + ensure_alpha img; + img.y <- Option.get img.alpha; + img.alpha <- None + +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 + +external alpha_of_color : t -> int -> int -> int -> int -> unit + = "caml_yuv_alpha_of_color" + +let alpha_of_color img (y, u, v) d = + ensure_alpha img; + alpha_of_color img y u v d + +external alpha_of_sameness : t -> t -> int -> unit + = "caml_yuv_alpha_of_sameness" + +let alpha_of_sameness ref img d = + ensure_alpha img; + alpha_of_sameness ref img d + +external alpha_of_diff : t -> t -> int -> int -> unit = "caml_yuv_alpha_of_diff" + +let alpha_of_diff ref img d s = + ensure_alpha img; + alpha_of_diff ref img d s + +external gradient_uv : t -> int * int -> int * int -> int * int -> unit + = "caml_yuv_gradient_uv" + +external hmirror : t -> unit = "caml_yuv_hmirror" + +module Effect = struct + external greyscale : t -> unit = "caml_yuv_greyscale" + external invert : t -> unit = "caml_yuv_invert" + external sepia : t -> unit = "caml_yuv_sepia" + external lomo : t -> unit = "caml_yuv_lomo" + + module Alpha = struct + let scale = scale_alpha + let disk = disk_alpha + end +end diff -Nru ocaml-mm-0.7.5/src/synth.ml ocaml-mm-0.8.1/src/synth.ml --- ocaml-mm-0.7.5/src/synth.ml 2022-02-03 12:20:47.000000000 +0000 +++ ocaml-mm-0.8.1/src/synth.ml 2022-05-24 14:23:18.000000000 +0000 @@ -38,9 +38,9 @@ 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 fill_add : Audio.buffer -> int -> int -> unit + method play_add : MIDI.buffer -> int -> Audio.buffer -> int -> int -> unit + method play : MIDI.buffer -> int -> Audio.buffer -> int -> int -> unit method reset : unit end @@ -71,12 +71,12 @@ 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 fill_add buf ofs len = + List.iter (fun note -> note.generator#fill_add buf ofs len) notes - method private fill buf = - Audio.clear buf; - self#fill_add buf + method private fill buf ofs len = + Audio.clear buf ofs len; + self#fill_add buf ofs len method private event = function @@ -86,24 +86,23 @@ | _ -> () (* TODO: add offset for evs *) - method play_add evs eofs buf = - let len = Audio.length buf in + method play_add evs eofs buf bofs len = 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#fill_add buf (bofs + ofs) delta; self#event e; play t tl (ofs + delta) - | [] -> self#fill_add (Audio.sub buf ofs (len - o)) + | [] -> self#fill_add buf (bofs + 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 play evs eofs buf bofs len = + Audio.clear buf bofs len; + self#play_add evs eofs buf bofs len method reset = notes <- [] end @@ -144,13 +143,14 @@ (* TODO: check for the last note? *) g#release - method fill_add buf = g#fill_add buf + method fill_add = g#fill_add - method play_add (_ : MIDI.buffer) (_ : int) (_ : Audio.buffer) : unit = + method play_add (_ : MIDI.buffer) (_ : int) (_ : Audio.buffer) (_ : int) + (_ : int) : unit = assert false - method play evs eofs buf : unit = - self#play_add evs eofs buf; + method play evs eofs buf bofs len : unit = + self#play_add evs eofs buf bofs len; assert false method reset = g#set_volume 0. @@ -159,21 +159,24 @@ 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 + method play_add : + MIDI.Multitrack.buffer -> int -> Audio.buffer -> int -> int -> unit + + method play : + MIDI.Multitrack.buffer -> int -> Audio.buffer -> int -> int -> 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 = + method play_add (evs : MIDI.Multitrack.buffer) eofs buf bofs len = for c = 0 to Array.length synth - 1 do - synth.(c)#play_add evs.(c) eofs buf + synth.(c)#play_add evs.(c) eofs buf bofs len done - method play evs eofs buf = - Audio.clear buf; - self#play_add evs eofs buf + method play evs eofs buf bofs len = + Audio.clear buf bofs len; + self#play_add evs eofs buf bofs len end end diff -Nru ocaml-mm-0.7.5/src/synth.mli ocaml-mm-0.8.1/src/synth.mli --- ocaml-mm-0.7.5/src/synth.mli 2022-02-03 12:20:47.000000000 +0000 +++ ocaml-mm-0.8.1/src/synth.mli 2022-05-24 14:23:18.000000000 +0000 @@ -48,14 +48,14 @@ 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 + method fill_add : Audio.buffer -> int -> int -> 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 + method play : MIDI.buffer -> int -> Audio.buffer -> int -> int -> unit (** Same as [play] but keeps data originally present in the buffer. *) - method play_add : MIDI.buffer -> int -> Audio.buffer -> unit + method play_add : MIDI.buffer -> int -> Audio.buffer -> int -> int -> unit (** Reset the synthesizer (sets all notes off in particular). *) method reset : unit @@ -89,10 +89,12 @@ class type t = object (** Synthesize into an audio buffer. *) - method play : MIDI.Multitrack.buffer -> int -> Audio.buffer -> unit + method play : + MIDI.Multitrack.buffer -> int -> Audio.buffer -> int -> int -> unit (** Same as [play] but keeps data originally present in the buffer. *) - method play_add : MIDI.Multitrack.buffer -> int -> Audio.buffer -> unit + method play_add : + MIDI.Multitrack.buffer -> int -> Audio.buffer -> int -> int -> unit end (** Create a multichannel synthesizer with given number of channels and a diff -Nru ocaml-mm-0.7.5/src/video.ml ocaml-mm-0.8.1/src/video.ml --- ocaml-mm-0.7.5/src/video.ml 2022-02-03 12:20:47.000000000 +0000 +++ ocaml-mm-0.8.1/src/video.ml 2022-05-24 14:23:18.000000000 +0000 @@ -32,45 +32,119 @@ *) open Mm_base -open Mm_image +(* open Mm_image *) +open Mm_audio + +module YUV420 = Mm_image.Image.YUV420 + +(** Images from which are made videos. *) +module type Image = sig + type t + + val create : int -> int -> t + val size : t -> int + val blit_all : t -> t -> unit + val copy : t -> t + val blank : t -> unit + val randomize : t -> unit +end module Image = struct - include Image.YUV420 + include Mm_image.Image.YUV420 let create w h = create w h + let scale = scale ~proportional:false end -type t = Image.t array -type buffer = t +module Make (Image : Image) = struct + module I = Image -let make len width height = Array.init len (fun _ -> Image.create width height) -let single img = [| img |] + type t = Image.t array + type buffer = t -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 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 +end -let blank vid off len = iter Image.blank vid off len -let randomize vid off len = iter Image.randomize vid off len +include Make (Image) + +(* Canvas are not in place so that we have to make a slightly different + implementation. *) +module Canvas = struct + module Image = Mm_image.Image.Canvas (Image) + + type image = Image.t + type t = Image.t array + + let make len (width, height) : t = + Array.init len (fun _ -> Image.create width height) + + let single img = [| img |] + let single_image img = single (Image.make img) + let length (v : t) = Array.length v + let copy (v : t) = Array.init (length v) (fun i -> v.(i)) + + let size (v : t) = + let n = ref 0 in + for i = 0 to Array.length v - 1 do + n := !n + Image.size v.(i) + done; + !n + + 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 put v i img = v.(i) <- Image.make img + + let blit sbuf sofs dbuf dofs len = + for i = 0 to len - 1 do + dbuf.(dofs + i) <- sbuf.(sofs + i) + done + + let map f buf ofs len = + for i = ofs to ofs + len - 1 do + buf.(i) <- f buf.(i) + done + + let blank buf ofs len = + map + (fun img -> Image.create (Image.width img) (Image.height img)) + buf ofs len + + let iter f buf ofs len = + for i = ofs to ofs + len - 1 do + buf.(i) <- Image.iter f buf.(i) + done +end (* module RE = struct @@ -96,6 +170,199 @@ if n mod 100 = 0 then (n / 100, 1) else (n, 100) end +module AVI = struct + module Writer = struct + let word n = + let s = Bytes.create 2 in + Bytes.set_int16_le s 0 n; + Bytes.unsafe_to_string s + + let dword n = + let s = Bytes.create 4 in + Bytes.set_int32_le s 0 (Int32.of_int n); + Bytes.unsafe_to_string s + + module Chunk = struct + let create id len = + let pad = len mod 2 = 1 in + assert (String.length id = 4); + let s = Bytes.create (8 + len + if pad then 1 else 0) in + Bytes.blit_string id 0 s 0 4; + Bytes.blit_string (dword len) 0 s 4 4; + if pad then Bytes.set s (8 + len) (char_of_int 0); + s + + let make id data = + let len = String.length data in + let s = create id len in + Bytes.blit_string data 0 s 8 len; + Bytes.unsafe_to_string s + + (* Audio in 16LE *) + (* let audio b = make "01wb" b *) + + let audio_s16le buf = + let len = Audio.length buf in + let channels = Audio.channels buf in + let s = create "01wb" (len * channels * 2) in + Audio.S16LE.of_audio buf 0 s 8 len; + Bytes.unsafe_to_string s + + (* Video in RGB. *) + (* let video b = make "00db" b *) + + let video_yuv420 img = + let open Mm_image in + let width = Image.YUV420.width img in + let height = Image.YUV420.height img in + let y, u, v = Image.YUV420.data img in + let y = Image.Data.to_string y in + let u = Image.Data.to_string u in + 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 o = ref 8 in + let add_sub data off len = + Bytes.blit_string data off s !o len; + o := !o + len + in + let add data = add_sub data 0 (String.length data) in + if y_stride = width then add y + else + for j = 0 to height - 1 do + add_sub y (j * y_stride) width + done; + if uv_stride = width / 2 then ( + add u; + add v) + else ( + for j = 0 to (height / 2) - 1 do + add_sub u (j * uv_stride) (width / 2) + done; + for j = 0 to (height / 2) - 1 do + add_sub v (j * uv_stride) (width / 2) + done); + Bytes.unsafe_to_string s + + let list = make "LIST" + end + + 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); + (* 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 *) + ) + 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 *) + ) + 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 *) + ) + in + Chunk.list ("strl" ^ stream_header ^ stream_format) + in + let audio_header = + 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 *)) + 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 *)) + in + Chunk.list ("strl" ^ stream_header ^ stream_format) + 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 -> "" + in + "RIFF" + ^ dword_max () (* file size *) + ^ "AVI " ^ headers ^ info ^ "LIST" ^ dword_max () ^ "movi" + end +end + module IO = struct exception Invalid_file @@ -124,6 +391,7 @@ end class virtual avi frame_rate w h = + (* let has_audio = audio_rate <> None in *) let frames_per_chunk = int_of_float (frame_rate +. 0.5) in let frame_size = w * h * 3 in object (self) @@ -134,122 +402,80 @@ initializer self#output "RIFF"; - self#output_int 0; - (* TOFILL: file size *) - self#output "AVI "; - (* file type *) + 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_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 *) + 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 *) + 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 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 *) + (* Important colors *) (* movie data *) self#output "LIST"; - self#output_int 0; - (* TOFILL: movie size *) + self#output_int 0; (* TOFILL: movie size *) self#output "movi"; (* video chunks follow *) diff -Nru ocaml-mm-0.7.5/src/video.mli ocaml-mm-0.8.1/src/video.mli --- ocaml-mm-0.7.5/src/video.mli 2022-02-03 12:20:47.000000000 +0000 +++ ocaml-mm-0.8.1/src/video.mli 2022-05-24 14:23:18.000000000 +0000 @@ -33,8 +33,11 @@ (** Operations on video data. *) +open Mm_audio open Mm_image +module YUV420 = Image.YUV420 + (** Images of videos. *) module Image : sig type t = Image.YUV420.t @@ -54,8 +57,9 @@ val size : t -> int val blank : t -> unit + val has_alpha : t -> bool val fill_alpha : t -> int -> unit - val scale : ?proportional:bool -> t -> t -> unit + val scale : t -> t -> unit val randomize : t -> unit (** [blit_all src dst] blits an entire image. *) @@ -110,6 +114,65 @@ val blank : t -> int -> int -> unit val randomize : t -> int -> int -> unit +(** Videos with canvas images. *) +module Canvas : sig + module Image : module type of Mm_image.Image.Canvas (Image) + + (** An image. *) + type image = Image.t + + (** A video. *) + type t = image array + + (** Create a video with given length and dimensions. *) + val make : int -> int * int -> t + + (** Make a copy of the video (images themselves are not copied since they are + supposed to be immutable). *) + val copy : t -> t + + (** Create a video with one canvas image. *) + val single : Image.t -> t + + (** Create a video with one image. *) + val single_image : Mm_image.Image.YUV420.t -> t + + (** Length of the video (in images). *) + val length : t -> int + + (** Estimated size of the video (in bytes). *) + val size : t -> int + + (** Get the nth image of the video. *) + val get : t -> int -> image + + (** Set the nth image of the video. *) + val set : t -> int -> image -> unit + + (** Apply a function on the nth image of the video. *) + val map_image : (image -> image) -> t -> int -> unit + + (** Render the nth image of the video. *) + val render : 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). *) + val put : t -> int -> Mm_image.Image.YUV420.t -> unit + + (** Blank the video starting at offset with given length. *) + val blank : t -> int -> int -> unit + + (** Copy the images of one video to the other. *) + val blit : t -> int -> t -> int -> int -> unit + + (** Map a function to the images of a video (starting at given offset, for + given length). *) + val map : (image -> image) -> t -> int -> int -> unit + + (** Iterate a function on the rendering of the images of the video. *) + val iter : (Mm_image.Image.YUV420.t -> unit) -> t -> int -> int -> unit +end + (* module Ringbuffer_ext : Ringbuffer.R with type elt = frame *) (* module Ringbuffer : Ringbuffer.R with type elt = frame *) @@ -122,6 +185,22 @@ val to_frac : t -> int * int end +(** Operation on files in AVI format. *) +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 + + (** 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 +end + module IO : sig exception Invalid_file