path: root/chickadee/audio/vorbis.scm

;;; Chickadee Game Toolkit
;;; Copyright © 2019 David Thompson <dthompson2@worcester.edu>
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;    http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

;;; Commentary:
;;
;; libvorbis bindings.
;;
;;; Code:

(define-module (chickadee audio vorbis)
  #:use-module (chickadee config)
  #:use-module (chickadee data bytestruct)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (rnrs bytevectors)
  #:use-module (system foreign)
  #:export (vorbis-open
            vorbis-clear
            vorbis-info
            vorbis-time-total
            vorbis-time-seek
            vorbis-read
            vorbis-fill-buffer

            vorbis-info?
            vorbis-info-version
            vorbis-info-channels
            vorbis-info-sample-rate))


;;;
;;; Low-level Bindings
;;;

(define vorbis-func
  (let ((lib (dynamic-link* %libvorbisfile)))
    (lambda (return-type function-name arg-types)
      (pointer->procedure return-type
                          (dynamic-func function-name lib)
                          arg-types))))

(define-syntax-rule (define-foreign name return-type func-name arg-types)
  (define name
    (vorbis-func return-type func-name arg-types)))

(define-bytestruct <ogg-sync-state>
  (struct
   (data (* u8))
   (storage int)
   (fill int)
   (returned int)
   (unsynced int)
   (headerbytes int)
   (bodybytes int)))

(define-bytestruct <ogg-stream-state>
  (struct
   (body-data (* u8))
   (body-storage long)
   (body-fill long)
   (body-returned long)
   (lacing-vals (* int))
   (granule-vals (* s64))
   (lacing-storage long)
   (lacing-fill long)
   (lacing-packet long)
   (lacing-returned long)
   (header (array 282 u8))
   (header-fill int)
   (e_o_s int)
   (b_o_s int)
   (serialno long)
   (pageno long)
   (packetno s64)
   (granulepos s64)))

(define-bytestruct <oggpack-buffer>
  (struct
   (endbyte long)
   (endbit int)
   (buffer (* u8))
   (ptr (* u8))
   (storage long)))

(define-bytestruct <vorbis-info>
  (struct
   (version int)
   (channels int)
   (rate long)
   (bitrate-upper long)
   (bitrate-nominal long)
   (bitrate-lower long)
   (bitrate-window long)
   (codec-setup (* void))))

(define-bytestruct-predicate vorbis-info? <vorbis-info>)
(define-bytestruct-getter vorbis-info-version <vorbis-info> (version))
(define-bytestruct-getter vorbis-info-channels <vorbis-info> (channels))
(define-bytestruct-getter vorbis-info-sample-rate <vorbis-info> (rate))

(define-bytestruct <vorbis-comment>
  (struct
   (user-comments (* (* u8)))
   (comment-lengths (* int))
   (comments int)
   (vendor (* u8))))

(define-bytestruct <vorbis-dsp-state>
  (struct
   (analysisp int)
   (vi (* <vorbis-info>))
   (pcm (* (* f32)))
   (prcmret (* (* f32)))
   (pcm-storage int)
   (pcm-current int)
   (pcm-returned int)
   (preextrapolate int)
   (eofflag int)
   (lW long)
   (W long)
   (nW long)
   (centerW long)
   (granulepos s64)
   (sequence s64)
   (glue-bits s64)
   (time-bits s64)
   (floor-bits s64)
   (res-bits s64)
   (backend-state (* void))))

(define-bytestruct <alloc-chain>
  (struct
   (ptr (* void))
   (next (* <alloc-chain>))))

(define-bytestruct <vorbis-block>
  (struct
   (pcm (* (* f32)))
   (opb <oggpack-buffer>)
   (lW long)
   (W long)
   (nW long)
   (pcmend int)
   (mode int)
   (eofflag int)
   (granulepos s64)
   (sequence s64)
   (vd (* <vorbis-dsp-state>))
   (localstore (* void))
   (localtop long)
   (localalloc long)
   (totaluse long)
   (reap (* <alloc-chain>))
   (glue-bits long)
   (time-bits long)
   (floor-bits long)
   (res-bits long)
   (internal (* void))))

(define-bytestruct <ov-callbacks>
  (struct
   ;; These are actually function pointers, but we don't use them so
   ;; void pointers are fine.
   (read-func (* void))
   (seek-func (* void))
   (close-func (* void))
   (tell-func (* void))))

(define-bytestruct <ogg-vorbis-file>
  (struct
   (datasource (* void))
   (seekable int)
   (offset s64)
   (end s64)
   (oy <ogg-sync-state>)
   (links int)
   (offsets (* s64))
   (dataoffsets (* s64))
   (serialnos (* long))
   (pcmlengths (* s64))
   (vi (* <vorbis-info>))
   (vc (* <vorbis-comment>))
   (pcm-offset s64)
   (ready-state int)
   (current-seialno long)
   (current-link int)
   (bittrack f64)
   (samptrack f64)
   (os <ogg-stream-state>)
   (vd <vorbis-dsp-state>)
   (vb <vorbis-block>)
   (callbacks <ov-callbacks>)))

(define OV_FALSE -1)
(define OV_EOF -2)
(define OV_HOLE -3)
(define OV_EREAD -128)
(define OV_EFAULT -129)
(define OV_EIMPL -130)
(define OV_EINVAL -131)
(define OV_ENOTVORBIS -132)
(define OV_EBADHEADER -133)
(define OV_EVERSION -134)
(define OV_ENOTAUDIO -135)
(define OV_EBADPACKET -136)
(define OV_EBADLINK -137)
(define OV_ENOSEEK -138)

(define-foreign ov-fopen
  int "ov_fopen" '(* *))

(define-foreign ov-open-callbacks
  int "ov_open_callbacks" (list '* '* '* long '*))

(define-foreign ov-clear
  int "ov_clear" '(*))

(define-foreign ov-info
  '* "ov_info" (list '* int))

(define-foreign ov-read
  long "ov_read" (list '* '* int int int int '*))

(define-foreign ov-comment
  '* "ov_comment" (list '* int))

(define-foreign ov-raw-seek
  int "ov_raw_seek" (list '* long))

(define-foreign ov-time-seek
  int "ov_time_seek" (list '* double))

(define-foreign ov-seekable
  long "ov_seekable" '(*))

(define-foreign ov-time-total
  double "ov_time_total" (list '* int))


;;;
;;; High-level public API
;;;

(define (vorbis-open file-name)
  "Open the OGG Vorbis audio file located at FILE-NAME."
  (let ((vf (bytestruct-alloc <ogg-vorbis-file>)))
    (ov-fopen (string->pointer file-name)
              (bytestruct->pointer <ogg-vorbis-file> vf))
    vf))

(define (vorbis-clear vf)
  "Clear the buffers of the Vorbis file VF."
  (ov-clear (bytestruct->pointer <ogg-vorbis-file> vf)))

(define (vorbis-info vf)
  (pointer->bytestruct <vorbis-info> (bytestruct-ref <ogg-vorbis-file> (vi) vf)))

(define (vorbis-time-total vf)
  (ov-time-total (bytestruct->pointer <ogg-vorbis-file> vf) -1))

(define (vorbis-time-seek vf t)
  (ov-time-seek (bytestruct->pointer <ogg-vorbis-file> vf) t))

(define* (vorbis-read vf buffer #:optional (start 0))
  (ov-read (bytestruct->pointer <ogg-vorbis-file> vf)
           (bytevector->pointer buffer start)
           (- (bytevector-length buffer) start)
           0 ; little endian
           2 ; 16 bits per sample
           1 ; signed data
           %null-pointer))

(define (vorbis-fill-buffer vf buffer)
  (let ((capacity (bytevector-length buffer)))
    (let loop ((size 0))
      (if (< size capacity)
          (let ((result (vorbis-read vf buffer size)))
            (cond
             ((zero? result)
              size)
             ((= result OV_HOLE)
              (loop size))
             ((or (= result OV_EBADLINK) (= result OV_EINVAL))
              -1)
             (else
              (loop (+ size result)))))
          size))))