(module resampler racket/base

  (require ffi/unsafe
           "soxr-ffi.rkt"
           "private/utils.rkt")

  (provide resampler-available?
           resampler-version
           make-resampler
           resampler?
           resampler-input-rate
           resampler-output-rate
           resampler-channels
           resampler-input-format
           resampler-output-format
           resampler-convert
           resampler-drain
           resampler-clear!
           resampler-close!
           resample-bytes
           pcm-format?
           pcm-format-sample-bytes
           pcm-format->soxr-datatype
           quality->soxr-recipe)

  (define-struct resampler
    (ctx input-rate output-rate channels input-format output-format
         soxr-input-format soxr-output-format input-sample-bytes output-sample-bytes closed?)
    #:mutable
    #:constructor-name make-raw-resampler)

  (define (resampler-available?) (soxr-available?))
  (define (resampler-version) (soxr-version))

  (define (normalize-format fmt who)
    (cond [(or (eq? fmt 's16) (eq? fmt 'int16) (eq? fmt 'int16-interleaved)) 's16]
          [(or (eq? fmt 's24) (eq? fmt 'int24) (eq? fmt 'int24-interleaved)) 's24]
          [(or (eq? fmt 's32) (eq? fmt 'int32) (eq? fmt 'int32-interleaved)) 's32]
          [(or (eq? fmt 'float32) (eq? fmt 'f32) (eq? fmt 'float)) 'float32]
          [(or (eq? fmt 'float64) (eq? fmt 'f64) (eq? fmt 'double)) 'float64]
          [else (raise-argument-error who "(or/c 's16 's24 's32 'float32 'float64)" fmt)]))

  (define (pcm-format? fmt)
    (with-handlers ([exn:fail? (lambda (e) #f)])
      (normalize-format fmt 'pcm-format?)
      #t))

  (define (pcm-format-sample-bytes fmt)
    (case (normalize-format fmt 'pcm-format-sample-bytes)
      [(s16) 2]
      [(s24) 3]
      [(s32 float32) 4]
      [(float64) 8]))

  (define (pcm-format-actual-sample-bytes fmt)
    ;; SoXR has no packed 24-bit datatype.  The wrapper expands s24 to s32
    ;; before processing and packs s32 back to s24 afterwards when requested.
    (case (normalize-format fmt 'pcm-format-actual-sample-bytes)
      [(s24) 4]
      [else (pcm-format-sample-bytes fmt)]))

  (define (pcm-format->soxr-datatype fmt)
    (case (normalize-format fmt 'pcm-format->soxr-datatype)
      [(s16) SOXR_INT16_I]
      [(s24 s32) SOXR_INT32_I]
      [(float32) SOXR_FLOAT32_I]
      [(float64) SOXR_FLOAT64_I]))

  (define (quality->soxr-recipe q)
    ;; The '*-bitq' recipes are resampling precision recipes; they do not mean
    ;; that the PCM output is 16/24/32-bit.  Output format is controlled by
    ;; #:output-format.
    (cond [(integer? q) q]
          [(or (eq? q 'qq) (eq? q 'quick)) SOXR_QQ]
          [(or (eq? q 'lq) (eq? q 'low)) SOXR_LQ]
          [(or (eq? q 'mq) (eq? q 'medium)) SOXR_MQ]
          [(or (eq? q 'hq) (eq? q 'high)) SOXR_HQ]
          [(or (eq? q 'vhq) (eq? q 'very-high)) SOXR_VHQ]
          [(eq? q '16-bit) SOXR_16_BITQ]
          [(eq? q '20-bit) SOXR_20_BITQ]
          [(eq? q '24-bit) SOXR_24_BITQ]
          [(eq? q '28-bit) SOXR_28_BITQ]
          [(eq? q '32-bit) SOXR_32_BITQ]
          [else (raise-argument-error 'quality->soxr-recipe
                                      "(or/c 'qq 'lq 'mq 'hq 'vhq '16-bit '20-bit '24-bit '28-bit '32-bit exact-integer?)" q)]))

  (define (phase->flags phase)
    (cond [(or (eq? phase 'linear) (eq? phase #f)) SOXR_LINEAR_PHASE]
          [(or (eq? phase 'intermediate) (eq? phase 'medium)) SOXR_INTERMEDIATE_PHASE]
          [(or (eq? phase 'minimum) (eq? phase 'min)) SOXR_MINIMUM_PHASE]
          [else (raise-argument-error 'make-resampler "(or/c 'linear 'intermediate 'minimum)" phase)]))

  (define (check-error who err)
    (when err (error who "~a" err)))

  (define (bytes->native bs size)
    (let ((p (malloc size 'atomic-interior)))
      (memcpy p 0 bs 0 size)
      p))

  (define (native->bytes p size)
    (let ((bs (make-bytes size)))
      (memcpy bs 0 p 0 size)
      bs))

  (define (native-signed-ref bs start bytes)
    (int-bytes->integer bs #t (system-big-endian?) start (+ start bytes)))

  (define (native-signed-set! bs start bytes value)
    (integer->int-bytes value bytes #t (system-big-endian?) bs start))

  (define (clamp-s32 v)
    (cond [(< v -2147483648) -2147483648]
          [(> v 2147483647) 2147483647]
          [else v]))

  (define (clamp-s24 v)
    (cond [(< v -8388608) -8388608]
          [(> v 8388607) 8388607]
          [else v]))

  (define (s24-bytes->s32-bytes buffer size)
    (let* ((sample-count (quotient size 3))
           (out (make-bytes (* sample-count 4))))
      (for ([i (in-range sample-count)])
        (let* ((in-off (* i 3))
               (out-off (* i 4))
               (sample (native-signed-ref buffer in-off 3)))
          (native-signed-set! out out-off 4 (clamp-s32 (arithmetic-shift sample 8)))))
      out))

  (define (s32-bytes->s24-bytes buffer size)
    (let* ((sample-count (quotient size 4))
           (out (make-bytes (* sample-count 3))))
      (for ([i (in-range sample-count)])
        (let* ((in-off (* i 4))
               (out-off (* i 3))
               (sample (native-signed-ref buffer in-off 4)))
          (native-signed-set! out out-off 3 (clamp-s24 (arithmetic-shift sample -8)))))
      out))

  (define (subbytes/size bs size)
    (if (= size (bytes-length bs)) bs (subbytes bs 0 size)))

  (define (prepare-input-bytes r buffer size)
    (case (resampler-input-format r)
      [(s24) (s24-bytes->s32-bytes buffer size)]
      [else (subbytes/size buffer size)]))

  (define (finish-output-bytes r buffer size)
    (case (resampler-output-format r)
      [(s24) (s32-bytes->s24-bytes buffer size)]
      [else (subbytes/size buffer size)]))

  (define (output-frame-capacity r in-frames)
    (let* ((ratio (/ (resampler-output-rate r) (resampler-input-rate r)))
           (delay (if (resampler-ctx r) (max 0.0 (soxr-delay (resampler-ctx r))) 0.0))
           (n (ceiling (+ 256 delay (* in-frames ratio)))))
      (max 256 (inexact->exact n))))

  (define (make-resampler input-rate output-rate channels
                          #:input-format [input-format 's32]
                          #:output-format [output-format 's32]
                          #:quality [quality 'hq]
                          #:phase [phase 'linear]
                          #:steep-filter? [steep-filter? #f]
                          #:scale [scale 1.0]
                          #:no-dither? [no-dither? #f]
                          #:num-threads [num-threads 1])
    (unless (resampler-available?)
      (error 'make-resampler "libsoxr is not available"))
    (unless (and (integer? channels) (> channels 0))
      (raise-argument-error 'make-resampler "exact-positive-integer?" channels))
    (let* ((in-fmt (normalize-format input-format 'make-resampler))
           (out-fmt (normalize-format output-format 'make-resampler))
           (itype (pcm-format->soxr-datatype in-fmt))
           (otype (pcm-format->soxr-datatype out-fmt))
           (io-flags (if no-dither? SOXR_NO_DITHER 0))
           (quality-flags (bitwise-ior (phase->flags phase) (if steep-filter? SOXR_STEEP_FILTER 0)))
           (io-spec (soxr-io-spec itype otype #:scale scale #:flags io-flags))
           (quality-spec (soxr-quality-spec (quality->soxr-recipe quality) #:flags quality-flags))
           (runtime-spec (soxr-runtime-spec #:num-threads num-threads)))
      (let-values (((ctx err) (soxr-create input-rate output-rate channels
                                           #:io-spec io-spec
                                           #:quality-spec quality-spec
                                           #:runtime-spec runtime-spec)))
        (check-error 'make-resampler err)
        (unless ctx (error 'make-resampler "libsoxr returned no resampler context"))
        (make-raw-resampler ctx input-rate output-rate channels in-fmt out-fmt itype otype
                            (pcm-format-actual-sample-bytes in-fmt)
                            (pcm-format-actual-sample-bytes out-fmt)
                            #f))))

  (define (ensure-open! r who)
    (when (or (not (resampler? r)) (resampler-closed? r))
      (error who "resampler is closed")))

  (define (check-frame-size who size frame-bytes)
    (unless (= (remainder size frame-bytes) 0)
      (error who "buffer size ~a is not a whole number of interleaved frames of ~a bytes" size frame-bytes)))

  (define (resampler-convert r buffer [size (bytes-length buffer)])
    (ensure-open! r 'resampler-convert)
    (let* ((nominal-in-frame-bytes (* (resampler-channels r) (pcm-format-sample-bytes (resampler-input-format r))))
           (actual-in-frame-bytes (* (resampler-channels r) (resampler-input-sample-bytes r))))
      (check-frame-size 'resampler-convert size nominal-in-frame-bytes)
      (cond [(zero? size) (values #"" 0)]
            [else
             (let* ((in-frames (quotient size nominal-in-frame-bytes))
                    (prepared (prepare-input-bytes r buffer size))
                    (in-ptr0 (bytes->native prepared (bytes-length prepared))))
               (let loop ((offset-frames 0) (remaining in-frames) (pieces '()) (total-frames 0))
                 (cond [(zero? remaining) (values (apply bytes-append (reverse pieces)) total-frames)]
                       [else
                        (let* ((out-cap (output-frame-capacity r remaining))
                               (out-size (* out-cap (resampler-channels r) (resampler-output-sample-bytes r)))
                               (out-ptr (malloc out-size 'atomic-interior))
                               (in-ptr (ptr-add in-ptr0 (* offset-frames actual-in-frame-bytes))))
                          (let-values (((err idone odone) (soxr-process (resampler-ctx r) in-ptr remaining out-ptr out-cap)))
                            (check-error 'resampler-convert err)
                            (when (and (> remaining 0) (zero? idone) (zero? odone))
                              (error 'resampler-convert "libsoxr made no progress"))
                            (let* ((raw-size (* odone (resampler-channels r) (resampler-output-sample-bytes r)))
                                   (raw (native->bytes out-ptr raw-size))
                                   (piece (finish-output-bytes r raw raw-size)))
                              (loop (+ offset-frames idone) (- remaining idone)
                                    (if (zero? odone) pieces (cons piece pieces))
                                    (+ total-frames odone)))))])))])))

  (define (resampler-drain r)
    (ensure-open! r 'resampler-drain)
    (let loop ((pieces '()) (total-frames 0))
      (let* ((delay (max 0.0 (soxr-delay (resampler-ctx r))))
             (out-cap (max 4096 (inexact->exact (ceiling (+ delay 256)))))
             (out-size (* out-cap (resampler-channels r) (resampler-output-sample-bytes r)))
             (out-ptr (malloc out-size 'atomic-interior)))
        (let-values (((err idone odone) (soxr-process (resampler-ctx r) #f 0 out-ptr out-cap)))
          (check-error 'resampler-drain err)
          (cond [(zero? odone) (values (apply bytes-append (reverse pieces)) total-frames)]
                [else
                 (let* ((raw-size (* odone (resampler-channels r) (resampler-output-sample-bytes r)))
                        (raw (native->bytes out-ptr raw-size))
                        (piece (finish-output-bytes r raw raw-size)))
                   (loop (cons piece pieces) (+ total-frames odone)))])))))

  (define (resampler-clear! r)
    (ensure-open! r 'resampler-clear!)
    (check-error 'resampler-clear! (soxr-clear (resampler-ctx r)))
    #t)

  (define (resampler-close! r)
    (when (and (resampler? r) (not (resampler-closed? r)))
      (soxr-delete (resampler-ctx r))
      (set-resampler-ctx! r #f)
      (set-resampler-closed?! r #t))
    #t)

  (define (resample-bytes buffer input-rate output-rate channels
                          #:size [size (bytes-length buffer)]
                          #:input-format [input-format 's32]
                          #:output-format [output-format 's32]
                          #:quality [quality 'hq]
                          #:phase [phase 'linear]
                          #:steep-filter? [steep-filter? #f]
                          #:scale [scale 1.0]
                          #:no-dither? [no-dither? #f]
                          #:num-threads [num-threads 1])
    (let ((r (make-resampler input-rate output-rate channels
                             #:input-format input-format
                             #:output-format output-format
                             #:quality quality
                             #:phase phase
                             #:steep-filter? steep-filter?
                             #:scale scale
                             #:no-dither? no-dither?
                             #:num-threads num-threads)))
      (dynamic-wind
       void
       (lambda ()
         (let-values (((a af) (resampler-convert r buffer size)))
           (let-values (((b bf) (resampler-drain r)))
             (values (bytes-append a b) (+ af bf)))))
       (lambda () (resampler-close! r)))))

  ) ; end of module