778 lines
24 KiB
Racket
778 lines
24 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
|
|
racket/list
|
|
"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
|
|
ao_reuse_buf_len
|
|
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
|
|
)
|
|
#:mutable
|
|
)
|
|
|
|
|
|
(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
|
|
buf-mutex
|
|
add-mutex
|
|
|
|
play-thread
|
|
|
|
at-second
|
|
music-duration
|
|
music-id
|
|
buf-size
|
|
volume-in-10000
|
|
|
|
valid
|
|
|
|
bufs
|
|
|
|
current-elem
|
|
bytes-left
|
|
)
|
|
#:mutable
|
|
)
|
|
|
|
(define ao-buf-ms 50) ;; Playback buffer of 0.5s
|
|
|
|
(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 (needed-bytes h)
|
|
(let ((req-bytes (/ (ao-handle-dev-bits-per-sample h) 8))
|
|
(rate-s (ao-handle-dev-rate h))
|
|
(channels (ao-handle-dev-channels h))
|
|
)
|
|
(/ (* req-bytes rate-s channels ao-buf-ms) 1000)
|
|
)
|
|
)
|
|
|
|
(define (bytes->samples h s)
|
|
(let ((req-bytes (/ (ao-handle-dev-bits-per-sample h) 8))
|
|
(rate-s (ao-handle-dev-rate h))
|
|
(channels (ao-handle-dev-channels h)))
|
|
(/ s req-bytes channels)))
|
|
|
|
|
|
(define (add h elem)
|
|
(mutex-lock (ao-handle-add-mutex h))
|
|
(add* h elem)
|
|
(mutex-unlock (ao-handle-add-mutex h))
|
|
)
|
|
|
|
(define (add* h elem)
|
|
(if (eq? (queue-elem-command elem) 'stop)
|
|
(begin
|
|
(unless (eq? (ao-handle-current-elem h) #f)
|
|
(async-channel-put (ao-handle-queue h) (ao-handle-current-elem h))
|
|
(set-ao-handle-current-elem! h #f))
|
|
(async-channel-put (ao-handle-queue h) elem)
|
|
)
|
|
(let* ((cb (ao-handle-current-elem h)))
|
|
(if (eq? cb #f)
|
|
(begin
|
|
(set-ao-handle-current-elem! h elem)
|
|
(set! cb elem)
|
|
(let* ((ns (needed-bytes h))
|
|
(new-buf (cadr (alloc-buf h ns))))
|
|
(memcpy new-buf (queue-elem-buf cb) (queue-elem-buflen cb))
|
|
;(dbg-sound "Allocated new buffer of ~a bytes (~a samples) for elem size ~a" ns (bytes->samples h ns) (queue-elem-buflen cb))
|
|
(reuse-buf h (queue-elem-buf cb))
|
|
(set-queue-elem-buf! cb new-buf)
|
|
(set-ao-handle-bytes-left! h (- ns (queue-elem-buflen cb)))
|
|
(set-ao-handle-buf-size! h (+ (ao-handle-buf-size h) (queue-elem-buflen elem)))
|
|
))
|
|
(if (or
|
|
(not (equal? (queue-elem-music-id cb) (queue-elem-music-id elem)))
|
|
(< (- (ao-handle-bytes-left h) (queue-elem-buflen elem)) 0))
|
|
(begin
|
|
; push this buffer and restart
|
|
;(dbg-sound "Pushing sound buffer with ~a samples left" (ao-handle-bytes-left h))
|
|
(async-channel-put (ao-handle-queue h) cb)
|
|
(set-ao-handle-current-elem! h #f)
|
|
(add* h elem))
|
|
(let ((offset (queue-elem-buflen cb)))
|
|
(memcpy (queue-elem-buf cb) offset (queue-elem-buf elem) (queue-elem-buflen elem))
|
|
(set-queue-elem-buflen! cb (+ offset (queue-elem-buflen elem)))
|
|
(set-ao-handle-bytes-left! h (- (ao-handle-bytes-left h) (queue-elem-buflen elem)))
|
|
(set-ao-handle-buf-size! h (+ (ao-handle-buf-size h) (queue-elem-buflen elem)))
|
|
(reuse-buf h (queue-elem-buf elem))
|
|
(when (= (ao-handle-bytes-left h) 0)
|
|
(async-channel-put (ao-handle-queue h) cb)
|
|
(set-ao-handle-current-elem! h #f))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
(define (new-elem h 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 h elem)
|
|
(reuse-buf h (queue-elem-buf elem))
|
|
; does nothing
|
|
#t)
|
|
|
|
(define (clear h)
|
|
(let ((count 0))
|
|
(mutex-lock (ao-handle-clear-mutex h))
|
|
(let ((el (get h 0)))
|
|
|
|
; Clear the elements in the queue
|
|
(while (not (eq? el #f))
|
|
(del-elem h el)
|
|
(set! count (+ count 1))
|
|
(set! el (get h 0)))
|
|
|
|
; Clear the current element in processing
|
|
(mutex-lock (ao-handle-add-mutex h))
|
|
(unless (eq? (ao-handle-current-elem h) #f)
|
|
(let* ((ce (ao-handle-current-elem h))
|
|
(cb (queue-elem-buf ce)))
|
|
(unless (eq? cb #f)
|
|
(reuse-buf h cb))))
|
|
(set-ao-handle-current-elem! h #f)
|
|
(set-ao-handle-bytes-left! h 0)
|
|
(set-ao-handle-buf-size! h 0)
|
|
(mutex-unlock (ao-handle-add-mutex h))
|
|
|
|
(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)))
|
|
|
|
|
|
(define (alloc-buf h size)
|
|
(let ((entry #f))
|
|
(letrec ((f (λ (entries min-size min-size-idx idx)
|
|
(if (null? entries)
|
|
min-size-idx
|
|
(let ((e (car entries)))
|
|
(if (<= size (car e))
|
|
(if (or (eq? min-size #f) (< (car e) min-size))
|
|
(f (cdr entries) (car e) idx (+ idx 1))
|
|
(f (cdr entries) min-size min-size-idx (+ idx 1))
|
|
)
|
|
(f (cdr entries) min-size min-size-idx (+ idx 1))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
))
|
|
(mutex-lock (ao-handle-buf-mutex h))
|
|
(let ((bufs (ao-handle-bufs h))
|
|
(entry #f))
|
|
(unless (null? bufs)
|
|
(let ((idx (f bufs #f #f 0)))
|
|
(unless (eq? idx #f)
|
|
(let ((e (list-ref bufs idx)))
|
|
;(dbg-sound "Reusing index ~a, ~a for size ~a" idx (car e) size)
|
|
(set! entry (list-ref bufs idx))
|
|
(set-ao-handle-bufs! h (append (take bufs idx) (drop bufs (+ idx 1))))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
(mutex-unlock (ao-handle-buf-mutex h))
|
|
;(dbg-sound "Alloc buf: ~a, got ~a" size (map (λ (e) (car e)) (ao-handle-bufs h)))
|
|
(if (eq? entry #f)
|
|
(list size (make-bytes size))
|
|
entry)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
(define (reuse-buf h buf)
|
|
(unless (eq? buf #f)
|
|
(mutex-lock (ao-handle-buf-mutex h))
|
|
(set-ao-handle-bufs! h (cons (list (bytes-length buf) buf) (ao-handle-bufs h)))
|
|
(when (> (length (ao-handle-bufs h)) 10)
|
|
(set-ao-handle-bufs! h (take (ao-handle-bufs h) 5)))
|
|
(mutex-unlock (ao-handle-buf-mutex h))
|
|
)
|
|
#t
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; 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 h 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 (cadr (alloc-buf h 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 h 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 (cadr (alloc-buf h 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 #t)))
|
|
|
|
(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 #f)
|
|
(convert-bits h 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)
|
|
(buf #f)
|
|
(buf-size 0))
|
|
(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)
|
|
(begin
|
|
(dbg-sound "nothing in the queue")
|
|
(sleep 0.005))
|
|
(begin
|
|
(if (eq? (queue-elem-command elem) 'stop)
|
|
(set! go-on #f)
|
|
(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)))
|
|
|
|
(let* ((size (queue-elem-buflen elem)))
|
|
(when (> size buf-size)
|
|
(set! buf (malloc size 'atomic-interior ))
|
|
(set! buf-size size))
|
|
(memcpy buf (queue-elem-buf elem) size)
|
|
(ao_play (ao-handle-ao-device h) buf size)
|
|
)
|
|
)
|
|
)
|
|
|
|
(del-elem h elem)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
#:pool 'own
|
|
)
|
|
)
|
|
|
|
|
|
|
|
(define handle-admin-mutex (make-mutex))
|
|
(define num-of-handles 0)
|
|
|
|
(register-finalizer-and-custodian-shutdown
|
|
num-of-handles
|
|
(λ (v)
|
|
(unless (= num-of-handles 0)
|
|
(ao_shutdown)))
|
|
#:at-exit? #t
|
|
)
|
|
|
|
(define (dec-ao-handles)
|
|
(mutex-lock handle-admin-mutex)
|
|
(set! num-of-handles (- num-of-handles 1))
|
|
(when (= num-of-handles 0)
|
|
(ao_shutdown)
|
|
(dbg-sound "ao_shutdown executed")
|
|
)
|
|
(mutex-unlock handle-admin-mutex)
|
|
)
|
|
|
|
(define (inc-ao-handles)
|
|
(mutex-lock handle-admin-mutex)
|
|
(when (= num-of-handles 0)
|
|
(ao_initialize)
|
|
(dbg-sound "ao_initialized executed")
|
|
)
|
|
(set! num-of-handles (+ num-of-handles 1))
|
|
(mutex-unlock handle-admin-mutex)
|
|
)
|
|
|
|
(define (ao_close* ao_ffi_handle)
|
|
(ao_close ao_ffi_handle)
|
|
(dec-ao-handles))
|
|
|
|
(define (ao_open_live* driver-id fmt matrix)
|
|
(inc-ao-handles)
|
|
(let ((r (ao_open_live driver-id fmt matrix)))
|
|
(when (eq? r #f)
|
|
(dec-ao-handles))
|
|
r))
|
|
|
|
(define (ao_open_file* driver-id file x fmt matrix)
|
|
(inc-ao-handles)
|
|
(let ((r (ao_open_file driver-id file x fmt matrix)))
|
|
(when (eq? r #f)
|
|
(dec-ao-handles))
|
|
r))
|
|
|
|
(define (ao_default_driver_id*)
|
|
(inc-ao-handles)
|
|
(let ((r (ao_default_driver_id)))
|
|
(dec-ao-handles)
|
|
r))
|
|
|
|
(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)
|
|
(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
|
|
(make-mutex) ; buf-mutex
|
|
(make-mutex) ; add-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
|
|
'() ; reuse buffer
|
|
|
|
#f ; current element
|
|
0 ; bytes left
|
|
)))
|
|
|
|
(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))
|
|
(register-finalizer handle (λ (v)
|
|
(when (ao-handle-valid v)
|
|
ao_stop_async v)))
|
|
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 h '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 h mem buf-size info)))
|
|
(reuse-buf h mem)
|
|
(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)))
|
|
(when (eq? (caddr m) #t)
|
|
(reuse-buf h mem)
|
|
(set! ao-mem (car m))
|
|
(set! ao-size (cadr m))))
|
|
|
|
(unless (bytes? ao-mem)
|
|
(error "Hey! this was unexpected!"))
|
|
|
|
|
|
(let ((elem (new-elem h '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 (ao_reuse_buf_len h)
|
|
(length (ao-handle-bufs h)))
|
|
|