The Midifile parser part is solved by Zapman, Dr Dri, and Dobro here:
http://www.purebasic.fr/english/viewtop ... er#p357273
To do:
The tempo trackbar gadget values must be adjusted to show real BPM.
Synchronization between music and scrolling; Can somebody help with this?
Please suggest features, EG: show track names, change track instruments, show barlines . . .
Code: Select all
;PBMidiReader Alpha 1
;By einander, based on old MidiParser by Zapman, Dr Dri and Dobro
;http://www.purebasic.fr/english/viewtopic.php?f=12&t=12766&p=357273&hilit=midi+parser#p357273
EnableExplicit
;
Enumeration ;Event Types
#MParEv_Hdr ;Hdr chunk Hnd
#MParEv_Trk ;Trk chunk Hnd
#MParEv_Com ;channel Ev Hnd
#MParEv_SysEx ;Sys exclusive Hnd
#MParEv_Sys ;Sys Ev Hnd
#MParEv_Meta ;meta Ev Hnd
#MParEv_Chunk ;non Trk chunks Hnd
#MParEv_Err ;Err Hnd
EndEnumeration
Enumeration ;Err codes
#MParErr_File : #MParErr_Hdr : #MParErr_EOF : #MParErr_Time : #MParErr_Com
#MParErr_SysEx : #MParErr_Sys : #MParErr_Meta : #MParErr_Trk
EndEnumeration
Enumeration ;Ev Hnds return value
#MParStop: #Continue
EndEnumeration
#MidiMax = $0FFFFFFF ;4 reserved Bytes
#MidiErr = $FFFFFFFF ;impossible VarLen or Num value
#MIDIHdr = 1684558925 ;"MThd"
#MIDITrk = 1802654797 ;"MTrk"
#MSEC = 60000.0 ; = millisecs in 1 minute
;
Structure MIDIData ; 3 Bytes + 1 null for each MIDIMessage
By1.A : By2.A : By3.A : Null.A
EndStructure
Structure MIDICHUNK : Type.I : Size.I :EndStructure
Structure MHdr : WTrk.W : WCount.W: WDelta.W :EndStructure
Structure Bytes : B.B[4] :EndStructure
Structure MidiDat : STime.I : Ev.I : D1.A : D2.A :EndStructure
Structure A4 : A.A[4] : EndStructure
Structure I2:I1.I:I2.I:EndStructure
Structure Par
Type.I
T.S
NTrk.I
Chan.I2[16]
RGB.I[16]
List Dat.MidiDat()
Array Le.I(127)
EndStructure
;
Define I,Wi,He,Ev,Showmidi,Chan
Define MidiHome.s="E:\musica\midi\" ; put here your midi directory <<<<<<<<<<<<<<<<<<<<<<<<<<<<
Global _Par.Par,_ParWn,_ProgBar,_Thread,_ThOut,_HMIDIout,_Tpo.D,_ChPlay
Global Dim _Chn(96), Dim _Pos.Point(127), Dim _EvHnds(#MParEv_Err)
Global __DMsg.MIDIData
__DMsg\Null=#Null
Prototype HdrHnd(Trk.W, Count.W, Delta.W)
Prototype TrkHnd()
Prototype ComHnd(Time, Ev, Chan, D1, D2)
Prototype SysExHnd(Time, Ev, Size, *Buf)
Prototype SysHnd(Time, Ev, D)
Prototype MetaHnd(Time, Ev, Size, *Buf)
Prototype ChunkHnd(Type, Size, *Buf)
;
Macro GadgetBottom(Gad) : GadgetY(Gad)+GadgetHeight(Gad) : EndMacro
Macro GadgetRight(Gad) : GadgetX(Gad)+GadgetWidth(Gad) : EndMacro
Macro Dmsg(Ev,D1,D2=0)
__DMsg\By1=Ev : __DMsg\By2=D1 : __DMsg\By3=D2
midiOutShortMsg_(_HMIDIout,PeekL(__Dmsg))
EndMacro
Macro QuitThread()
If IsThread(_Thread)
_Thout=#True
PauseThread(_Thread)
Alloff()
WaitThread(_Thread,200)
KillThread(_Thread)
_Thread=0
SetGadgetState(_ChPlay,0)
Alloff()
EndIf
EndMacro
Macro NtLen(Nt)
If _Par\Le(Nt) And GetGadgetState(_Par\Chan[Chan]\I2)
Y=H1-Nt*10
Sz=X-_Par\Le(Nt)-1
If Sz>-1
Box(_Par\Le(Nt),Y,Sz,10,_Par\RGB[Chan])
EndIf
EndIf
EndMacro
Procedure.W ReadBigEndianW(File)
ReadWord(File)
!BSWAP eax
!SHR eax, 16
ProcedureReturn
EndProcedure
;
Procedure.L ReadBigEndianL(File)
ReadLong(File)
!BSWAP eax
ProcedureReturn
EndProcedure
;
Procedure.Q PeekBigEndianN(*MemBuff.A4, Size)
Protected Result.Q, I
While I < Size
Result << 8
Result | (*MemBuff\A[I] & $FF)
I+1
Wend
ProcedureReturn Result
EndProcedure
;
;
Procedure InitMIDI()
Protected Midi.MIDIOUTCAPS,Devnum,Midiport
For Devnum=-1 To midiOutGetNumDevs_()-1
If midiOutGetDevCaps_(Devnum,@Midi,SizeOf(MIDIOUTCAPS))=0
If Midi\WVoices>0
MidiPort=Devnum
EndIf
EndIf
Next
If midiOutOpen_(@_Hmidiout,MidiPort,0,0,0)
MessageRequester("Midi Error","Midi device not found",0)
End
EndIf
EndProcedure
;
Procedure Menu1(Wn)
Protected Menu=CreateMenu(-1, WindowID(Wn))
MenuTitle("File")
MenuItem( 1, "Load MIDI File")
MenuTitle("?")
MenuItem(11, "About")
ProcedureReturn Menu
EndProcedure
;
Procedure NumToVarLen(Num)
Protected VarLen, I,*VarLen.Bytes
If Num & ~#MidiMax : VarLen = #MidiErr
Else
*VarLen = @VarLen
*VarLen\B[0] = (Num >> 0) & $7F
*VarLen\B[1] = (Num >> 7) & $7F
*VarLen\B[2] = (Num >> 14) & $7F
*VarLen\B[3] = (Num >> 21) & $7F
I = 3
While I > 0 And Not *VarLen\B[I]
I - 1
Wend
While I > 0
*VarLen\B[I] | $80
I - 1
Wend
EndIf
ProcedureReturn VarLen
EndProcedure
;
Procedure VarLenToNum(VarLen)
Protected Num, I,*VarLen.Bytes
*VarLen = @VarLen
Num | (*VarLen\B[0] & $7F) << 0
Num | (*VarLen\B[1] & $7F) << 7
Num | (*VarLen\B[2] & $7F) << 14
Num | (*VarLen\B[3] & $7F) << 21
If VarLen <> NumToVarLen(Num) : Num = #MidiErr : EndIf
ProcedureReturn Num
EndProcedure
;
Procedure WriteVarLen(File, Num)
Protected Write, VarLen, I, *VarLen.Bytes
VarLen = NumToVarLen(Num)
If IsFile(File) And VarLen <> #MidiErr
*VarLen = @VarLen
I = 3
While Not *VarLen\B[I]: I - 1: Wend
While I >= 0
Write + WriteByte(File, *VarLen\B[I])
I - 1
Wend
EndIf
ProcedureReturn Write
EndProcedure
;
Procedure ReadVarLen(File)
Protected VarLen, Len
If IsFile(File)
Repeat
VarLen = (VarLen << 8) | (ReadByte(File) & $FF)
Len + 1
Until Not VarLen & $80
If Len > 4 : VarLen = #MidiErr: EndIf
Else : VarLen = #MidiErr
EndIf
ProcedureReturn VarLenToNum(VarLen)
EndProcedure
;
Procedure VarLenSize(Value, IsVarLen = #False)
Protected Size
If IsVarLen : Value = VarLenToNum(Value): EndIf
If Value < 0 : Size = #MidiErr
ElseIf Value < (1 << 7) : Size = 1
ElseIf Value < (1 << 14) : Size = 2
ElseIf Value < (1 << 21) : Size = 3
ElseIf Value < (1 << 28) : Size = 4
Else : Size = #MidiErr
EndIf
ProcedureReturn Size
EndProcedure
;
;
Procedure MidiErr(ErrCode)
If _EvHnds(#MParEv_Err) ;if the user wants to catch it
CallFunctionFast(_EvHnds(#MParEv_Err), ErrCode) ;then lets give him
EndIf
ProcedureReturn #MParStop
EndProcedure
;
Procedure ParMHdr(File, *Hdr.MHdr)
Protected Result, Hnd.HdrHnd, Chunk.MIDICHUNK
Chunk\Type = ReadLong(File)
Chunk\Size = ReadBigEndianL(File)
If Chunk\Type = #MidiHdr And Chunk\Size = SizeOf(MHdr)
*Hdr\WTrk = ReadBigEndianW(File)
*Hdr\WCount = ReadBigEndianW(File)
*Hdr\WDelta = ReadBigEndianW(File)
Select *Hdr\WTrk
Case 0,1,2
_Par\Type=*Hdr\Wtrk
Result = #Continue
Hnd = _EvHnds(#MParEv_Hdr) ;except if the user doesn't agree
If Hnd : Result = Hnd(*Hdr\WTrk, *Hdr\WCount, *Hdr\WDelta): EndIf
Default : Result = MidiErr(#MParErr_Hdr) ;this is not a valid midi Hdr
EndSelect
Else : Result = MidiErr(#MParErr_Hdr) ;this is not a midi Hdr
EndIf
ProcedureReturn Result
EndProcedure
;
Procedure ParMTrk()
Protected Result = #Continue, Hnd.TrkHnd = _EvHnds(#MParEv_Trk)
If Hnd : Result = Hnd(): EndIf
ProcedureReturn Result
EndProcedure
;
Procedure ParMCom(File, Time,Ev, *P.Point)
Protected Result, Hnd.ComHnd, Chan = Ev&$F, D1 = ReadByte(File) & $FF ,D2
Ev = ((Ev >> 4) & $F)
*P\X=D1
If Ev <> $C And Ev <> $D : D2 = ReadByte(File) & $FF : *P\Y=D2: EndIf
If D1 & $80 Or D2 & $80 : MidiErr(#MParErr_Com) ;the MSB is set to 1 for Evs
Else ;the Com is valid so parsing continues
Result = #Continue
Hnd = _EvHnds(#MParEv_Com)
If Hnd : Result = Hnd(Time, Ev, Chan, D1, D2) : EndIf
EndIf
ProcedureReturn Result
EndProcedure
;
Procedure ParMSysEx(File, Time, Ev)
Protected Result, Size, *Buf, Hnd.SysExHnd
Size = ReadVarLen(File)
If Size = #MidiErr : MidiErr(#MParErr_SysEx)
Else : *Buf = AllocateMemory(Size)
EndIf
If *Buf
ReadData(File, *Buf, Size)
Result = #Continue
Hnd = _EvHnds(#MParEv_SysEx)
If Hnd : Result = Hnd(Time, Ev, Size, *Buf): EndIf
FreeMemory(*Buf)
Else: FileSeek(File, Loc(File) + Size)
Result = #Continue
EndIf
ProcedureReturn Result
EndProcedure
;
Procedure ParMSys(File, Time, Ev)
Protected Result, D
Protected Hnd.SysHnd
Select Ev
Case $F1, $F3 To $F9
D = ReadByte(File) & $FF
If D & $80 ;the MSB is set to 1 for Evs
MidiErr(#MParErr_Sys)
D = $FFFFFFFF
EndIf
Case $F2
D = ReadVarLen(File)
If VarLenSize(D) <> 2 ;this Ev D takes two Bytes
MidiErr(#MParErr_Sys)
D = $FFFFFFFF
EndIf
EndSelect
Hnd = _EvHnds(#MParEv_Sys)
If D >= 0 And Hnd : Result = Hnd(Time, Ev, D) : EndIf
ProcedureReturn Result
EndProcedure
;
Procedure ParMMeta(File, Time, MetaEv)
Protected Result, Size, *Buf , Hnd.MetaHnd
Size = ReadVarLen(File)
If Size = #MidiErr : MidiErr(#MParErr_Meta)
Else : *Buf = AllocateMemory(Size + 1) ;if Size = 0, force memory allocation
EndIf
If *Buf
ReadData(File, *Buf, Size)
Result = #Continue
Hnd = _EvHnds(#MParEv_Meta)
If Hnd : Result = Hnd(Time, MetaEv, Size, *Buf) : EndIf
FreeMemory(*Buf)
Else
FileSeek(File, Loc(File) + Size)
Result = #Continue
EndIf
ProcedureReturn Result
EndProcedure
;
Procedure ParMChunk(File, *Chunk.MIDICHUNK)
Protected Result, *Buf, Hnd.ChunkHnd
If *Chunk\Size : *Buf = AllocateMemory(*Chunk\Size): EndIf
If *Buf
ReadData(File, *Buf, *Chunk\Size)
Result = #Continue
Hnd = _EvHnds(#MParEv_Chunk)
If Hnd : Result = Hnd(*Chunk\Type, *Chunk\Size, *Buf) : EndIf
FreeMemory(*Buf)
Else
FileSeek(File, Loc(File) + *Chunk\Size)
Result = #Continue
EndIf
ProcedureReturn Result
EndProcedure
;
Procedure SetMidiEvHnd(EvType, CallBack)
Protected Set ;If CallBack is Null then the EvType is not catched (default behavior)
If EvType >= #MParEv_Hdr And EvType <= #MParEv_Err
_EvHnds(EvType) = CallBack
Set = #True
EndIf
ProcedureReturn Set
EndProcedure
;
Procedure ParMFile(FileName.S)
Protected Pard, KeepParsing,P.Point, Ev, MetaEv
Protected DeltaTime, Time, Old, Loc, Chunk.MIDICHUNK, Hdr.MHdr
Protected File = ReadFile(#PB_Any, FileName)
HideGadget(_Progbar,0)
If File
SetGadgetAttribute(_Progbar,#PB_ProgressBar_Maximum,Lof(File))
KeepParsing = ParMHdr(File, Hdr)
While KeepParsing And Not Eof(File) ; Chunk Loop (catch all chunks till the end of File)
SetGadgetState(_Progbar,Loc(File))
If GetAsyncKeyState_(27)&$8000 : End : EndIf
If Lof(File) - Loc(File) < SizeOf(MIDICHUNK) ;if not EOF then there must be another chunk
KeepParsing = MidiErr(#MParErr_EOF)
Else
Chunk\Type = ReadLong(File)
Chunk\Size = ReadBigEndianL(File)
EndIf
If KeepParsing And Lof(File) - Loc(File) < Chunk\Size ;if remaining Size is enough, identify the chunk
KeepParsing = MidiErr(#MParErr_EOF)
ElseIf KeepParsing
Select Chunk\Type
Case #MIDITrk ;inform the user that a new Trk is about to be Pard
KeepParsing = ParMTrk()
_Par\NTrk + 1 ;internal Trk Counter
Case #MidiHdr ;this chunk only append at the begining of the File
KeepParsing = MidiErr(#MParErr_Hdr)
Default ;we don't know this chunk...
KeepParsing = ParMChunk(File, Chunk)
EndSelect
EndIf
;
If KeepParsing And Chunk\Type = #MIDITrk ; Trk Par (catch all Evs till the end of the Trk)
Loc = Loc(File) + Chunk\Size ;exprected File location at the end of the Trk
Time = 0: MetaEv = 0
While Not (Ev = $FF And MetaEv = $2F) ;While Not EndOfTrk
SetGadgetState(_Progbar,Loc(File))
DeltaTime = ReadVarLen(File)
Time + DeltaTime
If DeltaTime = #MidiErr
MidiErr(#MParErr_Time)
Break
EndIf
Old = Ev
Ev = ReadByte(File) & $FF
If Ev < $80
FileSeek(File, Loc(File)-1)
Ev = Old
EndIf
Select Ev
Case $80 To $EF
KeepParsing = ParMCom(File, Time, Ev,@P)
AddElement(_Par\Dat())
_Par\Dat()\STime=Time
_Par\Dat()\Ev=Ev
_Par\Dat()\D1=P\X
_Par\Dat()\D2=P\Y
Case $F0, $F7 : KeepParsing = ParMSysEx(File, Time, Ev)
Case $FF
MetaEv = ReadByte(File) & $FF
If MetaEv & $80 : KeepParsing = MidiErr(#MParErr_Meta)
Else : KeepParsing = ParMMeta(File, Time, MetaEv)
EndIf
Default : KeepParsing = ParMSys(File, Time, Ev)
EndSelect
If Not KeepParsing ;the user doesn't want to continue or Err has occured ?
Break ;whatever... just Stop parsing
EndIf
Wend ;While Not EndOfTrk
If Loc <> Loc(File) ;the chunk Size is not the specified Size
KeepParsing = MidiErr(#MParErr_Trk)
EndIf
EndIf ;Trk Par
Wend ;Chunk Loop
If _Par\NTrk <> Hdr\WCount ;the number of Trks is not valid
KeepParsing = MidiErr(#MParErr_Trk)
EndIf
If KeepParsing : Pard = #True: EndIf
CloseFile(File)
Else: MidiErr(#MParErr_File)
EndIf
HideGadget(_Progbar,1)
ProcedureReturn Pard
EndProcedure
;
;
Procedure MfPlay(Void)
Protected OldSTime,Chan,X,Y=GadgetBottom(_ProgBar)+200,Sz,Stat
Protected Xlim=WindowWidth(_Parwn),Delay,Xstp.D=16,He=WindowHeight(_Parwn),SDif
Protected H1=He+120
ResetList(_Par\Dat())
With _Par\Dat()
StartDrawing(WindowOutput(_Parwn))
Repeat
X=0:OldSTime=0
Box(0,0,OutputWidth(),OutputHeight(),0)
ForEach _Par\Dat()
If \STime<>OldSTime
Sdif=\STime-OldSTime
SetWindowTitle(0,Str(\stime))
Delay=Sdif*_Tpo
If _Thout
StopDrawing()
Break 2
EndIf
Delay(Delay)
X+Sdif/4.0
If X>Xlim
X=0:Dim _Par\Le(127)
Box(0,0,OutputWidth(),OutputHeight(),0)
EndIf
EndIf
Stat=(\Ev >> 4) & $F
Chan = \Ev&$F
If GetGadgetState( _Par\Chan[Chan]\I2)
Dmsg(\Ev,\D1,\D2) ; toca
EndIf
OldSTime=\STime
If Stat=$9 And \D2; nt on con vel
Box(10+Chan*42,He-\D2/10,40,\D2/10-1,_Par\RGB[Chan]);monitor on
If GetGadgetState(_Par\Chan[Chan]\I2)
Y=H1-\D1*10
Box(X,Y,3,10,_Par\RGB[Chan])
_Par\Le(\D1)=X
Else
_Par\Le(\D1)=0
EndIf
ElseIf Stat =$8 Or Stat =$9 ; nt off or nt on con vel =0
Box(10+Chan*42,He-15,40,15,0) ; monitor off
If _Par\Le(\D1) And GetGadgetState(_Par\Chan[Chan]\I2)
Y=H1-\D1*10
Sz=X-_Par\Le(\D1)-1
If Sz>-1
Box(_Par\Le(\D1),Y,Sz,10,_Par\RGB[Chan])
EndIf
EndIf
EndIf
Next
Until _Thout
StopDrawing()
EndWith
EndProcedure
;
Procedure AllOff() ;- AllOff - All Notes off - silence
Protected I
For I=0 To 15
Dmsg($B0+I,120,0)
Next
EndProcedure
;
Procedure MidiReset()
Protected I
Dmsg($FF,0,0)
For I=0 To 15
Dmsg($B0+I,121,0)
Next
EndProcedure
;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
OpenWindow(0, 100, 100,700,500 ,"",#WS_OVERLAPPEDWINDOW|#WS_MAXIMIZE |#PB_Window_Invisible)
SetWindowColor(0,0)
Define Menu1=Menu1(0)
Wi=WindowWidth(0):He=WindowHeight(0)
_ProgBar=ProgressBarGadget(-1,10,10,Wi/2,20,0,100,#PB_ProgressBar_Smooth)
HideGadget(_Progbar,1)
_ChPlay=CheckBoxGadget(-1,GadgetRight(_Progbar)+20,10,80,20,"Play")
Define TbTpo=TrackBarGadget(-1,GadgetRight(_ChPlay)+10,GadgetY(_ChPlay),200,20,1,600)
SetGadgetState(Tbtpo,300)
_Tpo=(600-GetGadgetState(Tbtpo))/100
Define X=100,Y=GadgetBottom(_ProgBar)+200
Initmidi()
Define MidiFileName$
_ParWn=OpenWindow(-1,0,100,Wi,He-100,"",#PB_Window_BorderLess,WindowID(0))
Define Wdings=FontID(LoadFont(-1,"wingdings",12))
SetWindowColor(_Parwn,333333)
X=10:Y=He-40
UseGadgetList(WindowID(0))
Restore RGB:
For I=0 To 15
Read.I _Par\RGB[I]
_Par\Chan[I]\I1=TextGadget(-1,X,Y,40,20," "+Str(I),#PB_Text_Center)
_Par\Chan[I]\I2=ButtonGadget(-1,X,Y,16,14,Chr(252),#PB_Button_Toggle) ;,Str(I))
SetGadgetFont(_Par\Chan[I]\I2,Wdings)
;GadColor(_Par\Chan[I],_Par\RGB[I],0)
SetGadgetColor(_Par\Chan[I]\I1, #PB_Gadget_BackColor, _Par\RGB[I])
SetGadgetState(_Par\Chan[I]\I2,1) ; todos open
SetGadgetData(_Par\Chan[I]\I2,I)
X+42
Next
HideWindow(0,0)
Repeat
If GetAsyncKeyState_(27)&$8000 : End : EndIf
EV=WaitWindowEvent()
Select Ev
Case #PB_Event_Gadget
Select EventGadget()
Case _ChPlay
If GetGadgetState(_ChPlay)
If IsThread(_Thread)=0
_Thout=0
_Thread=CreateThread(@MfPlay(),0):EndIf
ThreadPriority(_Thread,31)
Else
QuitThread()
EndIf
Case TbTpo:_Tpo=(600-GetGadgetState(Tbtpo))/100
SetWindowTitle(0,StrD(_Tpo))
Case _Par\Chan[0]\I2 To _Par\Chan[15]\I2
Chan=GetGadgetData(EventGadget())
If GetGadgetState(EventGadget()): SetGadgetText(EventGadget(),Chr(252))
Else :SetGadgetText(EventGadget(),"")
EndIf
; Alloff() ; brute force but secure
If GetGadgetState(EventGadget())=0
Dmsg($B0+Chan,120,0)
;Apchan(Chan) ; sometimes fail
EndIf
EndSelect
Case #PB_Event_Menu
Select EventMenu()
Case 1
QuitThread()
MidiFileName$ = OpenFileRequester("Open midi File", midihome, "Midi|*.mid;*.midi", 0)
Midireset()
SetGadgetState(_Progbar,0)
_Par\T=MidiFileName$+Chr(10)
StartDrawing(WindowOutput(_Parwn))
ClearList(_Par\Dat())
If ParMFile(MidiFileName$) : _Par\T+Chr(10)+ GetFilePart(MidiFileName$) + " parsing complete."
Else : _Par\T+Chr(10)+ "Error while parsing " + GetFilePart(MidiFileName$)
; <<<<<<< To do :hide unused Tracks
EndIf
SortStructuredList(_Par\Dat(),#PB_Sort_Ascending,OffsetOf(Mididat\STime),#PB_Sort_Long)
StopDrawing()
EndSelect
EndSelect
Until EV=#PB_Event_CloseWindow
QuitThread()
End
;
DataSection
RGB:
Data.I $CDFFFF,$1328Dc,#Green,$Ff9933,#Yellow,#Magenta,$FFF882,$Fabada,$FFBFFF,$C8FFE4,$4E8BFF, $00A5FF, $AAddff,$FfaAdd,$Aaffdd,$Ddffaa
EndDataSection
