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

updates to sndfile.rkt & use-snd-file.rkt. Added an interface that doesn't

Browse Source 
eagerly transform data into lists.  It's also very restrictive (assumes
float & 2-channel).
This commit is contained in:
John Clements 2010-08-31 11:40:58 -07:00
parent 04a93812b4
commit c824241a6e
2 changed files with 153 additions and 60 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,6 +1,8 @@
#lang racket/base
(require ffi/unsafe)
(require ffi/unsafe
rackunit
racket/match)
;; 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
@ -223,6 +225,11 @@
;; 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))
@ -231,17 +238,18 @@
;; 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 : string bool -> (or/c (values/c data a-list) data)
;; read-sound-internal : path-string [bool] -> (values/c (or/c cblock (listof (listof sample))) a-list)
;; read the data from a file.
(define (read-sound-internal file meta?)
(define (read-sound-internal file #:split [split-into-lists? #t])
(let* ([sndfile (sf-open file 'sfm-read)]
[strings (and meta? (get-meta-strings sndfile))]
[strings (get-meta-strings sndfile)]
[info (sndfile-info sndfile)]
[frames (sf-info-frames info)]
[channels (sf-info-channels info)]
@ -253,24 +261,38 @@
[(float) sf-readf-double])]
[cblock (malloc (* frames channels) stype)]
[num-read (readf sndfile cblock frames)]
[data (cblock->list cblock stype (* num-read channels))]
[data (if (> channels 1) (n-split data channels) data)])
(unless (= frames num-read)
(error 'read-sound-internal
"wanted ~s frames, but got ~s" frames num-read))
(begin0 (if meta?
(values data `((frames ,frames)
(samplerate ,(sf-info-samplerate info))
(channels ,channels)
(format ,(sf-info-format info))
(sections ,(sf-info-sections info))
,@strings))
data)
(sf-close sndfile))))
[_ (unless (= frames num-read)
(error 'read-sound-internal
"wanted ~s frames, but got ~s: ~s"
frames num-read
(sf-strerror sndfile)))]
[data (if split-into-lists?
(split-sound-cblock cblock stype frames channels)
cblock)])
(begin0 (values data
`((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: ~s"
(sf-strerror sndfile))))))
;; split-sound-cblock : cblock ffi-type nat nat -> (listof frame)
;; ... where frame is (listof sample-value)
(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)
@ -285,37 +307,45 @@
[(pair? d) (loop (car d)) (loop (cdr d))]))
cblock)]))
(define (write-sound-internal file data meta)
;; 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/cblock
(define (write-sound-internal/cblock file cblock format samplerate frames channels sample-type meta)
(check-filename-format format file)
(let* ([writef (match sample-type
['short sf-writef-short]
['int sf-writef-int]
['float sf-writef-double])]
[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 cblock frames)])
(unless (= frames num-write)
(error 'write-sound-internal/cblock
"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/cblock "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) _double*])]
[writef (case (sample-type)
[(short) sf-writef-short]
[(int) sf-writef-int]
[(float) sf-writef-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)])]
[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)]
[_ (unless (= 0 (set-meta-strings sndfile meta))
(error 'write-sound-internal "failed to write meta strings: ~s"
(sf-strerror sndfile)))]
[num-write (writef sndfile cblock frames)])
(unless (= frames num-write)
(error 'write-sound-internal
"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 "failed to close file: ~s" (sf-strerror sndfile)))
(void)))
[else (default-samplerate)])])
(write-sound-internal/cblock file cblock format samplerate frames channels (sample-type) meta)))
(define file-format-table
'((#rx"\\.aiff?" (aiff pcm-16 file))
@ -344,6 +374,35 @@
[(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)]))
;; ==================== Exposed Scheme interface ====================
;; types of samples we handle: 'short, 'int, or 'float
@ -369,28 +428,63 @@
(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)
(read-sound-internal file #f))
(let*-values ([(data meta) (read-sound-internal file)])
data))
(provide read-sound*)
(define (read-sound* file)
(read-sound-internal file #t))
(read-sound-internal file #:split #t))
(provide write-sound)
(define (write-sound file data)
(write-sound-internal file data '()))
(write-sound-internal/lists file data '()))
;; meta is used only for samplerate & format
(provide write-sound*)
(define (write-sound* file data meta)
(write-sound-internal file data meta))
(write-sound-internal/lists file data meta))
;; a racketsound provides a representation for sounds
;; that leaves them packed as C data. For the moment, it's
;; 2-channel float only. Also, it discards all meta-information
;; except length and sample-rate
;; except length and sample-rate.
;; a racketsound is (racket-sound )
;(struct racketsound (data length sample-rate))
;; a racketsound is (racketsound cblock nat nat)
(provide (struct-out racketsound))
(struct racketsound (data frames sample-rate))
;; these readers and writers short-cut the translation to/from lists.
;; read-racketsound : path-string -> racketsound
;; read the file into a racketsound
(provide read-racketsound)
(define (read-racketsound file)
(parameterize ([sample-type 'float])
(let*-values ([(cblock meta) (read-sound-internal file #:split #f)])
(racketsound cblock (cadr (assq 'frames meta)) (cadr (assq 'samplerate meta))))))
;; write-racketsound : racketsound path-string -> (void)
;; write the racketsound to the given file as a wav.
(provide write-racketsound)
(define (write-racketsound sound file)
(write-sound-internal/cblock file (racketsound-data sound) '(wav float file)
(racketsound-sample-rate sound)
(racketsound-frames sound)
2
'float
;; for now, no meta-data possible.
'()))
;; test cases for check-filename-format:
;; 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")))

25
collects/ffi/examples/use-sndfile.rkt
View File

@ -1,6 +1,3 @@
;; The first three lines of this file were inserted by DrRacket. They record metadata
;; about the language level of this file in a form that our tools can easily process.
#reader(lib "htdp-beginner-reader.ss" "lang")((modname use-sndfile) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ())))
#! /usr/bin/env racket
#lang racket/base
@ -16,22 +13,24 @@
(let loop ([n n] [r '()])
(if (zero? n) r (loop (sub1 n) (cons x r)))))
;; N.B.: this won't work unless you have a file in the current working directory called "x.wav".
(let-values ([(data meta) (read-sound* "x.wav")])
;; N.B.: this won't work unless you have a file called "/tmp/x.wav".
(let-values ([(data meta) (read-sound* "/tmp/x.wav")])
(printf ">>> data-length: ~s\n>>> meta: ~s\n" (length data) meta)
(let* ([data data #;
(list-of (list (add-half (1st x) (1st y))
(add-half (2nd x) (2nd y)))
(x <- data
and
y <- (append (repeated-list (list 0.0 0.0) 11025) data)
and
i <- 0.1 0.12 ..))])
(x <- data
and
y <- (append (repeated-list (list 0.0 0.0) 11025) data)
and
i <- 0.1 0.12 ..))])
(printf "writing to y.wav\n")
(write-sound* "y.wav"
(write-sound* "/tmp/y.wav"
;data
;(append data (reverse data))
(append data (reverse (map reverse data)))
`((artist "Eli") (comment "Comment") (title "Title")
(date "1/1/1999") (software "mzscheme")
,@meta))))
(date "1/1/1999") (software "mzscheme")
,@meta))))