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

updated to remove dependency on rackunit

Browse Source
This commit is contained in:
John Clements 2010-08-31 14:33:16 -07:00
parent c824241a6e
commit 81a8bd3b28
1 changed files with 47 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,7 +1,7 @@
#lang racket/base #lang racket/base
(require ffi/unsafe (require ffi/unsafe
rackunit #;rackunit
racket/match) racket/match)
;; 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,
@ -211,10 +211,12 @@
(defsndfile sf-readf-short : _sndfile _pointer _sf-count-t -> _sf-count-t) (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-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-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-short : _sndfile _pointer _sf-count-t -> _sf-count-t)
(defsndfile sf-writef-int : _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-writef-double : _sndfile _pointer _sf-count-t -> _sf-count-t)
(defsndfile sf-get-string : _sndfile _sf-str-type -> _string) (defsndfile sf-get-string : _sndfile _sf-str-type -> _string)
@ -255,10 +257,7 @@
[channels (sf-info-channels info)] [channels (sf-info-channels info)]
[stype (case (sample-type) [stype (case (sample-type)
[(short) _int16] [(int) _int] [(float) _double*])] [(short) _int16] [(int) _int] [(float) _double*])]
[readf (case (sample-type) [readf (sample-type->reader (sample-type))]
[(short) sf-readf-short]
[(int) sf-readf-int]
[(float) sf-readf-double])]
[cblock (malloc (* frames channels) stype)] [cblock (malloc (* frames channels) stype)]
[num-read (readf sndfile cblock frames)] [num-read (readf sndfile cblock frames)]
[_ (unless (= frames num-read) [_ (unless (= frames num-read)
@ -313,10 +312,7 @@
;; write-sound-internal/cblock ;; write-sound-internal/cblock
(define (write-sound-internal/cblock file cblock format samplerate frames channels sample-type meta) (define (write-sound-internal/cblock file cblock format samplerate frames channels sample-type meta)
(check-filename-format format file) (check-filename-format format file)
(let* ([writef (match sample-type (let* ([writef (sample-type->writer sample-type)]
['short sf-writef-short]
['int sf-writef-int]
['float sf-writef-double])]
[info (make-sf-info frames samplerate channels format 1 #f)] [info (make-sf-info frames samplerate channels format 1 #f)]
[_ (unless (sf-format-check info) [_ (unless (sf-format-check info)
(error 'write-sound-internal "bad format: ~s" format))] (error 'write-sound-internal "bad format: ~s" format))]
@ -339,7 +335,7 @@
1 ; 1-channel if no data, or data is not made of lists 1 ; 1-channel if no data, or data is not made of lists
(length (car data)))] (length (car data)))]
[stype (case (sample-type) [stype (case (sample-type)
[(short) _int16] [(int) _int] [(float) _double*])] [(short) _int16] [(int) _int] [(float) _float] [(double) _double*])]
[cblock (frame-list->cblock data frames channels stype)] [cblock (frame-list->cblock data frames channels stype)]
[format (cond [(assq 'format meta) => cadr] [format (cond [(assq 'format meta) => cadr]
[else (guess-format file)])] [else (guess-format file)])]
@ -401,17 +397,34 @@
(error 'check-filename-format (error 'check-filename-format
"illegal format format: ~s" other)])) "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]
['float sf-readf-float]
['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]
['float sf-writef-float]
['double sf-writef-double]))
;; ==================== Exposed Scheme interface ==================== ;; ==================== Exposed Scheme interface ====================
;; types of samples we handle: 'short, 'int, or 'float ;; types of samples we handle: 'short, 'int, 'double, or 'float
(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)) (if (memq x '(short int float double))
x (error 'sample-type "bad type: ~s" x))))) x
(error 'sample-type "bad type: ~s" x)))))
;; TODO: add a parameter that will determine if you get a list, vector or ;; 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 ;; srfi/4-like thing. possibly also determine if a list/vector gets automatic
@ -447,32 +460,32 @@
(define (write-sound* file data meta) (define (write-sound* file data meta)
(write-sound-internal/lists file data meta)) (write-sound-internal/lists file data meta))
;; a racketsound provides a representation for sounds ;; an rsound (racket sound) provides a representation for sounds
;; that leaves them packed as C data. For the moment, it's ;; that leaves them packed as C data. For the moment, it's
;; 2-channel float only. Also, it discards all meta-information ;; 2-channel float only. Also, it discards all meta-information
;; except length and sample-rate. ;; except length and sample-rate.
;; a racketsound is (racketsound cblock nat nat) ;; a rsound is (rsound _cpointer nat nat)
(provide (struct-out racketsound)) (provide (struct-out rsound))
(struct racketsound (data frames sample-rate)) (struct rsound (data frames sample-rate))
;; these readers and writers short-cut the translation to/from lists. ;; these readers and writers short-cut the translation to/from lists.
;; read-racketsound : path-string -> racketsound ;; read-rsound : path-string -> rsound
;; read the file into a racketsound ;; read the file into a rsound
(provide read-racketsound) (provide read-rsound)
(define (read-racketsound file) (define (read-rsound file)
(parameterize ([sample-type 'float]) (parameterize ([sample-type 'float])
(let*-values ([(cblock meta) (read-sound-internal file #:split #f)]) (let*-values ([(cblock meta) (read-sound-internal file #:split #f)])
(racketsound cblock (cadr (assq 'frames meta)) (cadr (assq 'samplerate meta)))))) (rsound cblock (cadr (assq 'frames meta)) (cadr (assq 'samplerate meta))))))
;; write-racketsound : racketsound path-string -> (void) ;; write-rsound : rsound path-string -> (void)
;; write the racketsound to the given file as a wav. ;; write the rsound to the given file as a wav.
(provide write-racketsound) (provide write-rsound)
(define (write-racketsound sound file) (define (write-rsound sound file)
(write-sound-internal/cblock file (racketsound-data sound) '(wav float file) (write-sound-internal/cblock file (rsound-data sound) '(wav float file)
(racketsound-sample-rate sound) (rsound-sample-rate sound)
(racketsound-frames sound) (rsound-frames sound)
2 2
'float 'float
;; for now, no meta-data possible. ;; for now, no meta-data possible.
@ -480,11 +493,12 @@
;; test cases for check-filename-format:
;; test cases for check-filename-format: Commented out until there's a critical mass.
;; okay even though minor and file don't match: ;; okay even though minor and file don't match:
(check-not-exn (lambda () (check-filename-format '(wav float file) "/tmp/zabaglione.wav"))) ;(check-not-exn (lambda () (check-filename-format '(wav float file) "/tmp/zabaglione.wav")))
;; major doesn't match: ;; major doesn't match:
(check-exn exn:fail? (lambda () (check-filename-format '(wav float file) "/tmp/zabaglione.mat"))) ;(check-exn exn:fail? (lambda () (check-filename-format '(wav float file) "/tmp/zabaglione.mat")))
;; bad input format: ;; bad input format:
(check-exn exn:fail? (lambda () (check-filename-format '(spam spam spam spam) "/tmp/zabaglione.wav"))) ;(check-exn exn:fail? (lambda () (check-filename-format '(spam spam spam spam) "/tmp/zabaglione.wav")))