racket/collects/ffi/examples/sndfile.rkt
2012-06-25 15:59:17 -06:00

516 lines
21 KiB
Racket

#lang racket/base
(require ffi/unsafe
ffi/vector
racket/match
racket/runtime-path)
;; the constants in this file are pulled from version 1.0.21 of the
;; libsndfile header file. However, I think it would be a mistake to
;; specify this in the call to ffi-lib; it appears that this version is
;; a conservative extension of the earlier version (1.0.17?), and I
;; think you'll get graceful failures if the version is wrong.
(define-runtime-path mac-ffi-path "./lib/libsndfile")
(define libsndfile
(match (system-type)
['unix (ffi-lib "libsndfile" '("1.0.21" "1.0.20" ""))]
['macosx (ffi-lib mac-ffi-path '("1.0.21" "1.0.20" ""))]
['windows (error 'libsndfile "libsndfile not supported on windows.")]))
;; ==================== Types etc ====================
;; This is the scheme representation of the soundfile that is handled by
;; libsndfile.
;; In libsndfile the sndfile object is represented as a pointer. When
;; translating scheme->c the struct will just return the pointer. When
;; translating from c->scheme, ie. creating the object in scheme it will be
;; wrapped by an object finalizer that uses the libsndfile fuction sf_close that
;; returns a 0 upon successful termination or an error.
(define-struct sndfile (ptr [info #:mutable]))
(define _sndfile
(make-ctype _pointer sndfile-ptr
(lambda (p)
;; can't check here for null-ness of p, the check has to be
;; specific to the call.
(make-sndfile p #f))))
;; sf_count_t is a count type that depends on the operating system however it
;; seems to be a long int for all the supported ones so in this case we just
;; define it as an int64.
(define _sf-count-t _int64)
(define _sf-mode
(_bitmask '(sfm-read = #x10
sfm-write = #x20
sfm-rdwrt = #x30
;; I really have no clue what these are for:
sf-ambisonic-none = #x40
sf-ambisonic-b-format = #x41)))
(define str-types '(title copyright software artist comment date album license))
(define _sf-str-type (_enum (cons "dummy" str-types))) ; begins from 1
(define _sf-error (_enum '(no-error unrecognised-format system malformed-file unsupported-encoding)))
(define _sf-format
(let ([majors ; Major formats
'((wav #x010000) ; Microsoft WAV format (little endian default).
(aiff #x020000) ; Apple/SGI AIFF format (big endian).
(au #x030000) ; Sun/NeXT AU format (big endian).
(raw #x040000) ; RAW PCM data.
(paf #x050000) ; Ensoniq PARIS file format.
(svx #x060000) ; Amiga IFF / SVX8 / SV16 format.
(nist #x070000) ; Sphere NIST format.
(voc #x080000) ; VOC files.
(ircam #x0A0000) ; Berkeley/IRCAM/CARL
(w64 #x0B0000) ; Sonic Foundry's 64 bit RIFF/WAV
(mat4 #x0C0000) ; Matlab (tm) V4.2 / GNU Octave 2.0
(mat5 #x0D0000) ; Matlab (tm) V5.0 / GNU Octave 2.1
(pvf #x0E0000) ; Portable Voice Format
(xi #x0F0000) ; Fasttracker 2 Extended Instrument
(htk #x100000) ; HMM Tool Kit format
(sds #x110000) ; Midi Sample Dump Standard
(avr #x120000) ; Audio Visual Research
(wavex #x130000) ; MS WAVE with WAVEFORMATEX
(sd2 #x160000) ; Sound Designer 2
(flac #x170000) ; FLAC lossless file format
(caf #x180000) ; Core Audio File format
(wve #x190000) ; Psion WVE format
(ogg #x200000) ; Xiph OGG container
(mpc2k #x210000) ; Akai MPC 2000 sampler
(rf64 #x220000) ; RF64 WAV file
)]
[subtypes ; Subtypes from here on
'((pcm-s8 #x0001) ; Signed 8 bit data
(pcm-16 #x0002) ; Signed 16 bit data
(pcm-24 #x0003) ; Signed 24 bit data
(pcm-32 #x0004) ; Signed 32 bit data
(pcm-u8 #x0005) ; Unsigned 8 bit data (WAV and RAW only)
(float #x0006) ; 32 bit float data
(double #x0007) ; 64 bit float data
(ulaw #x0010) ; U-Law encoded
(alaw #x0011) ; A-Law encoded
(ima-adpcm #x0012) ; IMA ADPCM
(ms-adpcm #x0013) ; Microsoft ADPCM
(gsm610 #x0020) ; GSM 6.10 encoding
(vox-adpcm #x0021) ; OKI / Dialogix ADPCM
(g721-32 #x0030) ; 32kbs G721 ADPCM encoding
(g723-24 #x0031) ; 24kbs G723 ADPCM encoding
(g723-40 #x0032) ; 40kbs G723 ADPCM encoding
(dwvw-12 #x0040) ; 12 bit Delta Width Variable Word encoding
(dwvw-16 #x0041) ; 16 bit Delta Width Variable Word encoding
(dwvw-24 #x0042) ; 24 bit Delta Width Variable Word encoding
(dwvw-n #x0043) ; N bit Delta Width Variable Word encoding
(dpcm-8 #x0050) ; 8 bit differential PCM (XI only)
(dpcm-16 #x0051) ; 16 bit differential PCM (XI only)
(vorbis #x0060) ; Xiph Vorbis encoding.
)]
[endians ; Endian-ness options
'((file #x00000000) ; Default file endian-ness
(little #x10000000) ; Force little endian-ness
(big #x20000000) ; Force big endian-ness
(cpu #x30000000) ; Force CPU endian-ness
)]
[submask #x0000FFFF]
[typemask #x0FFF0000]
[endmask #x30000000])
(define (rev-find n l)
(let loop ([l l])
(cond [(null? l) #f]
[(eq? n (cadar l)) (caar l)]
[else (loop (cdr l))])))
(make-ctype _int
(lambda (syms)
(let ([major #f] [subtype #f] [endian #f])
(for-each
(lambda (sym)
(cond [(assq sym majors) =>
(lambda (x)
(if major
(error 'sf-format "got two major modes: ~s" syms)
(set! major (cadr x))))]
[(assq sym subtypes) =>
(lambda (x)
(if subtype
(error 'sf-format "got two subtype modes: ~s" syms)
(set! subtype (cadr x))))]
[(assq sym endians) =>
(lambda (x)
(if endian
(error 'sf-format "got two endian modes: ~s" syms)
(set! endian (cadr x))))]
[else (error 'sf-format "got a bad symbol: ~s" sym)]))
(if (list? syms) syms (list syms)))
(bitwise-ior (or major 0) (or subtype 0) (or endian 0))))
(lambda (n)
(let ([subtype (rev-find (bitwise-and n submask) subtypes)]
[major (rev-find (bitwise-and n typemask) majors)]
[endian (rev-find (bitwise-and n endmask) endians)])
(unless subtype
(error 'sf-format "got a bad number from C for subtype: ~x"
(bitwise-and n submask)))
(unless major
(error 'sf-format "got a bad number from C for major: ~x"
(bitwise-and n typemask)))
(unless endian
(error 'sf-format "got a bad number from C for endian: ~x"
(bitwise-and n endmask)))
(list major subtype endian))))))
(define-cstruct _sf-info
((frames _sf-count-t)
(samplerate _int)
(channels _int)
(format _sf-format)
(sections _int)
(seekable _bool)))
;; ==================== Utilities ====================
;; extract the given function from the library by replacing
;; hyphens with underscores in the name.
(define-syntax defsndfile
(syntax-rules (:)
[(_ name : type ...)
(define name
(get-ffi-obj (regexp-replaces (symbol->string 'name) '((#rx"-" "_")))
libsndfile (_fun type ...)))]))
(define (n-split l n)
(let loop ([l l][i 0][a2 null][a null])
(cond
[(null? l) (let ([a (if (null? a2)
a
(cons (reverse a2) a))])
(reverse a))]
[(= i n) (loop l 0 null (cons (reverse a2) a))]
[else (loop (cdr l) (add1 i) (cons (car l) a2) a)])))
;; ==================== sndfile API ====================
(defsndfile sf-strerror : _sndfile -> _string)
(defsndfile sf-error : _sndfile -> _int)
(defsndfile sf-close : _sndfile -> _int)
;; sf-open : path mode [optional-sf-info-pointer] -> sndfile
(defsndfile sf-open : (path mode . info) ::
(path : _file)
(mode : _sf-mode)
(info : _sf-info-pointer
= (if (pair? info) (car info) (make-sf-info 0 0 0 '() 0 #f)))
-> (sf : _sndfile)
-> (if (sndfile-ptr sf)
(begin (set-sndfile-info! sf info) sf)
;; goofy way to get the error code:
(error 'sf-open "~a" (sf-strerror (make-sndfile #f #f)))))
(defsndfile sf-format-check : _sf-info-pointer -> _bool)
(defsndfile sf-readf-short : _sndfile _pointer _sf-count-t -> _sf-count-t)
(defsndfile sf-readf-int : _sndfile _pointer _sf-count-t -> _sf-count-t)
(defsndfile sf-readf-float : _sndfile _pointer _sf-count-t -> _sf-count-t)
(defsndfile sf-readf-double : _sndfile _pointer _sf-count-t -> _sf-count-t)
(defsndfile sf-writef-short : _sndfile _pointer _sf-count-t -> _sf-count-t)
(defsndfile sf-writef-int : _sndfile _pointer _sf-count-t -> _sf-count-t)
(defsndfile sf-writef-float : _sndfile _pointer _sf-count-t -> _sf-count-t)
(defsndfile sf-writef-double : _sndfile _pointer _sf-count-t -> _sf-count-t)
(defsndfile sf-get-string : _sndfile _sf-str-type -> _string)
(defsndfile sf-set-string : _sndfile _sf-str-type _string -> _bool)
;; ==================== Utilities for the Scheme interface ====================
;; get-meta-strings : sndfile -> (listof (list/c sf-str-type string))
;; produce an association list for the meta-information associated with
;; the sndfile
;; Q: can sf-get-string signal an error? apparently so. I think it makes
;; sense to identify these errors with the simple lack of the string,
;; which requires no change to the code. I hope that such an error
;; doesn't pollute later operations on the soundfile.
(define (get-meta-strings sndfile)
(for/list ([s (in-list str-types)]
#:when (sf-get-string sndfile s))
(list s (string-copy (sf-get-string sndfile s)))))
;; set-meta-strings : sndfile (listof (list/c sf-str-type string)) -> (void)
;; given a sndfile and an association list between symbols and strings,
;; attach each string to the soundfile under the given symbol.
;; ** Ignores errors that occur during calls to sf-set-string. **
(define (set-meta-strings sndfile meta)
(for ([st (in-list str-types)])
(let ([found (assq st meta)])
(when found (sf-set-string sndfile st (cadr found))))))
;; read-sound-internal : path-string -> (values/c (or/c cblock (listof (listof sample))) a-list)
;; read the data from a file.
(define (read-sound-internal file)
(let* ([sndfile (sf-open file 'sfm-read)]
[strings (get-meta-strings sndfile)]
[info (sndfile-info sndfile)]
[frames (sf-info-frames info)]
[channels (sf-info-channels info)]
[stype (case (sample-type)
[(short) _int16] [(int) _int] [(float) _double*])]
[readf (sample-type->reader (sample-type))]
[cblock ((sample-type->vector-maker (sample-type)) (* frames channels))]
[num-read (readf sndfile ((sample-type->cpointer-extractor (sample-type)) cblock) frames)])
(unless (= frames num-read)
(error 'read-sound-internal "wanted ~e frames, but got ~e: ~e"
frames num-read (sf-strerror sndfile)))
(begin0 (values cblock
`((frames ,frames)
(samplerate ,(sf-info-samplerate info))
(channels ,channels)
(format ,(sf-info-format info))
(sections ,(sf-info-sections info))
,@strings))
(unless (= 0 (sf-close sndfile))
(error 'read-sound-internal "error while closing file: ~e"
(sf-strerror sndfile))))))
;; split-sound-cblock : cblock ffi-type nat nat -> (listof frame)
;; ... where frame is (listof sample-value)
;; NOT SUPPORTING THE LIST INTERFACE RIGHT NOW (2010-09-24)
#;(define (split-sound-cblock cblock stype frames channels)
(let* ([data (cblock->list cblock stype (* frames channels))])
(n-split data channels)))
;; frame-list->cblock : (listof (listof sample)) nat nat ctype -> cblock
(define (frame-list->cblock data frames channels type)
(cond
[(null? data) #f]
;; planning to get rid of this special-case...:
[(and (= 1 channels) (not (pair? (car data)))) (list->cblock data type)]
[else
(let ([test (lambda (x)
(and (list? x) (= channels (length x)) (andmap number? x)))])
(unless (andmap test data)
(error 'frame-list->cblock "got a bad frame: ~e"
(ormap (lambda (x) (and (not (test x)) x)) data))))
(let ([cblock (malloc (* channels frames) type)]
[i 0])
(let loop ([d data])
(cond [(number? d) (ptr-set! cblock type i d) (set! i (add1 i))]
[(pair? d) (loop (car d)) (loop (cdr d))]))
cblock)]))
;; there are some ugly hidden invariants here: what if the sample-type doesn't match
;; what's specified in the format? This is a question about libsndfile, and I should check it out...
;; write-sound-internal/s16vector
(define (write-sound-internal/s16vector file cblock format samplerate frames channels sample-type meta)
(check-filename-format format file)
(let* ([writef (sample-type->writer sample-type)]
[info (make-sf-info frames samplerate channels format 1 #f)]
[_ (unless (sf-format-check info)
(error 'write-sound-internal "bad format: ~s" format))]
[sndfile (sf-open file 'sfm-write info)]
[_ (set-meta-strings sndfile meta)]
[num-write (writef sndfile (s16vector->cpointer cblock) frames)])
(unless (= frames num-write)
(error 'write-sound-internal/s16vector
"wanted to write ~s frames, but wrote only ~s. ~s"
frames num-write (sf-strerror sndfile)))
(unless (= 0 (sf-close sndfile))
(error 'write-sound-internal/s16vector "failed to close file: ~s" (sf-strerror sndfile)))
(void)))
;; write-sound-internal/lists : path-string (listof (listof sample)) (listof (list/c symbol? string?)) -> (void)
;; a bunch of guessing happens here...
(define (write-sound-internal/lists file data meta)
(let* ([frames (length data)]
[channels (if (or (null? data) (not (pair? (car data))))
1 ; 1-channel if no data, or data is not made of lists
(length (car data)))]
[stype (case (sample-type)
[(short) _int16] [(int) _int] [(float) _float] [(double) _double*])]
[cblock (frame-list->cblock data frames channels stype)]
[format (cond [(assq 'format meta) => cadr]
[else (guess-format file)])]
[samplerate (cond [(assq 'samplerate meta) => cadr]
[else (default-samplerate)])])
(write-sound-internal/s16vector file cblock format samplerate frames channels (sample-type) meta)))
(define file-format-table
'((#rx"\\.aiff?" (aiff pcm-16 file))
(#rx"\\.wave?" (wav pcm-16 file))
(#rx"\\.au" (au pcm-16 file))
(#rx"\\.snd" (au pcm-16 file))
(#rx"\\.svx" (svx pcm-16 file))
(#rx"\\.paf" (paf pcm-16 big))
(#rx"\\.fap" (paf pcm-16 little))
(#rx"\\.nist" (nist pcm-16 little))
(#rx"\\.ircam" (ircam pcm-16 little))
(#rx"\\.sf" (ircam pcm-16 little))
(#rx"\\.voc" (voc pcm-16 file))
(#rx"\\.w64" (w64 pcm-16 file))
(#rx"\\.raw" (raw pcm-16 cpu))
(#rx"\\.mat4" (mat4 pcm-16 little))
(#rx"\\.mat5" (mat5 pcm-16 little))
(#rx"\\.mat" (mat4 pcm-16 little))
(#rx"\\.pvf" (pvf pcm-16 file))
(#rx"\\.sds" (sds pcm-16 file))
(#rx"\\.xi" (xi dpcm-16 file))))
(define (guess-format filename)
(let loop ([xs file-format-table])
(cond [(null? xs) (default-file-format)]
[(regexp-match (caar xs) filename) (cadar xs)]
[else (loop (cdr xs))])))
;; check-filename-format : format filename -> (void)
;; check that the format is compatible with the given pathname; it
;; should not be possible to write, e.g., an aiff file to a filename
;; ending in ".voc". If we don't recognize the filename extension, it's
;; okay.
;; EFFECT: signals an error if the format and filename are incompatible
(define (check-filename-format format filename)
(match format
[(list major minor file)
(let loop ([xs file-format-table])
(cond [(null? xs) (void)]
[(regexp-match (caar xs) filename)
(match (cadar xs)
[(list major/f minor/f file/f)
(unless (eq? major major/f)
(error 'check-filename-format
"can't use format ~s with filename ~s."
format
filename))]
[other
(error 'check-filename-format
"internal error: unrecognized format format in filename table: ~s" other)])]
[else (loop (cdr xs))]))]
[other
(error 'check-filename-format
"illegal format format: ~s" other)]))
;; return the reader that corresponds to a given sample-type
(define sample-type->reader
(match-lambda
['short sf-readf-short]
['int sf-readf-int]
['double sf-readf-double]))
;; return the writer that corresponds to a given sample-type
(define sample-type->writer
(match-lambda
['short sf-writef-short]
['int sf-writef-int]
['double sf-writef-double]))
;; return the vector-maker that corresponds to a given sample-type
(define sample-type->vector-maker
(match-lambda
['short make-s16vector]
['int make-s32vector]
['double make-f64vector]))
;; return the cpointer-extractor that corresponds to a given sample-type
(define sample-type->cpointer-extractor
(match-lambda
['short s16vector->cpointer]
['int s32vector->cpointer]
['double flvector->cpointer]))
;; ==================== Exposed Scheme interface ====================
;; types of samples we handle: 'short, 'int, 'double
(provide sample-type)
(define sample-type
(make-parameter
'float (lambda (x)
(if (memq x '(short int double))
x
(error 'sample-type "bad or unsupported type: ~s" x)))))
;; TODO: add a parameter that will determine if you get a list, vector or
;; srfi/4-like thing. possibly also determine if a list/vector gets automatic
;; treatment of 1-channel - not converting it into a list of singleton lists.
(provide default-samplerate)
(define default-samplerate
(make-parameter
11025 (lambda (x)
(if (and (integer? x) (positive? x))
x (error 'default-samplerate "bad samplerate: ~s" x)))))
(provide default-file-format)
(define default-file-format ; no guard, but should be good for _sf-format
(make-parameter '(wav pcm-16 file)))
;; read-sound : path-string -> (listof frame)
;; ... where frame is (listof sample)
(provide read-sound)
(define (read-sound file)
(let*-values ([(data meta) (read-sound-internal file)])
data))
(provide read-sound*)
(define (read-sound* file)
(read-sound-internal file #:split #t))
(provide write-sound)
(define (write-sound file data)
(write-sound-internal/lists file data '()))
(provide write-sound*)
(define (write-sound* file data meta)
(write-sound-internal/lists file data meta))
;; here's a simplified interface that leaves sounds packed as
;; C data. It's 2-channel 32-bit float only. Also, it discards
;; all meta-information except length and sample-rate.
(define global-channels 2)
;; read-sound/s16vector : path-string -> (list/c _pointer nat nat)
;; read the file into a buffer, return the data, the number of frames,
;; and the sample rate.
(provide read-sound/s16vector)
(define (read-sound/s16vector file)
(parameterize ([sample-type 'short])
(let*-values ([(cblock meta) (read-sound-internal file)])
(list cblock (cadr (assq 'frames meta)) (cadr (assq 'samplerate meta))))))
;; write-sound/s16vector : _pointer nat nat path-string -> (void)
;; write the cblock sound to the given file as a wav.
(provide write-sound/s16vector)
(define (write-sound/s16vector data sample-rate file)
(write-sound-internal/s16vector file data '(wav pcm-16 file)
sample-rate
(/ (s16vector-length data) global-channels)
2
'short
;; meta-data not supported.
'()))
;; test cases for check-filename-format: Commented out until there's a critical mass.
;; okay even though minor and file don't match:
;(check-not-exn (lambda () (check-filename-format '(wav float file) "/tmp/zabaglione.wav")))
;; major doesn't match:
;(check-exn exn:fail? (lambda () (check-filename-format '(wav float file) "/tmp/zabaglione.mat")))
;; bad input format:
;(check-exn exn:fail? (lambda () (check-filename-format '(spam spam spam spam) "/tmp/zabaglione.wav")))