#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))
  (_fun _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 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
  )
|#

(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 (integer-bytes->integer bs #t big?
                                                i
                                                (+ i bytes-per-sample))]
               [scaled (quotient (* sample volume-in-10000) 10000)])
          (integer->integer-bytes scaled
                                  bytes-per-sample
                                  #t
                                  big?
                                  bs
                                  i))))

    #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))))
|#

(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)
  (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-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    (integer-bytes->integer
                         buf #t in-big?
                         in-pos
                         (+ in-pos in-bytes))]
             [converted (arithmetic-shift sample shift)])
        (integer->integer-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)
      (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)))

    (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))


  



#|
(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]))
|#