Code: Select all
' karaoke midi player
' load and analyse midi files
' play song and lyrics
' copyright by oog/proog.de 2013-2017
'
Const Version="Version 0.17.01.06"
' This program is free software: you can redistribute it and/or modify
' it under the terms of the GNU General Public License as published by
' the Free Software Foundation, either version 3 of the License, or
' (at your option) any later version.
'
' This program is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY; without even the implied warranty of
' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
' GNU General Public License for more details.
'
' You should have received a copy of the GNU General Public License
' along with this program. If not, see <http://www.gnu.org/licenses/>.
'
'---------- program structure ----------
'
'loadFile(infile)
'setGlobalTempo()
'loadMidi
'retimeTrack
'analyseKaraoke
'showMidi
'buildSequence
'playMidi
'---------- play MIDI ----------
'Thanks to Mysoft who showed, how to use MIDI on Windows
'Link : http://www.freebasic.net/forum/viewtopic.php?t=12995
'Title: QB like PLAY plus more...
#include once "windows.bi"
#include once "win\mmsystem.bi"
type MidiMessage field=1
Number as UByte
ParmA as UByte
ParmB as UByte
Reserved as UByte
end Type
#define MidiSendMessage(MSGVAR) midiOutShortMsg(MYPLAYDEVICE, *cptr(integer ptr,@MSGVAR))
'---------- global declarations ----------
Const maxCounter=&H100000 'read max 1 MB file size
Const maxEvents=999999
Const maxTracks=999
Const maskEventType = &Hf0 'hi nibble=event type, lo nibble=channel
Const evNoteOff = &H80 'note number velocity
Const evNoteOn = &H90 'note number velocity
Const evNoteAftertouch = &HA0 'note number aftertouch value
Const evController = &HB0 'controller number controller value
Const evProgramChange = &HC0 'program number not used
Const evChannelAftertouch = &HD0 'aftertouch value not used
Const evPitchBend = &HE0 'pitch value (LSB) pitch value (MSB)
Const maskChannel = &H0f 'hi nibble=event type, lo nibble=channel
Const cDrumtrack = 9 'DrumTrack is channel 9 of 0..15 (or 10 of 1..16)
Const stringSeparator = "|"
Const ht="-------------------------------------------------------------"
Type thdChunk
startAddr As Integer
chunkID As String
chunkSize As UInteger
formatType As Integer
numOfTracks As Integer
timeDivision As Integer
End Type
Type ttrChunk
startAddr As Integer
chunkID As String
chunkSize As UInteger
' 'track info / analyse
' 'string events of the same type will be concatenated, separated by const stringSeparator
' Copyright As String 'copyright information.
' stName As String 'Sequence/Track Name
' instrument As String 'Instrument Name
'
' seqNumber As Integer 'Sequence Number, pattern number of a Type 2 MIDI file
' 'or the number of a sequence in a Type 0
' 'or Type 1 MIDI file
' numEvents As Integer 'count number of all events
' noteEvents As Integer 'count number of note events
' useChannels As Integer 'bit0 = channel 0, bit15 = channel 15
' textEvents As Integer 'meta FF01, track notes, comments, etc., usually ASCII
' lyrics As Integer 'meta FF05, Karaoke, usually a syllable or group of works per quarter note.
End Type
Type ttrInfo
'track info / analyse
'string events of the same type will be concatenated, separated by const stringSeparator
Copyright As String 'copyright information.
stName As String 'Sequence/Track Name
instrument As String 'Instrument Name
lastTicks As Integer 'ticks counter of last event (~track length)
seqNumber As Integer 'Sequence Number, pattern number of a Type 2 MIDI file
'or the number of a sequence in a Type 0
'or Type 1 MIDI file
loNote As Integer 'lowest note of track (to scale graphics)
hiNote As Integer 'highest note of track (to scale graphics)
numEvents As Integer 'count number of all events
noteEvents As Integer 'count number of note events
useChannels As Integer 'bit0 = channel 0, bit15 = channel 15
textEvents As Integer 'meta FF01, track notes, comments, etc., usually ASCII
lyrics As Integer 'meta FF05, Karaoke, usually a syllable or group of works per quarter note.
marker As Integer 'Marker
cuePoint As Integer 'Cue Point
prefix As Integer 'MIDI Channel Prefix
port As Integer 'MIDI Port Select
endOT As Integer 'End Of Track
tempo As Integer 'Set Tempo
sOffset As Integer 'SMPTE Offset
timeSig As Integer 'Time Signature
keySig As Integer 'Key Signature
seqSpec As Integer 'Sequencer Specific
sysEx As Integer 'SysEx Event
unknown As Integer 'unkwown event
End Type
Enum ParameterType
noParameter ' 0: no Parameter
channel_Para1 ' 1: EvPara1
channel_Para1_Para2 ' 2: EvPara1, EvPara2
vString ' 3: variable String on heap, evPara1=Heap Pointer
' first byte is counter
vData ' 4: variable data on heap, evPara1=Heap Pointer
' first byte is counter
bit7FlagData ' 5: variable data on heap, evPara1=Heap Pointer
' last byte has bit7=1
vUndefined ' 6: event code is undefined, so paraType is also
End Enum
Type tEvent
evDTime As Integer 'time source (relative ticks / Quarternote)
evTicks As Integer 'sum of ticks from start (absolute)
evCode As Integer '0x80-0xFF / 0xFF00-0xFFFF
evAddr As Integer 'address of event in MIDI file (when load from file)
setTempo As Integer 'Microseconds/Quarter-Note or 0
pType As ParameterType 'see enum ParameterType
evPara1 As Integer '0x00-0x7F / Heap Pointer
evPara2 As Integer '0x00-0x7F / Data Index
pNext As tEvent Ptr 'chain pointer
pPrev As tEvent Ptr 'chain pointer
End Type
Type tSequence
pEvent As tEvent Ptr 'MIDI event
playTime As Double 'playtime in seconds
trackIdx As Integer 'track index number (0 = Track 1...)
pNext As tSequence Ptr 'chain pointer
End Type
'---------- set global tempo ----------
'Set Tempo to default value 120 beats per minute.
'The value is set in Microseconds/Quarter-Note.
'---- Sonic Spot: ----
'The following formula's can be used to translate
'the tempo from microseconds per quarter-note to
'beats per minute and back.
'
'MICROSECONDS_PER_MINUTE = 60000000
'BPM = MICROSECONDS_PER_MINUTE / MPQN
'MPQN = MICROSECONDS_PER_MINUTE / BPM
'
#macro setGlobalTempo()
globalTempo=60000000/120
#endmacro
'---------- Calculate MIDI song tempo ----------
'Global Definition (Header Chunk):
'globalDivision = n Ticks / qnote (for example 192)
'
'Tempo changes (MIDI event)
'Set Tempo = n µs/MIDI quarter-note (for example 500000)
'
'Count Ticks (dTime) of the MIDI events
'actual qNote position = actualTick / globalDivision
'actual time = actual qNote position * Tempo / 1E6
'---------- global variables ----------
Dim Shared As MidiMessage MidiMsg
Dim Shared As HMIDIOUT MYPLAYDEVICE '// MIDI device interface for sending MIDI output
Dim Shared As String infile, outfile
Dim Shared As UByte midiDat(maxCounter)
Dim Shared As Integer addressCounter, filesize, outf
Dim Shared As UInteger globalNumOfTracks
Dim Shared As Integer globalFormatType
Dim Shared As longint globalDivision
Dim Shared As longint globalTempo
Dim Shared As Double globalPlaytime
Const heapMax=999999
Dim Shared As Integer heap(heapMax)
Dim Shared As Integer heapPtr
Const textinfoMax=9999
Dim Shared As String textinfo(textinfoMax)
Dim Shared As Integer textinfoPtr
Dim Shared As tEvent Ptr track(maxTracks)
Dim Shared As ttrInfo tInf(maxTracks)
Dim Shared As tEvent Ptr playEvent(maxTracks) 'cursor to next event of this track
Dim Shared As Integer trackPtr=1
'Dim Shared As Integer trkSeqNumber(maxTracks)
Dim Shared As Integer transpose
'---------- Informations, used by playMidi() ----------
Dim Shared As String globalInfInfo
'Dim Shared As String globalInfLanguage
Dim Shared As String globalInfTitle
'---------- Lyrics string array ----------
Const maxLyrics=999
Dim Shared As String lyrics(maxLyrics)
Dim Shared As tSequence Ptr lyricsStartEvent(maxLyrics)
Dim Shared As Integer lyricsCount
'---------- load file into midiDat() array ----------
'
Sub loadFile(fName As String)
var filenum = FreeFile()
If Open(fName For Binary Access Read As #filenum )=0 Then
While Not EOF(filenum)
Get #filenum, , midiDat(filesize)
filesize += 1
If filesize>maxCounter Then
Print "File too long error."
End
EndIf
Wend
Close #filenum
EndIf
End Sub
'---------- string function - convert time into H:MM:SS ----------
Function hms(t As Double) As String
Dim As Integer th, tm, ts
Dim As String r
th=t
ts=th Mod 60
th=(th-ts)\60
tm=th Mod 60
th=(th-ts)\60
r=Str(th)+":"+Right("0"+Str(tm),2)+":"+Right("0"+Str(ts),2)
Return r
End Function
'---------- string function - intLeft ----------
Function intLeft(n As Integer, size As Integer) As String
Dim As String r
r=Str(n)
If Len(r) < size Then
r=Left(r+Space(size),size)
EndIf
Return r
End Function
'---------- print string to stdout or file ----------
Sub pr(s As String="")
If outfile="" Then
Print s
Else
Print #outf, s
EndIf
End Sub
'---------- get next byte ----------
Function nextByte As UInteger
Dim As UByte d
d=midiDat(addressCounter)
addressCounter+=1
Return d
End Function
''---------- get next 4 character string ----------
'' chunk ID
Function headerStr As String
Return Chr(nextByte) _
+ Chr(nextByte) _
+ Chr(nextByte) _
+ Chr(nextByte)
End Function
'---------- get next n byte v_time value ----------
' add lower 7 bits in a loop
' last byte ist marked with bit7=0
' maximum possible value is signed 16 bit
'
Function getTime As String
Dim As UInteger t, d
Dim As String s
d=nextByte
s=Hex(d,2)
t+=d And 127
While (d And 128) > 0
t=t Shl 7
d=nextByte
s+=" "+Hex(d,2)
t+=d And 127
Wend
Return s+" = "+Str(t)+" Ticks"
End Function
'---------- get next 4 byte number ----------
Function num4 As UInteger
Return (nextByte Shl 24) _
+ (nextByte Shl 16) _
+ (nextByte Shl 8) _
+ (nextByte)
End Function
'---------- get next 2 byte number ----------
Function num2 As UInteger
Return (nextByte Shl 8) _
+ (nextByte)
End Function
'---------- get next track chunk ----------
Function getTrackChunk As ttrChunk
Dim As ttrChunk trChunk
trChunk.startAddr =addressCounter
trChunk.chunkID =headerStr
trChunk.chunkSize =num4
addressCounter=trChunk.startAddr+trChunk.chunkSize+8
Return trChunk
End Function
'---------- get next header chunk ----------
' a header chunk is the first chunk in the MIDI file
' set global variables:
' UInteger chunkNumOfTracks
' Integer chunkDivision
Function getHeaderChunk As thdChunk
Dim As thdChunk hdChunk
hdChunk.startAddr =addressCounter
hdChunk.chunkID =headerStr
hdChunk.chunkSize =num4
hdChunk.formatType =num2
hdChunk.numOfTracks =num2
hdChunk.timeDivision =num2
Return hdChunk
End Function
'---------- sequencer ----------
'---------- get next variable size number (vtime) ----------
Function vNum As UInteger
Dim As UInteger n, d
d=nextByte
n+=(d And 127)
While (d And 128) = 128
n=n Shl 7
d=nextByte
n+=(d And 127)
Wend
Return n
End Function
Type tEventInfo
paraType As ParameterType 'see enum ParameterType
paraName As String 'Parameter Code Name
End Type
'---------- get infos about a MIDI event ----------
'
Function eventInfo(eventCode As Integer) As tEventInfo
Dim As tEventInfo r
'1 - define parameter type (pType)
Select Case eventCode
Case &H80 to &H8F: 'Note Off
'r.paraName="Note Off"
r.paraName="NoteOff"
r.paraType = channel_Para1_Para2
Case &H90 to &H9F: 'Note On
'r.paraName="Note On"
r.paraName="NoteOn"
r.paraType = channel_Para1_Para2
Case &HA0 to &HAF: 'Polyphonic Key Pressure (Aftertouch)
'r.paraName="Polyphonic Key Pressure (Aftertouch)"
r.paraName="PolyPress"
r.paraType = channel_Para1_Para2
Case &HB0 to &HBF: 'Controller / Channel Mode Messages
'r.paraName="Controller / Channel Mode Messages"
r.paraName="Controller"
r.paraType = channel_Para1_Para2
Case &HC0 to &HCF: 'Program Change
'r.paraName="Program Change"
r.paraName="ProgChange"
r.paraType = channel_Para1
Case &HD0 to &HDF: 'Channel Pressure (Aftertouch)
'r.paraName="Channel Pressure (Aftertouch)"
r.paraName="ChanPress"
r.paraType = channel_Para1
Case &HE0 to &HEF: 'Pitch Bend
'r.paraName="Pitch Bend"
r.paraName="PitchBend"
r.paraType = channel_Para1_Para2
'System Common Messages
Case &HF0: 'System Exclusive
'r.paraName="System Exclusive"
r.paraName="SysEx"
r.paraType = vData
Case &HF1: 'MIDI Time Code Quarter Frame (0nnndddd )
'r.paraName="MIDI Time Code Quarter Frame"
r.paraName="TCQF"
r.paraType = channel_Para1
Case &HF2: 'Song Position Pointer
'r.paraName="Song Position Pointer"
r.paraName="SongPosPt"
r.paraType = channel_Para1_Para2
Case &HF3: 'Song Select (0.127)
'r.paraName="Song Select"
r.paraName="SongSelect"
r.paraType = channel_Para1
Case &HF6: 'Tune Request
'r.paraName="Tune Request"
r.paraName="TuneReqest"
r.paraType = noParameter
Case &HF7: 'End of System Exclusive (EOX)
'r.paraName="End of System Exclusive (EOX)"
r.paraName="EOX"
r.paraType = noParameter
'System Real Time Messages - Don't expect in a MIDI file
Case &HF8: 'Timing Clock
'r.paraName="Timing Clock"
r.paraName="TimingClock"
r.paraType = noParameter
Case &HFA: 'Start
'r.paraName="Start"
r.paraName="Start"
r.paraType = noParameter
Case &HFB: 'Continue
'r.paraName="Continue"
r.paraName="Continue"
r.paraType = noParameter
Case &HFC: 'Stop
'r.paraName="Stop"
r.paraName="Stop"
r.paraType = noParameter
Case &HFE: 'Active Sensing
'r.paraName="Active Sensing"
r.paraName="ActiveSens"
r.paraType = noParameter
Case &HFF: 'System Reset
'r.paraName="System Reset"
r.paraName="SystemReset"
r.paraType = noParameter
'Meta Events
Case &HFF00: 'Sequence Number
'Sequence Number - pattern number of a Type 2 MIDI file
'or the number of a sequence in a Type 0 or Type 1 MIDI file
'r.paraName="Sequence Number"
r.paraName="SeqNumber"
r.paraType = channel_Para1_Para2
Case &HFF01: 'Text Event
'r.paraName="Text Event"
r.paraName="Text"
r.paraType = vString
Case &HFF02: 'Copyright Notice
'r.paraName="Copyright Notice"
r.paraName="Copyright"
r.paraType = vString
Case &HFF03: 'Sequence/Track Name
'r.paraName="Sequence/Track Name"
r.paraName="Trackname"
r.paraType = vString
Case &HFF04: 'Instrument Name
'r.paraName="Instrument Name"
r.paraName="Instrument"
r.paraType = vString
Case &HFF05: 'Lyrics
'r.paraName="Lyrics"
r.paraName="Lyrics"
r.paraType = vString
Case &HFF06: 'Marker
'r.paraName="Marker"
r.paraName="Marker"
r.paraType = vString
Case &HFF07: 'Cue Point
'r.paraName="Cue Point"
r.paraName="CuePoint"
r.paraType = vString
Case &HFF20: 'MIDI Channel Prefix - associate channel with next meta events
'r.paraName="MIDI Channel Prefix (obsolete)"
r.paraName="ChannelPrefix"
r.paraType = vData
Case &HFF21: 'MIDI Port
'r.paraName="MIDI Port (obsolete)"
r.paraName="MIDIPort"
r.paraType = vData
Case &HFF2F: 'End Of Track
'r.paraName="End Of Track"
r.paraName="EndOfTrack"
r.paraType = vData
Case &HFF51: 'Set Tempo
'r.paraName="Set Tempo"
r.paraName="SetTempo"
r.paraType = vData
Case &HFF54: '
'r.paraName="SMPTE Offset"
r.paraName="SMPTEOffset"
r.paraType = vData
Case &HFF58: '
'r.paraName="Time Signature"
r.paraName="TimeSignature"
r.paraType = vData
Case &HFF59: '
'r.paraName="Key Signature"
r.paraName="KeySignature"
r.paraType = vData
Case &HFF7F: '
'r.paraName="Sequencer Specific"
r.paraName="Sequencer"
r.paraType = vData
Case Else: '
'r.paraName="Undefined"
r.paraName="Undefined"
r.paraType = vUndefined
End Select
Return r
End Function
'---------- load event data ----------
'
Sub loadEventData(event As tEvent Ptr)
Dim As UByte b
Dim As Integer d
'1 - define parameter type (pType)
event->pType = eventInfo(event->evCode).paraType
'2 - load parameters
Select Case event->pType
Case noParameter:
'no Parameter
'- nothing to do
Case channel_Para1:
'EvPara1
event->evPara1=nextByte
Case channel_Para1_Para2:
'EvPara1, EvPara2
event->evPara1=nextByte
event->evPara2=nextByte
Case vString:
'variable String on heap, evPara1=Heap Pointer
'first byte is counter
d=nextByte
event->evPara2=textinfoPtr
For i As Integer=1 To d
textinfo(textinfoPtr)+=Chr(nextByte)
Next i
textinfoPtr+=1
Case vData:
'variable data on heap, evPara1=Heap Pointer
'first byte is counter
d=nextByte
event->evPara2=heapPtr
heap(heapPtr)=d 'size counter byte
heapPtr+=1
For i As Integer=1 To d
heap(heapPtr)=nextByte
heapPtr+=1
Next i
'if event is "Set Tempo" then store tempo change
If event->evCode = &HFF51 Then
event->setTempo=(heap(heapPtr-3)Shl 16)_
+(heap(heapPtr-2)Shl 8)+heap(heapPtr-1)
EndIf
Case bit7FlagData:
'variable data on heap, evPara1=Heap Pointer
'last byte has bit7=1
event->evPara2=heapPtr
Do
b=nextByte
heap(heapPtr)=b
heapPtr+=1
Loop Until ((b And 128) = 128)
End Select
End Sub
'---------- get event parameter as string ----------
'
Function getEvPara(event As tEvent Ptr) As String
Dim As UByte b
Dim As Integer d
Dim As String s
Select Case event->pType
Case noParameter:
'no Parameter
'- nothing to do
s="--"
Case channel_Para1:
'EvPara1
s=Hex(event->evCode,1)+" "+Hex(event->evPara1,2)
Case channel_Para1_Para2:
'EvPara1, EvPara2
s=Hex(event->evCode,1)+" "+Hex(event->evPara1,2)+" "+Hex(event->evPara2,2)
Case vString:
'variable String on heap, evPara1=Heap Pointer
'first byte is counter
s=Chr(34)+textinfo(event->evPara2)+Chr(34)
Case vData:
'variable data on heap, evPara1=Heap Pointer
'first byte is counter
d=event->evPara2
s="["+Hex(heap(d))+"]"
For i As Integer=1 To heap(d)
s+=" "+Hex(heap(event->evPara2+i),2)
Next i
Case bit7FlagData:
'variable data on heap, evPara1=Heap Pointer
'last byte has bit7=1
d=event->evPara2
Do
b=heap(d)
d+=1
s+=Hex(b,2)+" "
Loop Until ((b And 128) = 128)
End Select
Return s
End Function
'---------- get event string-parameter without string delimiters "" ----------
'
Function getEvString(event As tEvent Ptr) As String
Dim As UByte b
Dim As Integer d
Dim As String s
s=""
Select Case event->pType
Case vString:
'variable String on heap, evPara1=Heap Pointer
'first byte is counter
s=textinfo(event->evPara2)
End Select
Return s
End Function
'---------- MIDI event is playable (note on, off...) ----------
'
Function isPlayable(eventCode As Integer) As Integer
Dim r As Integer = 0
'1 - define parameter type (pType)
Select Case eventCode
Case &H80 to &HEF:
r=-1
End Select
Return r
End Function
'---------- load all events in a chunk ----------
'
Sub loadTrackEvents(trkNum As Integer, trk As tEvent Ptr, startPos As Integer, endPos As Integer)
Dim As tEvent Ptr actEvent
Dim As tEvent Ptr newEvent
Dim As UInteger eventDTime
Dim As UInteger eventCode, runningStatus
Dim As Integer eventAddress
Dim As String s
addressCounter=startPos
actEvent=trk
While addressCounter<endPos
eventDTime=vNum
eventAddress=addressCounter
eventCode=nextByte
If eventCode=&HFF Then eventCode=&HFF00 Or nextByte
'Running Status is a data-thinning technique.
'It allows for the omision of status bytes if the current
'message to be transmitted has the same status byte
'(ie the same command and MIDI channel) as the previous
'message. It thus only applies to Channel (Voice and Mode)
'messages (0x8n - 0xEn).
'allow "runnung status" repeat codes
If (eventCode And &HFF80)=0 Then
addressCounter-=1
If runningStatus<>0 Then
eventCode=runningStatus 'save the running status
Else
pr
pr("ERROR: Running Status is zero at @"+Hex(addressCounter))
pr
EndIf
EndIf
newEvent=new tEvent '()
newEvent->pNext=0
newEvent->pPrev=actEvent
actEvent->pNext=newEvent
actEvent=newEvent
newEvent->evDTime=eventDTime
newEvent->evCode=eventCode
newEvent->evAddr=eventAddress
loadEventData(newEvent)
'track info / analyse
If isPlayable(eventCode) Then
runningStatus=eventCode 'save the running status
tInf(trackPtr).noteEvents += 1 'count number of note events
var ch=1 Shl(eventCode And maskChannel) 'bit0 = channel 0, bit15 = channel 15
tInf(trackPtr).useChannels = tInf(trackPtr).useChannels Or ch
If (eventCode And maskEventType) = evNoteOn Then
'store first note as lowest and highest note
If tInf(trackPtr).hiNote<0 Then
tInf(trackPtr).loNote=newEvent->evPara1
tInf(trackPtr).hiNote=newEvent->evPara1
Else
If newEvent->evPara1 < tInf(trackPtr).loNote Then
tInf(trackPtr).loNote=newEvent->evPara1
ElseIf newEvent->evPara1 > tInf(trackPtr).hiNote Then
tInf(trackPtr).hiNote=newEvent->evPara1
EndIf
EndIf
EndIf
Else
Select Case eventCode
Case &H00F0: 'SysEx Event
tInf(trackPtr).sysEx+=1 'count events
runningStatus=0 'clear the running status
Case &H00F0 To &H00F7: 'System Common and System Exclusive messages
runningStatus=0 'clear the running status
Case &HFF00: 'Sequence Number
tInf(trackPtr).seqNumber=newEvent->evPara1 Shl 8 + newEvent->evPara2
Case &HFF01: 'Text Event: track notes, comments...
tInf(trackPtr).textEvents+=1 'count events
Case &HFF02: 'Copyright Notice
If tInf(trackPtr).Copyright<>"" Then tInf(trackPtr).Copyright += stringSeparator
tInf(trackPtr).Copyright+=textinfo(newEvent->evPara2)
Case &HFF03: 'Sequence/Track Name
If tInf(trackPtr).stName<>"" Then tInf(trackPtr).stName += stringSeparator
tInf(trackPtr).stName+=textinfo(newEvent->evPara2)
Case &HFF04: 'Instrument Name
If tInf(trackPtr).instrument<>"" Then tInf(trackPtr).instrument += stringSeparator
tInf(trackPtr).instrument+=textinfo(newEvent->evPara2)
Case &HFF05: 'Karaoke, usually a syllable or group of works per quarter note.
tInf(trackPtr).lyrics+=1 'count events
Case &HFF06: 'Marker
tInf(trackPtr).marker+=1 'count events
Case &HFF07: 'Cue Point
tInf(trackPtr).cuePoint+=1 'count events
Case &HFF20: 'MIDI Channel Prefix
tInf(trackPtr).prefix+=1 'count events
Case &HFF21: 'MIDI Port
tInf(trackPtr).port+=1 'count events
Case &HFF2F: 'End Of Track
tInf(trackPtr).endOT+=1 'count events
Case &HFF51: 'Set Tempo
tInf(trackPtr).tempo+=1 'count events
Case &HFF54: 'SMPTE Offset
tInf(trackPtr).sOffset+=1 'count events
Case &HFF58: 'Time Signature
tInf(trackPtr).timeSig+=1 'count events
Case &HFF59: 'Key Signature
tInf(trackPtr).keySig+=1 'count events
Case &HFF7F: 'Sequencer Specific
tInf(trackPtr).seqSpec+=1 'count events
Case Else:
tInf(trackPtr).unknown+=1 'count events
PR(" Unknown Event Code:"+Hex(eventCode,6)_
+" @ "+Hex(eventAddress,6)_
+" Track="+Str(trackPtr+1))
End Select
EndIf
tInf(trackPtr).numEvents += 1 'count number of all events
Wend
End Sub
'---------- track chunk ----------
Sub loadTrackChunk(trk As Integer)
Dim As tEvent Ptr newEvent
Dim As ttrChunk trChunk
trChunk=getTrackChunk
If (trChunk.chunkID <> "MTrk") Then
pr("ERROR - invalid Track Chunk "+Str(trk)+":"+trChunk.chunkID)
'End
EndIf
newEvent=new tEvent
track(trackPtr)=newEvent
' trackPtr+=1
If trackPtr>maxTracks Then
Print "Error: Too much tracks"
Sleep
End
EndIf
newEvent->pPrev=0
newEvent->pNext=0
newEvent->evCode=-1 'track start
loadTrackEvents(trk, newEvent, trChunk.startAddr+8, trChunk.startAddr+trChunk.chunkSize+7)
trackPtr+=1
End Sub
'---------- header chunk ----------
Sub loadHeaderChunk
Dim As thdChunk hdChunk
hdChunk=getHeaderChunk
globalFormatType=hdChunk.formatType
globalNumOfTracks=hdChunk.numOfTracks
globalDivision=hdChunk.timeDivision
If (globalDivision And &H8000) <> 0 Then
pr
pr("time division="+Str(globalDivision And &H7FFF)+" frames per second")
pr("ERROR - Format not supported")
EndIf
If (hdChunk.chunkID <> "MThd") OrElse (hdChunk.formatType>2) Then
pr
pr("ERROR - invalid Header Chunk")
'End
EndIf
End Sub
'---------- read file from midiDat() array into sequencer ----------
'
Sub loadMidi
Dim As Integer cursor=0
Dim As tEvent Ptr thisEvent
Dim As String s
pr
pr(ht)
pr
pr("loadMIDI")
addressCounter=0
loadHeaderChunk
pr
pr("MIDI Header Chunk:")
pr("MIDI Format Type = "+Str(globalFormatType))
pr("Number Of Tracks = "+Str(globalNumOfTracks))
pr("Time Division = "+Str(globalDivision)+" Ticks per Beat")
pr
For t As Integer=1 To globalNumOfTracks
loadTrackChunk(t)
Next t
End Sub
'---------- retime midi tracks ----------
'
'calculate absolute tick counter for every event
'from the relative counter dTime
'Call this Sub
' - after song loading and
' - after track-editing
'
Sub retimeTrack
Dim As Integer ticksCounter
Dim As tEvent Ptr thisEvent
Dim As String s
pr
pr(ht)
pr
pr("retimeTrack")
pr
For t As Integer=1 To trackPtr-1
ticksCounter=0
thisEvent=track(t)
While thisEvent<>0
ticksCounter+=thisEvent->evDTime
thisEvent->evTicks=ticksCounter
thisEvent = thisEvent->pNext
Wend
'store track lenght (ticksCounter of last event)
tInf(t).lastTicks=ticksCounter
Next t
End Sub
'---------- print file from midiDat() array from sequencer ----------
'
Dim Shared As Integer globalKaraokeWordsTrack
Dim Shared As Integer globalKaraokeTypeTrack
Dim Shared As Integer globalKaraokeType
Dim Shared As Integer globalLyricsTrack
Dim Shared As Integer globalTextIsLyrics
Sub analyseKaraoke
Dim As tEvent Ptr thisEvent
Dim As String s
pr
pr(ht)
pr
pr("analyseKaraoke")
For t As Integer=1 To trackPtr-1
'Fint "Words" Track
if (tInf(t).stName = "Words") Then globalKaraokeWordsTrack=t
'Fint Track with most lyrics events
If tInf(t).lyrics>0 Then
If globalLyricsTrack=0 Then
globalLyricsTrack=t
globalTextIsLyrics=(1=1)
Else
If tInf(globalLyricsTrack).lyrics < tInf(t).lyrics Then
globalLyricsTrack=t
EndIf
EndIf
EndIf
'Karaoke Format 1: Soft karaoke / WinKaraoke Creator
If (LCase(tInf(t).stName) = "soft karaoke") Then
globalKaraokeTypeTrack=t
globalKaraokeType=1
EndIf
'Karaoke Format 2: KarMaker
If (LCase(Left(tInf(t).stName,12)) = "(c) karmaker") Then
globalKaraokeTypeTrack=t
globalKaraokeType=2
EndIf
Next t
pr
pr("KaraokeTypeTrack "+Str(globalKaraokeTypeTrack))
pr("KaraokeTypeTrName "+tInf(globalKaraokeTypeTrack).stName)
pr("globalKaraokeType "+Str(globalKaraokeType))
pr("KaraokeWordsTrack "+Str(globalKaraokeWordsTrack))
pr("LyricsTrack "+Str(globalLyricsTrack))
pr("TextIsLyrics "+Str(globalTextIsLyrics))
pr("Lyrics # "+Str(tInf(globalLyricsTrack).lyrics))
pr
pr
End Sub
'---------- print file from midiDat() array from sequencer ----------
'
Sub showMidi(showMidiFormat As Integer)
Dim As tEvent Ptr thisEvent
Dim As String s
pr
pr(ht)
pr
pr("showMIDI")
For t As Integer=1 To trackPtr-1
pr
pr("Track "+Str(t))
thisEvent=track(t)
pr(" Track Address Ticks quartNote EventCode Parameters")
pr(ht)
While thisEvent->pNext<>0
thisEvent = thisEvent->pNext
s=getEvPara(thisEvent)
If showMidiFormat=1 Then
pr(" "+intLeft(thisEvent->evTicks,6)_
+" "+eventInfo(thisEvent->evCode).paraName+" "+s)
ElseIf showMidiFormat=2 Then
pr(" Tr:"+intLeft(t,2)_
+" @:"+Hex(thisEvent->evAddr,6)_
+" Tk:"+intLeft(thisEvent->evTicks,7)_
+" qN:"+intLeft(Int(10*thisEvent->evTicks/globalDivision)/10,6)_
+" Code:"+Hex(thisEvent->evCode,4)_
+" Para:"+s _
+" ("+eventInfo(thisEvent->evCode).paraName+")")
EndIf
Wend
Next t
pr
End Sub
'---------- detect end of track by event code or zero pointer ----------
'
Function isEndOfTrack(ev As tEvent Ptr) As Integer
If (ev=0) OrElse (ev->evCode=&hFF2F) Then
Return -1
Else
Return 0
EndIf
End Function
'---------- build sequence "seq" ----------
'
Dim Shared As tSequence Ptr seq
Sub buildSequence
Dim As Integer nextEvent
Dim As tEvent Ptr thisEvent
Dim As tSequence Ptr nextSeq
Dim As Double playTime
Dim As Double lastTime
Dim As Integer lastTicks
pr
pr(ht)
pr
pr("buildSequence")
pr
While seq<>0
var cleanup=seq
seq=seq->pnext
DELETE cleanup
pr(".")
Wend
seq=new tSequence
nextSeq=seq
'set playCursors to track start (get first event with pNext)
For t As Integer=1 To trackPtr-1
playEvent(t)=track(t)->pNext '->pNext, because first element is dummy
Next t
playTime=0
lastTime=0
lastTicks=0
Do
'search all tracks for next to play event (time)
For t As Integer=1 To trackPtr-1
'1) set nextEvent to a valid track
If isEndOfTrack(playEvent(nextEvent))_
AndAlso Not(isEndOfTrack(playEvent(t))) Then
nextEvent=t
EndIf
'2) set what track has the next event in time
' but ignore "end of track" event
If (playEvent(t)<>0)_
AndAlso (playEvent(t)->evCode <>&HFF2F) _
AndAlso (playEvent(t)->evTicks <= playEvent(nextEvent)->evTicks) Then
nextEvent=t
EndIf
Next t
'store next event in sequence
nextSeq->trackIdx = nextEvent
nextSeq->pEvent = playEvent(nextEvent)
nextSeq->pnext = new tSequence
'calculate playtime of actual MIDI event
playTime=lastTime+(nextSeq->pEvent->evTicks-lastTicks)*globalTempo _
/globalDivision /1e6
nextSeq->playTime = playTime
If playTime>globalPlaytime Then globalPlaytime=playTime
'if tempo changes -> set new tempo
If nextSeq->pEvent->setTempo>0 Then
'MICROSECONDS_PER_MINUTE = 60000000
'BPM = MICROSECONDS_PER_MINUTE / MPQN
'MPQN = MICROSECONDS_PER_MINUTE / BPM
globalTempo=nextSeq->pEvent->setTempo
lastTicks=nextSeq->pEvent->evTicks
lastTime=playTime
EndIf
var qNote=nextSeq->pEvent->evTicks / globalDivision
pr(" T"+Left(Str(nextSeq->trackIdx+1)+" ",2)_
+" "+hms(nextSeq->playTime)_
+" qNote:"+Left(Str(Int(10*qNote)/10)+Space(6),6)_
+" Tks:"+Left(Str(nextSeq->pEvent->evTicks)+Space(8),8)_
+" Code:"+Hex(nextSeq->pEvent->evCode,4)_
+" PType:"+Hex(nextSeq->pEvent->pType,1)_
+" Param:"+getEvPara(nextSeq->pEvent))
nextSeq = nextSeq->pnext
If playEvent(nextEvent)<>0 Then playEvent(nextEvent)=playEvent(nextEvent)->pNext
Loop Until playEvent(nextEvent)=0
pr
pr("sequence complete.")
pr
End Sub
'---------- send "All Notes Off" to all channels ----------
'
Sub AllNotesOff
'MidiMsg.Number = evController
MidiMsg.ParmA = 123 'All Notes Off
MidiMsg.ParmB = 0 'All Notes Off
For i As Integer=0 To 15
MidiMsg.Number = evController Or i
MidiSendMessage(MidiMsg)
Next i
End Sub
'---------- get next line of lyrics from "seq" ----------
'
Function getLyricsElement(nextSeq As tSequence Ptr, setGlob As Integer) As String
Dim As String txt
If (nextSeq <> 0)_
AndAlso (nextSeq->pEvent <> 0) Then
If globalTextIsLyrics Then
If (nextSeq->pEvent->evCode=&HFF05) Then
txt=getEvString(nextSeq->pEvent)
If txt<" " Then txt="/"
EndIf
Else
If (nextSeq->pEvent->evCode=&HFF01) Then
txt=getEvString(nextSeq->pEvent)
var infoType=Left(txt,2)
var infoTxt=Right(txt,Len(txt)-2)
Select Case infoType
Case "@I": 'Information
txt=""
If setGlob Then globalInfInfo+=Chr(13,10)+" "+infoTxt
Case "@T": 'Title
txt=""
If setGlob Then globalInfTitle+=Chr(13,10)+" "+infoTxt
Case "@K": 'ignore (Karaoke Type Info)
txt=""
Case "@L": 'ignore (Karaoke Lyrics Language)
txt=""
Case "@V": 'ignore (Karaoke File Version)
txt=""
End Select
EndIf
EndIf
EndIf
'Handle KarMaker vocal strings
'(they might include 0x00 and some additional codes)
If InStr(txt,Chr(0)) Then
txt=Left(txt,InStr(txt,Chr(0))-1)
EndIf
Return txt
End Function
'---------- read Lyrics into string array ----------
' read lyrics from sequence "seq"
Sub readLyrics
Dim As tSequence Ptr nextSeq
nextSeq=seq
Do
'wait until next event has to be played
If nextSeq<>0 _
AndAlso (nextSeq->pEvent<>0) Then
var txt=getLyricsElement(nextSeq, 1)
Select Case Left(txt,1)
Case "/","\":
lyricsCount += 1
lyricsStartEvent(lyricsCount) = nextSeq
txt=Right(txt,Len(txt)-1)
End Select
'print lyrics
If txt<>"" Then
lyrics(lyricsCount) += txt
EndIf
nextSeq=nextSeq->pNext
EndIf
If lyricsCount>=maxLyrics Then
Print "Error: too much lyrics lines"
End
EndIf
Loop Until (nextSeq=0) OrElse (nextSeq->pEvent=0)
pr
pr("readLyrics:")
For i As Integer=1 To lyricsCount
pr(intleft(i,3)+": "+lyrics(i))
Next i
pr
Print "Read "+Str(lyricsCount)+" lines of lyrics."
If globalInfTitle="" Then globalInfTitle="- not defined -"
If globalInfInfo="" Then globalInfInfo="- not defined -"
End Sub
'---------- play MIDI file (with karaoke text) from "seq" ----------
'
Sub printLyricsLine(nextSeq As tSequence Ptr, yLine As integer)
Dim c As UInteger
'Normal Intense Value, Name
'0 black 8 dark grey
'1 blue 9 bright blue
'2 green 10 bright green
'3 cyan 11 bright cyan
'4 red 12 bright red
'5 pink 13 bright pink
'6 yellow 14 bright yellow
'7 grey 15 white
'print next line of lyrics
For i As Integer=1 To lyricsCount
If lyricsStartEvent(i)=nextSeq Then
c=Color()
Color 15,HiWord(c)
Locate yLine-2,1
Print lyrics(i);
Color 8,HiWord(c)
Locate yLine-1,1
Print lyrics(i+1);
Color c
Exit For
EndIf
Next i
End Sub
'---------- play MIDI file (with karaoke text) from "seq" ----------
'
Dim Shared As Integer cursX, cursY
Sub playMidiEvent(nextSeq As tSequence Ptr)
'play next MIDI event
'if tempo changes -> set new tempo
If nextSeq->pEvent->setTempo>0 Then
globalTempo=nextSeq->pEvent->setTempo
EndIf
'show player interface
var txt=getLyricsElement(nextSeq,0)
Select Case Left(txt,1)
Case "/":
cursX=1
cursY+=1
txt=Right(txt,Len(txt)-1)
Case "\":
cursX=1
cursY+=1 '2
txt=Right(txt,Len(txt)-1)
End Select
'scroll screen?
while cursY>=HiWord(Width)
Locate HiWord(Width),cursX
'write over playtime counter
Print " "
cursY-=1
Wend
printLyricsLine(nextSeq, cursY)
'print lyrics
If txt<>"" Then
Locate cursY-2,cursX
Print txt;
cursX+=Len(txt)
EndIf
'play note
If isPlayable(nextSeq->pEvent->evCode) Then
MidiMsg.Number = nextSeq->pEvent->evCode
MidiMsg.ParmA = nextSeq->pEvent->evPara1
MidiMsg.ParmB = nextSeq->pEvent->evPara2
'transpose note, but leave drums untouched
If (MidiMsg.Number And maskChannel) = cDrumtrack Then
'drums
MidiSendMessage(MidiMsg)
Else
'transpose other instruments
MidiMsg.ParmA+=transpose
'play if notes are in a valid range
If (MidiMsg.ParmA>=0) AndAlso (MidiMsg.ParmA<=127) Then
'play NoteOn
MidiSendMessage(MidiMsg)
EndIf
EndIf
EndIf
End Sub
'---------- play MIDI file (with karaoke text) from "seq" ----------
'
Sub playMidi(optionShowEventlist As Integer)
Dim As tSequence Ptr nextSeq
Dim As Integer nextEvent
Dim As Integer t, t0
Dim As tEvent Ptr thisEvent
Dim As Double startTime
Dim As Double lastTime
Dim As String k
Locate 1,1
Print "(+/-)Transpose (0)Quit "
nextSeq=seq
startTime=Timer
lastTime=startTime
cursX=1
cursY=HiWord(Width)-4
var quit=0
printLyricsLine(lyricsStartEvent(1), cursY+1)
Do
'wait until next event has to be played
If nextSeq<>0 _
AndAlso (nextSeq->pEvent<>0) Then
'while nothing to play, do user interface and save energy (sleep 1)
While nextSeq->playTime > (Timer-lastTime)
Sleep 1
If optionShowEventlist=0 Then
t=Timer-startTime
k=InKey
Select Case LCase(k)
Case "+":
AllNotesOff
If transpose<9 Then transpose+=1
Case "-":
AllNotesOff
If transpose>-9 Then transpose-=1
Case "0":
AllNotesOff
quit=-1
End Select
'bottom of screen
'print playtime
If t<>t0 Then 'seconds have changed
Locate HiWord(Width),2
Print hms(t)+" / "+hms(globalPlayTime);
If transpose Then
Print " T:"+Str(transpose)+" ";
Else
Print " ";
EndIf
t0=t
EndIf
EndIf
Wend
'play next MIDI event
playMidiEvent(nextSeq)
nextSeq=nextSeq->pNext
EndIf
Loop Until (nextSeq=0) OrElse (nextSeq->pEvent=0) OrElse quit
Print Chr(13,10)+"-- end --"
Print Chr(13,10)+"Title: "+globalInfTitle
Print Chr(13,10)+"Info: "+globalInfInfo
Sleep 2000
Print
End Sub
'---------- print file from midiDat() array from sequencer ----------
'
Function showTrackInfo(t As Integer) As String
Dim As String s
s=Chr(13,10)+"Track "+intLeft(t,2)
If tInf(t).seqNumber Then s+=" Sequence Number:"+intLeft(tInf(t).seqNumber,2)
If tInf(t).lastTicks Then
s+=Chr(13,10)
s+=" Ticks Counter: "+intLeft(tInf(t).lastTicks,5)
s+=Chr(13,10)
s+=" Quarter Notes: "+intLeft(tInf(t).lastTicks\globalDivision,5)
EndIf
If tInf(t).numEvents Then
s+=Chr(13,10)
s+=" Num of Events: "+intLeft(tInf(t).numEvents,4)
If (tInf(t).loNote + tInf(t).hiNote) > 0 Then
s+=Chr(13,10)+" - Lowest Note: "+intLeft(tInf(t).loNote,4)
s+=Chr(13,10)+" - Highest Note: "+intLeft(tInf(t).hiNote,4)
EndIf
s+=Chr(13,10)+" - Note Events: "+intLeft(tInf(t).noteEvents,4)
s+=Chr(13,10)+" - Text Events: "+intLeft(tInf(t).textEvents,3)
s+=Chr(13,10)+" - Lyrics: "+intLeft(tInf(t).lyrics,3)
s+=Chr(13,10)+" - Marker: "+intLeft(tInf(t).marker,3)
s+=Chr(13,10)+" - Cue Point: "+intLeft(tInf(t).cuePoint,3)
s+=Chr(13,10)+" - OBSOLETE MIDI Chan Prefix: "+intLeft(tInf(t).prefix,3)
s+=Chr(13,10)+" - OBSOLETE MIDI Port: "+intLeft(tInf(t).port,3)
s+=Chr(13,10)+" - End Of Track: "+intLeft(tInf(t).endOT,3)
s+=Chr(13,10)+" - Set Tempo: "+intLeft(tInf(t).tempo,3)
s+=Chr(13,10)+" - SMPTE Offset: "+intLeft(tInf(t).sOffset,3)
s+=Chr(13,10)+" - Time Signature: "+intLeft(tInf(t).timeSig,3)
s+=Chr(13,10)+" - Key Signature: "+intLeft(tInf(t).keySig,3)
s+=Chr(13,10)+" - Seqencer Specific: "+intLeft(tInf(t).seqSpec,3)
s+=Chr(13,10)+" - SysEx Events: "+intLeft(tInf(t).sysEx,3)
s+=Chr(13,10)+" - Unknown Events: "+intLeft(tInf(t).unknown,3)
EndIf
If tInf(t).copyright<>"" Then s+=Chr(13,10)+" Copyright....: "+tInf(t).copyright
If tInf(t).stName<>"" Then s+=Chr(13,10)+" Track Name...: "+tInf(t).stName
If tInf(t).instrument<>"" Then s+=Chr(13,10)+" Instrument...: "+tInf(t).instrument
If tInf(t).useChannels Then s+=Chr(13,10)+" Used Channels: "+Bin(tInf(t).useChannels,16)
Return s
End Function
'---------- read midi-file names into filenamelist()-array ----------
'
#include "dir.bi" 'provides constants to use for the attrib_mask parameter
Const maxFiles=999
Dim Shared As String filenamelist(maxFiles)
Dim Shared As Integer numFiles=0
Sub readFilenames(ByRef filespec As String, ByVal attrib As Integer)
Dim As String filename = Dir(filespec, attrib) ' Start a file search with the specified filespec/attrib *AND* get the first filename.
Do While Len(filename) > 0 ' If len(filename) is 0, exit the loop: no more filenames are left to be read.
filenamelist(numFiles)=filename
numFiles+=1
filename = Dir()
Loop
End Sub
'---------- delete infos from last song ----------
'
Sub deleteOldSong()
addressCounter=0
heapPtr=0
trackPtr=1
transpose=0
filesize=0
For i As Integer=0 To textinfoPtr
textinfo(i)=""
next i
textinfoPtr=0
For i As Integer=0 To lyricsCount
lyrics(i)=""
next i
lyricsCount=0
globalInfInfo=""
globalInfTitle=""
' outf=0
' globalNumOfTracks=0
' globalFormatType=0
' globalDivision=0
' globalTempo=0
' globalPlaytime=0
End Sub
'---------- select a song name from filenamelist()-array ----------
'
Dim Shared As Integer pg
Function selectSong() As String
Dim As String k
Dim As Integer maxPg=((numFiles-1)\9), mxSong
deleteOldSong()
If (numFiles>0) Then
Do
Cls
Print
Print "Karaoke Midi Player by oog/proog.de"
Print Version
Print "Choose a song (0 = Exit, +/- = Navigate):"
Print
Print
mxSong=(pg+1)*9
If mxSong>numFiles Then mxSong=numFiles
Print "Page: "+Str(pg+1)+"/"+Str(maxPg+1)+" - Songs:"+Str(pg*9+1)+"-"+Str(mxSong)+" of "+Str(numFiles)
Print
For i As Integer=0 To 8
If(i+pg*9)<numFiles Then
Print ""+Str(1+i)+" - "+filenamelist(i+pg*9)
If (i Mod 3)=2 Then Print
EndIf
Next i
Sleep
k=InKey
If (k>="1") AndAlso (k<="9") Then Return filenamelist((pg*9)+Asc(k)-Asc("1"))
If (k="0") Then Return ""
If (k="+") Then pg+=1
If (k="-") Then pg-=1
If pg>maxPg Then pg=maxPg
If pg<0 Then pg=0
Loop
Else
PR("")
PR("Error, no MIDI-Files/Songs found in ./songs/")
Sleep
end
EndIf
End Function
'---------- Init ----------
' MIDI init
MidiMsg.Reserved = 0
var FLAG = midiOutOpen(@MYPLAYDEVICE, MIDI_MAPPER, 0, 0, null)
if (FLAG <> MMSYSERR_NOERROR) Then
print "Error opening MIDI Output."
end If
For t As Integer=0 To maxTracks
tInf(t).loNote=-1
tInf(t).hiNote=-1
Next t
outfile="~out.txt"
Dim As Integer optionPlaySong=1
Dim As Integer optionShowEventlist=0
Dim As Integer optionShowMidiTracks=2
readFilenames("./songs/*.mid", fbArchive)
'---------- MAIN ----------
Do
transpose = 0
infile=selectSong()
If infile<>"" Then
Cls
Print
Print
Print "Song: "+infile
loadFile("./songs/"+infile)
outf = FreeFile()
Open outfile For Output As #outf
pr("Midi Karaoke Player")
pr(" File: "+infile)
pr(" Size: "+Str(filesize)+" Bytes.")
setGlobalTempo()
loadMidi
If trackPtr>1 Then
retimeTrack
analyseKaraoke
If optionShowMidiTracks Then
showMidi(optionShowMidiTracks)
EndIf
'show track info
For t As Integer=1 To trackPtr-1
pr(showTrackInfo(t))
Next t
buildSequence
readLyrics
If optionPlaySong=1 Then playMidi(optionShowEventlist)
EndIf
Close #outf
EndIf
Loop Until infile=""
End
Have fun.