Attribute VB_Name = "Sonido"
Option Explicit

Const MIN_VOL = 0                   ' volumen mínimo
Const MAX_VOL = 64                  ' volumen máximo
Const NO_ID = -1                    ' valor erróneo para IDs de sonido
Const CANALES_MUSICA = 64           ' canales para música+samples
Const CANALES_EFECTOS = 16          ' canales para samples (< CANALES_MUSICA)

Type Sonido
    id As Long                      ' ID del módulo/"sample" cargado
    PlayID As Long                  ' ID de reproduccuón del módulo/"sample"
End Type

Private bSonidoInic As Boolean      ' si se han inicializado las librerias
Private Modulos() As Sonido         ' para guardar los IDs de módulos cargados
Private bHayModulos As Boolean      ' si hay módulos cargados
Private Samples() As Sonido         ' para guardar los IDs de los "samples" cargados
Private bHaySamples As Boolean      ' si hay samples

Public Declare Function waveOutGetNumDevs Lib "winmm.dll" () As Long

' comprueba si hay instalada una tarjeta de sonido, devuelve True si la hay
' o False si no
Private Function TarjetaSonido() As Boolean
    Dim i As Long
    
    i = waveOutGetNumDevs()
    If i > 0 Then
        TarjetaSonido = True
    Else
        TarjetaSonido = False
    End If

End Function

' inicializa las librerías de sonido, devuelve True si correcto o False si error
' (se llamará al entrar en el programa)
Public Function InicializaSonido() As Boolean
    Dim iRet As Integer

    If bSonidoInic Then
        InicializaSonido = True
        Exit Function
    End If
    
    ' si no tiene tarjeta de sonido salimos sin error pero sin inicializar
    ' el sistema de sonido con lo cual cualquier llamada al resto de rutinas
    ' de sonido será ignorada
    If Not TarjetaSonido Then
        bSonidoInic = False
        InicializaSonido = True
        Exit Function
    End If

    iRet = MIDASstartup
    If iRet = 0 Then
        bSonidoInic = False
        InicializaSonido = False
        MsgBox "MIDASstartup: error", vbOKOnly + vbCritical, "Error MIDAS"
        Exit Function
    End If
    
    iRet = MIDASsetOption(MIDAS_OPTION_MIXRATE, 22050)
    If iRet = 0 Then
        bSonidoInic = False
        InicializaSonido = False
        MsgBox "MIDASsetOption: error MIDAS_OPTION_MIXRATE", vbOKOnly + vbCritical, "Error MIDAS"
        MIDASclose
        Exit Function
    End If
    
    ' sonido estéreo de 16 bits
    iRet = MIDASsetOption(MIDAS_OPTION_OUTPUTMODE, MIDAS_MODE_16BIT_STEREO)
    If iRet = 0 Then
        ' sonido estéreo de 8 bits
        iRet = MIDASsetOption(MIDAS_OPTION_OUTPUTMODE, MIDAS_MODE_8BIT_STEREO)
        If iRet = 0 Then
            ' sonido mono de 16 bits
            iRet = MIDASsetOption(MIDAS_OPTION_OUTPUTMODE, MIDAS_MODE_16BIT_MONO)
            If iRet = 0 Then
                ' sonido mono de 8 bits
                MIDASsetOption MIDAS_OPTION_OUTPUTMODE, MIDAS_MODE_8BIT_MONO
            End If
        End If
    End If
    
    iRet = MIDASsetOption(MIDAS_OPTION_DSOUND_MODE, MIDAS_DSOUND_DISABLED)
    If iRet = 0 Then
        bSonidoInic = False
        InicializaSonido = False
        MsgBox "MIDASsetOption: error MIDAS_OPTION_DSOUND_MODE", vbOKOnly + vbCritical, "Error MIDAS"
        MIDASclose
        Exit Function
    End If
    '''MIDASsetOption MIDAS_OPTION_FORCE_NO_SOUND ' se puede usar si falla MIDASinit
    
    iRet = MIDASinit
    If iRet = 0 Then
        bSonidoInic = False
        InicializaSonido = False
        MsgBox "MIDASinit: error", vbOKOnly + vbCritical, "Error MIDAS"
        MIDASclose
        Exit Function
    End If
    
    iRet = MIDASstartBackgroundPlay(0)
    If iRet = 0 Then
        bSonidoInic = False
        InicializaSonido = False
        MsgBox "MIDASstartBackgroundPlay: error", vbOKOnly + vbCritical, "Error MIDAS"
        MIDASclose
        Exit Function
    End If
    
    iRet = MIDASopenChannels(CANALES_MUSICA)
    If iRet = 0 Then
        bSonidoInic = False
        InicializaSonido = False
        MsgBox "MIDASopenChannels: error", vbOKOnly + vbCritical, "Error MIDAS"
        MIDASstopBackgroundPlay
        MIDASclose
        Exit Function
    End If
    
    iRet = MIDASallocAutoEffectChannels(CANALES_EFECTOS)
    If iRet = 0 Then
        bSonidoInic = False
        InicializaSonido = False
        MsgBox "MIDASallocAutoEffectChannels: error", vbOKOnly + vbCritical, "Error MIDAS"
        MIDASstopBackgroundPlay
        MIDASclose
        Exit Function
    End If

    ReDim Modulos(0)
    bHayModulos = False
    ReDim Samples(0)
    bHaySamples = False
    
    bSonidoInic = True
    InicializaSonido = True
    
End Function

' finaliza el sistema de sonido (se llamará al salir del programa)
Public Sub FinalizaSonido()
    Dim i As Long, lFin As Long

    If Not bSonidoInic Then
        Exit Sub
    End If
    
    ' descargamos todos los módulos de sonido y los "samples"
    If bHaySamples Then
        For i = 0 To UBound(Samples)
            If Samples(i).PlayID <> NO_ID Then
                MIDASstopSample Samples(i).PlayID
            End If
            MIDASfreeSample Samples(i).id
        Next
        bHaySamples = False
        ReDim Samples(0)
    End If
    
    If bHayModulos Then
        For i = 0 To UBound(Modulos)
            If Modulos(i).PlayID <> NO_ID Then
                MIDASstopModule Modulos(i).PlayID
            End If
            MIDASfreeModule Modulos(i).id
        Next
        bHayModulos = False
        ReDim Modulos(0)
    End If

    '''MIDASfreeAutoEffectChannels
    '''MIDAScloseChannels
    MIDASstopBackgroundPlay
    MIDASclose
    bSonidoInic = False

End Sub

' carga un módulo de sonido y devuelve su ID (0 si error)
' el nombre del módulo 'sMod' puede ser el nombre de un fichero o
' el identificador del recurso de sonido "#nnnnn"
Public Function CargarModulo(ByVal sMod As String) As Long
    Dim bRes As Boolean
    Dim i As Long, lMod As Long, lIDRes As Long
    Dim s As String, sFich As String, sFichRes As String
    
    If Not bSonidoInic Then
        CargarModulo = 0
        Exit Function
    End If
    
    On Error GoTo Error_CargaModulo
    sFichRes = sFichAventura & EXT_DLL
    
    bRes = False
    ' si el sonido está en un recurso
    If Left(sMod, 1) = "#" Then
        If Len(sMod) < 2 Then
            CargarModulo = 0
            Exit Function
        End If
        s = Right(sMod, Len(sMod) - 1)
        lIDRes = CLng(s)
        sFich = CargaResSonido(sFichRes, lIDRes)
        If sFich = "" Then
            CargarModulo = 0
            Exit Function
        End If
        bRes = True
    Else
        sFich = sMod
    End If

    lMod = MIDASloadModule(sFich)
    If lMod = 0 Then
        CargarModulo = 0
        Exit Function
    End If
    
    ' si el módulo estaba en un recurso, borra el fichero temporal
    If bRes Then
        On Error Resume Next
        Kill sFich
    End If
    
    ' guardamos el ID
    If Not bHayModulos Then
        Modulos(0).id = lMod
        Modulos(0).PlayID = NO_ID
        bHayModulos = True
    Else
        i = UBound(Modulos) + 1
        ReDim Preserve Modulos(i)
        Modulos(i).id = lMod
        Modulos(i).PlayID = NO_ID
    End If
    
    CargarModulo = lMod
    Exit Function
    
Error_CargaModulo:
    CargarModulo = 0
End Function

' carga un "sample" WAV y devuelve su ID (0 si error)
' el nombre del sample 'sWav' puede ser el nombre de un fichero o
' el identificador del recurso de sonido "#nnnnn"
Public Function CargarSample(ByVal sWav As String) As Long
    Dim bRes As Boolean
    Dim i As Long, lWav As Long, lIDRes As Long
    Dim s As String, sFich As String, sFichRes As String
    
    If Not bSonidoInic Then
        CargarSample = 0
        Exit Function
    End If
    
    On Error GoTo Error_CargaSample
    sFichRes = sFichAventura & EXT_DLL
    
    bRes = False
    ' si el sonido está en un recurso
    If Left(sWav, 1) = "#" Then
        If Len(sWav) < 2 Then
            CargarSample = 0
            Exit Function
        End If
        s = Right(sWav, Len(sWav) - 1)
        lIDRes = CLng(s)
        sFich = CargaResSonido(sFichRes, lIDRes)
        If sFich = "" Then
            CargarSample = 0
            Exit Function
        End If
        bRes = True
    Else
        sFich = sWav
    End If
    
    lWav = MIDASloadWaveSample(sFich, MIDAS_LOOP_NO)
    If lWav = 0 Then
        CargarSample = 0
        Exit Function
    End If
    
    ' si el sample estaba en un recurso, borra el fichero temporal
    If bRes Then
        On Error Resume Next
        Kill sFich
    End If
    
    ' guardamos el ID
    If Not bHaySamples Then
        Samples(0).id = lWav
        Samples(0).PlayID = NO_ID
        bHaySamples = True
    Else
        i = UBound(Samples) + 1
        ReDim Preserve Samples(i)
        Samples(i).id = lWav
        Samples(i).PlayID = NO_ID
    End If
    
    CargarSample = lWav
    Exit Function
    
Error_CargaSample:
    CargarSample = 0
End Function

' toca un módulo cargado, devuelve False si error
Public Function TocarModulo(ByVal lIDMod As Long) As Boolean
    Dim i As Long, lPlayID As Long

    If Not bSonidoInic Then
        TocarModulo = False
        Exit Function
    End If
    
    i = BuscaModulo(lIDMod)
    If i >= 0 Then
        lPlayID = MIDASplayModule(lIDMod, True)
        If lPlayID = 0 Then
            TocarModulo = False
        Else
            Modulos(i).PlayID = lPlayID
            TocarModulo = True
        End If
    Else
        TocarModulo = False
    End If

End Function

' toca un "sample" cargado, devuelve False si error
' se puede especificar la frecuencia (Hz), el volumen
' si estos valores se dejan todos a 0 se usan valores por defecto
Public Function TocarSample(ByVal lIDWav As Long, ByVal lFrec As Long, _
  ByVal lVol As Long) As Boolean
    Dim i As Long, lCanal As Long, lPlayID As Long

    If Not bSonidoInic Then
        TocarSample = False
        Exit Function
    End If

    If lFrec = 0 And lVol = 0 Then
        lFrec = 22050
        lVol = MAX_VOL
    Else
        ' ajustamos valores
        If lFrec < 0 Then
            lFrec = 0
        End If
        If lVol < MIN_VOL Then
            lVol = 0
        ElseIf lVol > MAX_VOL Then
            lVol = MAX_VOL
        End If
    End If
    
    i = BuscaSample(lIDWav)
    If i < 0 Then
        TocarSample = False
        Exit Function
    End If
    
    '''lCanal = MIDASallocateChannel
    '''If lCanal = MIDAS_ILLEGAL_CHANNEL Then
    '''    TocarSample = False
    '''Else
    '''    lPlayID = MIDASplaySample(lIDWav, lCanal, 0, lFrec, lVol, MIDAS_PAN_MIDDLE)
    '''    If lPlayID = 0 Then
    '''        TocarSample = False
    '''    Else
    '''        Samples(i).PlayID = lPlayID
    '''        TocarSample = True
    '''    End If
    '''    MIDASfreeChannel lCanal
    '''End If
    lPlayID = MIDASplaySample(lIDWav, MIDAS_CHANNEL_AUTO, 0, lFrec, lVol, MIDAS_PAN_MIDDLE)
    If lPlayID = 0 Then
        TocarSample = False
    Else
        Samples(i).PlayID = lPlayID
        TocarSample = True
    End If
    
End Function

' cambia el volumen general de reproducción
' (en porcentaje, 50 la mitad, 100 nada, 200 doble, ...)
Public Sub VolumenGeneral(ByVal lVol As Long)
    
    If Not bSonidoInic Then
        Exit Sub
    End If
    
    MIDASsetAmplification lVol

End Sub

' descarga un módulo de memoria
Public Sub DescargarModulo(ByVal lIDMod As Long)
    Dim bEncontrado As Boolean
    Dim i As Long, j As Long, lPlayIDMod As Long
    
    If Not bSonidoInic Then
        Exit Sub
    End If
    
    ' eliminamos el módulo de la lista
    bEncontrado = False
    i = 0
    Do While i <= UBound(Modulos)
        If Modulos(i).id = lIDMod Then
            bEncontrado = True
            lPlayIDMod = Modulos(i).PlayID
            
            For j = i To UBound(Modulos)
                If j < UBound(Modulos) Then
                    Modulos(j) = Modulos(j + 1)
                End If
            Next
            j = UBound(Modulos) - 1
            If j < 0 Then
                j = 0
                bHayModulos = False
            End If
            ReDim Preserve Modulos(j)
        End If
        i = i + 1
    Loop
    
    If bEncontrado Then
        If lPlayIDMod <> NO_ID Then
            MIDASstopModule lPlayIDMod
        End If
        MIDASfreeModule lIDMod
    End If
    
End Sub

' descarga un "sample" de memoria
Public Sub DescargarSample(ByVal lIDWav As Long)
    Dim bEncontrado As Boolean
    Dim i As Long, j As Long, lPlayIDWav As Long
    
    If Not bSonidoInic Then
        Exit Sub
    End If
    
    ' eliminamos el ID de la lista
    bEncontrado = False
    i = 0
    Do While i <= UBound(Samples)
        If Samples(i).id = lIDWav Then
            bEncontrado = True
            lPlayIDWav = Samples(i).PlayID
        
            For j = i To UBound(Samples)
                If j < UBound(Samples) Then
                    Samples(j) = Samples(j + 1)
                End If
            Next
            j = UBound(Samples) - 1
            If j < 0 Then
                j = 0
                bHaySamples = False
            End If
            ReDim Preserve Samples(j)
        End If
        i = i + 1
    Loop
    
    If bEncontrado Then
        If lPlayIDWav <> NO_ID Then
            MIDASstopSample lPlayIDWav
        End If
        MIDASfreeSample lIDWav
    End If

End Sub

' busca un módulo por su ID y devuelve su posición en la tabla de módulos
' devuelve -1 si no lo encontró
Private Function BuscaModulo(ByVal lID As Long) As Long
    Dim i As Long
      
    If bHayModulos Then
        For i = 0 To UBound(Modulos)
            If Modulos(i).id = lID Then
                BuscaModulo = i
                Exit Function
            End If
        Next
    End If
    
    BuscaModulo = -1
    
End Function

' busca un "sample" por su ID y devuelve su posición en la tabla de "samples"
' devuelve -1 si no lo encontró
Private Function BuscaSample(ByVal lID As Long) As Long
    Dim i As Long
      
    If bHaySamples Then
        For i = 0 To UBound(Samples)
            If Samples(i).id = lID Then
                BuscaSample = i
                Exit Function
            End If
        Next
    End If
    
    BuscaSample = -1
    
End Function