gistfile1.sls

(use binary.io)
(use math.const)
(use srfi-1)

;(define sampling-frequency 22050)
(define sampling-frequency 11025)
(define audio-channels 1)
(define audio-sampling-bits 8)

(define phase 0.0)

(define (get-sample freq waveform)
   (begin0
     (waveform
        (/ (* 2 pi phase) sampling-frequency))
     (set! phase
        (fmod (+ phase freq) sampling-frequency))))

(define (get-samples freq duration waveform)
  (let ((ticks (quotient (* duration sampling-frequency) 1000)))
    (map (lambda (n) (get-sample freq waveform)) (iota ticks 1))))


;; v: -1.0 ~ +1.0
(define (write-sample out wavedata)
  (for-each (lambda (v)
    (write-byte (clamp (x->integer (floor (+ 127 (* 127 v)))) 0 255) out)) wavedata))



(define (parse-mml mml)
  (map (lambda (ch)
         (cond
            ((eq? ch #\c) '(262 300))
            ((eq? ch #\d) '(294 300))
            ((eq? ch #\e) '(330 300))
            ((eq? ch #\f) '(349 300))
            ((eq? ch #\g) '(392 300))
            ((eq? ch #\a) '(440 300))
            ((eq? ch #\b) '(494 300))
            ((eq? ch #\r) '(  0 300))
            ((eq? ch #\p) '(  0 300))
         )) (string->list mml)))

(define (play-mml out mml)
  (for-each
    (lambda (elm)
      (write-sample out (get-samples (car elm) (cadr elm) sin)))
    (parse-mml mml)))


(define (get-le32 v)
  (list (modulo v 256) (modulo (quotient v 256) 256) (modulo (quotient (quotient v 256) 256) 256)
        (modulo (quotient (quotient (quotient v 256) 256) 256) 256)))
(define (get-le16 v)
  (list (modulo v 256) (modulo (quotient v 256) 256)))


(define (write-wave-header out)
  (map (lambda (v) (write-byte (floor v) out))
    (append
      (get-le32 #X46464952); "RIFF"
      (get-le32 #Xffffffff)
      (get-le32 #X45564157);"WAVE"
      (get-le32 #X20746d66);"fmt "
      (get-le32 16)
      (get-le16 1)
      (get-le16 audio-channels)
      (get-le32 sampling-frequency)
      (get-le32 (quotient (* sampling-frequency audio-channels audio-sampling-bits) 8))
      (get-le16 (* (quotient audio-sampling-bits 8) audio-channels))
      (get-le16 audio-sampling-bits)
      (get-le32 #X61746164) ; "data"
      (get-le32 #Xffffffff)
    )))

(let ((out (open-output-file "test.wav" :element-type :binary)))
;(let ((out (open-output-fd-port 1)))
  (write-wave-header out)
  (play-mml out "cdefedcpefgagfepcpcpcpcpcdefedc")
  (close-output-port out)
)