\ Midi player class for ALSA sequencer                 24jun02py

[IFUNDEF] midi-player
    include midi-classes.fs
[THEN]

\ ALSA libasound interface                             06jul02py

Vocabulary alsa-midi
also dos also memory also alsa-midi definitions

struct{
byte type         /* event type */
byte flags        /* event flags */
byte tag          /* arbitrary tag */
byte queue        /* schedule queue */
cell time_s    /* schedule time */
cell time_ns
short source       /* source address: client, port */
short dest         /* destination address: client, port */
40 string data        /* event data... */
} snd_seq_event


struct{
        cell client                     /* client number to inquire */
        cell type                       /* client type */
        64 string name                  /* client name */
        cell filter                     /* filter flags */
        8 string multicast_filter       /* multicast filter bitmap */
        32 string event_filter          /* event filter bitmap */
        cell num_ports                  /* RO: number of ports */
        cell event_lost                 /* number of lost events */
        64 string \                     /* for future use */
} snd_seq_client_info

struct{
        byte client   byte port               /* client/port numbers */
        64 string name                  /* port name */
        cell capability                 /* port capability bits */
        cell type                       /* port type bits */
        cell midi_channels              /* channels per MIDI port */
        cell midi_voices                /* voices per MIDI port */
        cell synth_voices               /* voices per SYNTH port */

        cell read_use                   /* R/O: subscribers for output (from thi
s port) */
        cell write_use                  /* R/O: subscribers for input (to this p
ort) */

        cell kernel                     /* reserved for kernel use (must be NULL
) */
        cell flags                      /* misc. conditioning */
        60 string time_queue            /* queue # for timestamping */
} snd_seq_port_info

Create cinfo  sizeof snd_seq_client_info allot
Create pinfo  sizeof snd_seq_port_info allot
	    
library libasound libasound.so.2

legacy off

libasound open int int int int (int) snd_seq_open
 ( *handle name streams mode -- f )
libasound close int (int) snd_seq_close ( handle -- flag )
libasound connect_to int int int int (int) snd_seq_connect_to
 ( seq port client port -- f )
libasound client_id int (int) snd_seq_client_id ( handle -- id )
libasound create_simple_port int int int int
 (int) snd_seq_create_simple_port ( handle name caps type -- f )
libasound set_output_buffer_size int int
 (int) snd_seq_set_output_buffer_size ( handle size -- f )
libasound alloc_named_queue int int
 (int) snd_seq_alloc_named_queue ( handle name -- queue )
libasound set_client_name int int
 (int) snd_seq_set_client_name ( handle name -- f )
libasound event_output_direct int int
 (int) snd_seq_event_output_direct ( handle ev -- f )
libasound event_output_buffer int int
 (int) snd_seq_event_output_buffer ( handle ev -- f )
libasound drain_output int
 (int) snd_seq_drain_output ( handle -- f )
libasound query_next_client int int
 (int) snd_seq_query_next_client ( handle info -- f )
libasound query_next_port int int
 (int) snd_seq_query_next_port ( handle info -- f )

libasound queue_tempo_sizeof
 (int) snd_seq_queue_tempo_sizeof ( -- size )
libasound queue_tempo_set_tempo int int
 (void) snd_seq_queue_tempo_set_tempo ( queue tempo -- )
libasound queue_tempo_set_ppq int int
 (void) snd_seq_queue_tempo_set_ppq ( queue ppq -- )
libasound set_queue_tempo int int int
 (int) snd_seq_set_queue_tempo ( handle q tempo -- f )
libasound get_queue_tempo int int int
 (int) snd_seq_get_queue_tempo ( handle q tempo -- f )

\ Midi player implementation                           06jul02py

also memory

&17 Value wavetable
&00 Value waveport

midi-player implements
  Create ev     here sizeof snd_seq_event dup allot erase
  Create _tempo here queue_tempo_sizeof   dup allot erase

  : open-seq  seq 0" hw" 3 0 open drop ;
  : sync-wait ( -- )  ticks @ 0= ?EXIT
      start-time @ real-ticks 2@
      precision @ 0=
      IF    division @ um/mod nip &5 / 1- &50 * ms>time 
      ELSE  division @ &10 ms>time / um/mod nip  THEN
      + till ;
  : sync seq @ drain_output drop sync-wait ;
  : create-port ( -- ) seq @ 0" Midi player" $63 2
    create_simple_port port ! ;
  : connect-seq seq @ port @ wavetable waveport connect_to drop ;
  : hex. ( -- )  base push hex . ;
  : list-ports ( -- )  cinfo @ pinfo c! -1 pinfo 1+ c!
      BEGIN  seq @ pinfo query_next_port  0= WHILE
	      pinfo snd_seq_port_info client c@ .
	      pinfo snd_seq_port_info port c@ . ."  '" 
	      pinfo snd_seq_port_info name >len type ." ' "
	      pinfo snd_seq_port_info capability @ hex.
	      pinfo snd_seq_port_info type @ hex.
	      pinfo snd_seq_port_info capability @ $42 = \ player
	      wavetable 0= waveport 0= and and  IF
		  pinfo snd_seq_port_info client c@ to wavetable
		  pinfo snd_seq_port_info port c@ to waveport
		  '*' emit
	      THEN cr
      REPEAT ;
  : list-clients ( -- )  cinfo off  0 to wavetable  0 to waveport
      BEGIN  seq @ cinfo query_next_client  0= WHILE
	      cinfo snd_seq_client_info client ?
	      cinfo snd_seq_client_info num_ports ?
	      cinfo snd_seq_client_info name >len type cr
	      list-ports
      REPEAT ;
  : search-ports ( -- )  cinfo @ pinfo c! -1 pinfo 1+ c!
      BEGIN  seq @ pinfo query_next_port  0= WHILE
	      pinfo snd_seq_port_info capability @ $42 = \ player
	      wavetable 0= waveport 0= and and  IF
		  pinfo snd_seq_port_info client c@ to wavetable
		  pinfo snd_seq_port_info port c@ to waveport
	      THEN
      REPEAT ;
  : search-clients ( -- )  cinfo off  0 to wavetable  0 to waveport
      BEGIN  seq @ cinfo query_next_client  0= WHILE
	      search-ports
      REPEAT ;
  : set-ev-header ( command -- )
              [ ev snd_seq_event type      ] ALiteral c!
      port @  [ ev snd_seq_event source 1+ ] ALiteral c!
      $FE     [ ev snd_seq_event dest      ] ALiteral c!
      $FD     [ ev snd_seq_event dest   1+ ] ALiteral c!
      queue @ [ ev snd_seq_event queue     ] ALiteral c!
      ticks @ [ ev snd_seq_event time_s    ] ALiteral !
    ( direct out ) ;
  : alloc-queue  seq @ 0" bigFORTH" alloc_named_queue queue ! ;
  : set-name seq @ 0" bigFORTH Midi player"
    set_client_name drop ;
  : 64k-buffer  seq @ $10000 set_output_buffer_size drop ;
  : seq-open ( -- )
      open-seq create-port
      alloc-queue set-name 64k-buffer
      search-clients connect-seq ;
  : seq-close ( -- ) seq @ close drop seq off ;

\ Timer and tempo                                      06jul02py

  : timer, ( clock -- ) dup ticks !
      &33 set-ev-header
      $00     [ ev snd_seq_event dest      ] ALiteral c!
      $00     [ ev snd_seq_event dest   1+ ] ALiteral c!
              [ ev snd_seq_event data      ] ALiteral !
      seq @ ev event_output_direct drop
      &31     [ ev snd_seq_event type      ] ALiteral c!
              [ ev snd_seq_event data      ] ALiteral off
      seq @ ev event_output_direct drop ;
  : tempo, ( tempo -- )  sync dup tempo !
      _tempo swap queue_tempo_set_tempo
      seq @ queue @ _tempo set_queue_tempo drop ;

\ Note control                                         06jul02py
  
  : note, ( vol note chn type -- ) set-ev-header
      [ ev snd_seq_event data ] ALiteral c!+ c!+ c!
      seq @ ev event_output_buffer drop ;
  : ctrl, ( value ctrl chn type -- ) set-ev-header
      [ ev snd_seq_event data ] ALiteral c!+ 3+ !+ !
      seq @ ev event_output_buffer drop ;
  
  : start,  ( vol note chn -- )
      over2 over2 over2 7 << + note-buf @ + c! 6 note, ;
  : stop,   ( vol note chn -- )
      0     over2 over2 7 << + note-buf @ + c! 7 note, ;
  : key,    ( vol note chn -- )       8 note, ;
  : seq_control, ( program ctrl chn -- ) &10 ctrl, ;
  : seq_patch,   ( program chn -- )   0 swap &11 ctrl, ;
  : seq_press,   ( value chn -- )     0 swap &12 ctrl, ;
  : seq_pitch,   ( value chn -- )     0 swap &13 ctrl, ;
  : seq_ctrl,    ( value chn -- )     0 swap &14 ctrl, ;

\ sysex                                                06jul02py
  
  | Create sysexbuf  $F0 c, $100 allot
  : sysex, ( buf len -- ) tuck
      sysexbuf 1+ swap move sysexbuf swap 1+
      &130 set-ev-header
      [ ev snd_seq_event data ] ALiteral noop !+ !
      seq @ ev event_output_direct drop ;

\ Timer commands                                       06jul02py
  
  : start-timer ( bpm ticks -- )
      _tempo rot queue_tempo_set_ppq tempo, 0 timer, ;
  : tstart, ( -- ) division @ &10000 / tempo @ start-timer ;
  : tstop,  ( -- )
      &32     [ ev snd_seq_event type      ] ALiteral c!
      port @  [ ev snd_seq_event source 1+ ] ALiteral c!
      $00     [ ev snd_seq_event dest      ] ALiteral c!
      $00     [ ev snd_seq_event dest   1+ ] ALiteral c!
      queue @ [ ev snd_seq_event queue     ] ALiteral c!
              [ ev snd_seq_event data      ] ALiteral off
      seq @ ev event_output_direct drop ;
  : twait, ( n -- )  drop ;
class;

\ Midi Track implementation                            06jul02py

(midi-track class midi-track
    cell var data
    cell var len
    cell var index
    cell var ticks
    cell var cmd

    midi-player ptr parent
how:
\ data handling                                        06jul02py

    : set ( parent -- )  bind parent ;
    : dispose ( -- )  data @ IF  data HandleOff  THEN ;

    : dp ( -- addr )  data @ index @ + ;
    : rb ( -- c )  dp c@  1 index +! ;
    : rvl ( -- n )
      0 BEGIN  index @ len @ u>= ?EXIT
               7 << rb dup $80 and  WHILE  $7F and or  REPEAT
      $7F and or ;

\ Meta event                                           06jul02py

    : meta-event ( len data -- )
      dup $51 = IF  2drop rb 8 << rb or 8 << rb or
                    parent tempo,  EXIT  THEN
      dup $2F = IF  drop -1 ticks ! index +!  EXIT  THEN
\      dup $03 = IF  drop 0 ?DO  rb emit  LOOP  cr  EXIT  THEN  
\      dup $7F = IF  drop 0 ?DO  rb emit  LOOP  cr  EXIT  THEN  
\      dup $58 = IF  drop index +!  EXIT  THEN
\      dup 1 8 within  IF  drop index +!  EXIT  THEN
      drop index +! ;

\ note events                                          06jul02py

    : note-off ( chn -- )  >r rb rb swap r> parent stop, ;
    : note-on  ( chn -- )  >r rb rb swap r> parent start, ;
    : key      ( chn -- )  >r rb rb swap r> parent key, ;
    : control  ( chn -- )  >r rb rb r> parent seq_control, ;
    : patch    ( chn -- )  rb swap parent seq_patch, ;
    : press    ( chn -- )  rb swap parent seq_press, ;
    : pitch    ( chn -- )  >r rb rb 7 << or $2000 - r>
      parent seq_pitch, ;
    : ctrl     ( chn -- ) dup 0= IF  drop
            rb dp over parent sysex, index +!  EXIT  THEN
        rb swap parent seq_ctrl, ;

\ Eval commands                                        06jul02py

    Create eval-table
    T] note-off note-on key control patch press pitch ctrl [
    : eval-command ( cmd/dev -- )
        dup $F and swap 4 >> 7 and cells eval-table + perform ;
    : play ( tick -- tick' )
      dup -1 = ?EXIT
      BEGIN  index @ len @ u>=  IF  -1 ticks !  THEN
             dup ticks @ u>= WHILE
             dp c@ $80 and  IF  rb cmd !  THEN
             cmd @ dup $80 $FF within
             IF    eval-command
             ELSE  $FF =
                   IF  rb rvl swap meta-event
             THEN  THEN  rvl ticks +!
      REPEAT  drop ticks @ ;
    : restart ( -- )  index off rvl ticks ! ;
    : assign ( addr u -- )
      dup len ! dup data Handle!
      data @ swap move  index off  rvl ticks ! ;
class;

midi-player implements
    : mfb ( -- addr )  filebuf @ fileptr @ + ;
    : rb ( -- c )  mfb c@  1 fileptr +! ;
    : rw ( -- w )  rb   8 << rb or ;
    : rl ( -- l )  rw $10 << rw or ;
    s" krTM" drop @ Constant 'MTrk
    s" dhTM" drop @ Constant 'MThd
    s" FFIR" drop @ Constant 'RIFF
    : read-tracks ( tracklen format ntrks division -- )
        &10000 * division !
        link[] track @ IF  dispose[] track  THEN
        dup tracks !
        dup midi-track new[] bind[] track
        dup 0 DO  ^ i track set  LOOP
        0 ?DO  rl 'MTrk <> ?LEAVE
            rl mfb over  I track assign
            fileptr +!
        LOOP 2drop ;
    : >tracks ( -- )
        rl dup 'RIFF = IF  drop $10 fileptr +! rl  THEN
        dup 'MThd = IF  drop rl rw rw rw read-tracks  EXIT
        THEN  drop ;
    : patch-buf ( n -- addr )  note-buf @ + ;

\ playing                                              31dec97py

    : start ( -- )
        stop
        $1000 dup NewTask activate
        up@ midi-task !
        seq-open  playing on
        division @ &10000 / tempo @ start-timer
        BEGIN  ticks @ -1 <> playing @ and  WHILE
            &50 play-delta
        REPEAT
        seq-close
        ticks off start-ticks off start-time off
        tracks @ 0 DO  i track restart  LOOP
        midi-task off ;
    : stop ( -- ) playing off
      BEGIN  midi-task @ WHILE  &20 wait  REPEAT
      note-buf @ $800 erase ;

\ Playing                                              06jul02py

    : play ( tick -- tick' )
      -1 tracks @
      0 ?DO  over I track play umin  LOOP  nip ;
    : play-delta ( n -- )
      seq @ 0= IF  seq-open  THEN
      ticks @ 0= IF
          0 play dup start-ticks ! ticks !
          0. real-ticks 2!
          timer@ start-time !
          tstart, sync  THEN
      ticks @ swap real-ticks 2@ division @ um/mod nip + >r
      BEGIN  play dup -1 <>
      WHILE  real-ticks 2@ division @ um/mod nip r@ u<
      WHILE  dup ticks @ -
             real-ticks 2@ division @ um/mod nip >r
             tempo @ um* real-ticks 2@ d+ real-ticks 2!
             real-ticks 2@ division @ um/mod nip
             dup r> u> IF  twait,  ELSE  drop  THEN
             dup ticks ! sync pause
      REPEAT  ELSE  dup ticks !  THEN  drop rdrop sync ;

\ high level commands                                  31dec97py

    : init ( -- )
        $800 note-buf Handle!  note-buf @ $800 erase
        &500000 tempo ! ;
    : file ( addr u -- )
        stop
        r/o open-file throw >r
        r@ filesize @ dup filelen ! filebuf Handle!
        filebuf @ filelen @ r@ read-file throw drop
        fileptr off  r> close-file throw
        >tracks filebuf HandleOff filelen off ;
    : dispose ( -- )  stop
        link[] track @ IF  dispose[] track  THEN
        filebuf @ IF  filebuf HandleOff  THEN
        note-buf HandleOff ;

class;

previous previous previous previous definitions
