Code: Select all
Const SW = 800
Const SH = 600
SCREEN SW, SH
Type NOTES
Field note As Byte // mikä nuotti (0-127)
Field velocity As Byte // voimakkuus
Field start As Integer // aloitus
Field length As Integer // pituus
Field channel As Byte // midi kanava (0-15)
Field track As Byte // monesko raita
Field trackPtr As Integer // osoitin TRACKS kokoelmaan
Field lyrics As String // nuottiin liitetyt sanat
End Type
Type TRACKS
Field id As Byte
Field name As String
Field instrument As String
Field minNote As Byte
Field maxNote As Byte
End Type
Type TEMPOEVENT
Field ms As Integer // eventin aika millisekunteina
Field tics As Integer // eventin aika
Field fact As Float // funktion sisäiseen käyttöön
Field bpm As Integer // tempo yleisimmässä muodossa (beats per minute)
Field nextEventPtr As Integer // seuraavan tempo eventin osoitin (0, jos viimeinen)
Field nextEventMs As Integer // seuraavan tempo eventin aloitusaika
End Type
Function getTrackPtr(id)
For nT.TRACKS = Each TRACKS
If nT\id = id Then Return ConvertToInteger(nT)
Next nT
Return 0
End Function
Dim file As String, sound As String
file = "C:\WINDOWS\media\town.mid"
If Len(file)=0 Then
StartSearch
count=0
Repeat
file2$=FindFile()
If file2$="" Then Exit
If Lower(Right(file2$,4))=".m"+"id" Then
count+1
file=file2
If Rand(1024)>512 Then Exit
EndIf
Forever
EndSearch
If count = 0 Then
Print "No midi files found in this directory (where exe is located)"
WaitKey
End
EndIf
EndIf
sound = Left(file,Len(file)-4)+".mp3"
If Not FileExists(sound) Then sound = file
Text 0,0,"reading midi. please wait."
DrawScreen
midi=ReadMIDI(file)
Cls
curTrack = 0
nT.TRACKS = Last(TRACKS)
lastTrack = nT\id
MARGIN = SW/30
heightRatio# = 1.8
noteReleaseF# = 1.8
noteRelease# = 1.8 // seconds
title$="Track 1"
PlaySound sound,80
start = Timer()
bpmEvent.TEMPOEVENT = First(TEMPOEVENT)
If bpmEvent = NULL Then
Print "no tempo event set"
WaitKey
End
EndIf
musicPlaying = False
Repeat
If bpmEvent\nextEventPtr <> 0 And msOffset >= bpmEvent\nextEventMs Then
bpmEvent = ConvertToType(bpmEvent\nextEventPtr)
EndIf
If (KeyHit(200) Or KeyHit(208)) Or curTrack = 0 Then
If curTrack = 0 Then curTrack + 1
curTrack = Min(lastTrack, Max(1, curTrack - KeyHit(200) + KeyHit(208)))
trackPtr = getTrackPtr(curTrack)
If Not trackPtr = 0 Then
nT.TRACKS = ConvertToType(trackPtr)
title = nT\name
Else
title = "Track "+curTrack
EndIf
SetWindow title + " - arrows up/down t"+"o change track"
EndIf
msOffset = (Timer() - start)
noteCount = 0
For nN.NOTES = Each NOTES
timeDiff = (msOffset-nN\start)
l# = (60000.0/bpmevent\bpm)*2
If nN\track = curTrack Then
If timeDiff >= -l And timeDiff < nN\length Then
nT.TRACKS = ConvertToType(nN\trackPtr)
range = nT\maxNote-nT\minNote
noteDiff = nN\note-nT\minNote
m# = SW/20 // margin
my#= SH/20 // margin-y
w# = (SW-m*2)/range
h# = w
x# = m + ((SW-m*2-w)/range)*noteDiff+w/2
If timeDiff < 0 Then
f# =(-timeDiff/l)
y# = my + f*(SH-my*2)
c = 255 - 255.0*f
tail=10
For j=y+h To y+h+tail-1 Step 2
cm=Max(0,c-(c/(tail-1))*(j-(y+h)))
Color cm,cm,cm
Box x-w/2,j,w,2
Next j
Color c,c,c
Box x-w/2, y, w, h
Else
f# = timeDiff/Float(nN\length)
y# = my
c = 255 - 255.0*f
Color c/3,c/2,c
w=w*(1+f)
Box x-w/2, y, w, h
EndIf
EndIf
EndIf
If timeDiff > nN\length Then Delete nN Else noteCount + 1
Next nN
Color cbwhite
Text 0,0,"current bpm: "+bpmEvent\bpm
DrawScreen
Until noteCount = 0
Function ReadMIDI( strFile As String )
If Not FileExists(strFile) Then Return False
If FileSize(strFile) < 20 Then Return False
Dim f As Integer
f = OpenToRead( strFile )
If ReadInt(f) <> $4D546864 Then Return Error(f, "Invalid file header!")
Dim chunkSize As Integer, midiType As Short, trackCount As Short, timeDiv As Short
chunkSize = ReadInt2(f) // 6
midiType = ReadShort2(f) // 0, 1, 2
If midiType > 1 Then Error(f, "Feature missing! Can't handle this kind of midi (type "+midiType+") :(")
trackCount = ReadShort2(f) // 1-65536
timeDiv = ReadShort2(f)
Dim mem As Integer, memOffset As Integer, timeOffset As Integer
memOffset=0
mem = MakeMEMBlock(4)
Dim a As Integer, deltaTime As Integer, start As Integer, eventType As Byte, tmpByte As Byte
Dim sequenceNumber(1) As Byte, tmpInt As Integer, msgType As Byte, midiCh As Byte, tmpString As String
For a = 0 To trackCount-1
nT.TRACKS = New(TRACKS)
nT\id = a
nT\maxNote= 0
nT\minNote= 127
trackPtr = ConvertToInteger(nT)
tmpInt=ReadInt(f)
If tmpInt <> $4D54726B Then Error(f, "Invalid track header! ("+Hex(tmpInt)+")")
chunkSize = ReadInt2(f)
start = FileOffset(f)
timeOffset=0
lastTempoEventMs = 0
lastTempoEvent = 0
trackVolume = 127
lyrics$ = ""
TE.TEMPOEVENT = First(TEMPOEVENT)
While FileOffset(f) < (start + chunkSize)
deltaTime=ReadVarLen(f)
if deltaTime>0 then lyrics = ""
timeOffset=timeOffset+deltaTime
If TE = NULL Then
msOffset = 0
Else
TEnext.TEMPOEVENT = After(TE)
While TEnext <> NULL
If timeOffset >= TEnext\tics Then Exit
TEnext = After(TEnext)
Wend
If TEnext <> NULL Then
TE = TEnext
EndIf
msOffset = TE\ms+(timeOffset-TE\tics)*TE\fact
EndIf
bb = ReadByte(f)
If bb Shr 7 Then
msgType = bb
Else
SeekFile f, FileOffset(f)-1
EndIf
If msgType = $FF Then
//metadataa
Dim metaType As Byte
offset = FileOffset(f)
metaType = ReadByte(f)
Select metaType
Case $00 // sequence number
l = ReadVarLen(f)
If l<>2 Then Return Error(f,"Invalid sequence number length ("+l+")")
sequenceNumber(0) = ReadByte(f)
sequenceNumber(1) = ReadByte(f)
Case $01 // text event
tmpString = ReadString2(f)
Case $02 // copyright notice
tmpString = ReadString2(f)
Case $03 // sequence/track name
nT\name = ReadString2(f)
Case $04 // instrument name
nT\instrument = ReadString2(f)
Case $05 // lyrics
lyrics = ReadString2(f)
Case $06 // marker
tmpString = ReadString2(f)
Case $07 // cue point
tmpString = ReadString2(f)
Case $20 // MIDI channel prefix
tmpInt = ReadVarLen(f)
If tmpInt > 4 Then Error(f, "Invalid MIDI channel prefix event at 0x"+Right(Hex(offset),4))
tmpInt=ReadBytes(f,tmpInt)
Case $21 // MIDI port
tmpInt = ReadVarLen(f)
If tmpInt > 4 Then Error(f,"Invalid MIDI port event at 0x"+Right(Hex(offset),4))
tmpInt=ReadBytes(f,tmpInt)
Case $2F // end of track
tmpByte=ReadByte(f)
If tmpByte <> 0 Then Error(f,"Invalid End of Track event at 0x"+Right(Hex(offset),4))
Case $51 // set tempo
tmpInt = ReadVarLen(f)
If tmpInt <> 3 Then Error(f,"Invalid tempo event at 0x"+Right(Hex(offset),4))
microSecsPerQuarterNote=ReadBytes(f,tmpInt)
ms = 0 : tics = 0 : fact#=1
If TE <> NULL Then ms = TE\ms : tics = TE\tics : fact = TE\fact
nTE.TEMPOEVENT = New(TEMPOEVENT)
nTE\tics = timeOffset
nTE\ms = ms+(nTE\tics-tics)*fact
nTE\fact = (microSecsPerQuarterNote / timeDiv / 1000.0)
nTE\bpm = (60000000.0/microSecsPerQuarterNote)
If TE <> NULL Then
TE\nextEventPtr = ConvertToInteger(nTE)
TE\nextEventMs = nTE\ms
EndIf
TE = nTE
Case $54 // smpte offset
tmpInt = ReadVarLen(f)
If tmpInt <> 5 Then Error(f,"Invalid SMPTE offset event at 0x"+Right(Hex(offset),4))
SecOffset = ReadByte(f)*3600+ReadByte(f)*60+ReadByte(f)
FrameOffset = ReadByte(f)*100 + ReadByte(f)
Case $58 // time signature
tmpInt = ReadVarLen(f)
If tmpInt <> 4 Then Error(f,"Invalid time signature event at 0x"+Right(Hex(offset),4))
p1 = ReadByte(f)
p2 = ReadByte(f)
p3 = ReadByte(f)
p4 = ReadByte(f)
Case $59 // key signature
tmpInt = ReadVarLen(f)
If tmpInt <> 2 Then Error(f,"Invalid key signature event at 0x"+Right(Hex(offset),4))
sf = ReadByte(f)
MajorMinor = ReadByte(f)
Case $7F // sequencer specific
tmpInt = ReadVarLen(f)
SeekFile f, FileOffset(f)+tmpInt
Default
//Error(f, "Unknown meta event 0x"+Right(Hex(metaType),2)+" at 0x"+Right(Hex(offset),4)+Chr(13)+"Length: "+ReadVarLen(f))
l=ReadVarLen(f)
//SeekFile f, FileOffset(f)+1
End Select
ElseIf msgType Shr 4 = $F Then
ll = ReadVarLen(f)
For asd=1 To ll
bb=ReadByte(f)
Next asd
ElseIf msgType > 0 Then
Dim param1 As Byte, param2 As Byte
eventType = (msgType Shr 4)
midiCh = (msgType Shl 28) Shr 28
param1 = ReadByte(f)
If (eventType >= $8 And eventType <= $B) Or eventType = $E Then param2 = ReadByte(f)
Select eventType
Case $8 // 1000 | note off | (note, velocity)
For nN.NOTES = Each NOTES
If nN\length = -1 And nN\note = param1 Then
If nN\track = a And nN\channel = midiCh Then
nN\length = Max(0,msOffset - nN\start)
Exit
EndIf
EndIf
Next nN
Case $9 // 1001 | note on | (note, velocity)
velocity = param2*trackVolume/127.0
If velocity = 0 Then
For nN.NOTES = Each NOTES
If nN\length = -1 And nN\note = param1 Then
If nN\track = a And nN\channel = midiCh Then
nN\length = Max(0,msOffset - nN\start)
Exit
EndIf
EndIf
Next nN
Else
nN.NOTES = New(NOTES)
nN\channel = midiCh
nN\track = a
nN\trackPtr = trackPtr
nN\note = param1
nN\velocity = velocity
nN\start = msOffset
nN\length = -1
nN\lyrics = lyrics
If nN\note > nT\maxNote Then nT\maxNote = nN\note
If nN\note < nT\minNote Then nT\minNote = nN\note
EndIf
Case $A // 1010 | note aftertouch | (note, velocity)
event = NOTE_AFTERTOUCH
Case $B // 1011 | controller event | (controller, value)
event = CONTROLLER_EVENT
If param1 = 7 Then trackVolume = param2
//Print param1+":"+controllerEvent(param1)
Case $C // 1100 | program change | (program)
event = PROGRAM_CHANGE
Case $D // 1101 | channel aftertouch | (amount = 0,127)
event = CHANNEL_AFTERTOUCH
Case $E // 1110 | pitch bend | (lsb, msb)
event = PITCH_BEND
n = getBytes(param1,0,6)+(getBytes(param2,0,6) Shl 7)-8192
Case $F // sysEx (jostain syystä ei handlattu jo aiemmin :d)
tmpInt = readBytes(f,ReadVarLen(f))
Default
Error(f, "Unknown event 0x"+Right(Hex(eventType),2)+" at 0x"+Right(Hex(offset),4))
End Select
EndIf
Wend
Next a
CloseFile f
Return mem
End Function
Function ReadString2(f)
Dim ret As String
l = ReadVarLen(f)
For i = 1 To l
ret = ret + Chr(ReadByte(f))
Next i
Return ret
End Function
Function Error(f As Integer = 0, strError As String = "")
If f Then CloseFile f
If strError <> "" Then MakeError StrError
Return False
End Function
Function ReadShort2(f As Integer)
Return (ReadByte(f) Shl 8 + ReadByte(f))
End Function
Function ReadInt2(f As Integer)
Return (ReadByte(f) Shl 24 + ReadByte(f) Shl 16 + ReadByte(f) Shl 8 + ReadByte(f))
End Function
Function ReadBytes(f As Integer, amount As Integer)
Dim ret As Integer, i As Integer
For i = amount-1 To 0 Step -1
ret = ret + ReadByte(f) Shl (i Shl 3)
Next i
Return ret
End Function
Function ReadVarLen(f As Integer)
a=ReadByte(f)
If a Shr 7 Then
b=ReadByte(f)
If b Shr 7 Then
c=ReadByte(f)
If c Shr 7 Then
Return (((a-128) Shl 7 +b-128) Shl 7 + c -128 ) Shl 7 + ReadByte(f)
Else
Return ((a-128) Shl 7 +b-128) Shl 7 + c
EndIf
Else
Return (a-128) Shl 7 +b
EndIf
Else
Return a
EndIf
EndFunction
Function getBytes(n, startId, endId)
l=(endId-startId+1)
n=(n Shl (32-startId-l))
n=(n Shr (32-l))
Return n
End Function