1010 lines
32 KiB
Racket
1010 lines
32 KiB
Racket
#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]))
|
|
|# |