563 lines
16 KiB
Racket
563 lines
16 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 "libao"])) '(#f)))
|
|
|
|
(define-ffi-definer define-ao libao)
|
|
|
|
(define _ao-device (_cpointer/null '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))
|
|
(_fun #:blocking? #t _ao-device _bytes _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 (make-bytes buflen))) ;((new-buf (malloc buflen 'atomic)))
|
|
; (memcpy new-buf buf buflen)
|
|
;(make-queue-elem command new-buf buflen at-second music-duration music-id)))
|
|
(make-queue-elem command 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 (is-big-endian? e)
|
|
(not (is-little-endian? 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 bs buf-size volume-in-10000)
|
|
;; bs: bytes
|
|
;; buf-size: aantal geldige bytes in bs
|
|
|
|
(let* ([bits (ao-handle-dev-bits-per-sample h)]
|
|
[bytes-per-sample (arithmetic-shift bits -3)]
|
|
[big? (is-big-endian? (ao-handle-dev-endianness h))])
|
|
|
|
(unless (= volume-in-10000 10000)
|
|
(for ([i (in-range 0 buf-size bytes-per-sample)])
|
|
(let* ([sample (int-bytes->integer bs #t big?
|
|
i
|
|
(+ i bytes-per-sample))]
|
|
[scaled (quotient (* sample volume-in-10000) 10000)])
|
|
(integer->int-bytes scaled
|
|
bytes-per-sample
|
|
#t
|
|
big?
|
|
bs
|
|
i))))
|
|
|
|
#t))
|
|
|
|
;;; planar -> intereleaved
|
|
|
|
|
|
(define (planar-to-interleaved mem buf-size info)
|
|
;; mem: bytes
|
|
;; result: (list bytes output-size)
|
|
|
|
(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]
|
|
[out (make-bytes out-size)])
|
|
|
|
(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)])
|
|
|
|
(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)])
|
|
(bytes-copy! out out-pos mem in-pos (+ in-pos bytes)))))
|
|
|
|
(list out out-size))))
|
|
|
|
;;; requested bits to device bits
|
|
|
|
|
|
(define (convert-bits buf buf-size in-bits in-endianness out-bits out-endianness)
|
|
;; buf: bytes
|
|
;; returns: (list out-bytes out-size)
|
|
|
|
(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 (make-bytes out-size)]
|
|
[shift (- out-bits in-bits)]
|
|
[in-big? (is-big-endian? in-endianness)]
|
|
[out-big? (is-big-endian? out-endianness)])
|
|
|
|
(for ([n (in-range samples)])
|
|
(let* ([in-pos (* n in-bytes)]
|
|
[out-pos (* n out-bytes)]
|
|
[sample (int-bytes->integer buf #t in-big? in-pos (+ in-pos in-bytes))]
|
|
[converted (arithmetic-shift sample shift)])
|
|
(integer->int-bytes converted out-bytes #t out-big? out out-pos)))
|
|
|
|
(list out 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)
|
|
(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)
|
|
)
|
|
)
|
|
(set! i (+ i 1))
|
|
)
|
|
)
|
|
|
|
(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)))
|
|
|
|
(unless (bytes? mem)
|
|
(error "ao_play_async: paramater mem must be of type bytes"))
|
|
|
|
(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)))
|
|
|
|
(unless (bytes? ao-mem)
|
|
(error "Hey! this was unexpected!"))
|
|
|
|
|
|
(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))
|
|
|