;;uses swindle and PLT Scheme
;;some constants - rates in Hz and as aiff bytestrings
(define rate44kHz (cons 44100 (bytes #xAC #x44 #x00 #x00)))
(define rate22kHz (cons 22255 (bytes #x56 #xEE #x8B #xA3)))
(define A440 440) ;ISO
(define A480 480) ;Bach organ
;;useful
(define (linear-pitch-space p &opt (middleA A440))
(define (log2 n) (/ (log n) (log 2)))
(expt 2
(+ (/ (- p 69)
12)
(log2 middleA))))
;;-1<x<1 to 16 bit int
(define (sample-to-bytes x)
(integer->integer-bytes (inexact->exact (floor (* x 32000))) 2 #t #t))
;;pack data into an IFF chunk
(define (enchunk ID buffer &opt (prefix (bytes)))
(let* ((l (+ (bytes-length buffer)
(bytes-length prefix)))
(nobytes (bytes))
(padded (if (odd? l)
(+ 1 l)
l)))
(if (eq? (string-length ID) 4)
(bytes-append (string->bytes/locale ID)
(integer->integer-bytes padded 4 #f #t)
(if prefix prefix nobytes)
buffer
(if (odd? l) (bytes 0) nobytes))
(error "ID must be 4 characters long!"))))
;;make a buffer of sample frames based on an operator of length t
(define (op->buffer operator t &opt (rate rate44kHz))
(let ((buffer (make-bytes (* 2
(+ 1 (* t (car rate))))))
(end t)
(inc (/ 1 (car rate))))
(let loop ((x 0)
(byteoffset 0))
(if (> x end)
buffer
(begin (bytes-copy! buffer
byteoffset
(sample-to-bytes (operator x)))
(loop (+ x inc) (+ byteoffset 2)))))))
;;buffer to aiff bytestring
(define (buffer->aiff bitstream &opt (rate rate44kHz))
(let ((frames (/ (bytes-length bitstream) 2)))
;;FORM chunk contains other chunks
(enchunk "FORM"
(bytes-append
;COMMon block
(enchunk "COMM"
(bytes-append
(integer->integer-bytes 1 2 #t #t) ;channels (mono)
(integer->integer-bytes frames 4 #f #t) ;sample frames (16)
(integer->integer-bytes 16 2 #t #t) ;bitwidth
(bytes #x40 #x0E) ;no idea
(cdr rate) ;framerate
(bytes 0 0 0 0))) ;yet more WTFery.
;Sound data block
(enchunk "SSND"
bitstream
(make-bytes 8 0))) ;;quick hack to ignore some unused settings
;;Name FORM type
(string->bytes/locale "AIFF"))))
;;
;;Some operators
;;
;;Sinewaves
(define (sinewave freq)
(lambda (x) (sin (* x freq 6.2832))))
;;whitenoise
(define (noise)
(lambda (x) (random)))
;;VCA
(define (ampmod signal mod)
(lambda (x) (* (signal x)
(mod x))))
;;half-wave
(define (half-wave op)
(lambda (x)
(let ((b (op x)))
(if (> b 0) b 0))))
;;FM
(define (FMoperator freq modulation)
(lambda (x)
(sin (+ (* x freq 6.2832)
(modulation x)))))
;;Mix sound sources
(define (mix &rest sources)
(lambda (x)
(/ (foldl (lambda (operation sum)
(+ sum
(operation x)))
0
sources)
(length sources))))
;;Amplitude tweak. Will clip cleanly if overdriven.
(define (amp a op)
(lambda (x)
(let ((b (* a (op x))))
(cond ((< b -1) -1)
((> b 1) 1)
(else b)))))
;;
;;generate sound
;;
(define complex-sound (op->buffer (mix (ampmod (mix (sinewave (linear-pitch-space 60))
(sinewave (linear-pitch-space 64))
(sinewave (linear-pitch-space 67))) ;C major
(half-wave (amp 10 (FMoperator 8
(sinewave 1))))) ;morse effect
(amp 0.3 (ampmod (noise)
(sinewave 0.08))) ;fading white noise
(ampmod (amp 10 (FMoperator (linear-pitch-space 58)
(sinewave (/ (linear-pitch-space 58) 3)))) ;distorted FM bass
(sinewave 0.01))) ;fade in
20
rate22kHz))
(with-output-to-file "test.aiff"
(thunk (display (buffer->aiff complex-sound rate22kHz)))
'replace)
RSS