s c h e m a t i c s : c o o k b o o k

;;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)