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