From 92227133ff2c91618918c7d3664e878d165c71e3 Mon Sep 17 00:00:00 2001 From: Hans Dijkema Date: Sun, 3 May 2026 10:13:28 +0200 Subject: [PATCH] racket version of async C backend --- audio-decoder.rkt | 2 +- flac-decoder.rkt | 76 ++- libao-async-ffi-racket.rkt | 1010 ++++++++++++++++++++++++++++++++++++ libao.rkt | 2 +- play-test.rkt | 30 +- 5 files changed, 1090 insertions(+), 30 deletions(-) create mode 100644 libao-async-ffi-racket.rkt diff --git a/audio-decoder.rkt b/audio-decoder.rkt index 1b748e4..38edffb 100644 --- a/audio-decoder.rkt +++ b/audio-decoder.rkt @@ -43,7 +43,7 @@ flac-read flac-seek flac-stop - 'flac)) + 'ao)) ;; MP3 (hash-set! audio-readers diff --git a/flac-decoder.rkt b/flac-decoder.rkt index fa8f04b..ca5a537 100644 --- a/flac-decoder.rkt +++ b/flac-decoder.rkt @@ -43,25 +43,70 @@ (define kinds (make-hash)) (define last-buffer #f) (define last-buf-len #f) + + (define (endian-little? e) + (cond [(eq? e 'little-endian) #t] + [(eq? e 'big-endian) #f] + [(eq? e 'native-endian) (not (system-big-endian?))] + [else (error (format "unknown endian value: ~a" e))])) + + (define (flac-channels->interleaved-buffer buffer block-size channels bits endianness) + (let* ([bytes (quotient bits 8)] + [little? (endian-little? endianness)] + [buf-size (* block-size channels bytes)] + [mem-out (malloc buf-size 'atomic)] + [out-pos 0]) + + (for ([k (in-range block-size)]) + (for ([channel (in-range channels)]) + (let* ([channel-ptr (ptr-ref buffer _pointer channel)] + [sample (ptr-ref channel-ptr _int32 k)]) + + (if little? + (for ([j (in-range bytes)]) + (ptr-set! mem-out _uint8 (+ out-pos j) + (bitwise-and + (arithmetic-shift sample (* -8 j)) + #xff))) + (for ([j (in-range bytes)]) + (ptr-set! mem-out _uint8 (+ out-pos j) + (bitwise-and + (arithmetic-shift sample + (* -8 (- bytes j 1))) + #xff)))) + + (set! out-pos (+ out-pos bytes))))) + + (list mem-out buf-size))) (define (process-frame handle frame buffer) - (let* ((h (flac-ffi-frame-header frame)) - (cb-audio (flac-handle-cb-audio handle)) - (ffi (flac-handle-ffi-decoder-handler handle)) - (type (hash-ref h 'number-type)) - (channels (hash-ref h 'channels)) - (block-size (hash-ref h 'blocksize))) + (let* ([h (flac-ffi-frame-header frame)] + [cb-audio (flac-handle-cb-audio handle)] + [type (hash-ref h 'number-type)] + [channels (hash-ref h 'channels)] + [block-size (hash-ref h 'blocksize)] + [bits (hash-ref h 'bits-per-sample)] + [endianness 'native-endian] + [result (flac-channels->interleaved-buffer + buffer block-size channels bits endianness)] + [mem-out (car result)] + [buf-size (cadr result)]) + (hash-set! h 'duration (flac-duration handle)) - (let ((sample (hash-ref h 'number))) - (hash-set! h 'sample sample)) - (set! last-buffer buffer) - (set! last-buf-len block-size) + (hash-set! h 'sample (hash-ref h 'number)) + (hash-set! h 'type 'interleaved) + (hash-set! h 'endianness endianness) + (hash-set! h 'bits-per-sample bits) + + (set! last-buffer mem-out) + (set! last-buf-len buf-size) + (hash-set! kinds type #t) + (when (procedure? cb-audio) - (cb-audio h buffer block-size)) - ) - #t - ) + (cb-audio h mem-out buf-size)) + + #t)) (define (process-meta handle meta) (let ((type (FLAC__StreamMetadata-type meta))) @@ -74,13 +119,14 @@ (hash-ref mh 'min-framesize) (hash-ref mh 'max-framesize) (hash-ref mh 'sample-rate) (hash-ref mh 'channels) - (hash-ref mh 'bits-per-sample) + 32 ; (hash-ref mh 'bits-per-sample) (hash-ref mh 'total-samples)))) (let ((duration (exact->inexact (/ (hash-ref mh 'total-samples) (hash-ref mh 'sample-rate))))) (hash-set! mh 'duration duration)) (set-flac-handle-stream-info! handle si) + (hash-set! mh 'bits-per-sample 32) ; Flac works internally 32 bits. (let ((cb (flac-handle-cb-stream-info handle))) (when (procedure? cb) (cb mh)))))) diff --git a/libao-async-ffi-racket.rkt b/libao-async-ffi-racket.rkt new file mode 100644 index 0000000..56b4d0d --- /dev/null +++ b/libao-async-ffi-racket.rkt @@ -0,0 +1,1010 @@ +#lang racket/base + +;; Pure Racket replacement for ao_playasync.c as used by libao.rkt. +;; +;; This module exports the same Racket API as libao-async-ffi.rkt, but it +;; calls Xiph libao directly and uses a Racket worker thread instead of the +;; C queue/thread backend. + +(define AO-ASYNC-VERSION 3) + +(require ffi/unsafe + ffi/unsafe/define + ffi/unsafe/custodian + racket/async-channel + data/queue + "private/utils.rkt") + +(provide ao_version_async + ao_create_async + ao_real_output_bits_async + ao_stop_async + ao_play_async + ao_is_at_music_id_async + ao_is_at_second_async + ao_music_duration_async + ao_bufsize_async + ao_clear_async + ao_pause_async + ao_set_volume_async + ao_volume_async + make-buffer-info + make-BufferInfo_t + ) + +;; ------------------------------------------------------------------------- +;; Public structs and enums: keep these equal to the old FFI module. + +(define _Endian_t + (_enum '(little-endian = 1 + big-endian = 2 + native-endian = 4))) + +(define-struct buffer-info + (type ; 'interleaved (old: 'ao) or 'planar (old: 'flac) + sample-bits + sample-rate + channels + endianness + ) + #:mutable + #:transparent + ) + +(define make-BufferInfo_t make-buffer-info) + +;; ------------------------------------------------------------------------- +;; Direct libao FFI. + +(define libao + (get-lib (list (case (system-type 'os) + [(windows) "libao-1.2.2"] + [else "ao"])) '(#f))) + +(define-ffi-definer define-ao libao) + +(define _ao-device (_cpointer 'ao-device)) +(define _ao-option (_cpointer/null 'ao-option)) + +(define-cstruct _ao_sample_format + ([bits _int] + [rate _int] + [channels _int] + [byte_format _Endian_t] + [matrix _string*/utf-8])) + +(define-ao ao_initialize (_fun -> _void)) +(define-ao ao_shutdown (_fun -> _void)) +(define-ao ao_default_driver_id (_fun -> _int)) +(define-ao ao_driver_id (_fun _string/utf-8 -> _int)) +(define-ao ao_open_live (_fun _int _ao_sample_format-pointer _ao-option -> _ao-device)) +(define-ao ao_open_file (_fun _int _string/utf-8 _int _ao_sample_format-pointer _ao-option -> _ao-device)) +(define-ao ao_close (_fun _ao-device -> _int)) + +;; ao_play can block until the device accepts more data. Mark it as blocking +;; so other Racket places/threads are not needlessly held up by the foreign +;; call. This is the important part that makes the C backend much less useful. +(define-ao ao_play + ;(_fun #:blocking? #t _ao-device _pointer _uint32 -> _int)) + (_fun _ao-device _pointer _uint32 -> _int)) + +;; ------------------------------------------------------------------------- +;; Mutex stuff +;; ------------------------------------------------------------------------- + +(define (make-mutex) + (let ((sem (make-semaphore))) + (semaphore-post sem) + sem)) + +(define (mutex-lock sem) + (semaphore-wait sem)) + +(define (mutex-unlock sem) + (semaphore-post sem)) + +;; ------------------------------------------------------------------------- +;; Async handle etc. +;; ------------------------------------------------------------------------- + +(define (command? x) + (or (eq? x 'play) (eq? x 'stop))) + +(define-struct queue-elem + (command + buf + buflen + at-second + music-duration + music-id + )) + + +(define-struct ao-handle + (queue + paused + + ao-device + requested-bits-per-sample + dev-bits-per-sample + dev-endianness + dev-channels + dev-rate + + mutex + pause-mutex + clear-mutex + play-thread + + at-second + music-duration + music-id + buf-size + volume-in-10000 + + valid + ) + #:mutable + ) + +(define (get h ms-wait) + (let ((el (if (<= ms-wait 0) + (sync/timeout 0 (ao-handle-queue h)) + (sync/timeout (/ ms-wait 1000.0) (ao-handle-queue h) )))) + (unless (eq? el #f) + (set-ao-handle-buf-size! h (- (ao-handle-buf-size h) (queue-elem-buflen el)))) + el)) + +(define (add h elem) + (set-ao-handle-buf-size! h (+ (ao-handle-buf-size h) (queue-elem-buflen elem))) + (async-channel-put (ao-handle-queue h) elem) + ) + +(define (new-elem command music-id at-second music-duration buflen buf) + (let ((new-buf (malloc buflen 'atomic))) + (memcpy new-buf buf buflen) + (make-queue-elem command new-buf buflen at-second music-duration music-id))) + +(define (del-elem elem) + ; does nothing + #t) + +(define (clear h) + (let ((count 0) + (el (get h 0))) + (mutex-lock (ao-handle-clear-mutex h)) + (while (not (eq? el #f)) + (del-elem el) + (set! count (+ count 1)) + (set! el (get h 0))) + (mutex-unlock (ao-handle-clear-mutex h)) + (dbg-sound "~a elements cleared" count) + ) + ) + +(define-syntax system-little-endian? + (syntax-rules () + ((_) (not (system-big-endian?))))) + +(define (is-little-endian? e) + (cond [(eq? e 'little-endian) #t] + [(eq? e 'big-endian) #f] + [(eq? e 'native-endian) (system-little-endian?)] + [else (error 'convert-bits "unknown endian value: ~a" e)])) + + +(define (endian-eq? a b) + (let ((le-a (is-little-endian? a)) + (le-b (is-little-endian? b))) + (eq? le-a le-b))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Converters +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Volume + +#| +(define (adjust-volume h buf buf-size volume-in-10000) + (let* ((bytes-per-sample (ao-handle-dev-bits-per-sample h)) + (endianness (ao-handle-dev-endianness h)) + (i 0) + (sample 0) + (sample32 #f) + (k 0) + (little-endian (if (eq? endianness 'little-endian) + #t + (if (eq? endianness 'native-endian) + (system-little-endian?) + #f))) + ) + (while (< i buf-size) + (if little-endian + (begin + (set! sample (if (> (ptr-ref buf _uint8 (- i 1)) 127) + -1 + 0)) + (set! k (- (+ bytes-per-sample i) 1)) + (while (>= k i) + (set! sample (bitwise-ior (arithmetic-shift sample 8) + (ptr-ref buf _uint8 k))) + (set! k (- k 1))) + ) + (begin + (set! sample (if (> (ptr-ref buf _uint8 i) 127) + -1 + 0)) + (set! k i) + (while (< k (+ i bytes-per-sample)) + (set! sample (bitwise-ior (arithmetic-shift sample 8) + (ptr-ref buf _uint8 k))) + (set! k (+ k 1))) + )) + (set! sample (round (inexact->exact (/ (* sample volume-in-10000) 10000)))) + (set! sample32 (integer->integer-bytes sample 4 #f (not little-endian))) + (set! k 0) + (while (< k bytes-per-sample) + (ptr-set! buf _uint8 (+ i k) (bytes-ref sample32 k)) + (set! k (+ k 1))) + + (set! i (+ i bytes-per-sample)) + ) + ) + ) +|# + +(define (adjust-volume h buf buf-size volume-in-10000) + (let* ((bits (ao-handle-dev-bits-per-sample h)) + (bytes-per-sample (arithmetic-shift bits -3)) + (endianness (ao-handle-dev-endianness h)) + (little-endian? (if (eq? endianness 'little-endian) + #t + (if (eq? endianness 'native-endian) + (system-little-endian?) + #f))) + (sample 0) + ) + + (for ([i (in-range 0 buf-size bytes-per-sample)]) + + ;; read signed sample + (set! sample + (if little-endian? + (let ([last (+ i bytes-per-sample -1)]) + (let loop ([k last] + [s (if (> (ptr-ref buf _uint8 last) 127) -1 0)]) + (if (< k i) + s + (loop (sub1 k) + (bitwise-ior + (arithmetic-shift s 8) + (ptr-ref buf _uint8 k)))))) + (let ([first i]) + (let loop ([k first] + [s (if (> (ptr-ref buf _uint8 first) 127) -1 0)]) + (if (= k (+ i bytes-per-sample)) + s + (loop (add1 k) + (bitwise-ior + (arithmetic-shift s 8) + (ptr-ref buf _uint8 k)))))))) + + ;; scale + (set! sample (quotient (* sample volume-in-10000) 10000)) + + ;; write signed sample back + (if little-endian? + (let loop ([k i] + [s sample]) + (unless (= k (+ i bytes-per-sample)) + (ptr-set! buf _uint8 k (bitwise-and s #xff)) + (loop (add1 k) (arithmetic-shift s -8)))) + (let loop ([k (+ i bytes-per-sample -1)] + [s sample]) + (unless (< k i) + (ptr-set! buf _uint8 k (bitwise-and s #xff)) + (loop (sub1 k) (arithmetic-shift s -8)))))) + + ) + #t + ) + +;;; planar -> intereleaved + +(define (planar-to-interleaved mem buf-size info) + (let* ([type (buffer-info-type info)] + [bits (buffer-info-sample-bits info)] + [channels (buffer-info-channels info)] + [bytes (arithmetic-shift bits -3)] + [out-size buf-size] + [mem-out (malloc out-size 'atomic)]) + + (unless (or (eq? type 'planar) (eq? type 'flac)) + (error (format "expected planar buffer, got: ~a" type))) + + (unless (zero? (remainder buf-size (* channels bytes))) + (error (format "buffer size ~a is not aligned to ~a channels of ~a-bit samples" + buf-size channels bits))) + + (let* ([samples-total (quotient buf-size bytes)] + [samples-per-channel (quotient samples-total channels)] + [plane-size (* samples-per-channel bytes)]) + + (dbg-sound "~a ~a ~a ~a ~a" bits bytes buf-size samples-total samples-per-channel) + + ;; Input: + ;; C0[0] C0[1] ... C0[n] + ;; C1[0] C1[1] ... C1[n] + ;; + ;; Output: + ;; C0[0] C1[0] ... Ck[0] + ;; C0[1] C1[1] ... Ck[1] + ;; + (for ([sample-index (in-range samples-per-channel)]) + (for ([channel (in-range channels)]) + (let* ([in-pos (+ (* channel plane-size) + (* sample-index bytes))] + [out-pos (* (+ (* sample-index channels) + channel) + bytes)]) + (for ([b (in-range bytes)]) + (ptr-set! mem-out _uint8 (+ out-pos b) + (ptr-ref mem _uint8 (+ in-pos b))))))) + + (list mem-out out-size)))) + + +;;; requested bits to device bits + +(define (convert-bits buf buf-size in-bits in-endianness out-bits out-endianness) + (let* ([in-bytes (arithmetic-shift in-bits -3)] + [out-bytes (arithmetic-shift out-bits -3)] + [samples (quotient buf-size in-bytes)] + [out-size (* samples out-bytes)] + [out-buf (malloc out-size 'atomic)] + [shift (- out-bits in-bits)] + [in-little? (is-little-endian? in-endianness)] + [out-little? (is-little-endian? out-endianness)]) + + (for ([n (in-range samples)]) + (let* ([in-pos (* n in-bytes)] + [out-pos (* n out-bytes)] + [sample + (if in-little? + (let* ([last (+ in-pos in-bytes -1)] + [sign (if (> (ptr-ref buf _uint8 last) 127) -1 0)]) + (let loop ([k last] [s sign]) + (if (< k in-pos) + s + (loop (sub1 k) + (bitwise-ior + (arithmetic-shift s 8) + (ptr-ref buf _uint8 k)))))) + (let* ([first in-pos] + [sign (if (> (ptr-ref buf _uint8 first) 127) -1 0)]) + (let loop ([k first] [s sign]) + (if (= k (+ in-pos in-bytes)) + s + (loop (add1 k) + (bitwise-ior + (arithmetic-shift s 8) + (ptr-ref buf _uint8 k)))))))] + [converted (arithmetic-shift sample shift)]) + + (if out-little? + (let loop ([k out-pos] [s converted]) + (unless (= k (+ out-pos out-bytes)) + (ptr-set! out-buf _uint8 k (bitwise-and s #xff)) + (loop (add1 k) (arithmetic-shift s -8)))) + (let loop ([k (+ out-pos out-bytes -1)] [s converted]) + (unless (< k out-pos) + (ptr-set! out-buf _uint8 k (bitwise-and s #xff)) + (loop (sub1 k) (arithmetic-shift s -8))))))) + + (list out-buf out-size))) + + + +(define (convert-req-bits-to-dev-bits h mem buf-size info) + (if (and (= (buffer-info-sample-bits info) (ao-handle-dev-bits-per-sample h)) + (endian-eq? (buffer-info-endianness info) (ao-handle-dev-endianness h))) + (list mem buf-size) + (begin + (dbg-sound "Converting info bits to dev bits: ~a ~a ~a ~a" + (buffer-info-sample-bits info) + (ao-handle-dev-bits-per-sample h) + (buffer-info-endianness info) + (ao-handle-dev-endianness h) + ) + + (convert-bits mem buf-size + (buffer-info-sample-bits info) + (buffer-info-endianness info) + (ao-handle-dev-bits-per-sample h) + (ao-handle-dev-endianness h) + ) + ) + ) + ) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ASync player +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (run h) + (thread + (λ () + (let ((go-on #t)) + (while go-on + (mutex-lock (ao-handle-pause-mutex h)) + (mutex-unlock (ao-handle-pause-mutex h)) + (mutex-lock (ao-handle-clear-mutex h)) + (let ((elem (get h 250))) + (mutex-unlock (ao-handle-clear-mutex h)) + (if (eq? elem #f) + (sleep 0.005) + (begin + (set-ao-handle-at-second! h (queue-elem-at-second elem)) + (set-ao-handle-music-duration! h (queue-elem-music-duration elem)) + (set-ao-handle-music-id! h (queue-elem-music-id elem)) + + (unless (= (ao-handle-volume-in-10000 h) 10000) + (adjust-volume h (queue-elem-buf elem) (queue-elem-buflen elem) + (ao-handle-volume-in-10000 h))) + + (if (eq? (queue-elem-command elem) 'stop) + (set! go-on #f) + (ao_play (ao-handle-ao-device h) + (queue-elem-buf elem) (queue-elem-buflen elem))) + + (del-elem elem) + )) + ) + ) + ) + ) + #:pool 'own + ) + ) + + +(define init #f) +(define (init-ao) + (when (eq? init #f) + (set! init #t) + (ao_initialize) + (register-finalizer-and-custodian-shutdown + init + (λ (v) + (ao_shutdown)) + #:at-exit? #t + ) + ) + ) + + +(define (try-open-device bits rate channels byte-format wav-output-file) + (let ((candidates (make-vector 3 bits)) + (n 1) + (result #f)) + + (when (> bits 24) + (vector-set! candidates n 24) + (set! n (+ n 1))) + + (when (> bits 16) + (vector-set! candidates n 16) + (set! n (+ n 1))) + + (let ((i 0)) + (while (< i n) + (let* ((fmt (make-ao_sample_format (vector-ref candidates i) + rate + channels + byte-format + #f)) + (driver-id (if (eq? wav-output-file #f) + (ao_default_driver_id) + (ao_driver_id "wav"))) + (dev (if (eq? wav-output-file #f) + (ao_open_live driver-id fmt #f) + (ao_open_file driver-id wav-output-file 1 fmt #f))) + ) + + (unless (eq? dev #f) + (set! result (list dev (vector-ref candidates i))) + (set! i n) + ) + ) + ) + ) + + (if (eq? result #f) + (list #f 0) + result) + ) + ) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; API +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (ao_version_async) + AO-ASYNC-VERSION) + +(define (ao_create_async bits rate channels byte-format wav-output-file) + (init-ao) + + (let ((handle (make-ao-handle + (make-async-channel) ; queue + #f ; paused + + #f ; ao-device + bits ; requested-bits-per-sample + 0 ; device bits per sample + 'little-endian ; dev-endianness + channels ; dev-channels + rate ; dev-rate + + (make-mutex) ; mutex + (make-mutex) ; pause-mutex + (make-mutex) ; clear-mutex + + #f ; play-thread + + 0.0 ; at-second + 0.0 ; music-duration + 0 ; music-id + + 0 ; total buf size + 10000 ; volume-in-10000 + + #t ; valid handle + ))) + + (let ((ao-dev-bits (try-open-device bits rate channels byte-format wav-output-file))) + (set-ao-handle-ao-device! handle (car ao-dev-bits)) + (set-ao-handle-dev-bits-per-sample! handle (cadr ao-dev-bits)) + + (if (eq? (car ao-dev-bits) #f) + (begin + (err-sound "Cannot open ao-device") + #f) + (begin + (set-ao-handle-play-thread! handle (run handle)) + handle) + ) + ) + ) + ) + +(define (ao_stop_async h) + (unless (ao-handle-valid h) + (error "Not a valid ao handle")) + + (dbg-sound "Stopping ao-async, calling clear") + (clear h) + (dbg-sound "Queue cleared") + + (when (ao-handle-paused h) + (mutex-unlock (ao-handle-pause-mutex h))) + + (let ((elem (new-elem 'stop 0 0.0 0.0 0 #f))) + (add h elem)) + + (dbg-sound "Stop command queued") + + (thread-wait (ao-handle-play-thread h)) + (dbg-sound "Play thread stopped") + + (ao_close (ao-handle-ao-device h)) + (dbg-sound "AO Device closed") + + (set-ao-handle-valid! h #f) + h + ) + +(define (ao_play_async h music-id at-second music-duration buf-size mem info) + (let ((type (buffer-info-type info))) + + (when (or (eq? type 'planar) (eq? type 'flac)) + (dbg-sound "Converting from planar to interleaved") + (let ((m (planar-to-interleaved mem buf-size info))) + (set! mem (car m)) + (set! buf-size (cadr m))) + ) + + (let ((ao-size buf-size) + (ao-mem mem)) + (let ((m (convert-req-bits-to-dev-bits h mem buf-size info))) + (set! ao-mem (car m)) + (set! ao-size (cadr m))) + + (let ((elem (new-elem 'play music-id at-second music-duration ao-size ao-mem))) + (add h elem)) + ) + ) + ) + +(define (ao_clear_async h) + (clear h)) + +(define (ao_is_at_second_async h) + (ao-handle-at-second h)) + +(define (ao_is_at_music_id_async h) + (ao-handle-music-id h)) + +(define (ao_music_duration_async h) + (ao-handle-music-duration h)) + +(define (ao_bufsize_async h) + (ao-handle-buf-size h)) + +(define (ao_set_volume_async h percentage) + (let ((volume-10000 (inexact->exact (round (* percentage 100.0))))) + (when (and (> volume-10000 9990) (< volume-10000 10010)) + (set! volume-10000 10000)) + (set-ao-handle-volume-in-10000! h volume-10000) + ) + ) + +(define (ao_volume_async h) + (let ((volume-10000 (ao-handle-volume-in-10000 h))) + (/ volume-10000 100.0) + ) + ) + +(define (ao_pause_async h paused) + (if (ao-handle-paused h) + (when (eq? paused #f) + (mutex-unlock (ao-handle-pause-mutex h)) + (set-ao-handle-paused! h #f) + ) + (when (eq? paused #t) + (mutex-lock (ao-handle-pause-mutex h)) + (set-ao-handle-paused! h #t) + ) + ) + ) + +(define (ao_real_output_bits_async h) + (ao-handle-dev-bits-per-sample h)) + + + + + + +#| +(define initialized? #f) +(define (ensure-ao-initialized!) + (unless initialized? + (ao_initialize) + (set! initialized? #t))) + +;; ------------------------------------------------------------------------- +;; Async player state. + +(struct play-frame (command music-id at-second music-duration data) #:transparent) + +(struct ao-async-handle + (device + requested-bits + device-bits + byte-format + channels + rate + queue + sema + lock + worker + paused-sema + paused-box + stopped-box + at-second-box + music-duration-box + at-music-id-box + buf-size-box + volume-box) + #:mutable) + +(define (with-lock l thunk) + (call-with-semaphore l thunk)) + +(define (box-set-under-lock! h b v) + (with-lock (ao-async-handle-lock h) + (lambda () (set-box! b v)))) + +(define (box-ref-under-lock h b) + (with-lock (ao-async-handle-lock h) + (lambda () (unbox b)))) + +(define (enqueue! h frame) + (with-lock (ao-async-handle-lock h) + (lambda () + (let ([q (ao-async-handle-queue h)] + [n (bytes-length (play-frame-data frame))]) + (q:enqueue! q frame) + (set-box! (ao-async-handle-buf-size-box h) + (+ (unbox (ao-async-handle-buf-size-box h)) n))))) + (semaphore-post (ao-async-handle-sema h))) + +(define (dequeue/timeout h timeout-ms) + (and (sync/timeout (/ timeout-ms 1000.0) (ao-async-handle-sema h)) + (with-lock (ao-async-handle-lock h) + (lambda () + (let ([q (ao-async-handle-queue h)]) + (and (not (q:queue-empty? q)) + (let ([frame (q:dequeue! q)]) + (set-box! (ao-async-handle-buf-size-box h) + (max 0 (- (unbox (ao-async-handle-buf-size-box h)) + (bytes-length (play-frame-data frame))))) + frame))))))) + + +(define (clear-queue! h) + (with-lock (ao-async-handle-lock h) + (lambda () + (let ([q (ao-async-handle-queue h)]) + (let loop () + (unless (q:queue-empty? q) + (q:dequeue! q) + (loop)))) + (set-box! (ao-async-handle-buf-size-box h) 0))) + ;; Drain semaphore posts that belonged to discarded queue elements. + (let loop () + (when (sync/timeout 0 (ao-async-handle-sema h)) + (loop)))) + +(define (wait-while-paused h) + (let loop () + (when (box-ref-under-lock h (ao-async-handle-paused-box h)) + (sync (ao-async-handle-paused-sema h)) + (loop)))) + +(define (player-loop h) + (let loop () + (wait-while-paused h) + (define frame (dequeue/timeout h 250)) + (cond + [(not frame) + (unless (box-ref-under-lock h (ao-async-handle-stopped-box h)) + (sleep 0.005) + (loop))] + [(eq? (play-frame-command frame) 'stop) + (box-set-under-lock! h (ao-async-handle-stopped-box h) #t) + (void)] + [else + (with-lock (ao-async-handle-lock h) + (lambda () + (set-box! (ao-async-handle-at-second-box h) (play-frame-at-second frame)) + (set-box! (ao-async-handle-music-duration-box h) (play-frame-music-duration frame)) + (set-box! (ao-async-handle-at-music-id-box h) (play-frame-music-id frame)))) + (define out (apply-volume h (play-frame-data frame))) + (ao_play (ao-async-handle-device h) out (bytes-length out)) + (loop)]))) + +;; ------------------------------------------------------------------------- +;; Opening and closing. + +(define (ao_async_version) 2) + +(define (make-format bits rate channels byte-format) + (make-ao_sample_format bits rate channels (endian->int byte-format) #f)) + +(define (endian->int e) + (case e + [(little-endian) 1] + [(big-endian) 2] + [(native-endian) 4] + [else e])) + +(define (try-open-device bits rate channels byte-format wav-file-output) + (define candidates + (append (list bits) + (if (> bits 24) (list 24) null) + (if (> bits 16) (list 16) null))) + (let loop ([xs candidates]) + (cond + [(null? xs) (values #f 0)] + [else + (define out-bits (car xs)) + (define fmt (make-format out-bits rate channels byte-format)) + (define dev + (if wav-file-output + (ao_open_file (ao_driver_id "wav") wav-file-output 1 fmt #f) + (ao_open_live (ao_default_driver_id) fmt #f))) + (if dev + (values dev out-bits) + (loop (cdr xs)))]))) + +(define (ao_create_async bits rate channels byte-format wav-file-output) + (ensure-ao-initialized!) + (define-values (dev opened-bits) + (try-open-device bits rate channels byte-format wav-file-output)) + (and dev + (letrec ([h (ao-async-handle dev + bits + opened-bits + byte-format + channels + rate + (q:make-queue) + (make-semaphore 0) + (make-semaphore 1) + #f + (make-semaphore 0) + (box #f) + (box #f) + (box -1.0) + (box 0.0) + (box -1) + (box 0) + (box 100.0))] + [t (thread (lambda () (player-loop h)))]) + (set-ao-async-handle-worker! h t) + h))) + +(define (ao_stop_async h) + (when h + (clear-queue! h) + (ao_pause_async h 0) + (enqueue! h (play-frame 'stop 0 0.0 0.0 #"")) + (thread-wait (ao-async-handle-worker h)) + (ao_close (ao-async-handle-device h)) + (void))) + +;; ------------------------------------------------------------------------- +;; Buffer conversion. + +(define (native-little-endian?) + ;(= 1 (integer-bytes->integer #"\1\0" #f #t))) + (not (system-big-endian?))) + +(define (little-endian-format? byte-format) + (case byte-format + [(little-endian) #t] + [(big-endian) #f] + [(native-endian) (native-little-endian?)] + [else (= byte-format 1)])) + +(define (copy-pointer-bytes ptr len) + (define bs (make-bytes len)) + (for ([i (in-range len)]) + (bytes-set! bs i (ptr-ref ptr _uint8 i))) + bs) + +(define (read-sample bs pos byte-count little?) + (define unsigned + (for/fold ([v 0]) ([i (in-range byte-count)]) + (define idx (if little? i (- byte-count i 1))) + (bitwise-ior v (arithmetic-shift (bytes-ref bs (+ pos idx)) (* 8 i))))) + (define bits (* byte-count 8)) + (define sign (arithmetic-shift 1 (- bits 1))) + (if (zero? (bitwise-and unsigned sign)) + unsigned + (- unsigned (arithmetic-shift 1 bits)))) + +(define (store-sample! bs pos byte-count little? sample) + (for ([i (in-range byte-count)]) + (define idx (if little? i (- byte-count i 1))) + (bytes-set! bs (+ pos idx) (bitwise-and sample #xff)) + (set! sample (arithmetic-shift sample -8)))) + +(define (convert-bits 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 (convert-requested-to-real h bs info) + (define requested-bits (BufferInfo_t-sample_bits info)) + (define output-bits (ao-async-handle-device-bits h)) + (define in-bytes (/ requested-bits 8)) + (define out-bytes (/ output-bits 8)) + (cond + [(= requested-bits output-bits) bs] + [else + (define samples (quotient (bytes-length bs) in-bytes)) + (define out (make-bytes (* samples out-bytes))) + (define little? (little-endian-format? (ao-async-handle-byte-format h))) + (for ([s (in-range samples)]) + (define sample (read-sample bs (* s in-bytes) in-bytes little?)) + (define converted (convert-bits sample requested-bits output-bits)) + (store-sample! out (* s out-bytes) out-bytes little? converted)) + out])) + +(define (flac-pointer->interleaved-bytes ptr sample-count info) + ;; FLAC buffers are int32_t *buffer[]: channel-oriented signed 32-bit + ;; samples. buf_size is the number of samples per channel. + (define bits (BufferInfo_t-sample_bits info)) + (define bytes-per-sample (/ bits 8)) + (define channels (BufferInfo_t-channels info)) + (define little? (little-endian-format? (BufferInfo_t-endiannes info))) + (define out (make-bytes (* sample-count channels bytes-per-sample))) + (define pos 0) + (for ([k (in-range sample-count)]) + (for ([ch (in-range channels)]) + (define channel-ptr (ptr-ref ptr _pointer ch)) + (define sample (ptr-ref channel-ptr _int32 k)) + (store-sample! out pos bytes-per-sample little? sample) + (set! pos (+ pos bytes-per-sample)))) + out) + +(define (ao_play_async h music-id at-second music-duration buf-size mem info) + (define source + (case (BufferInfo_t-type info) + [(ao) (copy-pointer-bytes mem buf-size)] + [(flac) (flac-pointer->interleaved-bytes mem buf-size info)] + [(mp3 ogg) + (eprintf "format ~a not supported yet\n" (BufferInfo_t-type info)) + #f] + [else + (eprintf "unknown buffer type ~a\n" (BufferInfo_t-type info)) + #f])) + (when source + (define out (convert-requested-to-real h source info)) + (enqueue! h (play-frame 'play + music-id + (real->double-flonum at-second) + (real->double-flonum music-duration) + out)))) + +;; ------------------------------------------------------------------------- +;; Status and controls. + +(define (ao_clear_async h) + (clear-queue! h)) + +(define (ao_is_at_second_async h) + (box-ref-under-lock h (ao-async-handle-at-second-box h))) + +(define (ao_is_at_music_id_async h) + (box-ref-under-lock h (ao-async-handle-at-music-id-box h))) + +(define (ao_music_duration_async h) + (box-ref-under-lock h (ao-async-handle-music-duration-box h))) + +(define (ao_bufsize_async h) + (box-ref-under-lock h (ao-async-handle-buf-size-box h))) + +(define (ao_real_output_bits_async h) + (ao-async-handle-device-bits h)) + +(define (ao_pause_async h paused) + (define pause? (not (zero? paused))) + (with-lock (ao-async-handle-lock h) + (lambda () + (define was-paused? (unbox (ao-async-handle-paused-box h))) + (set-box! (ao-async-handle-paused-box h) pause?) + (when (and was-paused? (not pause?)) + (semaphore-post (ao-async-handle-paused-sema h)))))) + +(define (ao_set_volume_async h percentage) + ;; Keep the old public meaning: 100.0 means 100 percent. + (define v (if (integer? percentage) (exact->inexact percentage) percentage)) + (with-lock (ao-async-handle-lock h) + (lambda () + (set-box! (ao-async-handle-volume-box h) + (if (and (>= v 99.9) (<= v 100.1)) 100.0 v))))) + +(define (ao_volume_async h) + (box-ref-under-lock h (ao-async-handle-volume-box h))) + +(define (apply-volume h bs) + (define volume (box-ref-under-lock h (ao-async-handle-volume-box h))) + (cond + [(= volume 100.0) bs] + [else + (define out (bytes-copy bs)) + (define bytes-per-sample (/ (ao-async-handle-device-bits h) 8)) + (define little? (little-endian-format? (ao-async-handle-byte-format h))) + (define factor (/ volume 100.0)) + (for ([pos (in-range 0 (bytes-length out) bytes-per-sample)]) + (define sample (read-sample out pos bytes-per-sample little?)) + (define scaled (inexact->exact (truncate (* sample factor)))) + (store-sample! out pos bytes-per-sample little? scaled)) + out])) +|# \ No newline at end of file diff --git a/libao.rkt b/libao.rkt index e5cc1ca..442b68b 100644 --- a/libao.rkt +++ b/libao.rkt @@ -1,7 +1,7 @@ #lang racket/base (require (prefix-in fin: finalizer) - (prefix-in ffi: "libao-async-ffi.rkt") + (prefix-in ffi: "libao-async-ffi-racket.rkt") ffi/unsafe ffi/unsafe/custodian data/queue diff --git a/play-test.rkt b/play-test.rkt index e423ec3..5282ea7 100644 --- a/play-test.rkt +++ b/play-test.rkt @@ -21,8 +21,8 @@ (set! test-file4 (build-path tests "mahler-2.ogg")) ) (when (eq? os 'windows) - (set! test-file3 (build-path tests "mahler-1.ogg")) - (set! test-file4 (build-path tests "mahler-2.ogg")) + (set! test-file3 (build-path tests "idyll.flac")) + (set! test-file4 (build-path tests "idyll.flac")) ) ) @@ -43,6 +43,7 @@ (define seeked #f) (define (audio-play type ao-type handle buf-info buffer buf-len) + ;(dbg-sound "~a ~a ~a ~a ~a" type ao-type handle buf-info buf-len) (let* ((sample (hash-ref buf-info 'sample)) (rate (hash-ref buf-info 'sample-rate)) (second (/ (* sample 1.0) (* rate 1.0))) @@ -58,8 +59,19 @@ (let ((perc (exact->inexact (* (/ (- duration 15) duration) 100.0)))) (info-sound "Seeking to ~a%" perc) (audio-seek current-audio-h perc)))))) + (cond-volume (λ () + (when (= (round current-seconds) 20) + (ao-set-volume! ao-h 70.0)) + (when (= (round current-seconds) 25) + (ao-set-volume! ao-h 30)) + (when (= (round current-seconds) 30) + (ao-set-volume! ao-h 100)) + (when (= (round current-seconds) 35) + (ao-set-volume! ao-h 150)) + (when (= (round current-seconds) 40) + (ao-set-volume! ao-h 100)))) ) - + (when (not (eq? ao-h #f)) (when (not (and (= current-bits bits-per-sample) @@ -116,6 +128,7 @@ (buf-seconds (exact->inexact (/ buf-size bytes-per-sample-all-channels rate)))) (second-printer buf-seconds) (cond-seek) + (cond-volume) (when (> buf-seconds 5) (letrec ((waiter (λ () (let ((buf-seconds-left (exact->inexact @@ -127,16 +140,7 @@ (begin (sleep 0.5) (second-printer buf-seconds) - (when (= (round current-seconds) 20) - (ao-set-volume! ao-h 70.0)) - (when (= (round current-seconds) 25) - (ao-set-volume! ao-h 30)) - (when (= (round current-seconds) 30) - (ao-set-volume! ao-h 100)) - (when (= (round current-seconds) 35) - (ao-set-volume! ao-h 150)) - (when (= (round current-seconds) 40) - (ao-set-volume! ao-h 100)) + (cond-volume) (cond-seek) (waiter))))) ))