racket-sound/libao/libao-async.rkt

#lang racket/base

(require ffi/unsafe/os-thread
         "../utils/utils.rkt"
         "libao-ffi.rkt"
         data/queue
         )

(provide ao_create_async
         ao_stop_async
         ao_play_async
         ao_is_at_second_async
         ao_music_duration_async
         ao_bufsize_async
         ao_clear_async
         ao_pause_async
         )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Mutex
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (make-mutex)
  (let ((sem (make-os-semaphore)))
    (os-semaphore-post sem)
    sem))

(define (mutex-lock mutex)
  (os-semaphore-wait mutex))

(define (mutex-unlock mutex)
  (os-semaphore-post mutex))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ao-player in os thread
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-struct ao-shm
  (mutex
   device
   [at-second #:mutable]
   [music-duration #:mutable]
   [bufsize #:mutable]
   queue-sem
   [queue #:mutable]
   [stopped #:mutable]
   [paused #:mutable]
   pause-sem
   )
  #:transparent
  )

(define (ao-player* shm)
  (call-in-os-thread
  ;(thread
   (λ ()
     (let ((ao-device (ao-shm-device shm)))
       (define (player)
         
         (mutex-lock (ao-shm-mutex shm))
         (let ((p (ao-shm-paused shm)))
           (mutex-unlock (ao-shm-mutex shm))
           (when p
             (os-semaphore-wait (ao-shm-pause-sem shm)))
           )
         
         (os-semaphore-wait (ao-shm-queue-sem shm))
         (mutex-lock (ao-shm-mutex shm))
         (if (= (queue-length (ao-shm-queue shm)) 0)
             (begin
               (mutex-unlock (ao-shm-mutex shm))
               (player))
             (let* ((elem (dequeue! (ao-shm-queue shm)))
                    (command (car elem))
                    )
               (mutex-unlock (ao-shm-mutex shm))
               (cond
                 [(eq? command 'stop)
                  (begin
                    (mutex-lock (ao-shm-mutex shm))
                    (set-ao-shm-stopped! shm #t)
                    (mutex-unlock (ao-shm-mutex shm))
                    'done)]
                 [(eq? command 'play)
                  (let ((at-second (cadr elem))
                        (duration (caddr elem))
                        (buf-len (cadddr elem))
                        (buf (car (cddddr elem)))
                        )
                    (mutex-lock (ao-shm-mutex shm))
                    (set-ao-shm-at-second! shm at-second)
                    (set-ao-shm-music-duration! shm duration)
                    (let ((bs (ao-shm-bufsize shm)))
                      (set-ao-shm-bufsize! shm (- bs buf-len)))
                    (mutex-unlock (ao-shm-mutex shm))
                    (ao_play ao-device buf buf-len)           ; Play this buffer part
                    ;(free buf)                                ; Free the previously malloc 'raw  (see libao.rkt)
                    )]
                 )
               (player)
               )
             )
         )
       (player)
       )
     )
   )
  )

(define (ao-player ao_device)
  (let ((shm (make-ao-shm (make-mutex)
                          ao_device
                          0.0 0.0 0
                          (make-os-semaphore) (make-queue)
                          #f
                          #f (make-os-semaphore))))
    (os-semaphore-post (ao-shm-pause-sem shm))
    (ao-player* shm)
    shm
    )
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; External interface
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (ao_create_async ao_device)
  (ao-player ao_device))

(define (ao_stop_async shm)
  (mutex-lock (ao-shm-mutex shm))
  (ao_clear_async* shm)
  (enqueue! (ao-shm-queue shm) (list 'stop 0 0 #f #f))
  (os-semaphore-post (ao-shm-queue-sem shm))
  (mutex-unlock (ao-shm-mutex shm))
  (let ((stopped (λ ()
                   (mutex-lock (ao-shm-mutex shm))
                   (let ((w (ao-shm-stopped shm)))
                     (mutex-unlock (ao-shm-mutex shm))
                     w))))
    (letrec ((loop (λ ()
                     (if (eq? (stopped) #t)
                         'stopped
                         (begin
                           (sleep 0.01)
                           (loop))))))
      (loop)
      'stopped)
    )
  )

(define (ao_play_async shm at-second music-duration buf-size buf)
  (let ((item (list 'play at-second music-duration buf-size buf)))
    (mutex-lock (ao-shm-mutex shm))
    (let ((bs (ao-shm-bufsize shm)))
      (set-ao-shm-bufsize! shm (+ bs buf-size)))
    (enqueue! (ao-shm-queue shm) item)
    (os-semaphore-post (ao-shm-queue-sem shm))
    (mutex-unlock (ao-shm-mutex shm))))

(define (ao_is_at_second_async shm)
  (mutex-lock (ao-shm-mutex shm))
  (let ((at-second (ao-shm-at-second shm)))
    (mutex-unlock (ao-shm-mutex shm))
    at-second))

(define (ao_music_duration_async shm)
  (mutex-lock (ao-shm-mutex shm))
  (let ((music-duration (ao-shm-music-duration shm)))
    (mutex-unlock (ao-shm-mutex shm))
    music-duration))

(define (ao_bufsize_async shm)
  (mutex-lock (ao-shm-mutex shm))
  (let ((buf-size (ao-shm-bufsize shm)))
    (mutex-unlock (ao-shm-mutex shm))
    buf-size))

(define (ao_clear_async shm)
  (mutex-lock (ao-shm-mutex shm))
  (ao_clear_async* shm)
  (mutex-unlock (ao-shm-mutex shm)))

(define (ao_clear_async* shm)
  (let ((q (ao-shm-queue shm)))
    (while (> (queue-length q) 0)
           ;(displayln (format "queue-length: ~a" (queue-length q)))
           ;(let* ((elem (dequeue! q))
                  ;(buf (car (cddddr elem))))
             ;(free buf))))
	   (dequeue! q))
  (set-ao-shm-queue! shm (make-queue))
  (set-ao-shm-bufsize! shm 0)
  )

(define (ao_pause_async shm pause)
  (if pause
      (begin
        (displayln "Pausing ao play thread")
        (os-semaphore-wait (ao-shm-pause-sem shm))
        (displayln (format "Setting pause now to ~a" pause))
        (mutex-lock (ao-shm-mutex shm))
        (set-ao-shm-paused! shm pause)
        (mutex-unlock (ao-shm-mutex shm)))
      (begin
        (displayln (format "Continuing ao play thread, now setting pause to ~a" pause))
        (mutex-lock (ao-shm-mutex shm))
        (set-ao-shm-paused! shm pause)
        (mutex-unlock (ao-shm-mutex shm))
        (displayln "Posting semaphore twice, one to let play thread continue, one for own use")
        (os-semaphore-post (ao-shm-pause-sem shm))
        (os-semaphore-post (ao-shm-pause-sem shm))
        )
      )
  )