From a30111ecf5f4879a8437e8bf8034af61daf31dac Mon Sep 17 00:00:00 2001
From: Hans Dijkema <hans@dijkewijk.nl>
Date: Thu, 7 May 2026 14:17:55 +0200
Subject: [PATCH] finally a working libao-async racket backend

---
 libao-async-ffi-racket.rkt | 311 +++++++++++++++++++++++++++++--------
 libao.rkt                  |  17 +-
 play-test.rkt              |   2 +-
 3 files changed, 254 insertions(+), 76 deletions(-)

diff --git a/libao-async-ffi-racket.rkt b/libao-async-ffi-racket.rkt
index 7e5753f..f6549ed 100644
--- a/libao-async-ffi-racket.rkt
+++ b/libao-async-ffi-racket.rkt
@@ -13,6 +13,7 @@
          ffi/unsafe/custodian
          racket/async-channel
          data/queue
+         racket/list
          "private/utils.rkt")
 
 (provide ao_version_async
@@ -86,9 +87,9 @@
 ;; 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 #:blocking? #t _ao-device _pointer _uint32 -> _int))
   ;(_fun _ao-device _pointer _uint32 -> _int))
-  (_fun #:blocking? #t _ao-device _bytes _uint32 -> _int))
+  ;(_fun #:blocking? #t _ao-device _bytes _uint32 -> _int))
 
 ;; -------------------------------------------------------------------------
 ;; Mutex stuff
@@ -119,7 +120,9 @@
    at-second
    music-duration
    music-id
-   ))
+   )
+  #:mutable
+  )
 
 
 (define-struct ao-handle
@@ -136,6 +139,9 @@
    mutex
    pause-mutex
    clear-mutex
+   buf-mutex
+   add-mutex
+   
    play-thread
 
    at-second
@@ -147,10 +153,15 @@
    valid
 
    bufs
+   
+   current-elem
+   bytes-left
    )
   #:mutable
   )
 
+(define ao-buf-ms 500)  ;; Playback buffer of 0.5s
+
 (define (get h ms-wait)
   (let ((el (if (<= ms-wait 0)
                 (sync/timeout 0 (ao-handle-queue h))
@@ -159,31 +170,113 @@
       (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 (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 (new-elem command music-id at-second music-duration buflen buf)
+(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 elem)
+(define (del-elem h elem)
+  (reuse-buf h (queue-elem-buf elem))
   ; does nothing
   #t)
 
 (define (clear h)
-  (let ((count 0)
-        (el (get h 0)))
+  (let ((count 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)
+    (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)
+      )
     )
   )
 
@@ -209,31 +302,54 @@
 
 (define (alloc-buf h size)
   (let ((entry #f))
-    (letrec ((f (λ (entries)
+    (letrec ((f (λ (entries min-size min-size-idx idx)
                   (if (null? entries)
-                      '()
+                      min-size-idx
                       (let ((e (car entries)))
-                        (if (< size (car e))
-                            (begin
-                              (set! entry e)
-                              (cdr entries))
-                            (begin
-                              (cons e (f (cdr 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))
                             )
                         )
                       )
                   )
                 ))
-      (set-ao-handle-bufs! h (f (ao-handle-bufs h)))
-      (if (eq? entry #f)
-          (list size (make-bytes size))
-          entry)
+      (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 size)
-  (set-ao-handle-bufs! h (cons (list size buf) (ao-handle-bufs h)))
+(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
   )
          
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -346,7 +462,9 @@
 (define (run h)
   (thread
    (λ ()
-     (let ((go-on #t))
+     (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))
@@ -354,23 +472,34 @@
           (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)))
-
+                (dbg-sound "nothing in the queue")
+                (sleep 0.005))
+              (begin
                 (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)))
+                    (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)))
 
-                (del-elem elem)
-                ))
+                      (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)
+                )
+              )
             )
           )
        )
@@ -380,20 +509,61 @@
   )
 
 
-(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 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))
@@ -416,11 +586,11 @@
                                             byte-format
                                             #f))
                 (driver-id (if (eq? wav-output-file #f)
-                               (ao_default_driver_id)
+                               (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)))
+                         (ao_open_live* driver-id fmt #f)
+                         (ao_open_file* driver-id wav-output-file 1 fmt #f)))
                 )
 
            (unless (eq? dev #f)
@@ -447,8 +617,6 @@
   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
@@ -463,6 +631,8 @@
                  (make-mutex)            ; mutex
                  (make-mutex)            ; pause-mutex
                  (make-mutex)            ; clear-mutex
+                 (make-mutex)            ; buf-mutex
+                 (make-mutex)            ; add-mutex
                  
                  #f                      ; play-thread
 
@@ -475,6 +645,9 @@
 
                  #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)))
@@ -487,6 +660,9 @@
             #f)
           (begin
             (set-ao-handle-play-thread! handle (run handle))
+            (register-finalizer handle (λ (v)
+                                         (when (ao-handle-valid v)
+                                           ao_stop_async v)))
             handle)
           )
       )
@@ -504,7 +680,7 @@
   (when (ao-handle-paused h)
     (mutex-unlock (ao-handle-pause-mutex h)))
 
-  (let ((elem (new-elem 'stop 0 0.0 0.0 0 #f)))
+  (let ((elem (new-elem h 'stop 0 0.0 0.0 0 #f)))
     (add h elem))
 
   (dbg-sound "Stop command queued")
@@ -512,7 +688,7 @@
   (thread-wait (ao-handle-play-thread h))
   (dbg-sound "Play thread stopped")
 
-  (ao_close (ao-handle-ao-device h))
+  (ao_close* (ao-handle-ao-device h))
   (dbg-sound "AO Device closed")
 
   (set-ao-handle-valid! h #f)
@@ -527,8 +703,8 @@
 
     (when (or (eq? type 'planar) (eq? type 'flac))
       (dbg-sound "Converting from planar to interleaved")
-      (let ((m (planar-to-interleaved mem buf-size info)))
-        (reuse-buf h mem buf-size)
+      (let ((m (planar-to-interleaved h mem buf-size info)))
+        (reuse-buf h mem)  
         (set! mem (car m))
         (set! buf-size (cadr m)))
       )
@@ -537,7 +713,7 @@
           (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 buf-size)
+          (reuse-buf h mem)
           (set! ao-mem (car m))
           (set! ao-size (cadr m))))
 
@@ -545,7 +721,7 @@
         (error "Hey! this was unexpected!"))
 
 
-      (let ((elem (new-elem 'play music-id at-second music-duration ao-size ao-mem)))
+      (let ((elem (new-elem h 'play music-id at-second music-duration ao-size ao-mem)))
         (add h elem))
       )
     )
@@ -597,4 +773,5 @@
   (ao-handle-dev-bits-per-sample h))
 
 (define (ao_reuse_buf_len h)
-  (length (ao-handle-bufs h)))
\ No newline at end of file
+  (length (ao-handle-bufs h)))
+
diff --git a/libao.rkt b/libao.rkt
index 15f8af1..c6503f9 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
@@ -164,13 +164,14 @@
     (unless (ao-valid? handle)
       (err-sound "Cannot play on an invalid ao-device")
       (error "Cannot play on an invalid ao-device"))
-    (ffi:ao_play_async (ao-handle-async-player handle)
-                       music-id
-                       (exact->inexact at-time-in-s)
-                       (exact->inexact music-duration-s)
-                       buf-len
-                       buffer
-                       buf-info)
+    (void 
+     (ffi:ao_play_async (ao-handle-async-player handle)
+                        music-id
+                        (exact->inexact at-time-in-s)
+                        (exact->inexact music-duration-s)
+                        buf-len
+                        buffer
+                        buf-info))
     
     )
   )
diff --git a/play-test.rkt b/play-test.rkt
index bc7f057..2f14119 100644
--- a/play-test.rkt
+++ b/play-test.rkt
@@ -46,7 +46,7 @@
          (bytes-per-sample-all-channels (* channels bytes-per-sample))
          (duration (hash-ref buf-info 'duration))
          (cond-seek (λ ()
-                      (when (= (round current-seconds) 10)
+                      (when (>= (round current-seconds) 10)
                         (when (and (= current-file-id 3) (not seeked))
                           (set! seeked #t)
                           (let ((perc (exact->inexact (* (/ (- duration 15) duration) 100.0))))