suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

updates to sndfile

Browse Source
This commit is contained in:
John Clements 2010-09-28 08:12:04 -07:00
parent 3e78806e67
commit e29c14c260
1 changed files with 59 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

97
collects/ffi/examples/sndfile.rkt
View File

@ -1,15 +1,21 @@
#lang racket/base #lang racket/base
(require ffi/unsafe (require ffi/unsafe
#;rackunit ffi/vector
racket/match) racket/match
racket/runtime-path)
;; the constants in this file are pulled from version 1.0.21 of the libsndfile header file. However, ;; 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 ;; 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 ;; 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. ;; think you'll get graceful failures if the version is wrong.
(define libsndfile (ffi-lib "libsndfile")) (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 ==================== ;; ==================== Types etc ====================
@ -205,7 +211,7 @@
-> (if (sndfile-ptr sf) -> (if (sndfile-ptr sf)
(begin (set-sndfile-info! sf info) sf) (begin (set-sndfile-info! sf info) sf)
;; goofy way to get the error code: ;; goofy way to get the error code:
(error 'sf-read "~a" (sf-strerror (make-sndfile #f #f))))) (error 'sf-open "~a" (sf-strerror (make-sndfile #f #f)))))
(defsndfile sf-format-check : _sf-info-pointer -> _bool) (defsndfile sf-format-check : _sf-info-pointer -> _bool)
@ -247,9 +253,9 @@
(when found (sf-set-string sndfile st (cadr found)))))) (when found (sf-set-string sndfile st (cadr found))))))
;; read-sound-internal : path-string [bool] -> (values/c (or/c cblock (listof (listof sample))) a-list) ;; read-sound-internal : path-string -> (values/c (or/c cblock (listof (listof sample))) a-list)
;; read the data from a file. ;; read the data from a file.
(define (read-sound-internal file #:split [split-into-lists? #t]) (define (read-sound-internal file)
(let* ([sndfile (sf-open file 'sfm-read)] (let* ([sndfile (sf-open file 'sfm-read)]
[strings (get-meta-strings sndfile)] [strings (get-meta-strings sndfile)]
[info (sndfile-info sndfile)] [info (sndfile-info sndfile)]
@ -258,17 +264,14 @@
[stype (case (sample-type) [stype (case (sample-type)
[(short) _int16] [(int) _int] [(float) _double*])] [(short) _int16] [(int) _int] [(float) _double*])]
[readf (sample-type->reader (sample-type))] [readf (sample-type->reader (sample-type))]
[cblock (malloc (* frames channels) stype)] [cblock ((sample-type->vector-maker (sample-type)) (* frames channels))]
[num-read (readf sndfile cblock frames)] [num-read (readf sndfile ((sample-type->cpointer-extractor (sample-type)) cblock) frames)]
[_ (unless (= frames num-read) [_ (unless (= frames num-read)
(error 'read-sound-internal (error 'read-sound-internal
"wanted ~s frames, but got ~s: ~s" "wanted ~s frames, but got ~s: ~s"
frames num-read frames num-read
(sf-strerror sndfile)))] (sf-strerror sndfile)))])
[data (if split-into-lists? (begin0 (values cblock
(split-sound-cblock cblock stype frames channels)
cblock)])
(begin0 (values data
`((frames ,frames) `((frames ,frames)
(samplerate ,(sf-info-samplerate info)) (samplerate ,(sf-info-samplerate info))
(channels ,channels) (channels ,channels)
@ -280,9 +283,11 @@
"error while closing file: ~s" "error while closing file: ~s"
(sf-strerror sndfile)))))) (sf-strerror sndfile))))))
;; split-sound-cblock : cblock ffi-type nat nat -> (listof frame) ;; split-sound-cblock : cblock ffi-type nat nat -> (listof frame)
;; ... where frame is (listof sample-value) ;; ... where frame is (listof sample-value)
(define (split-sound-cblock cblock stype frames channels) ;; 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))]) (let* ([data (cblock->list cblock stype (* frames channels))])
(n-split data channels))) (n-split data channels)))
@ -306,11 +311,12 @@
[(pair? d) (loop (car d)) (loop (cdr d))])) [(pair? d) (loop (car d)) (loop (cdr d))]))
cblock)])) cblock)]))
;; there are some ugly hidden invariants here: what if the sample-type doesn't match ;; 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... ;; what's specified in the format? This is a question about libsndfile, and I should check it out...
;; write-sound-internal/cblock ;; write-sound-internal/s16vector
(define (write-sound-internal/cblock file cblock format samplerate frames channels sample-type meta) (define (write-sound-internal/s16vector file cblock format samplerate frames channels sample-type meta)
(check-filename-format format file) (check-filename-format format file)
(let* ([writef (sample-type->writer sample-type)] (let* ([writef (sample-type->writer sample-type)]
[info (make-sf-info frames samplerate channels format 1 #f)] [info (make-sf-info frames samplerate channels format 1 #f)]
@ -318,13 +324,13 @@
(error 'write-sound-internal "bad format: ~s" format))] (error 'write-sound-internal "bad format: ~s" format))]
[sndfile (sf-open file 'sfm-write info)] [sndfile (sf-open file 'sfm-write info)]
[_ (set-meta-strings sndfile meta)] [_ (set-meta-strings sndfile meta)]
[num-write (writef sndfile cblock frames)]) [num-write (writef sndfile (s16vector->cpointer cblock) frames)])
(unless (= frames num-write) (unless (= frames num-write)
(error 'write-sound-internal/cblock (error 'write-sound-internal/s16vector
"wanted to write ~s frames, but wrote only ~s. ~s" "wanted to write ~s frames, but wrote only ~s. ~s"
frames num-write (sf-strerror sndfile))) frames num-write (sf-strerror sndfile)))
(unless (= 0 (sf-close sndfile)) (unless (= 0 (sf-close sndfile))
(error 'write-sound-internal/cblock "failed to close file: ~s" (sf-strerror sndfile))) (error 'write-sound-internal/s16vector "failed to close file: ~s" (sf-strerror sndfile)))
(void))) (void)))
;; write-sound-internal/lists : path-string (listof (listof sample)) (listof (list/c symbol? string?)) -> (void) ;; write-sound-internal/lists : path-string (listof (listof sample)) (listof (list/c symbol? string?)) -> (void)
@ -341,7 +347,7 @@
[else (guess-format file)])] [else (guess-format file)])]
[samplerate (cond [(assq 'samplerate meta) => cadr] [samplerate (cond [(assq 'samplerate meta) => cadr]
[else (default-samplerate)])]) [else (default-samplerate)])])
(write-sound-internal/cblock file cblock format samplerate frames channels (sample-type) meta))) (write-sound-internal/s16vector file cblock format samplerate frames channels (sample-type) meta)))
(define file-format-table (define file-format-table
'((#rx"\\.aiff?" (aiff pcm-16 file)) '((#rx"\\.aiff?" (aiff pcm-16 file))
@ -402,7 +408,6 @@
(match-lambda (match-lambda
['short sf-readf-short] ['short sf-readf-short]
['int sf-readf-int] ['int sf-readf-int]
['float sf-readf-float]
['double sf-readf-double])) ['double sf-readf-double]))
;; return the writer that corresponds to a given sample-type ;; return the writer that corresponds to a given sample-type
@ -410,19 +415,33 @@
(match-lambda (match-lambda
['short sf-writef-short] ['short sf-writef-short]
['int sf-writef-int] ['int sf-writef-int]
['float sf-writef-float]
['double sf-writef-double])) ['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 ==================== ;; ==================== Exposed Scheme interface ====================
;; types of samples we handle: 'short, 'int, 'double, or 'float ;; types of samples we handle: 'short, 'int, 'double
(provide sample-type) (provide sample-type)
(define sample-type (define sample-type
(make-parameter (make-parameter
'float (lambda (x) 'float (lambda (x)
(if (memq x '(short int float double)) (if (memq x '(short int double))
x x
(error 'sample-type "bad type: ~s" x))))) (error 'sample-type "bad or unsupported type: ~s" x)))))
@ -465,25 +484,27 @@
;; C data. It's 2-channel 32-bit float only. Also, it discards ;; C data. It's 2-channel 32-bit float only. Also, it discards
;; all meta-information except length and sample-rate. ;; all meta-information except length and sample-rate.
;; read-sound/floatblock : path-string -> (list/c _pointer nat nat) (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, ;; read the file into a buffer, return the data, the number of frames,
;; and the sample rate. ;; and the sample rate.
(provide read-sound/floatblock) (provide read-sound/s16vector)
(define (read-sound/floatblock file) (define (read-sound/s16vector file)
(parameterize ([sample-type 'float]) (parameterize ([sample-type 'short])
(let*-values ([(cblock meta) (read-sound-internal file #:split #f)]) (let*-values ([(cblock meta) (read-sound-internal file)])
(list cblock (cadr (assq 'frames meta)) (cadr (assq 'samplerate meta)))))) (list cblock (cadr (assq 'frames meta)) (cadr (assq 'samplerate meta))))))
;; write-sound/floatblock : _pointer nat nat path-string -> (void) ;; write-sound/s16vector : _pointer nat nat path-string -> (void)
;; write the floatblock sound to the given file as a wav. ;; write the cblock sound to the given file as a wav.
(provide write-sound/floatblock) (provide write-sound/s16vector)
(define (write-sound/floatblock data frames sample-rate file) (define (write-sound/s16vector data sample-rate file)
(write-sound-internal/cblock file data '(wav float file) (write-sound-internal/s16vector file data '(wav pcm-16 file)
sample-rate sample-rate
frames (/ (s16vector-length data) global-channels)
2 2
'float 'short
;; for now, no meta-data possible. ;; meta-data not supported.
'())) '()))