0.0.0.0:80 5line / master midi / midi.factor
master

Tree @master (Download .tar.gz)

midi.factor @master — raw · history · blame 

  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
! Copyright (C) 2026 Serre
! See https://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types alien.data alien.syntax arrays
assocs byte-arrays calendar classes.struct hex-strings kernel
math math.order math.parser memory namespaces ranges sequences
shuffle strings threads windows.types ;
IN: 5line.midi

! === Streamed MIDI output via Windows winmm.lib MIDI API

! == C Bindings

LIBRARY: winmm
TYPEDEF: uint MMRESULT

FUNCTION: UINT midiOutGetNumDevs ( )

STRUCT: MIDIOUTCAPSA
   { wMid WORD }
   { wPid WORD }
   { vDriverVersion UINT }
   { szPname  CHAR[32] }
   { wTechnology  WORD }
   { wVoices      WORD }
   { wNotes       WORD }
   { wChannelMask WORD }
   { dwSupport   DWORD } ;

FUNCTION: MMRESULT midiOutGetDevCapsA (
  UINT  uDeviceID,
  PVOID pmoc,
  UINT  cbmoc
)

FUNCTION: MMRESULT midiOutOpen (
  PVOID*     phmo,
  UINT       uDeviceID,
  DWORD_PTR  dwCallback,
  DWORD_PTR  dwInstance,
  DWORD      fdwOpen
)

FUNCTION: MMRESULT midiOutClose (
  HANDLE hmo
)

FUNCTION: MMRESULT midiOutShortMsg (
  HANDLE hmo,
  DWORD dwMsg
)

! == Midi Device Management

: midi-out-caps ( int -- struct )
   MIDIOUTCAPSA <struct> dup size
   over [ midiOutGetDevCapsA drop ] dip ;
   
: midi-out-name ( int -- string )
   midi-out-caps szPname>> [ 0 = ] reject >string ;
   
: all-midi-outs ( -- alist )
   midiOutGetNumDevs [0..b) 
   dup [ midi-out-name ] map zip ;

INITIALIZED-SYMBOL: active-midi-out [ f ]

: (open-midi-out) ( device-id -- )
  [ f void* <ref> dup ] dip 0 0 0 midiOutOpen 
  drop void* deref active-midi-out set-global ; 
! (todo: Error Handling)

: close-midi-out ( -- )
     active-midi-out get-global midiOutClose drop 
   f active-midi-out set-global ;
! (todo: Error Handling, Destructors?)

: open-midi-out ( device-id -- )
   active-midi-out get-global [ close-midi-out ] when
   (open-midi-out) ;

! == MIDI Messages (redundant with base midi vocab?)
CONSTANT: note-on  0b1001
CONSTANT: note-off 0b1000
CONSTANT: prog-chg 0b1100

: on-channel ( on? ch. -- bytes )
   [ note-on note-off ? 4 shift ] [ 1 max 16 min 1 - ] bi* + ;
   
: (chg-prog) ( prog ch. -- bytes )
   [ 1 - ] bi@ prog-chg 4 shift + 2array >byte-array ;

: chg-prog ( prog ch. -- )
   (chg-prog) bytes>hex-string hex>
         [ active-midi-out get-global ] dip
   midiOutShortMsg drop ;

CONSTANT: default-vel 127

: dial-note-bytes ( note on? ch. -- byte-array )
   on-channel swap 127 min default-vel 
   spin 3array >byte-array ;
   
: dial-note ( note on? ch. -- )
   dial-note-bytes bytes>hex-string hex> 
      [ active-midi-out get-global ] dip
   midiOutShortMsg drop ;
   
: midi-panic* ( ch. -- )
   [ 0 ..= 127 ] dip '[ f _ dial-note ] each ;  
: midi-panic ( -- )
   0 ..= 16 [ midi-panic* ] each ;
   
: with-midi-out ( quot device-id -- )
! Totally broken, either exits early or hangs forever.
! There's some lag inherent(?) to MIDI we need to compensate for
   open-midi-out 
      self [ resume stop ] curry compose "with-midi-out"
      spawn suspend drop 1 seconds sleep
   close-midi-out ;
   
: dial-on ( note ch. -- ) [ t ] dip dial-note ;

: dial-off-in ( note dt ch. -- ) 
   swap [ sleep [ f ] dip dial-note stop ] 
   3curry "Note Off" spawn drop ;

: dial-for ( note dt ch. -- )
   [ nip dial-on ] [ dial-off-in ] 3bi ;

: dial-notes-for ( note/dt-pairs ch. -- )
   '[ first2 _ dial-for ] each ;