Attribute VB_Name = "Module1"
' Modified by RandomName from ValleyBell's HMI2MID.bas
' https://github.com/ValleyBell/MidiConverters/blob/master/HMI2MID.bas

Option Explicit

Sub Main()

    Const PATH = "C:\HMP2MID\game22."

    Dim TrkCountOff As Byte
    Dim ppqnOff As Byte
    Dim BPMOff As Byte
    Dim ChannelPriorityOff As Byte
    Dim InstDesigOff As Byte
    Dim MidiOff As Integer

    Dim hmpType as String
    Dim i
    Dim TrkCount As Integer
    Dim ppqn As Integer
    Dim BPM as Byte
    Dim Tempo as Double
    Dim Tempo1 as Double
    Dim TempoByt1 As Byte
    Dim TempoByt2 As Byte
    Dim TempoByt3 As Byte
    Dim CurTrk As Integer
    Dim TempLng As Long
    Dim TempSht As Integer
    Dim TempByt As Byte
    Dim DlyArr(&H0 To &HF) As Byte
    Dim ChannelByt As Byte
    Dim channelPriority(1 to 16) as Byte

    Open PATH & "HMP" For Binary Access Read As #1 ' Also old HMI or HMQ
    Open PATH & "MID" For Binary Access Write As #2

    ' HMIMIDI header
    Dim magicHeader(6) As Byte
    magicHeader(0) = 72
    magicHeader(1) = 77
    magicHeader(2) = 73
    magicHeader(3) = 77
    magicHeader(4) = 73
    magicHeader(5) = 68
    magicHeader(6) = 73
    
    For i = 0 to UBound(magicHeader)
      Get #1, , TempByt
      If TempByt <> magicHeader(i) Then
        GoTo TheEnd
      End If
    Next
    
    Get #1, , TempByt
    Select Case CByte(TempByt)
      Case &H0
        hmpType = "HMIMIDI"
      Case &H50
        hmpType = "HMIMIDIP"
      Case &H52
        hmpType = "HMIMIDIR"
      Case Else
        GoTo TheEnd
    End Select

    If hmpType = "HMIMIDIP" Then
      Get #1, , TempByt
      If TempByt = 48 Then
        hmpType = "HMIMIDIP013195"
      End If
    End If

    Select Case hmpType
      ' Inst designators differ between Silverload and Lemmings Chronicles
      ' so the inst designators is not correct and I can't figure it out
      Case "HMIMIDI", "HMIMIDIR"
        TrkCountOff = &H1A
        ppqnOff = &H1C
        BPMOff = &H1E
        ChannelPriorityOff = &H22
        InstDesigOff = &H42
        MidiOff = &H186
      Case "HMIMIDIP"
        TrkCountOff = &H30
        ppqnOff = &H34
        BPMOff = &H38
        ChannelPriorityOff = &H40
        InstDesigOff = &H90
        MidiOff = &H308
      Case"HMIMIDIP013195"
        TrkCountOff = &H30
        ppqnOff = &H34
        BPMOff = &H38
        ChannelPriorityOff = &H40
        InstDesigOff = &H90
        MidiOff = &H388
    End Select

    Get #1, 1 + TrkCountOff, TrkCount
    
    Dim instDesig() As String
    Dim InstrFound() As String
    ReDim instDesig(1 To TrkCount + 1, 1 To 5) As String
    ReDim InstrFound(1 To TrkCount + 1) As String
    
    Put #2, 1 + &H0, "MThd"
    Put #2, , CLng(&H6000000)
    Put #2, , CInt(&H100)
    Put #2, , CByte(TrkCount \ &H100)
    Put #2, , CByte(TrkCount And &HFF)
    Get #1, 1 + ppqnOff, ppqn
    Get #1, 1 + BPMOff, BPM
 
    Put #2, , CByte(ppqn \ &H100)
    Put #2, , CByte(ppqn And &HFF)

    ' This formula doesn't work properly for Lemmings Chronicles
    ' Instead change the ppqn in the output MIDI file to 224 or change tempo to 5500000
    Tempo1 = ppqn / BPM * 1000000
    Tempo = Tempo1 / 256

    TempoByt1 = CByte(Tempo \ &H100)
    TempoByt2 = CByte(Tempo And &HFF)
    TempoByt3 = CByte(Tempo1 And &HFF)

    ' Channel priority is used by the HMI SOS to allow melodic notes
    ' to keep playing when polyphony is maxed out
    Seek #1, 1 + ChannelPriorityOff
    For CurTrk = 1 to 16
      Get #1, , channelPriority(curTrk)
      If hmpType = "HMIMIDIP" Or hmpType = "HMIMIDIP013195" Then
        Get #1, , TempSht
        Get #1, , TempByt
      Else
        Get #1, , TempByt
      End If
    Next CurTrk

    ' Instrument designators determine which audio devices a track
    ' should be played on.
    Seek #1, 1 + InstDesigOff
    For CurTrk = 1 To TrkCount + 1
      If hmpType = "HMIMIDIP" Or hmpType = "HMIMIDIP013195" Then
        Get #1, , TempLng ' Always seems to be 00000000
        For i = 1 to 4
          Get #1, , TempSht
          instDesig(CurTrk, i) = InstrMap(TempSht)
          Get #1, , TempSht
        Next

        InstrFound(CurTrk) = instDesig(CurTrk, 1) & instDesig(CurTrk, 2) & _
        instDesig(CurTrk, 3) & instDesig(CurTrk, 4)

      Else
        For i = 1 to 5
          Get #1, , TempSht
          instDesig(CurTrk, i) = InstrMap(TempSht)
        Next

        InstrFound(CurTrk) = instDesig(CurTrk, 1) & instDesig(CurTrk, 2) & _
        instDesig(CurTrk, 3) & instDesig(CurTrk, 4) & instDesig(CurTrk, 5)
      End If
    Next CurTrk

    Seek #1, 1 + MidiOff
    For CurTrk = &H0 To TrkCount - 1
      If hmpType = "HMIMIDIP" Or hmpType = "HMIMIDIP013195" Then
        Get #1, , TempLng
      Else
        Get #1, , TempSht
      End If
      Put #2, , "MTrk"
      Get #1, , TempSht
      If hmpType = "HMIMIDIP" Or hmpType = "HMIMIDIP013195" Then
        Get #1, , TempByt
        Get #1, , TempByt
      End If
      Get #1, , ChannelByt
      Get #1, , TempByt

      If CurTrk = &H0 Then
        If hmpType = "HMIMIDIP" Or hmpType = "HMIMIDIP013195" Then
          TempSht = TempSht - &H5
        Else
          TempSht = TempSht + &H1
        End If
      Else
      
        If channelPriority(ChannelByt + 1) <> 9 Then
          InstrFound(CurTrk) = InstrFound(CurTrk) & CStr(channelPriority(ChannelByt + 1))
        End If

        If Len(InstrFound(CurTrk)) > 0 Then
          InstrFound(CurTrk) = "[" & InstrFound(CurTrk) & "]"

        If ChannelByt = 0 And InstrFound(CurTrk) = "[GUFW]" Then
          InstrFound(CurTrk) = "Loop"
        End If

          ' I should probably just get the size at the end, come back
          ' and write it, but I don't know how to.
          If Len(InstrFound(CurTrk)) = 3 Then
            If hmpType = "HMIMIDIP" Or hmpType = "HMIMIDIP013195" Then
              TempSht = TempSht - CByte(Len(InstrFound(CurTrk))) - 2
            Else
              TempSht = TempSht - CByte(Len(InstrFound(CurTrk))) + 4
            End If
          End If
          If Len(InstrFound(CurTrk)) = 4 Then
            If hmpType = "HMIMIDIP" Or hmpType = "HMIMIDIP013195" Then
              TempSht = TempSht - CByte(Len(InstrFound(CurTrk)))
            Else
              TempSht = TempSht - CByte(Len(InstrFound(CurTrk))) + 6
            End If
          End If
          If Len(InstrFound(CurTrk)) = 5 Then
            If hmpType = "HMIMIDIP" Or hmpType = "HMIMIDIP013195" Then
              TempSht = TempSht - CByte(Len(InstrFound(CurTrk))) + 2
            Else
              TempSht = TempSht - CByte(Len(InstrFound(CurTrk))) + 8
            End If
          End If
          If Len(InstrFound(CurTrk)) = 6 Then
            If hmpType = "HMIMIDIP" Or hmpType = "HMIMIDIP013195" Then
              TempSht = TempSht - CByte(Len(InstrFound(CurTrk))) + 4
            Else
              TempSht = TempSht - CByte(Len(InstrFound(CurTrk))) + 10
            End If
          End If
          If Len(InstrFound(CurTrk)) = 7 Then
            If hmpType = "HMIMIDIP" Or hmpType = "HMIMIDIP013195" Then
              TempSht = TempSht - CByte(Len(InstrFound(CurTrk))) + 6
            Else
              TempSht = TempSht - CByte(Len(InstrFound(CurTrk))) + 12
            End If
          End If
            Else
          If hmpType = "HMIMIDIP" Or hmpType = "HMIMIDIP013195" Then
            TempSht = TempSht - &HC
          Else
            TempSht = TempSht - &H6
          End If
        End If
      End If
        Put #2, , CByte(&H0)
        Put #2, , CByte(&H0)
        Put #2, , CByte((TempSht And &HFF00&) \ &H100&)
        Put #2, , CByte((TempSht And &HFF&) \ &H1&)
        If CurTrk = &H0 Then
          Put #2, , CLng(&H351FF00)
          Put #2, , CByte(TempoByt1)
          Put #2, , CByte(TempoByt2)
          Put #2, , CByte(TempoByt3)
        Else
          If Len(InstrFound(CurTrk)) > 0 Then
            Put #2, , CInt(&HFF00)
            Put #2, , CByte(&H3)
            Put #2, , CByte(Len(InstrFound(CurTrk)))
            Put #2, , InstrFound(CurTrk)
          End If
        End If
      If hmpType = "HMIMIDIP" Or hmpType = "HMIMIDIP013195" Then
        Get #1, , TempSht
      End If
        Debug.Print "Track " & CurTrk & ": " & Hex$(TempSht)

        Do
          TempSht = &H0
          Get #1, , TempByt
          Do Until TempByt And &H80
            DlyArr(TempSht) = TempByt
            TempSht = TempSht + &H1
            Get #1, , TempByt
          Loop
          DlyArr(TempSht) = TempByt And &H7F

          Do While TempSht > &H0
            TempByt = &H80 Or DlyArr(TempSht)
            Put #2, , TempByt
            TempSht = TempSht - &H1
          Loop
            Put #2, , DlyArr(TempSht)
            
          Get #1, , TempByt
          Select Case TempByt And &HF0
            Case &H80, &H90, &HA0, &HB0, &HE0
              Get #1, , TempSht
              If (TempByt And &HF0) = &HB0 And TempSht = &H6C Then
                TempByt = &HFF
                TempSht = &H0
              End If
              Put #2, , TempByt
              Put #2, , TempSht
            Case &HC0, &HD0
              Put #2, , TempByt
              Get #1, , TempByt
              Put #2, , TempByt
            Case &HF0
              If TempByt <> &HFF Then Stop
              Put #2, , TempByt   ' FF
              Get #1, , TempByt   ' 2F
              Put #2, , TempByt
              If TempByt <> &H2F Then Stop
              Get #1, , TempByt   ' 00
              Put #2, , TempByt
              Exit Do
          End Select
        Loop
    Next CurTrk

    TheEnd:
    Close #2
    Close #1
End Sub

Function InstrMap(TempSht As Integer) As String
  Select Case TempSht
    Case &HA000 ' General MIDI
      InstrMap = "G"
    Case &HA002 ' FM OPL2/OPL3
      InstrMap = "F"
    Case &HA003 ' Callback
      InstrMap = "C"
    Case &HA004 ' Roland MT-32
      InstrMap = "M"
    Case &HA005 ' Digital MIDI samples
      InstrMap = "D"
    Case &HA006 ' Internal Speaker
      InstrMap = "I"
    Case &HA007 ' Software Wavetable
      InstrMap = "W"
    Case &HA00A ' Ultrasound
      InstrMap = "U"
    'Case &HA008 ' Maybe AWE32
    'Case &HA009 ' Maybe SB Pro OPL3
    Case Else
      InstrMap = vbNullString
  End Select
End Function