DouKaku?beta

Comment detail

Tiny MML (Nested Flatten) 
MML からAIFFファイルを生成し（※単純な正弦波です）iTunes等のプレイヤーに渡します。
とりあえず OS X での動作しか考えていませんが... 

A音の周波数設定 / テンポ / サンプリング周波数 / 純正律・平均律 / サンプルサイズ(8bit・16bit) / ステレオ・モノラル設定とか・・・無駄にこだわってみました。

Gauche 0.8.10 以降でないと動きません。
  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
(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)

言語間違えてる
　誤：awk
　正：scheme
どうやって直したらいいの？
こういう、高レベル言語でバイナリをいじくるコード好きです。

write-f80は組込みで持ってても良いように思い始めました。

write-u32-idstrはdisplayじゃだめなのかな。

write-block-s16-bigendianとwrite-block-s8は
(use gauche.sequence)してuvectorに直接for-eachを適用すると
シンプルになるかもしれません。 

make-noteでs16vector-set!とs8vector-set!を切り替えてるところですが、
(set! (ref vec i) ...) のようにすればジェネリックに書けます。速度は遅くなりますが。
さらに、(map-to <s8vector> (lambda (i) (* volume-maximum ...)) (iota sample-count))
のようにするとdoループも不要です。

make-sound-tableの(let ((c (first notes)) (d (second notes)) ...) のところは
util.matchを使って (let-match1 (c d e f g a b) notes ...) のようにも書けます。
shiroさん直々にご指導ありがとうございます。 write-f80 は今回は１回（ヘッダ部分にサンプリング周波数を書き込む為だけに）しか呼び出していませんが、組み込みで用意されていたら嬉しい場面ももしかしたらあるかもしれません。 ライブラリモジュールをもっと活用できるよう、今後使い込んで行きたいと思います。

Index

Feed

Other

Link

Pathtraq

loading...
Creative Commons License このサイトの内容は、 クリエイティブ・コモンズ・ライセンスの下でライセンスされています。 [詳細]