DouKaku?

(use srfi-13)
(use gauche.process)
(define *freq-table*
  '((#\c . "262") (#\d . "294") (#\e . "330") (#\f . "349") (#\g . "392") (#\a . "440") (#\b . "494") (#\r . "1")))
(define (play mml)
  (string-map
   (lambda (c) (process-wait (run-process "beep" "-f" (cdr (assq c *freq-table*)))) c)
   mml))
(play "cdefedcrefgagfercrcrcrcrcdefedcr")

(use srfi-1) ;first,second,...,seventh
(use srfi-4) ;uvector
(use binary.io) ;default-endianの設定とか
(default-endian 'big-endian)

;;
;; コンフィギュレーション
;;
(define tempo 120)
;(define frequency-A 440.0)
(define frequency-A 442.0)
(define use-just-intonation #f) ;純正律を用いる。#fなら平均律
(define sample-rate (* frequency-A 4)) ; 1.768KHzでサンプリング
;(define sample-rate 44100) ; 44.1KHzでサンプリングとか
;(define sample-size 8) ; sampling size (bit)
(define sample-size 16)
;(define stereo-mode #f)
(define stereo-mode #t)

;
; 内部で使用する値
;
(define volume-maximum (floor->exact (* 0.707 (if (= sample-size 16) 32767 127)))) ; 0.707は適当な音量
(define note-duration (/ 60 tempo 2))
(define note-sample-count (floor->exact (* sample-rate note-duration)))
(define sample-bytes (ash sample-size -3))

;;
;; 自前の出力系関数
;;
; 80 bit IEEE Standard 754 floating point number
(define (write-f80 value)
  (let ((vec (make-u8vector 10 0))
		(sign-mask 0)
		(exp 16383))
	(when (< value 0) 
		  (set! sign-mask 0x8000)
		  (set! value (- value)))
	(let* ((log (/ (log value) (log 2)))
		   (exp (floor->exact log))
		   (body (/ value (expt 2 exp)))
		   (first16 (logior sign-mask (+ 16383 exp))) )
	  (u8vector-set! vec 0 (ash first16 -8))
	  (u8vector-set! vec 1 (logand first16 255))
	  (let loop ((body (* body 128))
				 (i 2))
		(when (< i 10)
			  (let1 b (floor body)
					(u8vector-set! vec i b)
					(loop (* (- body b) 256) (+ i 1))) ))
	  (write-block vec) ; u8vector
	  )))

(define (write-u32-idstr idstr)
  (let write-id ((chars (string->list idstr))
				 (n 4))
	(when (< 0 n)
		  (write-char (car chars))
		  (write-id (cdr chars) (- n 1)))))
  
(define (write-chunk-head chunk-idstr chunk-size)
  (write-u32-idstr chunk-idstr)
  (write-u32 chunk-size))

(define (write-block-s16-bigendian vec)
  (do ((i 0 (+ i 1)))
	  ((= i (s16vector-length vec)) vec)
	(write-s16 (s16vector-ref vec i))
	(when stereo-mode
		  (write-s16 (s16vector-ref vec i))) ))
;  (lambda (vec) (write-block vec (current-output-port) 0 -1 'big-endian)))

(define (write-block-s8 vec)
  (do ((i 0 (+ i 1)))
	  ((= i (s8vector-length vec)) vec)
	(write-s8 (s8vector-ref vec i))
	(when stereo-mode
		  (write-s8 (s8vector-ref vec i))) ))

(define (save-as-aiff-file file-name sound-vecs)
  (let* ((num-sample-frames (apply + (map (if (= sample-size 16) s16vector-length s8vector-length) sound-vecs)))
		 (sound-chunk-size (+ 8 (* sample-bytes num-sample-frames (if stereo-mode 2 1)))))
	(with-output-to-file file-name
	  (lambda ()
		(write-chunk-head "FORM" (+ 4 26 8 sound-chunk-size))
		(write-u32-idstr "AIFF")

		(write-chunk-head "COMM" 18)
		(write-u16 (if stereo-mode 2 1)) ; numChannels
		(write-u32 num-sample-frames) ; numSampleFrames
		(write-u16 sample-size)
		(write-f80 sample-rate)

		(write-chunk-head "SSND" sound-chunk-size)
		(write-u32 0) ; offset
		(write-u32 0) ; blocksize
		(if (= sample-size 16)
			(for-each write-block-s16-bigendian sound-vecs) ; write-block だとうまく行かなかった
			(for-each write-block-s8 sound-vecs))
		))))

;;
;; 簡易（というか正弦波）サウンドジェネレータ
;;
; ８分休符のサウンドデータを生成
(define (make-pause sample-count)
  ((if (= sample-size 16) make-s16vector make-s8vector) sample-count 0))

; 指定した周波数で８分音符のサウンドデータを生成
(define (make-note freq sample-count)
  (do ((vec (make-pause sample-count)) ;(make-s8vector sample-count))
	   (i 0 (+ i 1)))
	  ((= i sample-count) vec)
	((if (= sample-size 16) s16vector-set! s8vector-set!) vec i
	 (* volume-maximum (sin (/ (* freq 3.14159265358979323846 2 i) sample-rate))) )))

(define (make-sound-table)
  (let* ((note-frequencies (map (lambda (mag) (* frequency-A mag))
								(if use-just-intonation
									(list 3/5 27/40 3/4 4/5 9/10 1 9/8)
									(map (lambda (x) (expt 2.0 x)) (list -3/4 -7/12 -5/12 -1/3 -1/6 0 1/6)))))
		 (notes (map (lambda (freq) (make-note freq note-sample-count)) note-frequencies))
		 (pause (make-pause note-sample-count)))
	(let ((c (first notes))
		  (d (second notes))
		  (e (third notes))
		  (f (fourth notes))
		  (g (fifth notes))
		  (a (sixth notes))
		  (b (seventh notes))
		  (r pause))
	  (define (sound-data-for-note note-char)
		(case note-char
		  ((#¥r #¥R) r)
		  ((#¥c #¥C) c)
		  ((#¥d #¥D) d)
		  ((#¥e #¥E) e)
		  ((#¥f #¥F) f)
		  ((#¥g #¥G) g)
		  ((#¥a #¥A) a)
		  ((#¥b #¥B) b)
		  (else r)))
	  (define (dispatch m)
		(case m
		  ((sound-for-note) sound-data-for-note)
		  (else (print "not defined."))))
	  dispatch)))

(define sound-table (make-sound-table))

(define (play-mml mml-string)
  (let ((aiff-file-name (string-append mml-string ".aiff"))
		(notes (string->list mml-string)))
	(save-as-aiff-file aiff-file-name (map [sound-table'sound-for-note] notes))
	(sys-exec "open" (list "open" aiff-file-name)) ))

; REPL
(define (input-loop)
  (let ((line (read-line)))
	(cond ((eof-object? line) 'eof)
		  ((string=? "" line) 'quit)
		  (else (play-mml line)
				(input-loop) ))))

(input-loop)