286 lines
13 KiB
Racket
286 lines
13 KiB
Racket
(module resampler racket/base
|
|
|
|
(require ffi/unsafe
|
|
"soxr-ffi.rkt"
|
|
"private/utils.rkt")
|
|
|
|
(provide resampler-available?
|
|
resampler-version
|
|
make-resampler
|
|
resampler?
|
|
resampler-input-rate
|
|
resampler-output-rate
|
|
resampler-channels
|
|
resampler-input-format
|
|
resampler-output-format
|
|
resampler-convert
|
|
resampler-drain
|
|
resampler-clear!
|
|
resampler-close!
|
|
resample-bytes
|
|
pcm-format?
|
|
pcm-format-sample-bytes
|
|
pcm-format->soxr-datatype
|
|
quality->soxr-recipe)
|
|
|
|
(define-struct resampler
|
|
(ctx input-rate output-rate channels input-format output-format
|
|
soxr-input-format soxr-output-format input-sample-bytes output-sample-bytes closed?)
|
|
#:mutable
|
|
#:constructor-name make-raw-resampler)
|
|
|
|
(define (resampler-available?) (soxr-available?))
|
|
(define (resampler-version) (soxr-version))
|
|
|
|
(define (normalize-format fmt who)
|
|
(cond [(or (eq? fmt 's16) (eq? fmt 'int16) (eq? fmt 'int16-interleaved)) 's16]
|
|
[(or (eq? fmt 's24) (eq? fmt 'int24) (eq? fmt 'int24-interleaved)) 's24]
|
|
[(or (eq? fmt 's32) (eq? fmt 'int32) (eq? fmt 'int32-interleaved)) 's32]
|
|
[(or (eq? fmt 'float32) (eq? fmt 'f32) (eq? fmt 'float)) 'float32]
|
|
[(or (eq? fmt 'float64) (eq? fmt 'f64) (eq? fmt 'double)) 'float64]
|
|
[else (raise-argument-error who "(or/c 's16 's24 's32 'float32 'float64)" fmt)]))
|
|
|
|
(define (pcm-format? fmt)
|
|
(with-handlers ([exn:fail? (lambda (e) #f)])
|
|
(normalize-format fmt 'pcm-format?)
|
|
#t))
|
|
|
|
(define (pcm-format-sample-bytes fmt)
|
|
(case (normalize-format fmt 'pcm-format-sample-bytes)
|
|
[(s16) 2]
|
|
[(s24) 3]
|
|
[(s32 float32) 4]
|
|
[(float64) 8]))
|
|
|
|
(define (pcm-format-actual-sample-bytes fmt)
|
|
;; SoXR has no packed 24-bit datatype. The wrapper expands s24 to s32
|
|
;; before processing and packs s32 back to s24 afterwards when requested.
|
|
(case (normalize-format fmt 'pcm-format-actual-sample-bytes)
|
|
[(s24) 4]
|
|
[else (pcm-format-sample-bytes fmt)]))
|
|
|
|
(define (pcm-format->soxr-datatype fmt)
|
|
(case (normalize-format fmt 'pcm-format->soxr-datatype)
|
|
[(s16) SOXR_INT16_I]
|
|
[(s24 s32) SOXR_INT32_I]
|
|
[(float32) SOXR_FLOAT32_I]
|
|
[(float64) SOXR_FLOAT64_I]))
|
|
|
|
(define (quality->soxr-recipe q)
|
|
;; The '*-bitq' recipes are resampling precision recipes; they do not mean
|
|
;; that the PCM output is 16/24/32-bit. Output format is controlled by
|
|
;; #:output-format.
|
|
(cond [(integer? q) q]
|
|
[(or (eq? q 'qq) (eq? q 'quick)) SOXR_QQ]
|
|
[(or (eq? q 'lq) (eq? q 'low)) SOXR_LQ]
|
|
[(or (eq? q 'mq) (eq? q 'medium)) SOXR_MQ]
|
|
[(or (eq? q 'hq) (eq? q 'high)) SOXR_HQ]
|
|
[(or (eq? q 'vhq) (eq? q 'very-high)) SOXR_VHQ]
|
|
[(eq? q '16-bit) SOXR_16_BITQ]
|
|
[(eq? q '20-bit) SOXR_20_BITQ]
|
|
[(eq? q '24-bit) SOXR_24_BITQ]
|
|
[(eq? q '28-bit) SOXR_28_BITQ]
|
|
[(eq? q '32-bit) SOXR_32_BITQ]
|
|
[else (raise-argument-error 'quality->soxr-recipe
|
|
"(or/c 'qq 'lq 'mq 'hq 'vhq '16-bit '20-bit '24-bit '28-bit '32-bit exact-integer?)" q)]))
|
|
|
|
(define (phase->flags phase)
|
|
(cond [(or (eq? phase 'linear) (eq? phase #f)) SOXR_LINEAR_PHASE]
|
|
[(or (eq? phase 'intermediate) (eq? phase 'medium)) SOXR_INTERMEDIATE_PHASE]
|
|
[(or (eq? phase 'minimum) (eq? phase 'min)) SOXR_MINIMUM_PHASE]
|
|
[else (raise-argument-error 'make-resampler "(or/c 'linear 'intermediate 'minimum)" phase)]))
|
|
|
|
(define (check-error who err)
|
|
(when err (error who "~a" err)))
|
|
|
|
(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 (native-signed-ref bs start bytes)
|
|
(int-bytes->integer bs #t (system-big-endian?) start (+ start bytes)))
|
|
|
|
(define (native-signed-set! bs start bytes value)
|
|
(integer->int-bytes value bytes #t (system-big-endian?) bs start))
|
|
|
|
(define (clamp-s32 v)
|
|
(cond [(< v -2147483648) -2147483648]
|
|
[(> v 2147483647) 2147483647]
|
|
[else v]))
|
|
|
|
(define (clamp-s24 v)
|
|
(cond [(< v -8388608) -8388608]
|
|
[(> v 8388607) 8388607]
|
|
[else v]))
|
|
|
|
(define (s24-bytes->s32-bytes buffer size)
|
|
(let* ((sample-count (quotient size 3))
|
|
(out (make-bytes (* sample-count 4))))
|
|
(for ([i (in-range sample-count)])
|
|
(let* ((in-off (* i 3))
|
|
(out-off (* i 4))
|
|
(sample (native-signed-ref buffer in-off 3)))
|
|
(native-signed-set! out out-off 4 (clamp-s32 (arithmetic-shift sample 8)))))
|
|
out))
|
|
|
|
(define (s32-bytes->s24-bytes buffer size)
|
|
(let* ((sample-count (quotient size 4))
|
|
(out (make-bytes (* sample-count 3))))
|
|
(for ([i (in-range sample-count)])
|
|
(let* ((in-off (* i 4))
|
|
(out-off (* i 3))
|
|
(sample (native-signed-ref buffer in-off 4)))
|
|
(native-signed-set! out out-off 3 (clamp-s24 (arithmetic-shift sample -8)))))
|
|
out))
|
|
|
|
(define (subbytes/size bs size)
|
|
(if (= size (bytes-length bs)) bs (subbytes bs 0 size)))
|
|
|
|
(define (prepare-input-bytes r buffer size)
|
|
(case (resampler-input-format r)
|
|
[(s24) (s24-bytes->s32-bytes buffer size)]
|
|
[else (subbytes/size buffer size)]))
|
|
|
|
(define (finish-output-bytes r buffer size)
|
|
(case (resampler-output-format r)
|
|
[(s24) (s32-bytes->s24-bytes buffer size)]
|
|
[else (subbytes/size buffer size)]))
|
|
|
|
(define (output-frame-capacity r in-frames)
|
|
(let* ((ratio (/ (resampler-output-rate r) (resampler-input-rate r)))
|
|
(delay (if (resampler-ctx r) (max 0.0 (soxr-delay (resampler-ctx r))) 0.0))
|
|
(n (ceiling (+ 256 delay (* in-frames ratio)))))
|
|
(max 256 (inexact->exact n))))
|
|
|
|
(define (make-resampler input-rate output-rate channels
|
|
#:input-format [input-format 's32]
|
|
#:output-format [output-format 's32]
|
|
#:quality [quality 'hq]
|
|
#:phase [phase 'linear]
|
|
#:steep-filter? [steep-filter? #f]
|
|
#:scale [scale 1.0]
|
|
#:no-dither? [no-dither? #f]
|
|
#:num-threads [num-threads 1])
|
|
(unless (resampler-available?)
|
|
(error 'make-resampler "libsoxr is not available"))
|
|
(unless (and (integer? channels) (> channels 0))
|
|
(raise-argument-error 'make-resampler "exact-positive-integer?" channels))
|
|
(let* ((in-fmt (normalize-format input-format 'make-resampler))
|
|
(out-fmt (normalize-format output-format 'make-resampler))
|
|
(itype (pcm-format->soxr-datatype in-fmt))
|
|
(otype (pcm-format->soxr-datatype out-fmt))
|
|
(io-flags (if no-dither? SOXR_NO_DITHER 0))
|
|
(quality-flags (bitwise-ior (phase->flags phase) (if steep-filter? SOXR_STEEP_FILTER 0)))
|
|
(io-spec (soxr-io-spec itype otype #:scale scale #:flags io-flags))
|
|
(quality-spec (soxr-quality-spec (quality->soxr-recipe quality) #:flags quality-flags))
|
|
(runtime-spec (soxr-runtime-spec #:num-threads num-threads)))
|
|
(let-values (((ctx err) (soxr-create input-rate output-rate channels
|
|
#:io-spec io-spec
|
|
#:quality-spec quality-spec
|
|
#:runtime-spec runtime-spec)))
|
|
(check-error 'make-resampler err)
|
|
(unless ctx (error 'make-resampler "libsoxr returned no resampler context"))
|
|
(make-raw-resampler ctx input-rate output-rate channels in-fmt out-fmt itype otype
|
|
(pcm-format-actual-sample-bytes in-fmt)
|
|
(pcm-format-actual-sample-bytes out-fmt)
|
|
#f))))
|
|
|
|
(define (ensure-open! r who)
|
|
(when (or (not (resampler? r)) (resampler-closed? r))
|
|
(error who "resampler is closed")))
|
|
|
|
(define (check-frame-size who size frame-bytes)
|
|
(unless (= (remainder size frame-bytes) 0)
|
|
(error who "buffer size ~a is not a whole number of interleaved frames of ~a bytes" size frame-bytes)))
|
|
|
|
(define (resampler-convert r buffer [size (bytes-length buffer)])
|
|
(ensure-open! r 'resampler-convert)
|
|
(let* ((nominal-in-frame-bytes (* (resampler-channels r) (pcm-format-sample-bytes (resampler-input-format r))))
|
|
(actual-in-frame-bytes (* (resampler-channels r) (resampler-input-sample-bytes r))))
|
|
(check-frame-size 'resampler-convert size nominal-in-frame-bytes)
|
|
(cond [(zero? size) (values #"" 0)]
|
|
[else
|
|
(let* ((in-frames (quotient size nominal-in-frame-bytes))
|
|
(prepared (prepare-input-bytes r buffer size))
|
|
(in-ptr0 (bytes->native prepared (bytes-length prepared))))
|
|
(let loop ((offset-frames 0) (remaining in-frames) (pieces '()) (total-frames 0))
|
|
(cond [(zero? remaining) (values (apply bytes-append (reverse pieces)) total-frames)]
|
|
[else
|
|
(let* ((out-cap (output-frame-capacity r remaining))
|
|
(out-size (* out-cap (resampler-channels r) (resampler-output-sample-bytes r)))
|
|
(out-ptr (malloc out-size 'atomic-interior))
|
|
(in-ptr (ptr-add in-ptr0 (* offset-frames actual-in-frame-bytes))))
|
|
(let-values (((err idone odone) (soxr-process (resampler-ctx r) in-ptr remaining out-ptr out-cap)))
|
|
(check-error 'resampler-convert err)
|
|
(when (and (> remaining 0) (zero? idone) (zero? odone))
|
|
(error 'resampler-convert "libsoxr made no progress"))
|
|
(let* ((raw-size (* odone (resampler-channels r) (resampler-output-sample-bytes r)))
|
|
(raw (native->bytes out-ptr raw-size))
|
|
(piece (finish-output-bytes r raw raw-size)))
|
|
(loop (+ offset-frames idone) (- remaining idone)
|
|
(if (zero? odone) pieces (cons piece pieces))
|
|
(+ total-frames odone)))))])))])))
|
|
|
|
(define (resampler-drain r)
|
|
(ensure-open! r 'resampler-drain)
|
|
(let loop ((pieces '()) (total-frames 0))
|
|
(let* ((delay (max 0.0 (soxr-delay (resampler-ctx r))))
|
|
(out-cap (max 4096 (inexact->exact (ceiling (+ delay 256)))))
|
|
(out-size (* out-cap (resampler-channels r) (resampler-output-sample-bytes r)))
|
|
(out-ptr (malloc out-size 'atomic-interior)))
|
|
(let-values (((err idone odone) (soxr-process (resampler-ctx r) #f 0 out-ptr out-cap)))
|
|
(check-error 'resampler-drain err)
|
|
(cond [(zero? odone) (values (apply bytes-append (reverse pieces)) total-frames)]
|
|
[else
|
|
(let* ((raw-size (* odone (resampler-channels r) (resampler-output-sample-bytes r)))
|
|
(raw (native->bytes out-ptr raw-size))
|
|
(piece (finish-output-bytes r raw raw-size)))
|
|
(loop (cons piece pieces) (+ total-frames odone)))])))))
|
|
|
|
(define (resampler-clear! r)
|
|
(ensure-open! r 'resampler-clear!)
|
|
(check-error 'resampler-clear! (soxr-clear (resampler-ctx r)))
|
|
#t)
|
|
|
|
(define (resampler-close! r)
|
|
(when (and (resampler? r) (not (resampler-closed? r)))
|
|
(soxr-delete (resampler-ctx r))
|
|
(set-resampler-ctx! r #f)
|
|
(set-resampler-closed?! r #t))
|
|
#t)
|
|
|
|
(define (resample-bytes buffer input-rate output-rate channels
|
|
#:size [size (bytes-length buffer)]
|
|
#:input-format [input-format 's32]
|
|
#:output-format [output-format 's32]
|
|
#:quality [quality 'hq]
|
|
#:phase [phase 'linear]
|
|
#:steep-filter? [steep-filter? #f]
|
|
#:scale [scale 1.0]
|
|
#:no-dither? [no-dither? #f]
|
|
#:num-threads [num-threads 1])
|
|
(let ((r (make-resampler input-rate output-rate channels
|
|
#:input-format input-format
|
|
#:output-format output-format
|
|
#:quality quality
|
|
#:phase phase
|
|
#:steep-filter? steep-filter?
|
|
#:scale scale
|
|
#:no-dither? no-dither?
|
|
#:num-threads num-threads)))
|
|
(dynamic-wind
|
|
void
|
|
(lambda ()
|
|
(let-values (((a af) (resampler-convert r buffer size)))
|
|
(let-values (((b bf) (resampler-drain r)))
|
|
(values (bytes-append a b) (+ af bf)))))
|
|
(lambda () (resampler-close! r)))))
|
|
|
|
) ; end of module
|