diff --git a/audio-encoder.rkt b/audio-encoder.rkt new file mode 100644 index 0000000..51a596d --- /dev/null +++ b/audio-encoder.rkt @@ -0,0 +1,180 @@ +(module audio-encoder racket/base + + (require racket/path + racket/string + racket/contract + racket/runtime-path + "flac-encoder.rkt" + "opus-encoder.rkt" + "taglib.rkt" + "private/pcm-converter.rkt" + "private/utils.rkt") + + (provide audio-encode + audio-supported-encoder-extensions + audio-register-encoder! + make-audio-encoder + audio-encoder?) + + (define-struct audio-encoder (exts open write finish settings)) + + (define-runtime-module-path-index audio-decoder-module "audio-decoder.rkt") + + (define audio-encoders (make-hash)) + + (define (audio-register-encoder! type encoder) + (hash-set! audio-encoders type encoder)) + + (audio-register-encoder! + 'flac + (make-audio-encoder '("flac") + flac-encoder-open + flac-encoder-write + flac-encoder-finish + flac-encoder-prepare-settings)) + + (audio-register-encoder! + 'opus + (make-audio-encoder '("opus" "oga") + opus-encoder-open + opus-encoder-write + opus-encoder-finish + opus-encoder-prepare-settings)) + + (define (audio-supported-encoder-extensions) + (apply append (map audio-encoder-exts (hash-values audio-encoders)))) + + (define (path-extension-symbol file) + (let ((ext (path-get-extension (build-path file)))) + (and ext (string->symbol (string-downcase (substring (bytes->string/utf-8 ext) 1)))))) + + (define (encoder-for-output output-file explicit-kind) + (let ((kind (or explicit-kind (path-extension-symbol output-file)))) + (cond [(and kind (hash-ref audio-encoders kind #f)) (values kind (hash-ref audio-encoders kind))] + [else (error 'audio-encode "cannot infer encoder from output file ~a" output-file)]))) + + (define (tag-value-copy! src dst getter setter empty?) + (let ((v (getter src))) + (unless (empty? v) (setter dst v)))) + + (define (empty-string? v) (or (eq? v #f) (and (string? v) (string=? v "")))) + (define (empty-number? v) (or (eq? v #f) (and (number? v) (< v 0)))) + + (define (merge-hash a b) + (let ((out (make-hash))) + (when (hash? a) + (for-each (lambda (k) (hash-set! out k (hash-ref a k))) (hash-keys a))) + (when (hash? b) + (for-each (lambda (k) (hash-set! out k (hash-ref b k))) (hash-keys b))) + out)) + + (define (copy-tags! input-file output-file) + (with-handlers ([exn:fail? (lambda (e) + (warn-sound "Could not copy tags from ~a to ~a: ~a" + input-file output-file (exn-message e)) + #f)]) + (call-with-id3-tags + input-file + (lambda (src) + (call-with-id3-tags + output-file + (lambda (dst) + (when (and (tags-valid? src) (tags-valid? dst)) + (tag-value-copy! src dst tags-title tags-title! empty-string?) + (tag-value-copy! src dst tags-album tags-album! empty-string?) + (tag-value-copy! src dst tags-artist tags-artist! empty-string?) + (tag-value-copy! src dst tags-comment tags-comment! empty-string?) + (tag-value-copy! src dst tags-genre tags-genre! empty-string?) + (tag-value-copy! src dst tags-composer tags-composer! empty-string?) + (tag-value-copy! src dst tags-album-artist tags-album-artist! empty-string?) + (tag-value-copy! src dst tags-year tags-year! empty-number?) + (tag-value-copy! src dst tags-track tags-track! empty-number?) + (tag-value-copy! src dst tags-disc-number tags-disc-number! empty-number?) + (let ((picture (tags-picture src))) + (unless (eq? picture #f) (tags-picture! dst picture))) + (tags-save! dst))) + #:mode 'read-write)) + #:mode 'read) + #t)) + + (define (audio-encode input-file output-file settings + #:encoder [explicit-kind #f] + #:copy-tags? [copy-tags? #t]) + (define-values (kind encoder) (encoder-for-output output-file explicit-kind)) + (define backend-handle #f) + (define format #f) + (define output-format #f) + (define converter #f) + (define frames-written 0) + + (define (ensure-open! fmt) + (when (eq? backend-handle #f) + ;; Record the resolved output format, not merely the incoming PCM format. + ;; This matters when only FLAC bit depth changes, because no swresample + ;; converter is needed but the resulting FLAC stream metadata still differs. + (set! output-format ((audio-encoder-settings encoder) settings fmt)) + (set! backend-handle ((audio-encoder-open encoder) output-file settings fmt)))) + + (define (write-backend! fmt buffer buf-len) + (ensure-open! fmt) + (set! frames-written (+ frames-written ((audio-encoder-write encoder) backend-handle fmt buffer buf-len)))) + + (define (ensure-flac-converter! input-format) + ;; FLAC encoding may be used as a sample-rate conversion target, for example + ;; 96 kHz -> 48 kHz. That conversion is not a property of libFLAC itself; + ;; it must happen on the decoded PCM stream before process_interleaved. + (when (and (eq? kind 'flac) + (eq? converter #f) + (pcm-conversion-needed? input-format settings)) + (set! converter (make-pcm-converter input-format settings)))) + + (define (write-converted! input-format buffer buf-len) + (ensure-flac-converter! input-format) + (cond [converter + (let-values (((out out-samples) (pcm-converter-convert converter buffer buf-len input-format))) + (when (> out-samples 0) + (write-backend! (pcm-converter-output-format converter) out (bytes-length out))))] + [else (write-backend! input-format buffer buf-len)])) + + (define (drain-converter!) + (when converter + (let loop () + (let-values (((out out-samples) (pcm-converter-drain converter))) + (when (> out-samples 0) + (write-backend! (pcm-converter-output-format converter) out (bytes-length out)) + (loop)))))) + + (define (on-format audio-kind ao-kind handle fmt) + ;; Keep stream metadata, but delay encoder creation until the first audio + ;; buffer. Some decoders report an output-oriented stream format first + ;; and then the exact PCM frame format in buf-info. + (set! format fmt)) + + (define (on-audio audio-kind ao-kind handle buf-info buffer buf-len) + (let ((effective-format (merge-hash format buf-info))) + (set! format effective-format) + (write-converted! effective-format buffer buf-len))) + + (let* ((audio-open-proc (dynamic-require audio-decoder-module 'audio-open)) + (audio-read-proc (dynamic-require audio-decoder-module 'audio-read)) + (decoder (audio-open-proc input-file on-format on-audio))) + (dynamic-wind + void + (lambda () (audio-read-proc decoder)) + (lambda () + (dynamic-wind + drain-converter! + (lambda () (when backend-handle ((audio-encoder-finish encoder) backend-handle))) + (lambda () (when converter (pcm-converter-close! converter))))))) + + (when copy-tags? (copy-tags! input-file output-file)) + (let ((r (make-hash))) + (hash-set! r 'encoder kind) + (hash-set! r 'input input-file) + (hash-set! r 'output output-file) + (hash-set! r 'input-format format) + (hash-set! r 'output-format output-format) + (hash-set! r 'frames-written frames-written) + r)) + + ) ; end of module diff --git a/ffmpeg-definitions.rkt b/ffmpeg-definitions.rkt index 2f1d257..287ee23 100644 --- a/ffmpeg-definitions.rkt +++ b/ffmpeg-definitions.rkt @@ -29,7 +29,20 @@ fmpg-buffer-start-sample fmpg-buffer-end-sample fmpg-sample-position - ffmpeg-version) + ffmpeg-version + + ;; Shared FFmpeg/swresample bindings for encoder-side PCM conversion. + ;; Keeping these exports here prevents a second, divergent FFmpeg FFI + ;; version layer in private/pcm-converter.rkt. + AV_SAMPLE_FMT_S32 + swr_alloc_set_opts2 + swr_init + swr_free + swr_get_out_samples + swr_get_delay + swr_convert + ffmpeg-make-default-channel-layout + ffmpeg-channel-layout-uninit!) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; C - Types & Functions @@ -248,6 +261,21 @@ ) ) +(def-avutil av_channel_layout_default + (_fun _AVChannelLayout-pointer _int -> _void)) + +(def-avutil av_channel_layout_uninit + (_fun _AVChannelLayout-pointer -> _void)) + +(define (ffmpeg-make-default-channel-layout channels) + (let ((p (malloc (ctype-sizeof _AVChannelLayout) 'atomic-interior))) + (av_channel_layout_default p channels) + p)) + +(define (ffmpeg-channel-layout-uninit! p) + (when p (av_channel_layout_uninit p)) + #t) + ; _AVCodecParameters: ; codec_type : AVMediaType ; codec_id : int / AVCodecID diff --git a/flac-definitions.rkt b/flac-definitions.rkt index e4ac81a..d3bf6a5 100644 --- a/flac-definitions.rkt +++ b/flac-definitions.rkt @@ -25,6 +25,13 @@ flac-bits-per-sample flac-total-samples flac-duration + + flac-encoder-handle + make-flac-encoder-handle + flac-encoder-handle-ffi-encoder-handler + flac-encoder-handle-settings + flac-encoder-handle-format + flac-encoder-handle-file ) (define-struct flac-stream-info @@ -105,4 +112,12 @@ ;#:transparent ) + + ;; A high level FLAC encoder handle. The actual native encoder pointer + ;; remains encapsulated in the FFI command handler, matching the existing + ;; decoder-side style in this package. + (define-struct flac-encoder-handle + (ffi-encoder-handler settings format file) + #:transparent) + ); end of module diff --git a/flac-encoder.rkt b/flac-encoder.rkt new file mode 100644 index 0000000..aa6eae2 --- /dev/null +++ b/flac-encoder.rkt @@ -0,0 +1,82 @@ +(module flac-encoder racket/base + + (require "libflac-ffi.rkt" + "flac-definitions.rkt") + + (provide flac-encoder-available? + flac-encoder-default-settings + flac-encoder-prepare-settings + flac-encoder-open + flac-encoder-write + flac-encoder-finish) + + (define (flac-encoder-available?) #t) + + (define (copy-hash h) + (let ((out (make-hash))) + (for-each (lambda (k) (hash-set! out k (hash-ref h k))) (hash-keys h)) + out)) + + (define (hash-ref/default h k default) + (if (hash-has-key? h k) (hash-ref h k) default)) + + (define (hash-merge base override) + (let ((out (copy-hash base))) + (when (hash? override) + (for-each (lambda (k) (hash-set! out k (hash-ref override k))) (hash-keys override))) + out)) + + (define (flac-encoder-default-settings) + (make-hash '((compression-level . 5) + (verify? . #f) + (blocksize . 0)))) + + (define (safe-flac-bits bits) + (cond [(and (integer? bits) (or (= bits 8) (= bits 12) (= bits 16) (= bits 20) (= bits 24))) bits] + [(and (integer? bits) (< bits 16)) 16] + [else 24])) + + (define (flac-encoder-prepare-settings settings format) + (let* ((base (flac-encoder-default-settings)) + (h (hash-merge base settings)) + ;; In encoder settings, 'sample-rate means the requested output rate. + ;; 'target-sample-rate is accepted as an explicit alias for readability. + (rate (hash-ref/default h 'target-sample-rate + (hash-ref/default h 'sample-rate (hash-ref format 'sample-rate)))) + (channels (hash-ref/default h 'target-channels + (hash-ref/default h 'channels (hash-ref format 'channels)))) + (bits0 (hash-ref/default h 'target-bits-per-sample + (hash-ref/default h 'bits-per-sample + (hash-ref/default format 'bits-per-sample 24)))) + (bits (safe-flac-bits bits0)) + (total (hash-ref/default h 'total-samples (hash-ref/default format 'total-samples #f)))) + (hash-set! h 'sample-rate rate) + (hash-set! h 'channels channels) + (hash-set! h 'bits-per-sample bits) + (when (hash-has-key? h 'target-sample-rate) (hash-remove! h 'target-sample-rate)) + (when (hash-has-key? h 'target-channels) (hash-remove! h 'target-channels)) + (when (hash-has-key? h 'target-bits-per-sample) (hash-remove! h 'target-bits-per-sample)) + (when (and total (integer? total) (>= total 0)) (hash-set! h 'total-samples total)) + (unless (hash-has-key? h 'streamable-subset?) (hash-set! h 'streamable-subset? (<= bits 24))) + h)) + + (define (flac-encoder-open output-file settings format) + (let* ((file (if (path? output-file) (path->string output-file) output-file)) + (resolved (flac-encoder-prepare-settings settings format)) + (handler (flac-ffi-encoder-handler))) + (handler 'new) + (handler 'configure resolved) + (handler 'init file) + (make-flac-encoder-handle handler resolved format file))) + + (define (flac-encoder-write handle buf-info buffer buf-len) + ((flac-encoder-handle-ffi-encoder-handler handle) 'write buffer buf-len buf-info)) + + (define (flac-encoder-finish handle) + (let ((handler (flac-encoder-handle-ffi-encoder-handler handle))) + (dynamic-wind + void + (lambda () (handler 'finish)) + (lambda () (handler 'delete))))) + + ) ; end of module diff --git a/libflac-ffi.rkt b/libflac-ffi.rkt index bbb8801..ccca33e 100644 --- a/libflac-ffi.rkt +++ b/libflac-ffi.rkt @@ -6,6 +6,7 @@ ) (provide flac-ffi-decoder-handler + flac-ffi-encoder-handler _FLAC__StreamMetadata FLAC__StreamMetadata-type flac-ffi-meta @@ -371,6 +372,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define _FLAC__StreamDecoder-pointer (_cpointer 'flac-streamdecoder)) +(define _FLAC__StreamEncoder-pointer (_cpointer 'flac-streamencoder)) (define _FLAC__Data-pointer (_cpointer/null 'flac-client-data)) ;(define _FLAC__StreamMetadata-pointer (_cpointer/null 'flac-stream-metadata)) @@ -639,5 +641,164 @@ )) ) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Direct FLAC encoder interface +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define FLAC__StreamEncoderInitStatus-ok 0) + +(define _FLAC__StreamEncoderProgressCallback _pointer) + +(define-libflac FLAC__stream_encoder_new + (_fun -> _FLAC__StreamEncoder-pointer)) + +(define-libflac FLAC__stream_encoder_delete + (_fun _FLAC__StreamEncoder-pointer -> _void)) + +(define-libflac FLAC__stream_encoder_finish + (_fun _FLAC__StreamEncoder-pointer -> FLAC__bool)) + +(define-libflac FLAC__stream_encoder_get_state + (_fun _FLAC__StreamEncoder-pointer -> _int)) + +(define-libflac FLAC__stream_encoder_set_verify + (_fun _FLAC__StreamEncoder-pointer FLAC__bool -> FLAC__bool)) + +(define-libflac FLAC__stream_encoder_set_streamable_subset + (_fun _FLAC__StreamEncoder-pointer FLAC__bool -> FLAC__bool)) + +(define-libflac FLAC__stream_encoder_set_channels + (_fun _FLAC__StreamEncoder-pointer _uint32_t -> FLAC__bool)) + +(define-libflac FLAC__stream_encoder_set_bits_per_sample + (_fun _FLAC__StreamEncoder-pointer _uint32_t -> FLAC__bool)) + +(define-libflac FLAC__stream_encoder_set_sample_rate + (_fun _FLAC__StreamEncoder-pointer _uint32_t -> FLAC__bool)) + +(define-libflac FLAC__stream_encoder_set_compression_level + (_fun _FLAC__StreamEncoder-pointer _uint32_t -> FLAC__bool)) + +(define-libflac FLAC__stream_encoder_set_blocksize + (_fun _FLAC__StreamEncoder-pointer _uint32_t -> FLAC__bool)) + +(define-libflac FLAC__stream_encoder_set_total_samples_estimate + (_fun _FLAC__StreamEncoder-pointer FLAC__uint64 -> FLAC__bool)) + +(define-libflac FLAC__stream_encoder_init_file + (_fun _FLAC__StreamEncoder-pointer + _string/utf-8 + _FLAC__StreamEncoderProgressCallback + _FLAC__Data-pointer + -> _int)) + +(define-libflac FLAC__stream_encoder_process_interleaved + (_fun _FLAC__StreamEncoder-pointer _pointer _uint32_t -> FLAC__bool)) + +(define (hash-ref/default h k default) + (if (hash-has-key? h k) (hash-ref h k) default)) + +(define (bool->flac-bool v) (if v 1 0)) + +(define (native-signed-ref bs start bytes) + (integer-bytes->integer bs #t (system-big-endian?) start (+ start bytes))) + +(define (scale-sample sample in-bits out-bits) + (cond [(> in-bits out-bits) (arithmetic-shift sample (- out-bits in-bits))] + [(< in-bits out-bits) (arithmetic-shift sample (- out-bits in-bits))] + [else sample])) + +(define (pcm-bytes->flac-int32-pointer buffer size channels in-bits out-bits) + (let* ((in-bytes (quotient in-bits 8)) + (sample-count (quotient size in-bytes)) + (frame-count (quotient sample-count channels)) + (ptr (malloc _int32 sample-count 'atomic-interior))) + (for ([i (in-range sample-count)]) + (let* ((off (* i in-bytes)) + (sample (native-signed-ref buffer off in-bytes))) + (ptr-set! ptr _int32 i (scale-sample sample in-bits out-bits)))) + (values ptr frame-count))) + +(define (flac-ffi-encoder-handler) + (define enc #f) + (define flac-file #f) + (define settings #f) + + (define (require-encoder who) + (when (eq? enc #f) (error who "FLAC encoder is not initialized"))) + + (define (new) + (if (eq? enc #f) + (begin (set! enc (FLAC__stream_encoder_new)) enc) + (error 'flac-ffi-encoder-handler "FLAC encoder already initialized"))) + + (define (configure h) + (require-encoder 'flac-encoder-configure) + (set! settings h) + (let ((channels (hash-ref h 'channels)) + (sample-rate (hash-ref h 'sample-rate)) + (bits (hash-ref h 'bits-per-sample)) + (compression-level (hash-ref/default h 'compression-level 5)) + (verify? (hash-ref/default h 'verify? #f)) + (streamable-subset? (hash-ref/default h 'streamable-subset? (<= (hash-ref h 'bits-per-sample) 24))) + (blocksize (hash-ref/default h 'blocksize 0)) + (total-samples (hash-ref/default h 'total-samples #f))) + (unless (FLAC__stream_encoder_set_channels enc channels) (error 'flac-encoder-configure "could not set channels")) + (unless (FLAC__stream_encoder_set_sample_rate enc sample-rate) (error 'flac-encoder-configure "could not set sample rate")) + (unless (FLAC__stream_encoder_set_bits_per_sample enc bits) (error 'flac-encoder-configure "could not set bits per sample")) + (unless (FLAC__stream_encoder_set_compression_level enc compression-level) (error 'flac-encoder-configure "could not set compression level")) + (unless (FLAC__stream_encoder_set_verify enc (bool->flac-bool verify?)) (error 'flac-encoder-configure "could not set verify")) + (unless (FLAC__stream_encoder_set_streamable_subset enc (bool->flac-bool streamable-subset?)) (error 'flac-encoder-configure "could not set streamable subset")) + (when (and (integer? blocksize) (> blocksize 0)) + (unless (FLAC__stream_encoder_set_blocksize enc blocksize) (error 'flac-encoder-configure "could not set blocksize"))) + (when (and (integer? total-samples) (>= total-samples 0)) + (unless (FLAC__stream_encoder_set_total_samples_estimate enc total-samples) (error 'flac-encoder-configure "could not set total samples estimate"))) + #t)) + + (define (init file) + (require-encoder 'flac-encoder-init) + (let ((r (FLAC__stream_encoder_init_file enc file #f #f))) + (set! flac-file file) + (unless (= r FLAC__StreamEncoderInitStatus-ok) + (error 'flac-encoder-init "FLAC encoder init failed with status ~a" r)) + #t)) + + (define (write buffer size buf-info) + (require-encoder 'flac-encoder-write) + (let* ((channels (hash-ref settings 'channels)) + (in-bits (hash-ref/default buf-info 'pcm-bits-per-sample + (hash-ref/default buf-info 'bits-per-sample + (hash-ref settings 'bits-per-sample)))) + (out-bits (hash-ref settings 'bits-per-sample))) + (let-values (((ptr frames) (pcm-bytes->flac-int32-pointer buffer size channels in-bits out-bits))) + (unless (FLAC__stream_encoder_process_interleaved enc ptr frames) + (error 'flac-encoder-write "FLAC encoder process_interleaved failed, state ~a" (FLAC__stream_encoder_get_state enc))) + frames))) + + (define (finish) + (require-encoder 'flac-encoder-finish) + (FLAC__stream_encoder_finish enc)) + + (define (delete) + (unless (eq? enc #f) + (FLAC__stream_encoder_delete enc) + (set! enc #f)) + #t) + + (lambda (cmd . args) + (cond [(eq? cmd 'new) (new)] + [(eq? cmd 'configure) (configure (car args))] + [(eq? cmd 'init) (init (car args))] + [(eq? cmd 'write) (write (car args) (cadr args) (caddr args))] + [(eq? cmd 'finish) (finish)] + [(eq? cmd 'delete) (delete)] + [(eq? cmd 'state) (and enc (FLAC__stream_encoder_get_state enc))] + [(eq? cmd 'file) flac-file] + [(eq? cmd 'settings) settings] + [else (error (format "unknown FLAC encoder command ~a" cmd))]))) + + ); end of module diff --git a/opus-encoder.rkt b/opus-encoder.rkt new file mode 100644 index 0000000..054ca2d --- /dev/null +++ b/opus-encoder.rkt @@ -0,0 +1,192 @@ +(module opus-encoder racket/base + + (require ffi/unsafe + "private/utils.rkt") + + (provide opus-encoder-available? + opus-encoder-default-settings + opus-encoder-prepare-settings + opus-encoder-open + opus-encoder-write + opus-encoder-finish) + + ;; libopusenc handles the Ogg container, OpusHead and OpusTags. The Racket + ;; side only feeds interleaved signed 16-bit PCM to ope_encoder_write(). + + (define libopusenc + (get-lib (case (system-type 'os) + [(windows) '("opusenc")] + [else '("opusenc" "libopusenc")]) + '(#f))) + + (define _OggOpusComments (_cpointer/null 'ogg-opus-comments)) + (define _OggOpusEnc (_cpointer/null 'ogg-opus-enc)) + + (define (ffi-proc name type) + (and libopusenc + (with-handlers ([exn:fail? (lambda (_) #f)]) + (get-ffi-obj name libopusenc type)))) + + (define ope_comments_create (ffi-proc "ope_comments_create" (_fun -> _OggOpusComments))) + (define ope_comments_destroy (ffi-proc "ope_comments_destroy" (_fun _OggOpusComments -> _void))) + (define ope_comments_add (ffi-proc "ope_comments_add" (_fun _OggOpusComments _string/utf-8 _string/utf-8 -> _int))) + (define ope_comments_add_picture_from_memory + (ffi-proc "ope_comments_add_picture_from_memory" (_fun _OggOpusComments _bytes _size _int _string/utf-8 -> _int))) + (define ope_encoder_create_file + (ffi-proc "ope_encoder_create_file" + (_fun _string/utf-8 _OggOpusComments _int32 _int _int (err : (_ptr o _int)) + -> (enc : _OggOpusEnc) + -> (values enc err)))) + (define ope_encoder_write (ffi-proc "ope_encoder_write" (_fun _OggOpusEnc _bytes _int -> _int))) + (define ope_encoder_drain (ffi-proc "ope_encoder_drain" (_fun _OggOpusEnc -> _int))) + (define ope_encoder_destroy (ffi-proc "ope_encoder_destroy" (_fun _OggOpusEnc -> _void))) + (define ope_strerror (ffi-proc "ope_strerror" (_fun _int -> _string/utf-8))) + (define ope_encoder_ctl/int (ffi-proc "ope_encoder_ctl" (_fun #:varargs-after 2 _OggOpusEnc _int _int -> _int))) + + (define OPUS_SET_BITRATE_REQUEST 4002) + (define OPUS_SET_VBR_REQUEST 4006) + (define OPUS_SET_COMPLEXITY_REQUEST 4010) + (define OPUS_SET_VBR_CONSTRAINT_REQUEST 4020) + (define OPUS_SET_SIGNAL_REQUEST 4024) + (define OPUS_SET_LSB_DEPTH_REQUEST 4036) + (define OPE_SET_COMMENT_PADDING_REQUEST 14004) + + (define OPUS_AUTO -1000) + (define OPUS_SIGNAL_VOICE 3001) + (define OPUS_SIGNAL_MUSIC 3002) + + (define (opus-encoder-available?) + (and libopusenc ope_comments_create ope_comments_destroy ope_encoder_create_file + ope_encoder_write ope_encoder_drain ope_encoder_destroy ope_strerror #t)) + + (define-struct opus-encoder-handle (enc comments settings format file) #:transparent) + + (define (hash-ref/default h k default) + (if (hash-has-key? h k) (hash-ref h k) default)) + + (define (copy-hash h) + (let ((out (make-hash))) + (for-each (lambda (k) (hash-set! out k (hash-ref h k))) (hash-keys h)) + out)) + + (define (hash-merge base override) + (let ((out (copy-hash base))) + (when (hash? override) + (for-each (lambda (k) (hash-set! out k (hash-ref override k))) (hash-keys override))) + out)) + + (define (opus-error-message code) + (if ope_strerror (ope_strerror code) (format "libopusenc error ~a" code))) + + (define (check-ope who r) + (when (negative? r) (error who "~a" (opus-error-message r))) + r) + + (define (opus-encoder-default-settings) + (make-hash '((bitrate . 160000) + (vbr? . #t) + (constrained-vbr? . #f) + (complexity . 10) + (comment-padding . 512)))) + + (define (valid-opus-rate? rate) + (or (= rate 8000) (= rate 12000) (= rate 16000) (= rate 24000) (= rate 48000))) + + (define (signal->int v) + (cond [(or (eq? v 'auto) (eq? v #f)) OPUS_AUTO] + [(eq? v 'voice) OPUS_SIGNAL_VOICE] + [(eq? v 'music) OPUS_SIGNAL_MUSIC] + [else (raise-argument-error 'opus-signal "(or/c 'auto 'voice 'music)" v)])) + + (define (opus-encoder-prepare-settings settings format) + (let* ((h (hash-merge (opus-encoder-default-settings) settings)) + (rate (hash-ref/default h 'sample-rate (hash-ref format 'sample-rate))) + (channels (hash-ref/default h 'channels (hash-ref format 'channels)))) + (unless (valid-opus-rate? rate) + (error 'opus-encoder-open "Opus input sample rate must be 8000, 12000, 16000, 24000 or 48000 Hz; got ~a. Resample before calling libopusenc." rate)) + (when (> channels 2) + (error 'opus-encoder-open "this first direct libopusenc backend only supports mono/stereo input; got ~a channels" channels)) + (hash-set! h 'sample-rate rate) + (hash-set! h 'channels channels) + (hash-set! h 'family 0) + h)) + + (define (apply-ctl! enc request value who) + (when ope_encoder_ctl/int + (check-ope who (ope_encoder_ctl/int enc request value)))) + + (define (apply-settings! enc settings) + (apply-ctl! enc OPUS_SET_BITRATE_REQUEST (hash-ref settings 'bitrate) 'opus-bitrate) + (apply-ctl! enc OPUS_SET_VBR_REQUEST (if (hash-ref/default settings 'vbr? #t) 1 0) 'opus-vbr) + (apply-ctl! enc OPUS_SET_VBR_CONSTRAINT_REQUEST (if (hash-ref/default settings 'constrained-vbr? #f) 1 0) 'opus-constrained-vbr) + (apply-ctl! enc OPUS_SET_COMPLEXITY_REQUEST (hash-ref/default settings 'complexity 10) 'opus-complexity) + (apply-ctl! enc OPE_SET_COMMENT_PADDING_REQUEST (hash-ref/default settings 'comment-padding 512) 'opus-comment-padding) + (when (hash-has-key? settings 'signal) + (apply-ctl! enc OPUS_SET_SIGNAL_REQUEST (signal->int (hash-ref settings 'signal)) 'opus-signal)) + (when (hash-has-key? settings 'lsb-depth) + (apply-ctl! enc OPUS_SET_LSB_DEPTH_REQUEST (hash-ref settings 'lsb-depth) 'opus-lsb-depth))) + + (define (add-comments! comments settings) + (when (hash-has-key? settings 'comments) + (let ((ch (hash-ref settings 'comments))) + (when (hash? ch) + (for-each (lambda (k) + (let ((v (hash-ref ch k))) + (when (string? v) + (check-ope 'opus-comment (ope_comments_add comments (string-upcase (symbol->string k)) v))))) + (hash-keys ch)))))) + + (define (opus-encoder-open output-file settings format) + (unless (opus-encoder-available?) (error 'opus-encoder-open "libopusenc could not be loaded")) + (let* ((file (if (path? output-file) (path->string output-file) output-file)) + (resolved (opus-encoder-prepare-settings settings format)) + (comments (ope_comments_create))) + (add-comments! comments resolved) + (let-values (((enc err) (ope_encoder_create_file file comments + (hash-ref resolved 'sample-rate) + (hash-ref resolved 'channels) + (hash-ref resolved 'family)))) + (unless enc (error 'opus-encoder-open "could not create Opus file ~a: ~a" file (opus-error-message err))) + (apply-settings! enc resolved) + (make-opus-encoder-handle enc comments resolved format file)))) + + (define (native-signed-ref bs start bytes) + (integer-bytes->integer bs #t (system-big-endian?) start (+ start bytes))) + + (define (sample->s16 sample in-bits) + (cond [(> in-bits 16) (arithmetic-shift sample (- 16 in-bits))] + [(< in-bits 16) (arithmetic-shift sample (- 16 in-bits))] + [else sample])) + + (define (write-s16-native! out offset sample) + (integer->integer-bytes sample 2 #t (system-big-endian?) out offset)) + + (define (pcm-bytes->s16 buffer size in-bits) + (let* ((in-bytes (quotient in-bits 8)) + (sample-count (quotient size in-bytes)) + (out (make-bytes (* sample-count 2)))) + (for ([i (in-range sample-count)]) + (let* ((in-off (* i in-bytes)) + (out-off (* i 2)) + (sample (native-signed-ref buffer in-off in-bytes))) + (write-s16-native! out out-off (sample->s16 sample in-bits)))) + out)) + + (define (opus-encoder-write handle buf-info buffer buf-len) + (let* ((settings (opus-encoder-handle-settings handle)) + (channels (hash-ref settings 'channels)) + (in-bits (hash-ref/default buf-info 'bits-per-sample 16)) + (pcm (if (= in-bits 16) buffer (pcm-bytes->s16 buffer buf-len in-bits))) + (frames (quotient (quotient (bytes-length pcm) 2) channels))) + (check-ope 'opus-encoder-write (ope_encoder_write (opus-encoder-handle-enc handle) pcm frames)) + frames)) + + (define (opus-encoder-finish handle) + (dynamic-wind + void + (lambda () (check-ope 'opus-encoder-finish (ope_encoder_drain (opus-encoder-handle-enc handle)))) + (lambda () + (ope_encoder_destroy (opus-encoder-handle-enc handle)) + (ope_comments_destroy (opus-encoder-handle-comments handle))))) + + ) ; end of module diff --git a/private/pcm-converter.rkt b/private/pcm-converter.rkt new file mode 100644 index 0000000..224021c --- /dev/null +++ b/private/pcm-converter.rkt @@ -0,0 +1,177 @@ +(module pcm-converter racket/base + + (require ffi/unsafe + "../ffmpeg-definitions.rkt") + + (provide pcm-conversion-needed? + make-pcm-converter + pcm-converter? + pcm-converter-input-format + pcm-converter-output-format + pcm-converter-convert + pcm-converter-drain + pcm-converter-close!) + + (define S32-BYTES 4) + + (define-struct pcm-converter (swr-ctx in-layout out-layout input-format output-format channels in-rate out-rate closed?) + #:mutable + #:constructor-name make-raw-pcm-converter) + + (define (hash-ref/default h k default) + (if (and (hash? h) (hash-has-key? h k)) (hash-ref h k) default)) + + (define (copy-hash h) + (let ((out (make-hash))) + (when (hash? h) + (for-each (lambda (k) (hash-set! out k (hash-ref h k))) (hash-keys h))) + out)) + + (define (native-signed-ref bs start bytes) + (integer-bytes->integer bs #t (system-big-endian?) start (+ start bytes))) + + (define (native-signed-set! bs start bytes value) + (integer->integer-bytes value bytes #t (system-big-endian?) bs start)) + + (define (clamp-s32 v) + (cond [(< v -2147483648) -2147483648] + [(> v 2147483647) 2147483647] + [else v])) + + (define (expand-sample-to-s32 sample in-bits) + (clamp-s32 (if (< in-bits 32) (arithmetic-shift sample (- 32 in-bits)) sample))) + + (define (pcm-bytes->s32-bytes buffer size in-bits) + (cond [(= in-bits 32) (if (= size (bytes-length buffer)) buffer (subbytes buffer 0 size))] + [else + (let* ((in-bytes (quotient in-bits 8)) + (sample-count (quotient size in-bytes)) + (out (make-bytes (* sample-count S32-BYTES)))) + (for ([i (in-range sample-count)]) + (let* ((in-off (* i in-bytes)) + (out-off (* i S32-BYTES)) + (sample (native-signed-ref buffer in-off in-bytes))) + (native-signed-set! out out-off S32-BYTES (expand-sample-to-s32 sample in-bits)))) + out)])) + + (define (bytes->native bs size) + (let ((p (malloc size 'atomic-interior))) + (memcpy p 0 bs 0 size) + p)) + + (define (native->bytes p size) + (let ((bs (make-bytes size))) + (memcpy bs 0 p 0 size) + bs)) + + (define (make-plane ptr) + (let ((planes (malloc _pointer 1 'atomic-interior))) + (ptr-set! planes _pointer 0 ptr) + planes)) + + (define (target-sample-rate settings input-format) + (hash-ref/default settings 'target-sample-rate + (hash-ref/default settings 'sample-rate + (hash-ref input-format 'sample-rate)))) + + (define (target-channels settings input-format) + (hash-ref/default settings 'target-channels + (hash-ref/default settings 'channels + (hash-ref input-format 'channels)))) + + (define (target-bits settings input-format) + (hash-ref/default settings 'target-bits-per-sample + (hash-ref/default settings 'bits-per-sample + (let ((bits (hash-ref/default input-format 'bits-per-sample 24))) + (if (and (integer? bits) (<= bits 24)) bits 24))))) + + (define (make-output-format input-format settings) + (let* ((out (copy-hash input-format)) + (in-rate (hash-ref input-format 'sample-rate)) + (out-rate (target-sample-rate settings input-format)) + (total (hash-ref/default input-format 'total-samples #f))) + (hash-set! out 'sample-rate out-rate) + (hash-set! out 'channels (target-channels settings input-format)) + (hash-set! out 'bits-per-sample (target-bits settings input-format)) + (hash-set! out 'pcm-bits-per-sample 32) + (hash-set! out 'type 'interleaved) + (hash-set! out 'endianness 'native-endian) + (when (and (integer? total) (>= total 0) (integer? in-rate) (> in-rate 0)) + (hash-set! out 'total-samples (inexact->exact (round (* total (/ out-rate in-rate)))))) + out)) + + (define (pcm-conversion-needed? input-format settings) + (let ((in-rate (hash-ref input-format 'sample-rate)) + (in-channels (hash-ref input-format 'channels)) + (out-rate (target-sample-rate settings input-format)) + (out-channels (target-channels settings input-format))) + (or (not (= in-rate out-rate)) + (not (= in-channels out-channels))))) + + (define (make-pcm-converter input-format settings) + (let* ((channels-in (hash-ref input-format 'channels)) + (channels-out (target-channels settings input-format)) + (rate-in (hash-ref input-format 'sample-rate)) + (rate-out (target-sample-rate settings input-format)) + (in-layout (ffmpeg-make-default-channel-layout channels-in)) + (out-layout (ffmpeg-make-default-channel-layout channels-out))) + (let-values (((ret ctx) (swr_alloc_set_opts2 #f + out-layout AV_SAMPLE_FMT_S32 rate-out + in-layout AV_SAMPLE_FMT_S32 rate-in + 0 #f))) + (when (< ret 0) (error 'make-pcm-converter "swr_alloc_set_opts2 failed: ~a" ret)) + (let ((ret-init (swr_init ctx))) + (when (< ret-init 0) (error 'make-pcm-converter "swr_init failed: ~a" ret-init)) + (make-raw-pcm-converter ctx in-layout out-layout input-format (make-output-format input-format settings) + channels-out rate-in rate-out #f))))) + + (define (ensure-open! c who) + (when (or (not (pcm-converter? c)) (pcm-converter-closed? c)) + (error who "PCM converter is closed"))) + + (define (convert* c in-bytes in-samples) + (let* ((channels (pcm-converter-channels c)) + (max-out-samples (swr_get_out_samples (pcm-converter-swr-ctx c) in-samples))) + (cond [(<= max-out-samples 0) (values #"" 0)] + [else + (let* ((out-size (* max-out-samples channels S32-BYTES)) + (out-ptr (malloc out-size 'atomic-interior)) + (out-planes (make-plane out-ptr)) + (in-ptr (and in-bytes (bytes->native in-bytes (bytes-length in-bytes)))) + (in-planes (and in-ptr (make-plane in-ptr))) + (out-samples (swr_convert (pcm-converter-swr-ctx c) out-planes max-out-samples in-planes in-samples))) + (when (< out-samples 0) (error 'pcm-converter-convert "swr_convert failed: ~a" out-samples)) + (values (native->bytes out-ptr (* out-samples channels S32-BYTES)) out-samples))]))) + + (define (pcm-converter-convert c buffer size buf-info) + (ensure-open! c 'pcm-converter-convert) + (let* ((in-bits (hash-ref/default buf-info 'bits-per-sample (hash-ref (pcm-converter-input-format c) 'bits-per-sample))) + (in-bytes (quotient in-bits 8)) + (in-channels (hash-ref (pcm-converter-input-format c) 'channels)) + (in-samples (quotient (quotient size in-bytes) in-channels)) + (s32 (pcm-bytes->s32-bytes buffer size in-bits))) + (convert* c s32 in-samples))) + + (define (pcm-converter-drain c) + (ensure-open! c 'pcm-converter-drain) + (let* ((ctx (pcm-converter-swr-ctx c)) + (delay (swr_get_delay ctx (pcm-converter-out-rate c))) + (channels (pcm-converter-channels c))) + (cond [(<= delay 0) (values #"" 0)] + [else + (let* ((out-size (* delay channels S32-BYTES)) + (out-ptr (malloc out-size 'atomic-interior)) + (out-planes (make-plane out-ptr)) + (out-samples (swr_convert ctx out-planes delay #f 0))) + (when (< out-samples 0) (error 'pcm-converter-drain "swr_convert drain failed: ~a" out-samples)) + (values (native->bytes out-ptr (* out-samples channels S32-BYTES)) out-samples))]))) + + (define (pcm-converter-close! c) + (when (and (pcm-converter? c) (not (pcm-converter-closed? c))) + (set-pcm-converter-swr-ctx! c (swr_free (pcm-converter-swr-ctx c))) + (ffmpeg-channel-layout-uninit! (pcm-converter-in-layout c)) + (ffmpeg-channel-layout-uninit! (pcm-converter-out-layout c)) + (set-pcm-converter-closed?! c #t)) + #t) + + ) ; end of module