1 ! Copyright (C) 2015 John Benediktsson
2 ! See http://factorcode.org/license.txt for BSD license
4 USING: accessors assocs byte-arrays combinators endian io
5 io.encodings.binary io.encodings.string io.encodings.utf8
6 io.files io.streams.byte-array io.streams.peek kernel literals
7 make math sequences sequences.generalizations ;
11 ! TODO: sometimes track length not specified
12 ! TODO: parse division
13 ! TODO: key-signature-decode
15 TUPLE: midi header chunks ;
19 TUPLE: midi-chunk type bytes ;
21 C: <midi-chunk> midi-chunk
23 TUPLE: midi-header format #chunks division ;
25 TUPLE: midi-track events ;
27 TUPLE: meta-event delta name value ;
29 C: <meta-event> meta-event
31 TUPLE: sysex-event delta type bytes ;
33 C: <sysex-event> sysex-event
35 TUPLE: midi-event delta name value ;
37 C: <midi-event> midi-event
40 { 0 "the file contains a single multi-channel track" }
41 { 1 "the file contains one or more simultaneous tracks (or MIDI outputs) of a sequence" }
42 { 2 "the file contains one or more sequentially independant single-track patterns" }
45 CONSTANT: min-pitchwheel -8192
46 CONSTANT: max-pitchwheel 8191
48 CONSTANT: min-songpos 0
49 CONSTANT: max-songpos 16383
51 CONSTANT: key-signatures H{
84 CONSTANT: smpte-framerate H{
93 : read-number ( -- number )
95 7 shift read1 [ 0x7f bitand + ] keep
98 : parse-meta ( type bytes -- name value )
100 { 0x00 [ 2 head be> "sequence-number" ] }
101 { 0x01 [ utf8 decode "text" ] }
102 { 0x02 [ utf8 decode "copyright" ] }
103 { 0x03 [ utf8 decode "track-name" ] }
104 { 0x04 [ utf8 decode "instrument-name" ] }
105 { 0x05 [ utf8 decode "lyrics" ] }
106 { 0x06 [ utf8 decode "marker" ] }
107 { 0x07 [ utf8 decode "cue-point" ] }
108 { 0x09 [ utf8 decode "device-name" ] }
109 { 0x20 [ first "channel-prefix" ] }
110 { 0x21 [ first "midi-port" ] }
111 { 0x2f [ drop t "end-of-track" ] }
112 { 0x51 [ 3 head be> "set-tempo" ] }
117 [ -6 shift "frame-rate" ,, ]
118 [ 0x3f bitand "hours" ,, ] bi
125 ] H{ } make "smpte-offset" ] }
130 [ 2 * "denominator" ,, ]
131 [ "clocks-per-tick" ,, ]
132 [ "notated-32nd-notes-per-beat" ,, ]
134 ] H{ } make "time-signature" ] }
135 { 0x59 [ key-signatures at "key-signature" ] }
136 { 0x7f [ "sequencer-specific" ] }
139 : read-meta ( delta -- event )
140 read1 read-number read parse-meta <meta-event> ;
142 : read-sysex ( delta type -- event )
143 read-number read <sysex-event> ;
145 : read-message ( delta type -- message )
149 [ 0x0f bitand "channel" ,, ] [ 0xf0 bitand ] bi {
151 read1 "note" ,, read1 "velocity" ,, ] }
153 read1 "note" ,, read1 "velocity" ,, ] }
155 read1 "note" ,, read1 "value" ,, ] }
156 { 0xb0 [ "control-change"
157 read1 "control" ,, read1 "value" ,, ] }
158 { 0xc0 [ "program-change"
159 read1 "program" ,, ] }
160 { 0xd0 [ "aftertouch"
162 { 0xe0 [ "pitchwheel"
163 read1 read1 7 shift + min-pitchwheel + "pitch" ,, ] }
168 ! system common messages
169 { 0xf0 [ "sysex" { 0xf7 } read-until drop ] }
170 { 0xf1 [ "quarter-made" [
172 [ -4 shift "frame-type" ,, ]
173 [ 0x0f bitand "frame-value" ,, ] bi
175 { 0xf2 [ "songpos" read1 read1 7 shift + ] }
176 { 0xf3 [ "song-select" read1 ] }
177 { 0xf6 [ "tune-request" f ] }
180 { 0xf8 [ "clock" f ] }
181 { 0xfa [ "start" f ] }
182 { 0xfb [ "continue" f ] }
183 { 0xfc [ "stop" f ] }
184 { 0xfe [ "active-sensing" f ] }
185 { 0xff [ "reset" f ] }
189 : read-event ( delta type -- event )
191 { 0xf0 [ 0xf0 read-sysex ] }
192 { 0xf7 [ 0xf7 read-sysex ] }
193 { 0xff [ read-meta ] }
197 : read-status ( prev-status -- prev-status' status )
201 drop read1 dup 0xff = [
206 : read-event-header ( prev-status -- prev-status' delta status )
207 [ read-number ] dip read-status swapd ;
209 : parse-events ( data -- events )
210 binary <byte-reader> <peek-stream> [
212 peek1 [ read-event-header ] [ f f ] if dup
213 ] [ read-event ] produce 3nip
214 ] with-input-stream ;
216 : <midi-header> ( bytes -- header )
217 2 cut 2 cut [ be> ] tri@ midi-header boa ;
219 : <midi-track> ( bytes -- track )
220 parse-events midi-track boa ;
222 : read-chunk ( -- chunk )
223 4 read 4 read be> read swap {
224 { $[ "MThd" >byte-array ] [ <midi-header> ] }
225 { $[ "MTrk" >byte-array ] [ <midi-track> ] }
226 [ swap <midi-chunk> ]
229 : read-header ( -- header )
230 read-chunk dup midi-header? t assert= ;
232 : read-chunks ( header -- chunks )
233 #chunks>> [ read-chunk ] replicate ;
237 : read-midi ( -- midi )
238 read-header dup read-chunks <midi> ;
240 : >midi ( byte-array -- midi )
241 binary [ read-midi ] with-byte-reader ;
243 : file>midi ( path -- midi )
244 binary [ read-midi ] with-file-reader ;
248 : write-number ( n -- )
251 [ -7 shift dup 0 > ] [
252 [ 8 shift 0x80 bitor ]
253 [ [ 0x7f bitand + ] keep ] bi*
256 [ [ -8 shift ] [ 0x80 bitand 0 > ] bi ]
257 [ dup 0xff bitand write1 ] do while drop ;
259 : write-string ( str -- )
260 utf8 encode [ length write-number ] [ write ] bi ;
262 GENERIC: write-event ( prev-status event -- status )
264 M: meta-event write-event
265 [ delta>> write-number 0xff write1 ] [ value>> ] [ name>> ] tri {
266 { "sequence-number" [ B{ 0x00 0x02 } write 2 >be write ] }
267 { "text" [ 0x01 write1 write-string ] }
268 { "copyright" [ 0x02 write1 write-string ] }
269 { "track-name" [ 0x03 write1 write-string ] }
270 { "instrument-name" [ 0x04 write1 write-string ] }
271 { "lyrics" [ 0x05 write1 write-string ] }
272 { "marker" [ 0x06 write1 write-string ] }
273 { "cue-point" [ 0x07 write1 write-string ] }
274 { "device-name" [ 0x09 write1 write-string ] }
275 { "channel-prefix" [ B{ 0x20 0x01 } write write1 ] }
276 { "midi-port" [ B{ 0x21 0x01 } write write1 ] }
277 { "end-of-track" [ B{ 0x2f 0x00 } write drop ] }
278 { "set-tempo" [ B{ 0x51 0x03 } write 3 >be write ] }
280 B{ 0x54 0x05 } write {
281 [ "frame-rate" of 6 shift ]
282 [ "hours" of + write1 ]
283 [ "minutes" of write1 ]
284 [ "seconds" of write1 ]
285 [ "frames" of write1 ]
286 [ "subframes" of write1 ]
289 B{ 0x58 0x04 } write {
290 [ "numerator" of write1 ]
291 [ "denominator" of 2 /i write1 ]
292 [ "clocks-per-tick" of write1 ]
293 [ "notated-32nd-notes-per-beat" of write1 ]
297 key-signatures value-at write ] }
298 { "sequencer-specific" [
300 [ length write-number ] [ write ] bi ] }
303 M: sysex-event write-event
305 [ delta>> write-number ]
307 [ bytes>> write ] tri f ;
309 : write-status ( prev-status status -- )
311 [ = ] keep swap [ drop ] [ write1 ] if
316 : write-channel ( prev-status value status quot -- status )
319 "channel" of + [ write-status ] keep
323 M: midi-event write-event
324 [ delta>> write-number ] [ value>> ] [ name>> ] tri {
329 [ "velocity" of write1 ] bi
334 [ "velocity" of write1 ] bi
339 [ "value" of write1 ] bi
343 [ "control" of write1 ]
344 [ "value" of write1 ] bi
347 0xc0 [ "program" of write1 ] write-channel ] }
349 0xd0 [ "value" of write1 ] write-channel ] }
352 "pitch" of min-pitchwheel -
353 [ 0x7f bitand write1 ]
354 [ -7 shift write1 ] bi
357 ! system common messages
359 [ drop 0xf0 dup write1 ] dip
360 write 0xf7 write1 ] }
362 [ drop 0xf1 dup write1 ] dip
363 [ "frame-type" of 4 shift ]
364 [ "frame-value" of + ] bi write1 ] }
366 [ drop 0xf2 dup write1 ] dip
367 [ 0x7f bitand write1 ]
368 [ -7 shift write1 ] bi ] }
370 [ drop 0xf3 dup write1 ] dip write1 ] }
371 { "tune-request" [ 2drop 0xf6 dup write1 ] }
374 { "clock" [ 2drop 0xf8 dup write1 ] }
375 { "start" [ 2drop 0xfa dup write1 ] }
376 { "continue" [ 2drop 0xfb dup write1 ] }
377 { "stop" [ 2drop 0xfc dup write1 ] }
378 { "active-sensing" [ 2drop 0xfe dup write1 ] }
379 { "reset" [ 2drop 0xff dup write1 ] }
382 GENERIC: write-chunk ( chunk -- )
384 M: midi-header write-chunk
385 $[ "MThd" >byte-array ] write
387 [ format>> ] [ #chunks>> ] [ division>> ] tri
388 [ 2 >be write ] tri@ ;
390 M: midi-track write-chunk
391 $[ "MTrk" >byte-array ] write
393 events>> f swap [ write-event ] each drop
395 [ length 4 >be write ] [ write ] bi ;
397 M: midi-chunk write-chunk
399 [ bytes>> [ length 4 >be write ] [ write ] bi ] bi ;
403 : write-midi ( midi -- )
404 [ header>> write-chunk ]
405 [ chunks>> [ write-chunk ] each ] bi ;
407 : midi> ( midi -- byte-array )
408 binary [ write-midi ] with-byte-writer ;
410 : midi>file ( midi path -- )
411 binary [ write-midi ] with-file-writer ;