guile-examples/sound/riff-wave/write.scm

(library (riff-wave-writer)
  (export pi
          sine*
          make-sine-func
          make-stepper
          make-sine-oscillator
          sample-function
          float->bytevector
          integer->bytevector
          max-amplitude)
  (import (except (rnrs base) let-values vector-for-each)
          (only (guile)
                lambda* λ
                ;; printing
                ;; display
                ;; simple-format
                ;; numbers
                inexact->exact
                ;; input output
                call-with-output-file
                current-output-port)
          (ice-9 exceptions)
          (ice-9 binary-ports)
          (rnrs bytevectors)
          (srfi srfi-43)
          ;; structs
          (srfi srfi-9)
          ;; functional structs
          (srfi srfi-9 gnu)
          (bytevector-utils)
          (model)
          (math)))


;;; function utilities

(define make-stepper
  (λ (func step-size)
    "Make a function, which calls FUNC with an argument, which
is calculated according to a given STEP-SIZE."
    (λ (n)
      (func (* n step-size)))))


(define make-sine-oscillator
  (λ (sine-func step-size)
    "Return a function, which takes a factor for a step-index to
calculate a sine value at that step."
    (make-stepper sine-func step-size)))


(define sample-function
  (λ (stepped-func num-samples)
    "Given a function FUNC, return a vector of NUM-SAMPLES
consequtive samples."
    (let ([sample-vector (make-vector num-samples 0)])
      (let iter ([counter 0])
        (cond
         [(< counter num-samples)
          (vector-set! sample-vector
                       counter
                       ;; Expects a stepped function. A
                       ;; stepped function translates the
                       ;; input argument to the nth step as
                       ;; input argument. Such as produced
                       ;; by make-stepper.
                       (stepped-func counter))
          (iter (+ counter 1))]
         [else sample-vector])))))


;;; calculation

(define max-amplitude
  (λ (bit-depth)
    (- (expt 2 (- bit-depth 1)) 1)))


(define write-riff-wave
  (λ (file-name riff-wave bit-depth)
    (define maximum-amplitude (max-amplitude bit-depth))
    (define convert-sample
      (λ (sample)
        (integer->bytevector
         (float->scaled-truncated-integer sample maximum-amplitude)
         2 #:endianness 'little)))

    (define chunk-header-bytevectors
      (λ (id size)
        "Construct a list of bytevectors for given chunk header
information and return it."
        (list (ascii-string->bytevector id 4 #:endianness 'big)
              (integer->bytevector size 4 #:endianness 'little))))

    (call-with-output-file file-name
      (λ (out-port)
        (let ([header-chunk (riff-wave-header-chunk riff-wave)]
              [format-chunk (riff-wave-format-chunk riff-wave)]
              [data-chunk (riff-wave-data-chunk riff-wave)])

          ;; Write the header chunk -- The header chunk only
          ;; has a header. Or interpreted differently, its
          ;; data are the other chunks.
          (for-each (λ (bv) (put-bytevector out-port bv))
                    (append
                     (chunk-header-bytevectors
                      (header-chunk-id header-chunk)
                      (header-chunk-size header-chunk))
                     (list
                      (ascii-string->bytevector (header-chunk-riff-type header-chunk)
                                                4 #:endianness 'big))))

          ;; Write the format chunk header.
          (for-each (λ (bv) (put-bytevector out-port bv))
                    (chunk-header-bytevectors
                     (format-chunk-id format-chunk)
                     (format-chunk-size format-chunk)))

          ;; Write the format chunk.
          (put-bytevector
           out-port
           (integer->bytevector
            (format-chunk-compression-code format-chunk)
            COMPRESSION-CODE-BYTES #:endianness 'little))

          (put-bytevector
           out-port
           (integer->bytevector
            (format-chunk-num-channels format-chunk)
            NUM-CHANNELS-BYTES #:endianness 'little))

          (put-bytevector
           out-port
           (integer->bytevector
            (format-chunk-sample-rate format-chunk)
            SAMPLE-RATE-BYTES #:endianness 'little))

          (put-bytevector
           out-port
           (integer->bytevector
            (format-chunk-avg-byte-rate format-chunk)
            AVG-BYTE-RATE-BYTES #:endianness 'little))

          (put-bytevector
           out-port
           (integer->bytevector
            (format-chunk-block-align format-chunk)
            BLOCK-ALIGN-BYTES #:endianness 'little))

          (put-bytevector
           out-port
           (integer->bytevector
            (format-chunk-significant-bits-per-sample format-chunk)
            SIGNIFICANT-BITS-PER-SAMPLE-BYTES #:endianness 'little))

          ;; Write the data chunk header.
          (for-each (λ (bv) (put-bytevector out-port bv))
                    (chunk-header-bytevectors
                     (data-chunk-id data-chunk)
                     (data-chunk-size data-chunk)))

          ;; Write the data chunk.
          (vector-for-each
           (λ (_index sample)
             (put-bytevector out-port (convert-sample sample)))
           (data-chunk-samples data-chunk)))))))


(let* ([file-name "waveform.wav"]
       [duration 2 #|seconds|#]
       [sample-rate 44100]
       [step-size (/ 1 sample-rate)]
       [sine-func (make-sine-func #:amplitude #e0.5 #:frequency 440)]
       [oscillator (make-sine-oscillator sine-func step-size)]
       [num-channels 1]  ; mono
       [compression-code 1]  ; uncompressed
       [bit-depth 16]  ; multiple of 8
       [extra-format-bytes-count 0]
       [samples-count (* duration sample-rate)]
       [samples (sample-function oscillator samples-count)])
  (let ([riff-wave
         (make-riff-wave
          (make-header-chunk (calculate-header-chunk-size
                              (calculate-format-chunk-size extra-format-bytes-count)
                              (calculate-data-chunk-size samples-count
                                                         bit-depth
                                                         num-channels)))
          (make-format-chunk compression-code
                             num-channels
                             sample-rate
                             bit-depth)
          (make-data-chunk samples
                           bit-depth
                           num-channels))])
    (write-riff-wave file-name riff-wave bit-depth)))