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 (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (rnrs bytevectors)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-9 gnu)
  #: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 ogg-sync-state
  (list '* ; data
        int ; storage
        int ; fill
        int ; returned
        int ; unsynced
        int ; headerbytes
        int ; bodybytes
        ))

(define ogg-stream-state
  (list '* ; body_data
        long ; body_storage
        long ; body_fill
        long ; body_returned
        '* ; lacing_vals
        '* ; granule_vals
        long ; lacing_storage
        long ; lacing_fill
        long ; lacing_packet
        long ; lacing_returned
        (make-list 282 uint8) ; header
        int ; header_fill
        int ; e_o_s
        int ; b_o_s
        long ; serialno
        long ; pageno
        int64 ; packetno
        int64 ; granulepos
        ))

(define oggpack-buffer
  (list long ; endbyte
        int ; endbit
        '* ; buffer
        '* ; ptr
        long ; storage
        ))

(define vorbis-dsp-state
  (list int ; analysisp
        '* ; vi
        '* ; pcm
        '* ; pcmret
        int ; pcm_storage
        int ; pcm_current
        int ; pcm_returned
        int ; preextrapolate
        int ; eofflag
        long ; lW
        long ; W
        long ; nW
        long ; centerW
        int64 ; granulepos
        int64 ; sequence
        int64 ; glue_bits
        int64 ; time_bits
        int64 ; floor_bits
        int64 ; res_bits
        '* ; backend_state
        ))

(define vorbis-block
  (list '* ; pcm
        oggpack-buffer ; opb
        long ; lW
        long ; W
        long ; nW
        int ; pcmend
        int ; mode
        int ; eofflag
        int64 ; granulepos
        int64 ; sequence
        '* ; vd
        '* ; localstore
        long ; localtop
        long ; localalloc
        long ; totaluse
        '* ; reap
        long ; glue_bits
        long ; time_bits
        long ; floor_bits
        long ; res_bits
        '* ; internal
        ))

(define %vorbis-info
  (list int ; version
        int ; channels
        long ; rate
        long ; bitrate_upper
        long ; bitrate_nominal
        long ; bitrate_lower
        long ; bitrate_window
        '* ; codec_setup
        ))

(define ov-callbacks
  (list '* ; read_func
        '* ; seek_func
        '* ; close_func
        '* ; tell_func
        ))

(define ogg-vorbis-file
  (list '* ; datasource
        int ; seekable
        int64 ; offset
        int64 ; end
        ogg-sync-state ; oy
        int ; links
        '* ; offsets
        '* ; dataoffsets
        '* ; serialnos
        '* ; pcmlengths
        '* ; vi
        '* ; vc
        int64 ; pcm_offset
        int ; ready_state
        long ; current_serialno
        int ; current_link
        double ; bittrack
        double ; samptrack
        ogg-stream-state ; os
        vorbis-dsp-state ; vd
        vorbis-block ; vb
        ov-callbacks ; 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-record-type <vorbis-file>
  (wrap-vorbis-file bv ptr)
  vorbis-file?
  (bv vorbis-file-bv)
  (ptr unwrap-vorbis-file))

(define (display-vorbis-file vf port)
  (format port "#<vorbis-file ~x>" (pointer-address (unwrap-vorbis-file vf))))

(set-record-type-printer! <vorbis-file> display-vorbis-file)

(define (vorbis-open file-name)
  "Open the OGG Vorbis audio file located at FILE-NAME."
  (let* ((bv (make-bytevector (sizeof ogg-vorbis-file)))
         (ptr (bytevector->pointer bv)))
    (ov-fopen (string->pointer file-name) ptr)
    (wrap-vorbis-file bv ptr)))

(define (vorbis-clear vf)
  "Clear the buffers of the Vorbis file VF."
  (ov-clear (unwrap-vorbis-file vf)))

(define-record-type <vorbis-info>
  (make-vorbis-info version channels sample-rate)
  vorbis-info?
  (version vorbis-info-version)
  (channels vorbis-info-channels)
  (sample-rate vorbis-info-sample-rate))

(define (vorbis-info vf)
  (match (parse-c-struct (ov-info (unwrap-vorbis-file vf) -1)
                         %vorbis-info)
    ((version channels sample-rate _ _ _ _ _)
     (make-vorbis-info version channels sample-rate))))

(define (vorbis-time-total vf)
  (ov-time-total (unwrap-vorbis-file vf) -1))

(define (vorbis-time-seek vf t)
  (ov-time-seek (unwrap-vorbis-file vf) t))

(define* (vorbis-read vf buffer #:optional (start 0))
  (ov-read (unwrap-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))))