extra/midi/midi.factor

   1 ! Copyright (C) 2015 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3
   4 USING: accessors assocs byte-arrays combinators endian fry 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 ;
   8
   9 IN: midi
  10
  11 ! TODO: sometimes track length not specified
  12 ! TODO: parse division
  13 ! TODO: key-signature-decode
  14
  15 TUPLE: midi header chunks ;
  16
  17 C: <midi> midi
  18
  19 TUPLE: midi-chunk type bytes ;
  20
  21 C: <midi-chunk> midi-chunk
  22
  23 TUPLE: midi-header format #chunks division ;
  24
  25 TUPLE: midi-track events ;
  26
  27 TUPLE: meta-event delta name value ;
  28
  29 C: <meta-event> meta-event
  30
  31 TUPLE: sysex-event delta type bytes ;
  32
  33 C: <sysex-event> sysex-event
  34
  35 TUPLE: midi-event delta name value ;
  36
  37 C: <midi-event> midi-event
  38
  39 CONSTANT: formats H{
  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" }
  43 }
  44
  45 CONSTANT: min-pitchwheel -8192
  46 CONSTANT: max-pitchwheel 8191
  47
  48 CONSTANT: min-songpos 0
  49 CONSTANT: max-songpos 16383
  50
  51 CONSTANT: key-signatures H{
  52     { B{ -7 0 } "Cb" }
  53     { B{ -6 0 } "Gb" }
  54     { B{ -5 0 } "Db" }
  55     { B{ -4 0 } "Ab" }
  56     { B{ -3 0 } "Eb" }
  57     { B{ -2 0 } "Bb" }
  58     { B{ -1 0 } "F" }
  59     { B{ 0 0 } "C" }
  60     { B{ 1 0 } "G" }
  61     { B{ 2 0 } "D" }
  62     { B{ 3 0 } "A" }
  63     { B{ 4 0 } "E" }
  64     { B{ 5 0 } "B" }
  65     { B{ 6 0 } "F#" }
  66     { B{ 7 0 } "C#" }
  67     { B{ -7 1 } "Abm" }
  68     { B{ -6 1 } "Ebm" }
  69     { B{ -5 1 } "Bbm" }
  70     { B{ -4 1 } "Fm" }
  71     { B{ -3 1 } "Cm" }
  72     { B{ -2 1 } "Gm" }
  73     { B{ -1 1 } "Dm" }
  74     { B{ 0 1 } "Am" }
  75     { B{ 1 1 } "Em" }
  76     { B{ 2 1 } "Bm" }
  77     { B{ 3 1 } "F#m" }
  78     { B{ 4 1 } "C#m" }
  79     { B{ 5 1 } "G#m" }
  80     { B{ 6 1 } "D#m" }
  81     { B{ 7 1 } "A#m" }
  82 }
  83
  84 CONSTANT: smpte-framerate H{
  85     { 0 24 }
  86     { 1 25 }
  87     { 2 29.97 }
  88     { 3 30 }
  89 }
  90
  91 <PRIVATE
  92
  93 : read-number ( -- number )
  94     0 [ 7 bit? ] [
  95         7 shift read1 [ 0x7f bitand + ] keep
  96     ] do while ;
  97
  98 : parse-meta ( type bytes -- name value )
  99     swap {
 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" ] }
 113         { 0x54 [
 114             [
 115                 5 firstn {
 116                     [
 117                         [ -6 shift "frame-rate" ,, ]
 118                         [ 0x3f bitand "hours" ,, ] bi
 119                     ]
 120                     [ "minutes" ,, ]
 121                     [ "seconds" ,, ]
 122                     [ "frames" ,, ]
 123                     [ "subframes" ,, ]
 124                 } spread
 125             ] H{ } make "smpte-offset" ] }
 126         { 0x58 [
 127             [
 128                 first4 {
 129                     [ "numerator" ,, ]
 130                     [ 2 * "denominator" ,, ]
 131                     [ "clocks-per-tick" ,, ]
 132                     [ "notated-32nd-notes-per-beat" ,, ]
 133                 } spread
 134             ] H{ } make "time-signature" ] }
 135         { 0x59 [ key-signatures at "key-signature" ] }
 136         { 0x7f [ "sequencer-specific" ] }
 137     } case swap ;
 138
 139 : read-meta ( delta -- event )
 140     read1 read-number read parse-meta <meta-event> ;
 141
 142 : read-sysex ( delta type -- event )
 143     read-number read <sysex-event> ;
 144
 145 : read-message ( delta type -- message )
 146     dup 0xf0 < [
 147         [
 148             ! channel messages
 149             [ 0x0f bitand "channel" ,, ] [ 0xf0 bitand ] bi {
 150                 { 0x80 [ "note-off"
 151                     read1 "note" ,, read1 "velocity" ,, ] }
 152                 { 0x90 [ "note-on"
 153                     read1 "note" ,, read1 "velocity" ,, ] }
 154                 { 0xa0 [ "polytouch"
 155                     read1 "note" ,, read1 "value" ,, ] }
 156                 { 0xb0 [ "control-change"
 157                     read1 "control" ,, read1 "value" ,, ] }
 158                 { 0xc0 [ "program-change"
 159                     read1 "program" ,, ] }
 160                 { 0xd0 [ "aftertouch"
 161                     read1 "value" ,, ] }
 162                 { 0xe0 [ "pitchwheel"
 163                     read1 read1 7 shift + min-pitchwheel + "pitch" ,, ] }
 164             } case
 165         ] H{ } make
 166     ] [
 167         {
 168             ! system common messages
 169             { 0xf0 [ "sysex" { 0xf7 } read-until drop ] }
 170             { 0xf1 [ "quarter-made" [
 171                     read1
 172                     [ -4 shift "frame-type" ,, ]
 173                     [ 0x0f bitand "frame-value" ,, ] bi
 174                 ] H{ } make ] }
 175             { 0xf2 [ "songpos" read1 read1 7 shift + ] }
 176             { 0xf3 [ "song-select" read1 ] }
 177             { 0xf6 [ "tune-request" f ] }
 178
 179             ! real-time messages
 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 ] }
 186         } case
 187     ] if <midi-event> ;
 188
 189 : read-event ( delta type -- event )
 190     {
 191         { 0xf0 [ 0xf0 read-sysex ] }
 192         { 0xf7 [ 0xf7 read-sysex ] }
 193         { 0xff [ read-meta ] }
 194         [ read-message ]
 195     } case ;
 196
 197 : read-status ( prev-status -- prev-status' status )
 198     peek1 dup 0x80 < [
 199         drop dup
 200     ] [
 201         drop read1 dup 0xff = [
 202             nip dup
 203         ] unless
 204     ] if ;
 205
 206 : read-event-header ( prev-status -- prev-status' delta status )
 207     [ read-number ] dip read-status swapd ;
 208
 209 : parse-events ( data -- events )
 210     binary <byte-reader> <peek-stream> [
 211         f [
 212             peek1 [ read-event-header ] [ f f ] if dup
 213         ] [ read-event ] produce 3nip
 214     ] with-input-stream ;
 215
 216 : <midi-header> ( bytes -- header )
 217     2 cut 2 cut [ be> ] tri@ midi-header boa ;
 218
 219 : <midi-track> ( bytes -- track )
 220     parse-events midi-track boa ;
 221
 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> ]
 227     } case ;
 228
 229 : read-header ( -- header )
 230     read-chunk dup midi-header? t assert= ;
 231
 232 : read-chunks ( header -- chunks )
 233     #chunks>> [ read-chunk ] replicate ;
 234
 235 PRIVATE>
 236
 237 : read-midi ( -- midi )
 238     read-header dup read-chunks <midi> ;
 239
 240 : >midi ( byte-array -- midi )
 241     binary [ read-midi ] with-byte-reader ;
 242
 243 : file>midi ( path -- midi )
 244     binary [ read-midi ] with-file-reader ;
 245
 246 <PRIVATE
 247
 248 : write-number ( n -- )
 249     [ 0x7f bitand ] keep
 250
 251     [ -7 shift dup 0 > ] [
 252         [ 8 shift 0x80 bitor ]
 253         [ [ 0x7f bitand + ] keep ] bi*
 254     ] while drop
 255
 256     [ [ -8 shift ] [ 0x80 bitand 0 > ] bi ]
 257     [ dup 0xff bitand write1 ] do while drop ;
 258
 259 : write-string ( str -- )
 260     utf8 encode [ length write-number ] [ write ] bi ;
 261
 262 GENERIC: write-event ( prev-status event -- status )
 263
 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 ] }
 279         { "smpte-offset" [
 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 ]
 287             } cleave ] }
 288         { "time-signature" [
 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 ]
 294             } cleave ] }
 295         { "key-signature" [
 296             B{ 0x59 0x02 } write
 297             key-signatures value-at write ] }
 298         { "sequencer-specific" [
 299             0x7f write1
 300             [ length write-number ] [ write ] bi ] }
 301     } case drop f ;
 302
 303 M: sysex-event write-event
 304     drop
 305     [ delta>> write-number ]
 306     [ type>> write1 ]
 307     [ bytes>> write ] tri f ;
 308
 309 : write-status ( prev-status status -- )
 310     dup 0xf0 < [
 311         [ = ] keep swap [ drop ] [ write1 ] if
 312     ] [
 313         nip write1
 314     ] if ;
 315
 316 : write-channel ( prev-status value status quot -- status )
 317     [
 318         swap [
 319             "channel" of + [ write-status ] keep
 320         ] keep
 321     ] dip call ; inline
 322
 323 M: midi-event write-event
 324     [ delta>> write-number ] [ value>> ] [ name>> ] tri {
 325
 326         { "note-off" [
 327             0x80 [
 328                 [ "note" of write1 ]
 329                 [ "velocity" of write1 ] bi
 330             ] write-channel ] }
 331         { "note-on" [
 332             0x90 [
 333                 [ "note" of write1 ]
 334                 [ "velocity" of write1 ] bi
 335             ] write-channel ] }
 336         { "polytouch" [
 337             0xa0 [
 338                 [ "note" of write1 ]
 339                 [ "value" of write1 ] bi
 340             ] write-channel ] }
 341         { "control-change" [
 342             0xb0 [
 343                 [ "control" of write1 ]
 344                 [ "value" of write1 ] bi
 345             ] write-channel ] }
 346         { "program-change" [
 347             0xc0 [ "program" of write1 ] write-channel ] }
 348         { "aftertouch" [
 349             0xd0 [ "value" of write1 ] write-channel ] }
 350         { "pitchwheel" [
 351             0xe0 [
 352                 "pitch" of min-pitchwheel -
 353                 [ 0x7f bitand write1 ]
 354                 [ -7 shift write1 ] bi
 355             ] write-channel ] }
 356
 357         ! system common messages
 358         { "sysex" [
 359             [ drop 0xf0 dup write1 ] dip
 360             write 0xf7 write1 ] }
 361         { "quarter-made" [
 362             [ drop 0xf1 dup write1 ] dip
 363             [ "frame-type" of 4 shift ]
 364             [ "frame-value" of + ] bi write1 ] }
 365         { "songpos" [
 366             [ drop 0xf2 dup write1 ] dip
 367             [ 0x7f bitand write1 ]
 368             [ -7 shift write1 ] bi ] }
 369         { "song-select" [
 370             [ drop 0xf3 dup write1 ] dip write1 ] }
 371         { "tune-request" [ 2drop 0xf6 dup write1 ] }
 372
 373         ! real-time messages
 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 ] }
 380     } case ;
 381
 382 GENERIC: write-chunk ( chunk -- )
 383
 384 M: midi-header write-chunk
 385     $[ "MThd" >byte-array ] write
 386     $[ 6 4 >be ] write
 387     [ format>> ] [ #chunks>> ] [ division>> ] tri
 388     [ 2 >be write ] tri@ ;
 389
 390 M: midi-track write-chunk
 391     $[ "MTrk" >byte-array ] write
 392     binary [
 393         events>> f swap [ write-event ] each drop
 394     ] with-byte-writer
 395     [ length 4 >be write ] [ write ] bi ;
 396
 397 M: midi-chunk write-chunk
 398     [ type>> write ]
 399     [ bytes>> [ length 4 >be write ] [ write ] bi ] bi ;
 400
 401 PRIVATE>
 402
 403 : write-midi ( midi -- )
 404     [ header>> write-chunk ]
 405     [ chunks>> [ write-chunk ] each ] bi ;
 406
 407 : midi> ( midi -- byte-array )
 408     binary [ write-midi ] with-byte-writer ;
 409
 410 : midi>file ( midi path -- )
 411     binary [ write-midi ] with-file-writer ;