midi softsynth

User projects written in or related to FreeBASIC.
dafhi
Posts: 1373
Joined: Jun 04, 2005 9:51

midi softsynth

Postby dafhi » Apr 24, 2012 18:18

quality synth done the old-fashioned way.

[May 9] - savewave also writes loop points .. FL Studio, Wavosaur, riffpad, and several wav format sites were (no pun intended) instrumental in helping me get this far

[May 8]
- removed LUT designation which is now part of the WAV synth
- other simplifications

[May 5]
[3] - loader 32 bps fix, synth freq and vol adjustments
[2] - a few simplifications
[1] - qwerty controller, 24 bit wave support, PADSynth

[Apr 26]
[2] - fix for wave when looping = false
[1] - midi reconnect, LUT loop fix, 8 and 32 bit .wav support

[Apr 25] - linear interpolation for LUT and WAV synths
[Apr 24]
[2] - wave player dynamic sound
[1] - high velocity clicks fixed

Code: Select all

/'  midi softsynth by dafhi

2 synth algos:

1. WAV
  A.  .wav player
  B.  Two LUT (look-up table) generators
 1. A simple one by me
 2. Unique implementation of the PADsynth algorith - http://zynaddsubfx.sourceforge.net/doc/PADsynth/PADsynth.htm
 
 3. can save LUT as .wav file

2.  Raw, or formula-based

'/


Const                   SYNTH_WAV = 0
Const                   SYNTH_RAW = 1

Dim shared as integer   SynthType = SYNTH_WAV

#Ifndef FALSE
Const as integer FALSE = 0
Const as integer TRUE = not FALSE
#endif

dim shared as string    str_InitialWaveFile
dim shared as integer   NormalizeOnLoad = FALSE
dim shared as integer   LoopWave = TRUE

'str_InitialWaveFile = "temp.wav"


'' if audio skips, mess with these
Dim shared as integer   nBuffers= 5
dim shared as integer   nSamplesPerBuffer = 230
Dim Shared As Integer   rate = 44100 \ 1


'' -----------------------------
'  common initializations
' ------------------------------

dim shared as integer   Normalize_Volume = 5000

Dim Shared As UByte     Polyphony = 16
dim shared as single    release_time = 0.8

'' ---------------------
'  Common Vars
' ---------------------

Dim Shared As Integer   SynthRunning

dim shared as single    samps_per_cycle
Dim shared as single    ws_base

Dim shared as single    TwoPi = 8 * atn(1)
#ifndef Pi
Const                   pi    = 4 * Atn(1)
#EndIf

Randomize

Dim Shared As Single    basefreq: basefreq = (44100 / rate) / 200

#Ifndef floor
#Define floor(x) (((x)*2.0-0.5)shr 1) '' http://www.freebasic.net/forum/viewtopic.php?p=118633
#define ceil(x) (-((-(x)*2.0-0.5)shr 1))
#endif

Function Note2Freq(n as integer) as double
  return (ws_base) * 2 ^ ((n - 67) / 12)
end Function

Union SngLR
  As Single             sval
  Type
    As single           L
    As single           R
  End Type
End Union

Dim shared as SngLR     waveLUT()
dim shared as SngLR     precision_buf()

Type STEREO_SAMPLE
  union
  type
  as short L
  as short R
  end type
  as uinteger Both
  end union
End Type

Type increments
    as Single           func
    as Single           func2
    as Single           func3
end type

type chan field = 4
    as Double           func
    as Double           func2
    as Double           func3
    as increments       i
end type

type notevars
    as chan             chanL
    as chan             chanR
    as single           volume
    as single           baseFreq
    as single           modval
    As Integer          scancode
    As UInteger          release_samples
    As Single           release_iVol
End Type

Dim Shared As notevars  shared_notes(1 To polyphony)

Type ChordType
   Declare Function   NoteOn(ByVal scancode As Integer, ByVal noteNr As Integer = 0, ByVal Velo as single = 0.7, ByVal freq_ As Single = 0, ByVal duration as single = 0) As Integer
   Declare sub        NoteOff(ByVal scancode As Integer,ByVal ReleaseTime As Single = 1.0)
   Declare sub        Panic
  private:
  as integer          Dummy
End Type
Sub ChordType.Panic
  For I as integer = 1 to Polyphony
    shared_notes(I).release_samples = 0
  Next
End Sub

Dim Shared As ChordType     mychord

dim shared as integer   MIDI_NOT_RUNNING
dim shared as integer   DEMO_NOTE = 48

Sub NoteON__LUT_VS_RAW(Byval note as ubyte, ByVal velo_ as single = 0.7, byval duration as single = 0)
  select case SynthType
  Case SYNTH_RAW: mychord.NoteOn( note, note - 57, velo_,, duration )
  Case SYNTH_WAV: mychord.NoteOn( note, 0, velo_, Note2Freq(note), duration )
  End Select
End Sub

Sub LUT_DEMO(ByVal note_val as integer = 0, ByVal duration as single = 0)
  if note_val > 0 Then
    dim as single velocity = 0.7
    NoteON__LUT_VS_RAW note_val, velocity, duration
  elseif MIDI_NOT_RUNNING Then
    ''demo the new wave
    mychord.NoteOn( DEMO_NOTE, 0, 1.0, Note2Freq(DEMO_NOTE), duration )
  end if
End Sub

dim shared as integer       WAVE_BUSY
dim shared as integer       AVERT_NEW_NOTES
dim shared as integer       OldUB

#Macro Redim_(wLUT,NewUBound)
  OldUB = UBound(wLUT)
  if OldUB <> NewUBound Then
    AVERT_NEW_NOTES = TRUE
    While WAVE_BUSY
      sleep 1
    Wend
    mychord.Panic
    Redim wLUT(NewUBound)
  end if
#EndMacro

dim shared as integer   redundant_to_save_wav


'' -------------
'  Text Helper
' --------------

dim shared as string    strLineCLR: strLineCLR = space(50)
#Macro ClearPrint(LineNR)
  locate LineNR,1
  ? strLineCLR
  Locate LineNR,1
#EndMacro


'' -------------
'   Load Wav
' --------------

Private Type FileHeader
    lRiff As Integer
    lFileSize As Integer
    lWave As Integer
    lFormat As Integer
    lFormatLength As Integer
End Type

Private Type WaveFormat2
    wFormatTag As Short
    nChannels As Short
    nSamplesPerSec As Integer
    nAvgBytesPerSec As Integer
    nBlockAlign As Short
    wBitsPerSample As Short
End Type

Private Type ChunkHeader
    lType As Integer
    lLen As Integer
End Type

Private Function WaveReadFormat(ByVal InFileNum As Short, ByRef lDataLength As Integer) As WaveFormat2
 
    'http://www.vbforums.com/showthread.php?t=388562
   
    Dim header As FileHeader
    Dim HdrFormat As WaveFormat2
    Dim chunk As ChunkHeader
    Dim by As Byte
    Dim i As Integer
   
    Get #InFileNum, 1, header
   
    If header.lRiff <> &H46464952 Then Exit Function
    If header.lWave <> &H45564157 Then Exit Function
    If header.lFormat <> &H20746D66 Then Exit Function
   
    If header.lFormatLength < 16 Then Exit Function
   
    Get #InFileNum, , HdrFormat
   
    ' Seek to next chunk by discarding any format bytes.
    For i = 1 To header.lFormatLength - 16
        Get #InFileNum, , by
    Next
   
    ' Ignore chunks until we get to the "data" chunk.
    Get #InFileNum, , chunk
    Do While chunk.lType <> &H61746164
        For i = 1 To chunk.lLen
            Get #InFileNum, , by
        Next
        Get #InFileNum, , chunk
    Loop
   
    lDataLength = chunk.lLen ' Retrieve the size of the data.
   
    WaveReadFormat = HdrFormat
End Function

#Macro macro_PosNeg_TwosCompl(out_,lpSrc_)
  lpInt = lpSrc_
  If (*lpInt And Sign_) Then
    Result_ = -((*lpInt And Mask_ - 1) Xor Mask_)
  Else
    Result_ = (*lpInt And Mask_)
  End If
  out_ = Result_ * mul_
#EndMacro

#Macro macro_To_waveLUT(pSrc,pSrc0)

  Sign_ = 1 Shl (wf_.wBitsPerSample - 1)
  Mask_ = Sign_ - 1
  Dim As Single mul_ = 1 / Sign_
  lChanAdvance = ChanM * ByPS
  lpByt = @pSrc0
 
  For I As integer = 0 to nSamples - 1
    macro_PosNeg_TwosCompl( waveLUT(I).L, lpByt )
    lpBytChan = lpByt + lChanAdvance
    macro_PosNeg_TwosCompl( waveLUT(I).R, lpBytChan )
    lpByt += lChunkSiz
  Next

#EndMacro

#Macro macro_To_waveLUT_Common(pSrc)
 
  ByPS = wf_.wBitsPerSample Shr 3
  lChunkSiz = ByPS * wf_.nChannels
  nSamples = tmpSize \ (lChunkSiz)
  ReDim pSrc(nSamples * wf_.nChannels - 1)
 
  Get #1, , pSrc()
  Close #1 ' Close the file.
  Redim_(waveLUT,nSamples)

  ws_base = 16 * 25 * (wf_.nSamplesPerSec / rate)
  samps_per_cycle = nSamples
   
#EndMacro

#Macro macro_Normalize(waveLUT_,nSamples,vol_mult_pre_)
  dim as single highVal
  For I As integer = 0 to nSamples
    dim as single sngL = abs(waveLUT_(I).L)
    dim as single sngR = abs(waveLUT_(I).R)
    if highVal < sngL  then highVal = sngL
    if highVal < sngR  then highVal = sngR
  Next
  if highVal > 0 Then
    dim as single mul_ = 1 / highVal
    mul_ *= vol_mult_pre_
    For I As integer = 0 to nSamples
      waveLUT_(I).L *= mul_
      waveLUT_(I).R *= mul_
    Next
  end if
#EndMacro

Sub LoadWave(ByRef fileName As String,ByVal Normalize_ as Integer=FALSE, ByVal VolMult as Single=1.0, ByVal PlayOnLoad as integer=FALSE)

  Dim As Single vol_mult_pre = Normalize_Volume * VolMult
 
  'ClearPrint(19)
  ClearPrint(18)

  Open fileName For Binary Access Read As #1

  dim as integer    tmpSize, ByPS, lChunkSiz, lChanAdvance
  dim as WaveFormat2 wf_ = WaveReadFormat( 1, tmpSize )

  dim as integer  nSamples
   
  dim as integer  nSampsPer = samps_per_cycle
  if tmpSize > 0 Then
   
    Dim As Byte Ptr     lpByt, lpBytChan
    Dim As Integer Ptr  lpInt
   
    dim as integer  ChanM = wf_.nChannels - 1
    Dim As Integer  Mask_
    Dim As Integer  Sign_
    Dim As Integer  Result_

    If wf_.wBitsPerSample = 8 Then
   
      dim as byte bsamples()
      macro_To_waveLUT_Common(bsamples)
      macro_To_waveLUT(bsamples,bsamples(0))
     
    ElseIf wf_.wBitsPerSample = 16 Then
   
      Dim As Short lsamples()
      macro_To_waveLUT_Common(lsamples)
      macro_To_waveLUT(lsamples,lsamples(0))
     
    elseif wf_.wBitsPerSample = 24 Then
   
      Type Samp24
        As UByte  F1,F2,F3
      End Type
      Dim As Samp24 L3samples()
      macro_To_waveLUT_Common(L3samples)
      macro_To_waveLUT(L3samples,L3samples(0).F1)
     
    elseif wf_.wBitsPerSample = 32 Then
   
      Dim As Single isamples()
      macro_To_waveLUT_Common(isamples)
      For I As integer = 0 to nSamples - 1
        dim as integer PosL = I*wf_.nChannels
        waveLUT(I).L = isamples(PosL)
        waveLUT(I).R = isamples(PosL+ChanM)
      Next

    Else
      samps_per_cycle = 0
      Close #1 ' Close the file.
    end if
   
  else
    samps_per_cycle = 0
    Close #1 ' Close the file.
  End if
 
  if samps_per_cycle > 0 Then
    if Normalize_ Then
      macro_Normalize(waveLUT,nSamples,vol_mult_pre)
    elseif vol_mult_pre <> 1.0 Then
      For I As integer = 0 to nSamples - 1
        waveLUT(I).L *= vol_mult_pre
        waveLUT(I).R *= vol_mult_pre
      Next
      waveLUT(nSamples) = waveLUT(0)
    end If
    ? "loaded ";fileName
    SynthType = SYNTH_WAV
    AVERT_NEW_NOTES = FALSE
    redundant_to_save_wav = TRUE

    if PlayOnLoad then
      dim as single duration = 1.5
      dim as integer note = 48
      LUT_DEMO note , duration
    end if

  else
    ? fileName; "  error!"
    samps_per_cycle = nSampsPer
  end if
 
End Sub


'' -------------
'   SaveWave
' --------------

#Macro zSaveLoad(pVar)
   If DoSave Then
      Put #nFile,,pVar
   Else
      Get #nFile,,pVar
   EndIf
#EndMacro

type SamplerChunk
  as string * 4   ID = "smpl"
  as integer      chunkSize
  as integer      dwManufacturer
  as integer      dwProduct
  as integer      dwSamplePeriod
  as integer      dwMIDIUnityNote
  as integer      dwMIDIPitchFraction
  as integer      dwSMPTEFormat
  as integer      dwSMPTEOffset
  as integer      cSampleLoops
  as integer      cbSamplerData
end type

type SampleLoop
  as integer      dwIdentifier
  as integer      dwType
  as integer      dwStart
  as integer      dwEnd
  as integer      dwFraction
  as integer      dwPlayCount
end type

Sub SaveWave(ByRef fileName As String, waveLUT() As SngLR)

  If redundant_to_save_wav Then exit sub
  if SynthType = SYNTH_RAW then exit sub
  if samps_per_cycle < 1 then exit sub
 
  ClearPrint(18)
 
  dim as single norm_scale = 32767

  ''often with computer programming, ubound = datasize - 1,
  ''but for sample interpolation, I need one extra sample
  ''at the end.
 
  ''This means that "nSamples" = UBound of softsynth array,
  ''instead of "nSamples" = UBound + 1
 
  Dim As Integer nSamps = UBound(waveLUT)

  ''dafhi's synth
  if samps_per_cycle <> nSamps Then nSamps = samps_per_cycle
 
  ''wav file will not include the redundant sample
  dim as integer UB = nSamps - 1

  dim as SngLR          Temp_(UB)
 
  For I As Integer = 0 To UB
    Temp_(I) = waveLUT(I)
  Next

  macro_Normalize(Temp_,UB,norm_scale)
 
  Dim As STEREO_SAMPLE  SampleLR(UB)
  Dim As Single valu
  For I As Integer = 0 To UB
    valu = Temp_(I).L + 0.5
    SampleLR(I).L = floor(valu)
    valu = Temp_(I).R + 0.5
    SampleLR(I).R = floor(valu)
  Next

  'http://www.topherlee.com/software/pcm-tut-wavformat.html
   
  Dim sampleRate as Integer = 44100
  Dim lenfmt As Integer = 16
  Dim wavetype As Short = 1
  Dim bitSize as Short= 16
  Dim nChannels as Short = 2
  Dim As Integer ByPS = bitSize / 8
  Dim As Short   ByPS_X_Chn = ByPS * nChannels
  Dim As Integer   BytesPerOneSecond = ByPS_X_Chn * rate
  Dim nSamples as Integer = nSamps
  Dim waveSize As Integer = ByPS_X_Chn * nSamples
  Dim fileSize as UInteger = waveSize + 36 + 68 ''68 for loop info
 
  dim as SamplerChunk lSampChunk
  dim as SampleLoop   lSampLoop

  dim as short nFile = FreeFile
 
  Open fileName For Binary Access Write As #nFile
 
  '' Write the header
  dim as integer DoSave = TRUE
  zSaveLoad("RIFF")
  zSaveLoad(filesize)
  zSaveLoad("WAVE")
  zSaveLoad("fmt ")
  zSaveLoad( lenfmt)
  zSaveLoad(wavetype)
  zSaveLoad(nChannels)
  zSaveLoad(sampleRate)
  zSaveLoad(BytesPerOneSecond)
  zSaveLoad(ByPS_X_Chn)
  zSaveLoad(bitSize)
  zSaveLoad("data")
  zSaveLoad(waveSize)

  Put #nFile,, sampleLR()

  '' http://www.sonicspot.com/guide/wavefiles.html#smpl
  lSampChunk.cSampleLoops = 1
  lSampChunk.chunkSize = 36 + 24 * lSampChunk.cSampleLoops
  lSampChunk.dwMIDIUnityNote = 60

  zSaveLoad(lSampChunk.ID)
  zSaveLoad(lSampChunk.chunkSize)
  zSaveLoad(lSampChunk.dwManufacturer)
  zSaveLoad(lSampChunk.dwProduct)
  zSaveLoad(lSampChunk.dwSamplePeriod)
  zSaveLoad(lSampChunk.dwMIDIUnityNote)
  zSaveLoad(lSampChunk.dwMIDIPitchFraction)
  zSaveLoad(lSampChunk.dwSMPTEFormat)
  zSaveLoad(lSampChunk.dwSMPTEOffset)
  zSaveLoad(lSampChunk.cSampleLoops)
  zSaveLoad(lSampChunk.cbSamplerData)
 
  lSampLoop.dwEnd = (nSamples - 1)

  zSaveLoad(lSampLoop.dwIdentifier)
  zSaveLoad(lSampLoop.dwType)
  zSaveLoad(lSampLoop.dwStart)
  zSaveLoad(lSampLoop.dwEnd)
  zSaveLoad(lSampLoop.dwFraction)
  zSaveLoad(lSampLoop.dwPlayCount)
 
  Close #nFile ' Close the file.

  ? "saved "; filename

  redundant_to_save_wav = TRUE
 
End Sub


'' -----------------------
'  softsynth - polyphony
' ------------------------

Dim Shared As Integer   NoteOn_Ref(255)

Sub SetFreq(ByRef nvars as notevars, ByVal scancode As Integer, byval note as single, byval velo as single = 1.0, ByVal freq_ As Single = 0, ByVal duration as single)

    If freq_ = 0 Then 'RAW
      nvars.volume = velo * 22000
      nvars.modval = 1
      nvars.baseFreq = 2 ^ (note / 12)
    Else
      nvars.volume = velo
      dim as integer UB = UBound(waveLUT)
      if samps_per_cycle = UB Then
        ''PADsynth or wave file
        nvars.modval = UB
      else
        ''dafhi's synth
        nvars.modval = rate
      end if
      nvars.baseFreq = freq_
    End If

    nvars.chanL.i.func = basefreq * nvars.baseFreq
   
    If SynthType = SYNTH_RAW Then
       nvars.chanL.func = Rnd * nvars.modval
       nvars.chanR.func = Rnd * nvars.modval
    Else
       nvars.chanL.func = 0
       nvars.chanR.func = 0
       nvars.chanL.func2 = 0
       nvars.chanR.func2 = 0
       nvars.chanL.func3 = 0
       nvars.chanR.func3 = 0
    End If

    nvars.chanR.i.func = nvars.chanL.i.func
    nvars.chanL.i.func2 = nvars.chanL.i.func * (1 + 0.003 * (Rnd - 0.5))
    nvars.chanL.i.func3 = nvars.chanL.i.func * (1 + 0.003 * (Rnd - 0.5))
    nvars.chanR.i.func2 = nvars.chanL.i.func * (1 + 0.003 * (Rnd - 0.5))
    nvars.chanR.i.func3 = nvars.chanL.i.func * (1 + 0.003 * (Rnd - 0.5))
    if duration > 0 then
      nvars.release_samples = duration * rate
    else
      nvars.release_samples = -1
    end if
    nvars.release_iVol = 0
    nvars.scancode = scancode
End Sub

#Macro macro_pRef(scancode_)
   Dim As Integer Ptr pRef = @NoteOn_Ref(scancode_)
#EndMacro

#Macro macro_NoteOn_Common()

  Dim As Integer    SUCCESS = FALSE
  Dim As Integer    Index = 1
  Dim As UInteger   samps = shared_notes(Index).release_samples
  For idx As integer = 1 To Polyphony
    If shared_notes(idx).release_samples < samps Then
      samps = shared_notes(Idx).release_samples
      Index = idx
    End If
  Next
   
#EndMacro

Function ChordType.NoteOn(ByVal scancode As Integer, ByVal noteNr As integer, ByVal Velo as Single, ByVal freq_ As single, ByVal duration as single) As Integer
  if AVERT_NEW_NOTES then exit function
  macro_NoteOn_Common()
  shared_notes(Index).scancode = 0
  NoteOn_Ref(scancode) = Index
  SetFreq shared_notes(Index), scancode, noteNr, velo, freq_, duration
  Return SUCCESS
End Function

Sub ChordType.NoteOff(ByVal scancode As Integer,ByVal ReleaseTime As Single)
  if AVERT_NEW_NOTES then exit sub
  macro_pRef( scancode )
  If scancode = shared_notes(*pRef).scancode Then
    ReleaseTime *= rate
    If ReleaseTime <> 0 Then
       With shared_notes(*pRef)
          If ReleaseTime < .release_samples Then
          .release_samples = ReleaseTime
          .release_iVol = -.volume / (ReleaseTime)
          End If
       End With
    End If
  End If
End Sub

Dim Shared As Single        mPitchBend = 1


'' --------------------------------------------------------------------------- '
'                                                                              '
'                             LUT generators                                   '
'                                                                              '
' ---------------------------------------------------------------------------- '

dim shared as single tmpMod

#Macro Modulus(pValue,pModulus)
  tmpMod = pModulus
  pValue -= tmpMod * floor((pValue / tmpMod))
#EndMacro

#Include Once "vbcompat.bi"
Function Progress( ByVal input_ as single, ByVal input_max_ as single = 100 ) as string
    return Format( 100 * input_ / input_max_ , "###.#" ) & "%"
end function


'' ---------------
'    -~- FFT -~-
' ----------------


''2 ^ 10 = 1024
''2 ^ 18 = 262144
Dim As uByte    lutpow = 14

Dim Shared As Integer MaxPowerOfTwo = 20
If lutpow > MaxPowerOfTwo Then lutpow = MaxPowerOfTwo

Dim As Integer   size_PADLUT = 1 Shl lutpow

Function NumberOfBitsNeeded(ByVal PowerOfTwo as Integer) as Integer
    for I As Integer= 0 to MaxPowerOfTwo
        if (PowerOfTwo and (1 shl I)) <> 0 then
            return I
        End If
    Next
    Return 0
End Function
Function ReverseBits(ByVal Index As Integer,ByVal NumBits As Integer) As Integer
  Dim As Integer Rev
  for I As Integer = 0 to NumBits - 1
    Rev Shl= 1
    Rev Or= Index And 1
    Index Shr= 1
  Next
  Return Rev
End Function

Dim Shared As Integer RevBits(size_PADLUT)

Dim As Integer BitsNeeded = NumberOfBitsNeeded(size_PADLUT)
For I As Integer = 0 To size_PADLUT
  RevBits(I) = ReverseBits(I, BitsNeeded)
Next

Function IsPowerOfTwo(ByVal X as Integer) As Integer
  Dim As Integer  I, Y
  Y = 2
  for I = 1 To MaxPowerOfTwo
    if X = Y then Return TRUE
    Y Shl= 1
  Next
  Return FALSE
End Function

Sub FourierTransform(ByVal AngleNumerator As Single, _
                     ByVal NumSamples As Integer, _
                     lpReal As Single Ptr, _
                     lpImag As Single Ptr, _
                     lpRealOut As Single Ptr, _
                     lpImagOut As Single Ptr)
                     
' http://www.koders.com/delphi/fidB6DD10205DAFD71EFF5093D4916237BB2801DD8D.aspx
 
  Dim As Integer I, J, K, N, BlockSize, BlockEnd', NumBits
  Dim As single  Delta_angle, Delta_ar
  Dim As single  Alpha, Beta
  Dim As single  Tr, Ti, Ar, Ai
 
  if not IsPowerOfTwo(NumSamples) or (NumSamples < 2) then
      ?"Error in procedure Fourier:  NumSamples="; NumSamples
      ?" is not a positive integer power of 2."
      Exit Sub
  End If
 
  'NumBits = NumberOfBitsNeeded(NumSamples)
  for I = 0 to NumSamples
    J = RevBits(I)
    lpRealOut[J] = lpReal[I]
    lpImagOut[J] = lpImag[I]
  Next
 
  BlockEnd = 1
  BlockSize = 2
  while BlockSize <= NumSamples
    Delta_angle = AngleNumerator / BlockSize
    Alpha = Sin(0.5 * Delta_angle)
    Alpha = 2.0 * Alpha * Alpha
    Beta = Sin(Delta_angle)

    I = 0
    while I < NumSamples
      Ar = 1.0 ''cos(0)
      Ai = 0.0 ''sin(0)

      J = I
      for N = 0 to BlockEnd - 1
          K = J + BlockEnd
          Tr = Ar * lpRealOut[K] - Ai * lpImagOut[K]
          Ti = Ar * lpImagOut[K] + Ai * lpRealOut[K]
          lpRealOut[K] = lpRealOut[J] - Tr
          lpImagOut[K] = lpImagOut[J] - Ti
          lpRealOut[J] += Tr
          lpImagOut[J] += Ti
          Delta_ar = Alpha * Ar + Beta * Ai
          Ai -= (Alpha * Ai - Beta * Ar)
          Ar -= Delta_ar
          J += 1
      Next

      I += BlockSize
    Wend
   
    Locate 1,1
    ? "Part - of 3: "; Rnd

    BlockEnd = BlockSize
    BlockSize Shl= 1
  Wend
End Sub

Sub FFT(ByVal NumSamples As Integer, _
        lpReal As Single Ptr, _
        lpImag As Single Ptr, _
        lpRealOut As Single Ptr, _
        lpImagOut As Single Ptr)
    FourierTransform( 2 * PI, NumSamples, lpReal, lpImag, lpRealOut, lpImagOut )
    Dim As Single maxval
    For I As Integer = 0 To NumSamples
      If lpImagOut[I] > maxval Then maxval = lpImagOut[I]
    Next
    maxval = Normalize_Volume / maxval
    For I As Integer = 0 To NumSamples
      lpImagOut[I] *= maxval
    Next
End Sub

Dim Shared As Integer morphPage

Dim shared As Single re_L(1,size_PADLUT)
Dim shared As Single im_L(1,size_PADLUT)
Dim shared As Single re_R(1,size_PADLUT)
Dim shared As Single im_R(1,size_PADLUT)

Dim shared As Single temp_(size_PADLUT)
Dim shared As Single out_L(1,size_PADLUT)
Dim shared As Single out_R(1,size_PADLUT)

#Macro macro_Copy_FFT_Result()
  For I As Integer = 0 To size_PADLUT - 1
    waveLUT(I).L = out_L(morphPage,I)
    waveLUT(I).R = out_R(morphPage,I)
  Next
  waveLUT(size_PADLUT) = waveLUT(0)
#EndMacro
 
#Macro macro_abcd_ptrs()
  Dim As Single Ptr a_ = @Re_L(morphPage,0)
  Dim As Single Ptr b_ = @Re_R(morphPage,0)
  Dim As Single Ptr c_ = @Im_L(morphPage,0)
  Dim As Single Ptr d_ = @Im_R(morphPage,0)
#EndMacro

'' ------------
'  PADsynth
' -------------

#Macro AmpToComplex(lpRe_L,lpRe_R,lpIm_L,lpIm_R)
  FOR i As Integer=0 to UBby2
    Dim As Single phase = Rnd * TwoPi
    lpRe_R[i]=freq_amp(i)*cos(phase)
    lpIm_R[i]=freq_amp(i)*sin(phase)
    phase = Rnd * TwoPi
    lpRe_L[i]=freq_amp(i)*cos(phase)
    lpIm_L[i]=freq_amp(i)*sin(phase)
  Next
#EndMacro

Sub PADsynth_Modified( waveLUT() As SngLR, ByVal size_PADLUT As Integer)
 
  /'
   a re-configuration of
   http://zynaddsubfx.sourceforge.net/doc/PADsynth/PADsynth.htm
  '/

  Dim As Integer UBby2 = size_PADLUT /2 - 1
  Dim As Single   freq_amp(UBby2)
 
  ClearPrint(1)
  ? "Part 1 of 3:"
 
  dim as single scale_mod_ = 12
  dim as integer scale(7)
  dim as single note_mod = ubound(scale)
  scale(0)=0
  scale(1)=2
  scale(2)=4
  scale(3)=5
  scale(4)=7
  scale(5)=9
  scale(6)=11
  scale(7)=scale_mod_
 
  dim as single base_freq = 220.0 * (size_PADLUT / 524288)

  for J as integer = 1 to 3 + floor(Rnd * 3)
    dim as integer octave = floor((Rnd) * 6)
    dim as integer note = floor(rnd * note_mod)
    dim as single cf_ = base_freq * Note2Freq( 12 * octave + scale(note)  )
    dim as single bwid_scale = 0.033 * (0.02 + rnd)
    dim as single bf_ = cf_ - 0.5 * bwid_scale
    dim as single df_ = bwid_scale * cf_
    dim as single amp_ = rnd - 0.1
    FOR J As integer=1 to 2 + Rnd * 60
      dim as single freq_ = cf_ * ( 1 + bwid_scale*(rnd - 0.5) )
      freq_amp(freq_) += amp_ * (Rnd - 0.1)
    next
  Next
 
  macro_abcd_ptrs()
 
  AmpToComplex( a_, b_, c_, d_ )
 
  FFT( size_PADLUT, a_, c_, @temp_(0), @out_L(morphPage,0) )
  FFT( size_PADLUT, b_, d_, @temp_(0), @out_R(morphPage,0) )
 
  Redim_(waveLUT,size_PADLUT)
  macro_Copy_FFT_Result()
 
  morphPage = 1 - morphPage
 
  samps_per_cycle = size_PADLUT
 
  redundant_to_save_wav = FALSE
  SynthType = SYNTH_WAV
  AVERT_NEW_NOTES = FALSE
  ws_base = 16 * 25 * (rate / 44100)
   
End Sub

'' ------------------
'  LUTsynth
' -------------------

#Macro t_wave_macro(a)
  a -= floor(a)
  if a > 0.75 then
    a -= 1
  elseif a > 0.25 then
    a = 0.5 - a
  end if
#EndMacro

function twave(byval input_ as double) as double
  t_wave_macro(input_)
  return input_
End Function

Function twave_mod(ByVal input_ As Single, ByVal mod_ As Single) As Single
  modulus(input_, mod_)
  if input_ > mod_ * 0.75 then
    input_ -= mod_
  elseif input_ > mod_ * 0.25 then
    input_ = mod_ * 0.5 - input_
  end if
  return input_
End Function

Dim shared as single    LUT_precision = 25 /' reduce if you like aliasing (heard in low notes)
.. good values: 1, 2, 5, 10, 25, 50, 125, 250, 1250 '/

#Macro macro_LUTBounds()

  '' Recommended: do not change these values.  These create minimum-size LUT,
  '' as well as modulus for incr and pos
  samps_per_cycle =(LUT_precision * rate) / (10000)
  Dim as single   lut_increm = 10000 / (LUT_precision * rate)
 
  Dim as integer  LutMax = floor(samps_per_cycle+1) * (nSamplesPerBuffer) * 2 + rate

#EndMacro

Sub CalcLUT()
 
  macro_LUTBounds()
  Redim_(waveLUT,LutMax)
 
  Dim As UByte Info_Ticks = 50
  Dim as integer J, info_tick = ubound(waveLUT) / Info_Ticks

  dim as integer print_begin = 1
  ClearPrint(print_begin)
  ? "calculating LUT .."

  '' any wave form
  for i as integer =0 to ubound(waveLUT) - 1
    dim as single iPos = lut_increm * i
    dim as single a1 = sin( TwoPi*iPos )
    dim as single a2 = 4 * twave(iPos)
    a1 += a2
    waveLUT(i).L = a1
    waveLUT(i).R = a1
   
    '' progress indicator
    J += 1
    if J = info_tick then
      locate print_begin,30
      a1 = 100 * i / ubound(waveLUT)
      ? Left( Str(a1), 4 ); "%"
      J = 0
    end if
  next
 
  macro_Normalize(waveLUT,LutMax,Normalize_Volume)
  waveLUT(LutMax) = waveLUT(0)

  locate print_begin + 1,1: ? space(7) ''erase progress text
  Locate print_begin, 1
  ? "calculating LUT .. DONE": ?
 
  redundant_to_save_wav = FALSE
  SynthType = SYNTH_WAV
  AVERT_NEW_NOTES = FALSE
  ws_base = 16 * LUT_precision * (rate / 44100)
End Sub


'' -----------------------
'  softsynth - render
' ------------------------

#Macro z_WriteSample_LUT_AddDynamics(pChan,iChan,pfunc2,pfunc3)
  sVal += pfunc2
  sVal += pfunc3
  pChan.func2 += iChan.func2
  pChan.func3 += iChan.func3
#EndMacro

#Macro z_WriteSample_LUT_GetVal(pChan,iChan,pfunc)
  sVal = pFunc
  pChan.func += iChan.func
#EndMacro

#Macro macro_PitchWheel(iChan,pChan)
  iChan.func = pChan.i.func * mPitchBend
  iChan.func2 = pChan.i.func2 * mPitchBend
  iChan.func3 = pChan.i.func3 * mPitchBend
#EndMacro

#Macro z_chanMod(pChan, modval)
  Modulus(pChan.func, (modval))
  Modulus(pChan.func2, modval)
  Modulus(pChan.func3, modval)
#EndMacro

#Macro z_WriteSample_RAW_AddDynamics(pChan,iChan,pfunc)
  sVal += pfunc(pChan.func2)
  sVal += pfunc(pChan.func3)
  pChan.func2 += iChan.func2
  pChan.func3 += iChan.func3
#EndMacro

#Macro WriteSample_RAW(pChan,iChan,pDest,pFunc)
  sVal = pFunc(pChan.func)
  pChan.func += iChan.func
  z_WriteSample_RAW_AddDynamics(pChan,iChan,pFunc)
  pDest += sVal * pNote.Volume
#EndMacro

#Macro macro_CheckMod(func,ifunc)
  sng_ = (pNote.modval - func) / ifunc + 1.0
  TestSamps = floor( sng_ )
  if TestSamps < samps then
    samps = TestSamps
    ResetPos = TRUE
    if Loop_ Then
    else
      If SynthType = SYNTH_WAV Then
        if TestSamps > TestSampsGreatest Then
          TestSampsGreatest = TestSamps
        end if
      end if
    End if
  end if
#EndMacro

#Macro zRenderSlice_AddGetCommon(pfunc,ifunc,lpSrc)
  posA = floor(pfunc)
  valA = lpSrc[posA].sval
  lerp = pfunc - posA
  pfunc += ifunc
#EndMacro

#Define zSampleResult(lpSrc) ( valA + lerp * (lpSrc[posA+1].sval - valA) )

#Macro zRenderSlice_AddVal(pfunc,ifunc,lpSrc)
  zRenderSlice_AddGetCommon(pfunc,ifunc,lpSrc)
  sVal += zSampleResult(lpSrc)
#EndMacro

#Macro zRenderSlice_GetVal(pfunc,ifunc,lpSrc)
  zRenderSlice_AddGetCommon(pfunc,ifunc,lpSrc)
  sVal = zSampleResult(lpSrc)
#EndMacro

#Macro zRenderSlice_Channel(pNote,pChan,iChan,lpSrc,lpDest)
  Do
    dim as integer    samps = nSamples
    dim as integer    ResetPos
    macro_CheckMod(pChan.func,iChan.func)
    macro_CheckMod(pChan.func2,iChan.func2)
    macro_CheckMod(pChan.func3,iChan.func3)
   
    If ivol = 0 Then
      For I as integer = 0 to samps - 1
        zRenderSlice_GetVal( pChan.func, iChan.func, lpSrc )
        zRenderSlice_AddVal( pChan.func2, iChan.func2, lpSrc )
        zRenderSlice_AddVal( pChan.func3, iChan.func3, lpSrc )
        lpDest[I].sval += sVal * pNote.Volume
      Next
    Else
      For I as integer = 0 to samps - 1
        zRenderSlice_GetVal( pChan.func, iChan.func, lpSrc )
        zRenderSlice_AddVal( pChan.func2, iChan.func2, lpSrc )
        zRenderSlice_AddVal( pChan.func3, iChan.func3, lpSrc )
        lpDest[I].sval += sVal * pNote.Volume
        pNote.Volume += ivol
      Next
    EndIf
    nSamples -= samps
    If ResetPos Then
      lpDest += samps
      z_chanMod(pChan, pNote.modval)
    end if
  Loop Until nSamples = 0
  nSamples = save_samps
#EndMacro

Sub RenderSlice(ByRef lpSt As SngLR Ptr, ByVal nSamples As Integer, ByRef pNote As notevars, ByRef iChanL as increments, ByRef iChanR as increments, ByVal Loop_ as integer)
  dim as integer    save_samps = nSamples
  dim as single     sng_
  dim as integer    TestSamps
  dim as integer    TestSampsGreatest
  dim as single     ivol = pNote.release_iVol * 0.5
 
  dim as single     sVal
  dim as integer    posA
  dim as single     lerp
  dim as single     valA
 
  dim as SngLR ptr  lpSrcL = @waveLUT(0).L
  dim as SngLR ptr  lpSrcR = @waveLUT(0).R
  dim as SngLR ptr  lpDstL = @lpSt->L
  dim as SngLR ptr  lpDstR = @lpSt->R
 
  WAVE_BUSY = TRUE
 
  zRenderSlice_Channel(pNote,pNote.ChanL,iChanL,lpSrcL,lpDstL)
  zRenderSlice_Channel(pNote,pNote.ChanR,iChanR,lpSrcR,lpDstR)
 
  WAVE_BUSY = FALSE
 
  if TestSampsGreatest Then
    pNote.release_samples = nSamples
  end if
End Sub

Sub RenderNote(byval lpSt As SngLR ptr, ByVal nSamples as integer, ByRef pNote As notevars, ByVal chord_index as integer)

  If pNote.release_samples <= 0 Then
  Else
   
    '' prevent volume from going nuts if something odd happens
    if pNote.Volume < 0 Then pNote.Volume = 0

    If pNote.release_samples < nSamples Then
      nSamples = pNote.release_samples
    EndIf
    Dim As increments         iChanL
    Dim As increments         iChanR
    macro_PitchWheel( iChanL, pNote.chanL )
    macro_PitchWheel( iChanR, pNote.chanR )
   
    If SynthType = SYNTH_WAV Then
      if samps_per_cycle > 0 Then
        RenderSlice(lpSt,nSamples,pNote,iChanL,iChanR,LoopWave)
      end if

    Else

      dim as single   sVal
     
      For I as integer = 0 to (nSamples - 1)
        WriteSample_RAW( pNote.chanL, iChanL, lpSt[I].L, twave )
        WriteSample_RAW( pNote.chanR, iChanR, lpSt[I].R, twave )
        pNote.Volume += pNote.release_iVol
      Next
      z_chanMod(pNote.chanL, pNote.modval)
      z_chanMod(pNote.chanR, pNote.modval)
     
    End If
    pNote.release_samples -= nSamples
   EndIf
End Sub

'' --------------
'   TimerVars
' ---------------

dim shared as double            gTime

Type TimerVars
    As Double                   destination
    Declare Sub                 Activate( ByVal delay_ as double = 0.0 )
    As Double                   delay
    Declare Property            Update() As Integer
    Declare Property            inside() as integer
    As Double                   remaining
   Private:
    As Integer                  UpdateRequest
End Type
Property TimerVars.Inside() as Integer
    if gTime <= destination Then
        remaining = destination - gTime
        Inside = TRUE
    end if
End Property
Sub TimerVars.Activate( ByVal delay_ as double )
  if SynthRunning Then
    destination = Timer + delay_
    UpdateRequest = TRUE
  End if
End Sub
Property TimerVars.Update() as integer
    If UpdateRequest Then
        If destination < Timer Then
            UpdateRequest = FALSE
            Update = TRUE
        End If
    End if
End Property

dim shared as TimerVars Midi_ReAcquire


'  ########################
' # MIDI->Audio Template #
'########################
#include "windows.bi"
#include "win/mmsystem.bi"

#define DEBUG

#ifdef DEBUG
#define DPRINT(txt) OPEN ERR FOR OUTPUT AS #99:print #99,txt:close #99
#else
#define DPRINT(txt) :
#EndIf

type MIDI_MESSAGE
  union
  type
    as uinteger LNibble :4
    as uinteger HNibble :4
    as uinteger LByte   :7
    as uinteger unussed1:1
    as uinteger HByte   :7
    as uinteger unussed2:9
  end type
  as uinteger value
  end union
end type

const NOTE_OFF = &H8
const NOTE_ON = &H9

' ########################
' # simple MIDI in class #
' ########################
type MIDIIN_DEVICE
  declare Constructor'(DeviceIndex as integer=0) ' default = first MIDI port
  declare destructor
  declare sub ReAcquire
  private:
  declare static sub MidiInProc(byval hMidiIn   as HMIDIIN, _
                                byval DriverMsg as DWORD  , _
                                byval pDevice   as MIDIIN_DEVICE ptr, _
                                byval MidiMsg   as MIDI_MESSAGE, _
                                byval MidiTime  as DWORD)
  as integer  ISOpen,IsRunning
  as MMRESULT LastResult
  as HMIDIIN  hDevice
end type

sub MIDIIN_DEVICE.ReAcquire
  Dim As Integer Dev_
 
  '' -----------------------------------------------------
  ' - midi in caps - modified from a post by alfakilo
  ' -----------------------------------------------------
 
  Dim As Integer nMidis=midiInGetNumDevs()
  Dim As Integer ret
  Dim As MIDiInCAPS caps
 
  If nMidis<1 Then
    ? "error: sorry no midi input on this system!"
    Midi_ReAcquire.Activate 2.5
    MIDI_NOT_RUNNING = TRUE
    Beep: Exit sub
  ElseIf nMidis = 1 Then
    Dev_ = 0
    ret=midiInGetDevCaps(Dev_,@caps,Sizeof(MIDiInCAPS))
    ? "MIDI device: "; caps.szPname
  Else
    For i As Integer=0 To nMidis-1
      ret=midiInGetDevCaps(i,@caps,Sizeof(MIDiInCAPS))
      If ret=0 Then
      ? "[" & i & "] =" & caps.szPname
      Else
      Beep:? "warning can't get caps from device[" & i & "] !"
      End If
    Next
    If nMidis>1 Then
      ? "select one midiIn device a number between 0 and " & nMidis-1 & " and press enter/return!"
      Input Dev_
    Else
      Dev_=-1
    End If
  End If
 
  For Purge As Integer = 1 To 2
    LastResult = midiInOpen(@hDevice,_
                      Dev_, _
                      cast(uinteger,@MidiInProc), _
                      cast(uinteger,@This), _
                      CALLBACK_FUNCTION or MIDI_IO_STATUS)
   
    IsOpen = (LastResult = MMSYSERR_NOERROR)
   
    if IsOpen then
    LastResult = midiInStart(hDevice)
    IsRunning = (LastResult = MMSYSERR_NOERROR)
    end If
 
    if (IsOpen=0) or (IsRunning=0) then
      if LastResult = 4 then
        'already connected
      else
      ? "MIDIIN_DEVICE error: "; LastResult
      end if
    end if
    If Purge = 1 Then
       if IsRunning then midiInStop  hDevice
       if IsOpen    then midiInClose hDevice
    End If
  Next

  MIDI_NOT_RUNNING = Not IsRunning
     
End Sub

Constructor MIDIIN_DEVICE
  ReAcquire
End constructor

destructor MIDIIN_DEVICE
  if (hDevice<>NULL) then
    if IsRunning then midiInStop  hDevice
    if IsOpen    then midiInClose hDevice
  end if
end destructor

' the midi in callback
sub MIDIIN_DEVICE.MidiInProc(byval hMidiIn   as HMIDIIN, _
                             byval DriverMsg as DWORD  , _
                             byval pDevice   as MIDIIN_DEVICE ptr, _
                             byval MidiMsg   as MIDI_MESSAGE, _
                             byval MidiTime  as DWORD)

  dim as integer note,vel
  dim as short v16
  select case as const DriverMsg
  case MIM_DATA
    'dprint("MIM_DATA param1=" & hex(MidiMsg,8) & " param2=" & MidiTime)
    select case as const MidiMsg.HNibble
    case &H8
      note = MidiMsg.LByte
      'dprint("Note Off " & note)
      mychord.NoteOff( note, release_time )
    case &H9
      note = MidiMsg.LByte
      vel  = MidiMsg.HByte
      if vel=0 then
        'dprint("Note Off " & note)
        mychord.NoteOff( note, release_time )
      else
        'dprint("Note On  " & note & " vel " & vel)
        NoteON__LUT_VS_RAW note, vel / 127
      end if
    case &HA':dprint("Polyphonic Pressure " & MidiMsg.LByte & "," & MidiMsg.HByte)
    case &HB':dprint("Control Change      " & MidiMsg.LByte & "," & MidiMsg.HByte)
    case &HC':dprint("Program Change      " & MidiMsg.LByte)
    case &HD':dprint("Channel Pressure    " & MidiMsg.LByte)
    case &HE: v16  = MidiMsg.HByte - 63
        If v16 > 0 Then v16 -= 1
        Dim As Single Whole_Step = 2
        mPitchBend = 2 ^ (Whole_Step * (v16 / 63) / 12)
        'dprint("Pitch Wheel Control " & v16)
    case &HF ' (SysEx)
      select case as const MidiMsg.LNibble
      case &h0 : dprint("System Exclusive")
      case &h1 : dprint("Time Code")
      case &h2 : dprint("Song Position Pointer")
      case &h3 : dprint("Song Select")
      case &h6 : dprint("Tune Request")
      case &h8 : dprint("Timing Clock")
      case &hA : dprint("Sart")
      case &hB : dprint("Continue")
      case &hC : dprint("Stop")
      case &HE : dprint("Active Sensing")
      case &HF : dprint("System Reset")
      end select
    end select
  case MIM_OPEN      : dprint("MIM_OPEN")
  case MIM_CLOSE     : dprint("MIM_CLOSE")
    Midi_ReAcquire.Activate 1.0
  case MIM_LONGDATA  : dprint("MIM_LONGDATA")
  case MIM_ERROR     : dprint("MIM_ERROR")
  case MIM_LONGERROR : dprint("MIM_LONGERROR")
  case MIM_MOREDATA  : dprint("MIM_MOREDATA")
  end select
end sub


' ##########################
' # simple AUDIO out class #
' ##########################

type WAVEOUT_DEVICE
  declare constructor(DeviceIndex as integer=-1) ' default = WAVE_MAPPER
  declare destructor
  private:
  declare static sub WaveOutProc(hDevice       as HWAVEOUT, _
                                 DriverMessage as uinteger, _
                                 pDevice       as WAVEOUT_DEVICE ptr, _
                                 pWaveHeader   as PWAVEHDR, _
                                 Param2        as DWORD)
  declare sub PrepareBuffer(pBuffer as PWAVEHDR)
  as WAVEFORMATEX     wfex
  as WAVEOUTCAPS      Caps
  as HWAVEOUT         hDevice
  as MMRESULT         LastResult
  as PWAVEHDR ptr     Buffers
  as integer          IsAccurate,IsOpen,IsRunning
  as integer          nPlayedBuffers
end type


constructor WAVEOUT_DEVICE(DeviceIndex as integer)

  LastResult = waveOutGetDevCaps(DeviceIndex, _
                                 @Caps, _
                                 sizeof(WAVEOUTCAPS))
  if (LastResult=MMSYSERR_NOERROR) then
    with caps
    ISAccurate = (.dwSupport and WAVECAPS_SAMPLEACCURATE)
    end with
  end if
  with wfex
    .wFormatTag      = WAVE_FORMAT_PCM
    .nSamplesPerSec  = rate
    .nChannels       = 2
    .wBitsPerSample  = 16
    .nBlockAlign     = (.wBitsPerSample shr 3) * .nChannels
    .nAvgBytesPerSec = .nBlockAlign * .nSamplesPerSec
    .cbSize          = 0 ' no extra bytes
  end with
  LastResult = waveOutOpen(@hDevice, _
                           DeviceIndex, _
                           cptr(LPCWAVEFORMATEX,@wfex), _
                           cast(uinteger,@WaveOutProc), _
                           cast(uinteger,@this), _
                           CALLBACK_FUNCTION)
 
  ' prepare buffers
  if IsOpen then
    dim as integer size = wfex.nBlockAlign
    size*=nSamplesPerBuffer
    Buffers=callocate(nBuffers*sizeof(PWAVEHDR))
    for i as integer =0 to nBuffers-1
      Buffers[i] = callocate(sizeof(WAVEHDR))
      with *Buffers[i]
        .lpData         = callocate(size)
        .dwBufferLength = size
        .dwUser         = i
        .dwFlags        = 0
      end with
      LastResult = waveOutPrepareHeader(hDevice   , _
                                        Buffers[i], _
                                        sizeof(WAVEHDR))
     
    next
    for i as integer=0 to nBuffers-1
      waveOutWrite(hDevice,Buffers[i],sizeof(WAVEHDR))
    next
    IsRunning=1
  end if
end constructor

' stop the device and free all resources
destructor WAVEOUT_DEVICE
  if (hDevice<>NULL) then
    if (IsOpen<>0) then
      if (IsRunning<>0) then
        IsRunning=0
        waveOutReset hDevice ' mark all buffer as done
        sleep 1100
      end if
      if (Buffers<>NULL) then
        if (nBuffers>0) then
          for i as integer = 0 to nBuffers-1
            if (Buffers[i]<>NULL) then
              if (Buffers[i]->dwFlags and WHDR_PREPARED) then
                waveOutUnprepareHeader(hDevice,Buffers[i],sizeof(WAVEHDR))
              end if
              if Buffers[i]->lpData then deallocate Buffers[i]->lpData
              deallocate Buffers[i]
            end if
          next
        end if
        deallocate Buffers
      end if
      waveOutClose hDevice
    end if
  end if
  dprint("WAVEOUT_DEVICE~")
end destructor

' the audio out callback
sub WAVEOUT_DEVICE.WaveOutProc(hDevice   as HWAVEOUT, _
                               DriverMsg as uinteger, _
                               pDevice   as WAVEOUT_DEVICE ptr, _
                               pBuffer   as PWAVEHDR, _
                               Param2    as DWORD)
  select case as const DriverMsg
  case WOM_DONE
    pDevice->nPlayedBuffers+=1
    if pDevice->IsRunning then
      pDevice->PrepareBuffer(pBuffer)
    else
      DPRINT("WOM_DONE")
    end if
  case WOM_OPEN : dprint("WOM_OPEN")
    pDevice->IsOpen = 1
  case WOM_CLOSE : dprint("WOM_CLOSE")
    pDevice->IsOpen = 0
  end select
end sub

#Macro LimitThenCopy(pSrc,pDest)
  if pSrc > 32767 then
    pSrc = 32767
  elseif pSrc < -32767 then
    pSrc = -32767
  end if
  pSrc += 0.5
  pDest = floor(pSrc)
#EndMacro

sub WAVEOUT_DEVICE.PrepareBuffer(pBuffer as PWAVEHDR)
   
  waveOutUnprepareHeader(hDevice,pBuffer,sizeof(WAVEHDR))
  pBuffer->dwFlags = 0

  ' pointer to the 16 bit stereo samples
  Dim as STEREO_SAMPLE ptr pSamples  = cptr(STEREO_SAMPLE ptr,pBuffer->lpData)
 
  Dim as SngLR SngNull

   ' zero left and right channels
  For lpLR as SngLR ptr = @precision_buf(0) to @precision_buf(nSamplesPerBuffer-1)
    *lpLR = SngNull
  Next
   
  For J As integer = 1 To Polyphony
    RenderNote( @precision_buf(0), nSamplesPerBuffer, shared_notes(J), J )
  Next
 
  For I as integer = 0 to nSamplesPerBuffer - 1
    dim as SngLR ptr lpSrcLR = @precision_buf(I)
    LimitThenCopy(lpSrcLR->L, pSamples[I].L)
    LimitThenCopy(lpSrcLR->R, pSamples[I].R)
  Next
 
  ' prepare and write the new buffer
  if (IsRunning<>0) then
    waveOutPrepareHeader(hDevice,pBuffer,sizeof(WAVEHDR))
    waveOutWrite(hDevice,pBuffer,sizeof(WAVEHDR))
  end if
 
end sub

'' -----------------
'   Main
' ------------------

#include "fbgfx.bi"

using FB
dim as event e
dim as integer Ctrl_Key_Down

'' ------------------
'  QWERTY controller
' -------------------

dim shared as ubyte Note_QWERTY(255)
Note_QWERTY(SC_Q) = 48
Note_QWERTY(SC_W) = 50
Note_QWERTY(SC_E) = 52
Note_QWERTY(SC_R) = 53
Note_QWERTY(SC_T) = 55

Note_QWERTY(SC_2) = 49
Note_QWERTY(SC_3) = 51
Note_QWERTY(SC_5) = 54

Note_QWERTY(SC_Z) = 36
Note_QWERTY(SC_X) = 38
Note_QWERTY(SC_C) = 40
Note_QWERTY(SC_V) = 41
Note_QWERTY(SC_B) = 43

Note_QWERTY(SC_S) = 37
Note_QWERTY(SC_D) = 39
Note_QWERTY(SC_G) = 42

#Macro QWERTY_Controller(EVENT_)

  ''SC_S not included here because also used for save wav
 
  Case  SC_Q,SC_W,SC_E,SC_R,SC_T,SC_2,SC_3,SC_5, _
        SC_Z,SC_X,SC_C,SC_V,SC_B,SC_D,SC_G
  If EVENT_ = NOTE_ON Then
    LUT_DEMO( Note_QWERTY(e.scancode) )
  ElseIf EVENT_ = NOTE_OFF Then
    mychord.NoteOff Note_QWERTY(e.scancode)
  End if
#EndMacro

'' ------------------
'  load wavetable
' -------------------

if str_InitialWaveFile <> "" Then
  LoadWave str_InitialWaveFile, NormalizeOnLoad
elseIf SynthType = SYNTH_WAV Then
  CalcLUT
End if

'' ------------------
'  engage hyperdrive
' -------------------

ReDim precision_buf(nSamplesPerBuffer-1)

if waveOutGetNumDevs()<1 then
  ? "sorry no active WAVE output device !"
  beep
end if

dim as WAVEOUT_DEVICE WaveOut
dim as MIDIIN_DEVICE  MidiIn

If Not MIDI_NOT_RUNNING Then
? "play your MIDI keys single notes or chords ..."
? "you can see all messages for pitch wheel"
? "and all other controllers too"
end if

ScreenRes 480,360

If MIDI_NOT_RUNNING Then
  ?"play C D E F G using Q W E R T"
end if

locate 5,1
? "Key Commands:"
?
? "7 - PADsynth LUT"
? "8 - simple LUT"
? "9 - Load mywave.wav"
? "0 - formula"
?
? "Ctrl S - LUT to mywave.wav"
?
? "U - Save randname.wav"
?
? "Press 'P' at any time to reset the synth engine"

SynthRunning = TRUE

Do While SynthRunning
 
  If (ScreenEvent(@e)) Then
   
    If e.type = EVENT_KEY_PRESS Then
     
      Select Case e.scancode
      QWERTY_Controller(NOTE_ON)
      Case SC_S
        if Ctrl_Key_Down Then
          SaveWave("mywave.wav",waveLUT())
        else
          '' qwerty controller
          LUT_DEMO( Note_QWERTY(e.scancode) )
        End If
      Case SC_P
        MyChord.Panic
      Case SC_7
        PADsynth_Modified( waveLUT(), size_PADLUT )
      Case SC_8
        CalcLUT
      Case SC_9
        LoadWave "mywave.wav", NormalizeOnLoad
      Case SC_0
        ClearPrint(1)
        ? "formula synth"
        SynthType = SYNTH_RAW
      Case SC_U
        SaveWave(left(str(rnd),9) & ".wav",waveLUT())
      Case SC_CONTROL
        Ctrl_Key_Down = TRUE
      case SC_ESCAPE
        SynthRunning = FALSE
      End select
     
    elseif e.type = EVENT_KEY_RELEASE Then
     
      Select Case e.scancode
      QWERTY_Controller(NOTE_OFF)
      case SC_S
        '' QWERTY controller
        mychord.NoteOff Note_QWERTY(e.scancode)
      Case SC_CONTROL
        Ctrl_Key_Down = FALSE
      End Select
     
    endif
   
  End If
 
  If Midi_ReAcquire.Update Then
    ?
    ?"Midi connection lost .. attempting reconnect"
    ?
    MidiIn.ReAcquire
    MyChord.Panic
  End if 
  sleep 10
Loop

dim shared as integer   AUTOSAVE_ONEXIT = FALSE

if AUTOSAVE_ONEXIT Then
  if SynthType = SYNTH_WAV Then
    SaveWave(left(str(rnd),9) & ".wav",waveLUT())
  end if
end if
Last edited by dafhi on Dec 16, 2014 7:09, edited 22 times in total.
dafhi
Posts: 1373
Joined: Jun 04, 2005 9:51

Re: midi softsynth

Postby dafhi » Apr 26, 2012 15:49

you can use this to create a wav file

Code: Select all

Randomize

Type SampleLR
   As Short      L
   As Short      R
End Type

#Ifndef FALSE
Const as integer FALSE = 0
Const as integer TRUE = not FALSE
#endif

#Ifndef floor
#Define floor(x) ((x*2.0-0.5)shr 1) '' http://www.freebasic.net/forum/viewtopic.php?p=118633
#define ceil(x) (-((-x*2.0-0.5)shr 1))
#endif

#Macro t_wave_macro(a)

  ''      0.25            ''
  ''      /  \            ''
  ''     /    \           ''
  ''    /      \          ''
  ''  0.0      0.0        ''
  ''             \      / ''
  ''              \    /  ''
  ''               \  /   ''
  ''              -0.25   ''
 
    a -= floor(a)
    if a > 0.75 then
        a -= 1
    elseif a > 0.25 then
        a = 0.5 - a
    end if
#EndMacro

function twave(byval input_ as double) as Double
    t_wave_macro(input_)
    return input_
End function

#Macro zSaveLoad(pVar)
   If DoSave Then
      Put #1,,pVar
   Else
      Get #1,,pVar
   EndIf
#EndMacro

#Macro LimitVal(val_,mult_)
  val_ *= (mult_)
  if val_ > 32767 then
    val_ = 32767
  elseif val_ < -32767 then
    val_ = -32767
  end if
#EndMacro

Sub SaveWave(ByRef fileName As String)

  Dim As Integer      samps_per_cycle = 200
  Dim As Integer      sampsU = samps_per_cycle - 1
  Dim As Single       bIncr = 1 / sampsU
  Dim As Single       two_pi = 8 * Atn(1)
  dim as single       pos2_L = 1 + 0.01 * (rnd + 1)
  dim as single       pos2_R = 1 + 0.01 * (rnd + 1)

  Dim As SampleLR     sampleLR(sampsU)

  For I As integer = 0 to sampsU
 
    Dim As Single pos_ = bIncr * I
   
    '' range: -0.5 to 0.5
    Dim As Single sine = 0.5 * Sin(two_pi * pos_)
    Dim As Single saw = pos_ - floor(pos_) - 0.5
    dim as single waves_ = sine + saw
   
    Dim As Single tri_L = twave(pos_) + twave(pos_ * pos2_L)
    dim as single sng_L = (tri_L + waves_) / 3
   
    Dim As Single tri_R = twave(pos_) + twave(pos_ * pos2_R)
    dim as single sng_R = (tri_R + waves_) / 3
   
    LimitVal(sng_L,65535)
    LimitVal(sng_R,65535)
    sampleLR(I).L = sng_L
    sampleLR(I).R = sng_R
 
  Next
   
   'http://www.topherlee.com/software/pcm-tut-wavformat.html
   
   Dim sampleRate as Integer = 44100 / 2
   Dim lenfmt As Integer = 16
   Dim wavetype As Short = 1
   Dim bitSize as Short= 16
   Dim nChannels as Short = 2
   Dim As Integer ByPS = bitSize / 8
   Dim As Short   ByPS_X_Chn = ByPS * nChannels
   Dim As Integer   BytesPerOneSecond = ByPS_X_Chn * sampleRate
   Dim nSamples as Integer = samps_per_cycle
   Dim waveSize As Integer = ByPS_X_Chn * nSamples
   Dim fileSize as Integer = waveSize + 44
   
   Open fileName For Binary Access Write As #1

   '' Write the header
  dim as integer DoSave = TRUE
   zSaveLoad("RIFF")
   zSaveLoad(filesize)
   zSaveLoad("WAVE")
   zSaveLoad("fmt ")
   zSaveLoad( lenfmt)
   zSaveLoad(wavetype)
   zSaveLoad(nChannels)
   zSaveLoad(sampleRate)
   zSaveLoad(BytesPerOneSecond)
   zSaveLoad(ByPS_X_Chn)
   zSaveLoad(bitSize)
   zSaveLoad("data")
   zSaveLoad(waveSize)

  Put #1,, sampleLR()

  Close #1 ' Close the file.
 
  ? "saved "; filename
 
End Sub

SaveWave "temp.wav"

sleep 2000


Here is the previous midi synth

Code: Select all

/' midi softsynth by dafhi

1.  Raw, based on user defined functions.  cpu-expensive, but great quality,
limitless possibility, and intuitive

2.  Look-Up Table, creates a digital sample of several waveform cycles,
requires mental gymnastics to ensure proper looping.

3.  Wav file reader.
'/

#Ifndef FALSE
Const as integer FALSE = 0
Const as integer TRUE = not FALSE
#endif

Const                   SYNTH_RAW = 0
Const                   SYNTH_LUT = 1
Const                   SYNTH_WAV = 2

Dim shared as integer   SynthType = SYNTH_LUT

dim shared as string    strWaveFile
dim shared as integer   LoopWave = TRUE
strWaveFile = "temp.wav"


'' if your audio skips, mess with these
Dim shared as integer   nBuffers= 5
dim shared as integer   nSamplesPerBuffer = 230
Dim Shared As Integer   rate = 44100 \ 1


'' ---------------------
'  more customizations
' ---------------------

Dim Shared As UByte     Polyphony = 10
dim shared as single    release_time = 0.8

Dim shared as single    LUT_precision = 25 /' reduce if you like aliasing (heard in low notes)
.. good values: 1, 2, 5, 10, 25, 50, 125, 250, 1250 '/

'' ---------------------
'  Common
' ---------------------

Dim Shared As Integer   SynthRunning
dim shared as single    samps_per_cycle

#Ifndef floor
#Define floor(x) (((x)*2.0-0.5)shr 1) '' http://www.freebasic.net/forum/viewtopic.php?p=118633
#define ceil(x) (-((-(x)*2.0-0.5)shr 1))
#endif

Union SngLR
  As Single             sval
  Type
    As single             L
    As single             R
  End Type
End Union

dim shared as SngLR     waveLUT()
dim shared as SngLR     precision_buf()

#Macro Modulus(pValue,pModulus)
   pValue -= pModulus * floor(pValue / pModulus)
#EndMacro

#Macro t_wave_macro(a)
    a -= floor(a)
    if a > 0.75 then
        a -= 1
    elseif a > 0.25 then
        a = 0.5 - a
    end if
#EndMacro

function twave(byval input_ as double) as double
    t_wave_macro(input_)
    return input_
End function

Type increments
    as Single           func
    as Single           func2
    as Single           func3
end type

type chan field = 4
    as Double           func
    as Double           func2
    as Double           func3
    as increments       i
end type

type notevars
    as chan             chanL
    as chan             chanR
    as single           volume
    as single           baseFreq
    as single           modval
    As Integer          scancode
    As UInteger         release_samples
    As Single           release_iVol
End Type

Dim Shared As notevars  shared_notes(1 To polyphony)
Dim Shared As Integer   NoteOn_Ref(255)

Dim Shared As Single    basefreq

Sub SetFreq(ByRef nvars as notevars, ByVal scancode As Integer, byval note as single, byval velo as single = 1.0, ByVal freq_ As Single = 0)

    If freq_ = 0 Then 'RAW
      basefreq = (44100 / rate) / 200
      nvars.modval = 1
      nvars.baseFreq = 2 ^ (note / 12)
      nvars.volume = 12000 * velo
    Else 'LUT or WAV
      nvars.volume = 6000 * velo
      if SynthType = SYNTH_WAV Then
        nvars.modval = UBound(waveLUT)
        nvars.baseFreq = freq_
      else
        nvars.modval = rate
        nvars.baseFreq = freq_
      end if
    End If

    nvars.chanL.i.func = basefreq * nvars.baseFreq
   
    If SynthType = SYNTH_RAW Then
       nvars.chanL.func = Rnd * nvars.modval
       nvars.chanR.func = Rnd * nvars.modval
    ElseIf SynthType = SYNTH_LUT or SynthType = SYNTH_WAV Then
       nvars.chanL.func = 0
       nvars.chanR.func = 0
       nvars.chanL.func2 = 0
       nvars.chanR.func2 = 0
       nvars.chanL.func3 = 0
       nvars.chanR.func3 = 0
    End If

    nvars.chanR.i.func = nvars.chanL.i.func
    nvars.chanL.i.func2 = nvars.chanL.i.func * (1 + 0.003 * (Rnd - 0.5))
    nvars.chanL.i.func3 = nvars.chanL.i.func * (1 + 0.003 * (Rnd - 0.5))
    nvars.chanR.i.func2 = nvars.chanL.i.func * (1 + 0.003 * (Rnd - 0.5))
    nvars.chanR.i.func3 = nvars.chanL.i.func * (1 + 0.003 * (Rnd - 0.5))
    nvars.release_samples = -1
    nvars.release_iVol = 0
    nvars.scancode = scancode
End Sub

Type ChordType
   Declare Function   NoteOn(ByVal scancode As Integer, ByVal noteNr As Integer = 0, ByVal Velo as single = 0.7, ByVal freq_ As Single = 0) As Integer
   Declare sub        NoteOff(ByVal scancode As Integer,ByVal ReleaseTime As Single = 1.0)
   Declare sub        Panic
  private:
  as integer          Dummy
End Type
Sub ChordType.Panic
  For I as integer = 1 to Polyphony
    shared_notes(I).release_samples = 0
  Next
End Sub

#Macro macro_pRef(scancode_)
   Dim As Integer Ptr pRef = @NoteOn_Ref(scancode_)
#EndMacro

#Macro macro_NoteOn_Common()

   Dim As Integer SUCCESS = FALSE
   Dim As Integer Index = 1
   Dim As UInteger   samps = shared_notes(Index).release_samples
   For idx As integer = 1 To Polyphony
      If shared_notes(idx).release_samples < samps Then
         samps = shared_notes(Idx).release_samples
         Index = idx
      End If
   Next
   
#EndMacro

Function ChordType.NoteOn(ByVal scancode As Integer, ByVal noteNr As integer, ByVal Velo as Single, ByVal freq_ As single) As Integer
   macro_NoteOn_Common()
   shared_notes(Index).scancode = 0
   NoteOn_Ref(scancode) = Index
   SetFreq shared_notes(Index), scancode, noteNr, velo, freq_
   Return SUCCESS
End Function

Sub ChordType.NoteOff(ByVal scancode As Integer,ByVal ReleaseTime As Single)
   macro_pRef( scancode )
   If scancode = shared_notes(*pRef).scancode Then
      ReleaseTime *= rate
      If ReleaseTime <> 0 Then
         With shared_notes(*pRef)
            If ReleaseTime < .release_samples Then
            .release_samples = ReleaseTime
            .release_iVol = -.volume / (ReleaseTime)
            End If
         End With
      End If
   End If
End Sub

Dim Shared As ChordType     mychord

Dim Shared As Single        mPitchBend = 1


'' ============================== ''
''                                ''
''           TimerVars            ''
''                                ''
''                                ''

/'
  To re-acquire midi upon lost connection
'/

dim shared as double            gTime

Type TimerVars
    As Double                   destination
    Declare Sub                 Activate( ByVal delay_ as double = 0.0 )
    As Double                   delay
    Declare Property            Update() As Integer
    Declare Property            inside() as integer
    As Double                   remaining
   Private:
    As Integer                  UpdateRequest
End Type
Property TimerVars.Inside() as Integer
    if gTime <= destination Then
        remaining = destination - gTime
        Inside = TRUE
    end if
End Property
Sub TimerVars.Activate( ByVal delay_ as double )
  if SynthRunning Then
    destination = Timer + delay_
    UpdateRequest = TRUE
  End if
End Sub
Property TimerVars.Update() as integer
    If UpdateRequest Then
        If destination < Timer Then
            UpdateRequest = FALSE
            Update = TRUE
        End If
    End if
End Property

dim shared as TimerVars Midi_ReAcquire

' |                            | '
' |        TimerVars           | '
' +----------------------------+ '

'  ########################
' # MIDI->Audio Template #
'########################
#include "windows.bi"
#include "win/mmsystem.bi"

#define DEBUG

#ifdef DEBUG
#define DPRINT(txt) OPEN ERR FOR OUTPUT AS #99:print #99,txt:close #99
#else
#define DPRINT(txt) :
#EndIf

type MIDI_MESSAGE
  union
  type
    as uinteger LNibble :4
    as uinteger HNibble :4
    as uinteger LByte   :7
    as uinteger unussed1:1
    as uinteger HByte   :7
    as uinteger unussed2:9
  end type
  as uinteger value
  end union
end type

' ########################
' # simple MIDI in class #
' ########################
type MIDIIN_DEVICE
  declare Constructor'(DeviceIndex as integer=0) ' default = first MIDI port
  declare destructor
  declare sub ReAcquire
  private:
  declare static sub MidiInProc(byval hMidiIn   as HMIDIIN, _
                                byval DriverMsg as DWORD  , _
                                byval pDevice   as MIDIIN_DEVICE ptr, _
                                byval MidiMsg   as MIDI_MESSAGE, _
                                byval MidiTime  as DWORD)
  as integer  ISOpen,IsRunning
  as MMRESULT LastResult
  as HMIDIIN  hDevice
end type

sub MIDIIN_DEVICE.ReAcquire
  Dim As Integer Dev_
 
  '' -----------------------------------------------------
  ' - midi in caps - modified from a post by alfakilo
  ' -----------------------------------------------------
 
  Dim As Integer nMidis=midiInGetNumDevs()
  Dim As Integer ret
  Dim As MIDiInCAPS caps

  If nMidis<1 Then
      ? "error: sorry no midi input on this system!"
      Midi_ReAcquire.Activate 2.5
      Beep: Exit sub':Sleep:End
   ElseIf nMidis = 1 Then
      Dev_ = 0
      ret=midiInGetDevCaps(Dev_,@caps,Sizeof(MIDiInCAPS))
      ? "MIDI device: "; caps.szPname
   Else
      For i As Integer=0 To nMidis-1
         ret=midiInGetDevCaps(i,@caps,Sizeof(MIDiInCAPS))
         If ret=0 Then
         ? "[" & i & "] =" & caps.szPname
         Else
         Beep:? "warning can't get caps from device[" & i & "] !"
         End If
      Next
      If nMidis>1 Then
         ? "select one midiIn device a number between 0 and " & nMidis-1 & " and press enter/return!"
         Input Dev_
      Else
         Dev_=-1
      End If
   End If

   For Purge As Integer = 1 To 2
      LastResult = midiInOpen(@hDevice,_
                        Dev_, _
                        cast(uinteger,@MidiInProc), _
                        cast(uinteger,@This), _
                        CALLBACK_FUNCTION or MIDI_IO_STATUS)
     
      IsOpen = (LastResult = MMSYSERR_NOERROR)
     
      if IsOpen then
      LastResult = midiInStart(hDevice)
      IsRunning = (LastResult = MMSYSERR_NOERROR)
      end If
     
      if (IsOpen=0) or (IsRunning=0) then
        if LastResult = 4 then
          'already connected
        else
        ? "MIDIIN_DEVICE error: "; LastResult
        end if
      end if
      If Purge = 1 Then
         if IsRunning then midiInStop  hDevice
         if IsOpen    then midiInClose hDevice
      End If
   Next
End Sub

Constructor MIDIIN_DEVICE
  ReAcquire
  ' macro_MidiDevs(LastResult,hDevice)
   'dim as MMRESULT pLastRes
End constructor

destructor MIDIIN_DEVICE
  if (hDevice<>NULL) then
    if IsRunning then midiInStop  hDevice
    if IsOpen    then midiInClose hDevice
  end if
end destructor

Dim shared as single       ws_base

Function Note2Freq(n as integer) as double
  return (ws_base) * 2 ^ ((n - 67) / 12)
end Function

' the midi in callback
sub MIDIIN_DEVICE.MidiInProc(byval hMidiIn   as HMIDIIN, _
                             byval DriverMsg as DWORD  , _
                             byval pDevice   as MIDIIN_DEVICE ptr, _
                             byval MidiMsg   as MIDI_MESSAGE, _
                             byval MidiTime  as DWORD)

  dim as integer note,vel
  dim as short v16
  select case as const DriverMsg
  case MIM_DATA     
    'dprint("MIM_DATA param1=" & hex(MidiMsg,8) & " param2=" & MidiTime)
    select case as const MidiMsg.HNibble
    case &H8
      note = MidiMsg.LByte
      dprint("Note Off " & note)
      mychord.NoteOff( note, release_time )
    case &H9
      note = MidiMsg.LByte
      vel  = MidiMsg.HByte
      if vel=0 then
        dprint("Note Off " & note)
        mychord.NoteOff( note, release_time )
      else
        dprint("Note On  " & note & " vel " & vel)
        select case SynthType
        Case SYNTH_RAW: mychord.NoteOn( note, note - 57, vel / 127 )
        Case SYNTH_LUT, SYNTH_WAV: mychord.NoteOn( note, 0, vel / 127, Note2Freq(note) )
        End Select
      end if
    case &HA:dprint("Polyphonic Pressure " & MidiMsg.LByte & "," & MidiMsg.HByte)
    case &HB:dprint("Control Change      " & MidiMsg.LByte & "," & MidiMsg.HByte)
    case &HC:dprint("Program Change      " & MidiMsg.LByte)
    case &HD:dprint("Channel Pressure    " & MidiMsg.LByte)
    case &HE: v16  = MidiMsg.HByte - 63
        If v16 > 0 Then v16 -= 1
        Dim As Single Whole_Step = 2
        mPitchBend = 2 ^ (Whole_Step * (v16 / 63) / 12)
        dprint("Pitch Wheel Control " & v16)
    case &HF ' (SysEx)
      select case as const MidiMsg.LNibble
      case &h0 : dprint("System Exclusive")
      case &h1 : dprint("Time Code")
      case &h2 : dprint("Song Position Pointer")
      case &h3 : dprint("Song Select")
      case &h6 : dprint("Tune Request")
      case &h8 : dprint("Timing Clock")
      case &hA : dprint("Sart")
      case &hB : dprint("Continue")
      case &hC : dprint("Stop")
      case &HE : dprint("Active Sensing")
      case &HF : dprint("System Reset")
      end select
    end select
  case MIM_OPEN      : dprint("MIM_OPEN")
  case MIM_CLOSE     : dprint("MIM_CLOSE")
    Midi_ReAcquire.Activate 1.0
  case MIM_LONGDATA  : dprint("MIM_LONGDATA")
  case MIM_ERROR     : dprint("MIM_ERROR")
  case MIM_LONGERROR : dprint("MIM_LONGERROR")
  case MIM_MOREDATA  : dprint("MIM_MOREDATA")
  end select
end sub

type STEREO_SAMPLE
  union
  type
  as short LeftChn
  as short RightChn
  end type
  as uinteger BothChn
  end union
End Type

Dim shared as STEREO_SAMPLE ptr pSamples
dim shared as integer nActive,firstNote=128,LastNote=-1


' ##########################
' # simple AUDIO out class #
' ##########################

type WAVEOUT_DEVICE
  declare constructor(DeviceIndex as integer=-1) ' default = WAVE_MAPPER
  declare destructor
  private:
  declare static sub WaveOutProc(hDevice       as HWAVEOUT, _
                                 DriverMessage as uinteger, _
                                 pDevice       as WAVEOUT_DEVICE ptr, _
                                 pWaveHeader   as PWAVEHDR, _
                                 Param2        as DWORD)
  declare sub PrepareBuffer(pBuffer as PWAVEHDR)
  as WAVEFORMATEX     wfex
  as WAVEOUTCAPS      Caps
  as HWAVEOUT         hDevice
  as MMRESULT         LastResult
  as PWAVEHDR ptr     Buffers
  as integer          IsAccurate,IsOpen,IsRunning
  as integer          nPlayedBuffers
end type


'' ------------------
'   wav reader
' ----------------

Private Type FileHeader
    lRiff As Integer
    lFileSize As Integer
    lWave As Integer
    lFormat As Integer
    lFormatLength As Integer
End Type

Private Type WaveFormat2
    wFormatTag As Short
    nChannels As Short
    nSamplesPerSec As Integer
    nAvgBytesPerSec As Integer
    nBlockAlign As Short
    wBitsPerSample As Short
End Type

Private Type ChunkHeader
    lType As Integer
    lLen As Integer
End Type

Private Function WaveReadFormat(ByVal InFileNum As Short, ByRef lDataLength As Integer) As WaveFormat2
 
    'http://www.vbforums.com/showthread.php?t=388562
   
    Dim header As FileHeader
    Dim HdrFormat As WaveFormat2
    Dim chunk As ChunkHeader
    Dim by As Byte
    Dim i As Integer
   
    Get #InFileNum, 1, header
   
    If header.lRiff <> &H46464952 Then Exit Function
    If header.lWave <> &H45564157 Then Exit Function
    If header.lFormat <> &H20746D66 Then Exit Function
   
    If header.lFormatLength < 16 Then Exit Function
   
    Get #InFileNum, , HdrFormat
   
    ' Seek to next chunk by discarding any format bytes.
    For i = 1 To header.lFormatLength - 16
        Get #InFileNum, , by
    Next
   
    ' Ignore chunks until we get to the "data" chunk.
    Get #InFileNum, , chunk
    Do While chunk.lType <> &H61746164
        For i = 1 To chunk.lLen
            Get #InFileNum, , by
        Next
        Get #InFileNum, , chunk
    Loop
   
    lDataLength = chunk.lLen ' Retrieve the size of the data.
   
    WaveReadFormat = HdrFormat
End Function

Sub LoadWave(ByRef fileName As String, ByVal DoSave As Integer = 0, ByVal TestSave as Integer = 0)
   
  Open fileName For Binary Access Read As #1

  dim as integer    tmpSize
  dim as WaveFormat2 wf_ = WaveReadFormat( 1, tmpSize )
 
  if tmpSize > 0 Then

    basefreq = (wf_.nSamplesPerSec / rate) / 800
    dim as integer  ChanM = wf_.nChannels - 1
   
    dim as integer  nSamples
   
    if wf_.wBitsPerSample = 16 Then
     
      nSamples = tmpSize \ (2 * wf_.nChannels)   
      ReDim waveLUT(nSamples)
      dim as short lsamples(nSamples * wf_.nChannels - 1)
      Get #1, , lsamples()
      For I As integer = 0 to nSamples - 1
        dim as integer PosL = I*wf_.nChannels
        waveLUT(I).L = lsamples(PosL) / &H8000
        waveLUT(I).R = lsamples(PosL+ChanM) / &H8000
      Next
      waveLUT(nSamples) = waveLUT(0)
      samps_per_cycle = nSamples
     
    elseif wf_.wBitsPerSample = 8 Then

      nSamples = tmpSize \ (1 * wf_.nChannels)
      ReDim waveLUT(nSamples)
      dim as byte bsamples(nSamples * wf_.nChannels - 1)
      Get #1, , bsamples()
      For I As integer = 0 to nSamples - 1
        dim as integer PosL = I*wf_.nChannels
        waveLUT(I).L = bsamples(PosL) / &H80
        waveLUT(I).R = bsamples(PosL+ChanM) / &H80
      Next
      waveLUT(nSamples) = waveLUT(0)
      samps_per_cycle = nSamples
     
      samps_per_cycle = nSamples
     
    elseif wf_.wBitsPerSample = 32 Then
     
      nSamples = tmpSize \ (4 * wf_.nChannels)
      ReDim waveLUT(nSamples)
      dim as single isamples(nSamples * wf_.nChannels - 1)
      Get #1, , isamples()
      For I As integer = 0 to nSamples - 1
        dim as integer PosL = I*wf_.nChannels
        waveLUT(I).L = isamples(PosL)
        waveLUT(I).R = isamples(PosL+ChanM)
      Next
      waveLUT(nSamples) = waveLUT(0)
      samps_per_cycle = nSamples
     
    else
     
      samps_per_cycle = 0
    end if
   
  else
    samps_per_cycle = 0
  End if

  if samps_per_cycle = 0 Then
      ?
      ? "wave file error!"
      ?
  end if
  Close #1 ' Close the file.
End Sub


'' Definition for Format(), used below
#include "string.bi"

#Macro macro_LUTBounds()

  '' Recommended: do not change these values.  These create minimum-size LUT,
  '' as well as modulus for signal incr and pos
  samps_per_cycle =(LUT_precision * rate) / (10000)
  Dim as single   lut_increm = 10000 / (LUT_precision * rate)
 
  Dim as integer  LutMax = floor(samps_per_cycle+1) * (nSamplesPerBuffer) * 2 + rate

#EndMacro

Sub CalcLUT()
 
  basefreq = (44100 / rate) / 200
 
  macro_LUTBounds()
  ReDim waveLUT(LutMax)
 
  Dim As UByte Info_Ticks = 50
  Dim as integer J, info_tick = ubound(waveLUT) / Info_Ticks

  dim as integer print_begin = 1
  Locate print_begin,1
  ? "calculating LUT .."

  '' any wave form
  for i as integer =0 to ubound(waveLUT)
    dim as single iPos = lut_increm * i
    dim as single a1 = sin( atn(1)*iPos )
    dim as single a2 = 4 * twave(iPos)
    a1 += a2
    a1 *= 0.25
    waveLUT(i).L = a1
    waveLUT(i).R = a1
   
    '' progress indicator
    J += 1
    if J = info_tick then
      locate print_begin + 1,1
      a1 = 100 * i / ubound(waveLUT)
      ? "%";Left( Str(a1), 4 )
      J = 0
    end if
  next
 
  locate print_begin + 1,1: ? space(7) ''erase progress text
  Locate print_begin, 1
  ? "calculating LUT .. DONE": ?
End Sub

constructor WAVEOUT_DEVICE(DeviceIndex as integer)

  LastResult = waveOutGetDevCaps(DeviceIndex, _
                                 @Caps, _
                                 sizeof(WAVEOUTCAPS))
  if (LastResult=MMSYSERR_NOERROR) then
    with caps
    ISAccurate = (.dwSupport and WAVECAPS_SAMPLEACCURATE)
    end with
  end if
  with wfex
    .wFormatTag      = WAVE_FORMAT_PCM
    .nSamplesPerSec  = rate
    .nChannels       = 2
    .wBitsPerSample  = 16
    .nBlockAlign     = (.wBitsPerSample shr 3) * .nChannels
    .nAvgBytesPerSec = .nBlockAlign * .nSamplesPerSec
    .cbSize          = 0 ' no extra bytes
  end with
  LastResult = waveOutOpen(@hDevice, _
                           DeviceIndex, _
                           cptr(LPCWAVEFORMATEX,@wfex), _
                           cast(uinteger,@WaveOutProc), _
                           cast(uinteger,@this), _
                           CALLBACK_FUNCTION)
 
  ' prepare buffers
  if IsOpen then
    dim as integer size = wfex.nBlockAlign
    size*=nSamplesPerBuffer
    Buffers=callocate(nBuffers*sizeof(PWAVEHDR))
    for i as integer =0 to nBuffers-1
      Buffers[i] = callocate(sizeof(WAVEHDR))
      with *Buffers[i]
        .lpData         = callocate(size)
        .dwBufferLength = size
        .dwUser         = i
        .dwFlags        = 0
      end with
      LastResult = waveOutPrepareHeader(hDevice   , _
                                        Buffers[i], _
                                        sizeof(WAVEHDR))
     
    next
    for i as integer=0 to nBuffers-1
      waveOutWrite(hDevice,Buffers[i],sizeof(WAVEHDR))
    next
    IsRunning=1
  end if
end constructor

' stop the device and free all resources
destructor WAVEOUT_DEVICE
  if (hDevice<>NULL) then
    if (IsOpen<>0) then
      if (IsRunning<>0) then
        IsRunning=0
        waveOutReset hDevice ' mark all buffer as done
        sleep 1100
      end if
      if (Buffers<>NULL) then
        if (nBuffers>0) then
          for i as integer = 0 to nBuffers-1
            if (Buffers[i]<>NULL) then
              if (Buffers[i]->dwFlags and WHDR_PREPARED) then
                waveOutUnprepareHeader(hDevice,Buffers[i],sizeof(WAVEHDR))
              end if
              if Buffers[i]->lpData then deallocate Buffers[i]->lpData
              deallocate Buffers[i]
            end if
          next
        end if
        deallocate Buffers
      end if
      waveOutClose hDevice
    end if
  end if
  dprint("WAVEOUT_DEVICE~")
end destructor

' the audio out callback
sub WAVEOUT_DEVICE.WaveOutProc(hDevice   as HWAVEOUT, _
                               DriverMsg as uinteger, _
                               pDevice   as WAVEOUT_DEVICE ptr, _
                               pBuffer   as PWAVEHDR, _
                               Param2    as DWORD)
  select case as const DriverMsg
  case WOM_DONE
    pDevice->nPlayedBuffers+=1
    if pDevice->IsRunning then
      pDevice->PrepareBuffer(pBuffer)
    else
      DPRINT("WOM_DONE")
    end if
  case WOM_OPEN : dprint("WOM_OPEN")
    pDevice->IsOpen = 1
  case WOM_CLOSE : dprint("WOM_CLOSE")
    pDevice->IsOpen = 0
  end select
end sub


' -----------
'   Synth
'-----------

#Macro z_WriteSample_LUT_AddDynamics(pChan,iChan,pfunc2,pfunc3)
  sVal += pfunc2
  sVal += pfunc3
  pChan.func2 += iChan.func2
  pChan.func3 += iChan.func3
#EndMacro

#Macro z_WriteSample_LUT_GetVal(pChan,iChan,pfunc)
  sVal = pFunc
  pChan.func += iChan.func
#EndMacro

#Macro macro_PitchWheel(iChan,pChan)
iChan.func = pChan.i.func * mPitchBend
iChan.func2 = pChan.i.func2 * mPitchBend
iChan.func3 = pChan.i.func3 * mPitchBend
#EndMacro

#Macro z_chanMod(pChan, modval)
  Modulus(pChan.func, modval)
  Modulus(pChan.func2, modval)
  Modulus(pChan.func3, modval)
#EndMacro

#Macro z_WriteSample_AddDynamics(pChan,iChan,pfunc)
  sVal += pfunc(pChan.func2)
  sVal += pfunc(pChan.func3)
  pChan.func2 += iChan.func2
  pChan.func3 += iChan.func3
#EndMacro

#Macro WriteSample(pChan,iChan,pDest,pFunc)
  sVal = pFunc(pChan.func)
  pChan.func += iChan.func
  z_WriteSample_AddDynamics(pChan,iChan,pFunc)
  pDest += sVal * pNote.Volume
#EndMacro

#Macro macro_CheckMod(func,ifunc)
  sng_ = (pNote.modval - func) / ifunc + 1.0
  TestSamps = floor( sng_ )
  if TestSamps < samps then
    samps = TestSamps
    ResetPos = TRUE
    if Loop_ Then
    else
      If SynthType = SYNTH_WAV Then
        if TestSamps > TestSampsGreatest Then
          TestSampsGreatest = TestSamps
        end if
      end if
    End if
  end if
#EndMacro

#Macro zRenderWave_AddGetCommon(pfunc,ifunc,lpSrc)
  posA = floor(pfunc)
  valA = lpSrc[posA].sval
  lerp = pfunc - posA
  pfunc += ifunc
#EndMacro

#Define zSampleResult(lpSrc) ( valA + lerp * (lpSrc[posA+1].sval - valA) )

#Macro zRenderWave_AddVal(pfunc,ifunc,lpSrc)
  zRenderWave_AddGetCommon(pfunc,ifunc,lpSrc)
  sVal += zSampleResult(lpSrc)
#EndMacro

#Macro zRenderWave_GetVal(pfunc,ifunc,lpSrc)
  zRenderWave_AddGetCommon(pfunc,ifunc,lpSrc)
  sVal = zSampleResult(lpSrc)
#EndMacro

#Macro zRenderWave_Channel(pNote,pChan,iChan,lpSrc,lpDest)
  Do
    dim as integer    samps = nSamples
    dim as integer    ResetPos
    macro_CheckMod(pChan.func,iChan.func)
    macro_CheckMod(pChan.func2,iChan.func2)
    macro_CheckMod(pChan.func3,iChan.func3)
    For I as integer = 0 to samps - 1
      zRenderWave_GetVal( pChan.func, iChan.func, lpSrc )
      zRenderWave_AddVal( pChan.func2, iChan.func2, lpSrc )
      zRenderWave_AddVal( pChan.func3, iChan.func3, lpSrc )
      lpDest[I].sval += sVal * pNote.Volume
      pNote.Volume += ivol
    Next
    nSamples -= samps
    If ResetPos Then
      lpDest += samps
      z_chanMod(pChan, pNote.modval)
    end if
  Loop Until nSamples = 0
  nSamples = save_samps
#EndMacro

Sub RenderWave(ByRef lpSt As SngLR Ptr, ByVal nSamples As Integer, ByRef pNote As notevars, ByRef iChanL as increments, ByRef iChanR as increments, ByVal Loop_ as integer)
  dim as integer    save_samps = nSamples
  dim as single     sng_
  dim as integer    TestSamps
  dim as integer    TestSampsGreatest
  dim as single     ivol = pNote.release_iVol * 0.5
 
  dim as single     sVal
  dim as integer    posA
  dim as single     lerp
  dim as single     valA
 
  dim as SngLR ptr  lpSrcL = @waveLUT(0).L
  dim as SngLR ptr  lpSrcR = @waveLUT(0).R
  dim as SngLR ptr  lpDstL = @lpSt->L
  dim as SngLR ptr  lpDstR = @lpSt->R
 
  zRenderWave_Channel(pNote,pNote.ChanL,iChanL,lpSrcL,lpDstL)
  zRenderWave_Channel(pNote,pNote.ChanR,iChanR,lpSrcR,lpDstR)
 
  if TestSampsGreatest Then
    pNote.release_samples = nSamples
  end if
End Sub

Sub RenderNote(byval lpSt As SngLR ptr, ByVal nSamples as integer, ByRef pNote As notevars, ByVal chord_index as integer)

  If pNote.release_samples = 0 Then
  Else
   
    '' prevent volume from going nuts if something odd happens
    if pNote.Volume < 0 Then pNote.Volume = 0

    If pNote.release_samples < nSamples Then
      nSamples = pNote.release_samples
    EndIf
    Dim As increments         iChanL
    Dim As increments         iChanR
    macro_PitchWheel( iChanL, pNote.chanL )
    macro_PitchWheel( iChanR, pNote.chanR )
   
    If SynthType = SYNTH_WAV Then
      if samps_per_cycle > 0 Then
        z_chanMod(iChanL, samps_per_cycle)
        z_chanMod(iChanR, samps_per_cycle)
        RenderWave(lpSt,nSamples,pNote,iChanL,iChanR,LoopWave)
      end if

    Else

      dim as single             sVal
      If SynthType = SYNTH_RAW Then
     
        For I as integer = 0 to (nSamples - 1)
          WriteSample( pNote.chanL, iChanL, lpSt[I].L, twave )
          WriteSample( pNote.chanR, iChanR, lpSt[I].R, twave )
          pNote.Volume += pNote.release_iVol
        Next
        z_chanMod(pNote.chanL, pNote.modval)
        z_chanMod(pNote.chanR, pNote.modval)
     
      ElseIf SynthType = SYNTH_LUT Then
       
        z_chanMod(iChanL, samps_per_cycle)
        z_chanMod(iChanR, samps_per_cycle)
        RenderWave(lpSt,nSamples,pNote,iChanL,iChanR,LoopWave)
     
      End If
    End If
    pNote.release_samples -= nSamples
   EndIf
End Sub

#Macro LimitThenCopy(pSrc,pDest)
  if pSrc > 32767 then
    pSrc = 32767
  elseif pSrc < -32767 then
    pSrc = -32767
  end if
  pSrc += 0.5
  pDest = floor(pSrc)
#EndMacro

sub WAVEOUT_DEVICE.PrepareBuffer(pBuffer as PWAVEHDR)
   
  waveOutUnprepareHeader(hDevice,pBuffer,sizeof(WAVEHDR))
  pBuffer->dwFlags = 0

  ' pointer to the 16 bit stereo samples
  pSamples  = cptr(STEREO_SAMPLE ptr,pBuffer->lpData)
 
  Dim as SngLR SngNull

   ' zero left and right channels
  For lpLR as SngLR ptr = @precision_buf(0) to @precision_buf(nSamplesPerBuffer-1)
    *lpLR = SngNull
  Next
   
  For J As integer = 1 To Polyphony
    RenderNote( @precision_buf(0), nSamplesPerBuffer, shared_notes(J), J )
  Next
 
  For I as integer = 0 to nSamplesPerBuffer - 1
    dim as SngLR ptr lpSrcLR = @precision_buf(I)
    LimitThenCopy(lpSrcLR->L, pSamples[I].LeftChn)
    LimitThenCopy(lpSrcLR->R, pSamples[I].RightChn)
  Next
 
  ' prepare and write the new buffer
  if (IsRunning<>0) then
    waveOutPrepareHeader(hDevice,pBuffer,sizeof(WAVEHDR))
    waveOutWrite(hDevice,pBuffer,sizeof(WAVEHDR))
  end if
 
end sub

'
' main
'

redim precision_buf(nSamplesPerBuffer-1)
If SynthType = SYNTH_LUT Then
  ws_base = 32 * LUT_precision * (rate / 44100)
  CalcLUT
ElseIf SynthType = SYNTH_WAV Then
  ws_base = 32 * LUT_precision * (rate / 44100)
  LoadWave strWaveFile
End if
 
if midiInGetNumDevs()<1 then
  ? "sorry no active MIDI input device !"
  beep':sleep:end
end if

if waveOutGetNumDevs()<1 then
  ? "sorry no active WAVE output device !"
  beep:sleep:end
end if

dim as WAVEOUT_DEVICE WaveOut
dim as MIDIIN_DEVICE  MidiIn

? "play your MIDI keys single notes or chords ..."
? "you can see all messages for pitch wheel"
? "and all other controllers too"

#include "fbgfx.bi"

using FB
dim as event e

ScreenRes 480,360
? "Press 'P' at any time to reset the synth engine"

SynthRunning = TRUE

Do While SynthRunning
  If (ScreenEvent(@e)) Then
      if e.type = EVENT_KEY_RELEASE Then
        Select Case e.scancode
        Case SC_ESCAPE
          SynthRunning = FALSE
        Case SC_P
          MyChord.Panic
        End Select
      endif
  End If
  If Midi_ReAcquire.Update Then
    ?
    ?"Midi connection lost .. attempting reconnect"
    ?
    MidiIn.ReAcquire
    MyChord.Panic
    'macro_MidiDevs(MidiIn.LastResult,MidiIn.hDevice)
  End if 
  sleep 200
Loop
veggie
Posts: 75
Joined: May 17, 2009 12:52

Re: midi softsynth

Postby veggie » May 18, 2012 11:34

Now this is a great project, well done!
dafhi
Posts: 1373
Joined: Jun 04, 2005 9:51

Re: midi softsynth

Postby dafhi » May 18, 2012 16:54

Thank you. Some day I shall simplify this into a general sound thingy. I am quite pleased for how this sounds as a synth.
veggie
Posts: 75
Joined: May 17, 2009 12:52

Re: midi softsynth

Postby veggie » May 29, 2012 11:12

Dafhi I would like to understand this code a little better, is there any online resources that you would recommend? Sound synthesis is something I am interested in but it's pretty difficult to find a clear explanation of the techniques involved.
dafhi
Posts: 1373
Joined: Jun 04, 2005 9:51

Re: midi softsynth

Postby dafhi » May 29, 2012 23:21

All sounds at any given time may be thought of as "one" signal.
As such, layering or stacking, this is where many synth designers start.

I modified the top of my source so you can make your own sound.

Code: Select all

#Macro macro_LUT_Simple()

  '' default synth.  look-up table for cpu-friendly operation

  for i as integer =0 to ubound(waveLUT) - 1
 
    dim as single iPos = lut_increm * i
   
    '' uncomment below to layer additional functions
   
    dim as Single triangle = 4 * twave(iPos)
    Dim As Single sawtooth '= iPos - floor(iPos) - 0.5
    dim as Single sine '= sin( TwoPi*iPos )
   
    Dim As Single sum = sine + 2 * (triangle + sawtooth)
     
    waveLUT(i).L = sum
    waveLUT(i).R = sum
   
    macro_ProgressIndicator()
   
  next
#EndMacro

'' ---------------
'               
' ----------------

Const                   SYNTH_WAV = 0
Const                   SYNTH_RAW = 1

Dim shared as integer   SynthType = SYNTH_WAV

#Ifndef FALSE
Const as integer FALSE = 0
Const as integer TRUE = not FALSE
#endif

dim shared as string    str_InitialWaveFile
dim shared as integer   NormalizeOnLoad = FALSE
dim shared as integer   LoopWave = TRUE

'str_InitialWaveFile = "temp.wav"


'' if audio skips, mess with these
Dim shared as integer   nBuffers= 5
dim shared as integer   nSamplesPerBuffer = 230
Dim Shared As Integer   rate = 44100 \ 1


'' -----------------------------
'  common initializations
' ------------------------------

dim shared as integer   Normalize_Volume = 5000

Dim Shared As UByte     Polyphony = 16
dim shared as single    release_time = 0.1

'' ---------------------
'  Common Vars
' ---------------------

Dim Shared As Integer   SynthRunning

dim shared as single    samps_per_cycle
Dim shared as single    ws_base

Dim shared as single    TwoPi = 8 * atn(1)
#ifndef Pi
Const                   pi    = 4 * Atn(1)
#EndIf

Randomize

Dim Shared As Single    basefreq: basefreq = (44100 / rate) / 200

#Ifndef floor
#Define floor(x) (((x)*2.0-0.5)shr 1) '' http://www.freebasic.net/forum/viewtopic.php?p=118633
#define ceil(x) (-((-(x)*2.0-0.5)shr 1))
#endif

Function Note2Freq(n as integer) as double
  return (ws_base) * 2 ^ ((n - 67) / 12)
end Function

Union SngLR
  As Single             sval
  Type
    As single           L
    As single           R
  End Type
End Union

Dim shared as SngLR     waveLUT()
dim shared as SngLR     precision_buf()

Type STEREO_SAMPLE
  union
  type
  as short L
  as short R
  end type
  as uinteger Both
  end union
End Type

Type increments
    as Single           func
    as Single           func2
    as Single           func3
end type

type chan field = 4
    as Double           func
    as Double           func2
    as Double           func3
    as increments       i
end type

type notevars
    as chan             chanL
    as chan             chanR
    as single           volume
    as single           baseFreq
    as single           modval
    As Integer          scancode
    As UInteger          release_samples
    As Single           release_iVol
End Type

Dim Shared As notevars  shared_notes(1 To polyphony)

Type ChordType
   Declare Function   NoteOn(ByVal scancode As Integer, ByVal noteNr As Integer = 0, ByVal Velo as single = 0.7, ByVal freq_ As Single = 0, ByVal duration as single = 0) As Integer
   Declare sub        NoteOff(ByVal scancode As Integer,ByVal ReleaseTime As Single = release_time)
   Declare sub        Panic
  private:
  as integer          Dummy
End Type
Sub ChordType.Panic
  For I as integer = 1 to Polyphony
    shared_notes(I).release_samples = 0
  Next
End Sub

Dim Shared As ChordType     mychord

dim shared as integer   MIDI_NOT_RUNNING
dim shared as integer   DEMO_NOTE = 48

Sub NoteON__LUT_VS_RAW(Byval note as ubyte, ByVal velo_ as single = 0.7, byval duration as single = 0)
  select case SynthType
  Case SYNTH_RAW: mychord.NoteOn( note, note - 57, velo_,, duration )
  Case SYNTH_WAV: mychord.NoteOn( note, 0, velo_, Note2Freq(note), duration )
  End Select
End Sub

Sub LUT_DEMO(ByVal note_val as integer = 0, ByVal duration as single = 0)
  if note_val > 0 Then
    dim as single velocity = 0.7
    NoteON__LUT_VS_RAW note_val, velocity, duration
  elseif MIDI_NOT_RUNNING Then
    ''demo the new wave
    mychord.NoteOn( DEMO_NOTE, 0, 1.0, Note2Freq(DEMO_NOTE), duration )
  end if
End Sub

dim shared as integer       WAVE_BUSY
dim shared as integer       AVERT_NEW_NOTES
dim shared as integer       OldUB

#Macro Redim_(wLUT,NewUBound)
  OldUB = UBound(wLUT)
  if OldUB <> NewUBound Then
    AVERT_NEW_NOTES = TRUE
    While WAVE_BUSY
      sleep 1
    Wend
    mychord.Panic
    Redim wLUT(NewUBound)
  end if
#EndMacro

dim shared as integer   redundant_to_save_wav


'' -------------
'  Text Helper
' --------------

dim shared as string    strLineCLR: strLineCLR = space(50)
#Macro ClearPrint(LineNR)
  locate LineNR,1
  ? strLineCLR
  Locate LineNR,1
#EndMacro


'' -------------
'   Load Wav
' --------------

Private Type FileHeader
    lRiff As Integer
    lFileSize As Integer
    lWave As Integer
    lFormat As Integer
    lFormatLength As Integer
End Type

Private Type WaveFormat2
    wFormatTag As Short
    nChannels As Short
    nSamplesPerSec As Integer
    nAvgBytesPerSec As Integer
    nBlockAlign As Short
    wBitsPerSample As Short
End Type

Private Type ChunkHeader
    lType As Integer
    lLen As Integer
End Type

Private Function WaveReadFormat(ByVal InFileNum As Short, ByRef lDataLength As Integer) As WaveFormat2
 
    'http://www.vbforums.com/showthread.php?t=388562
   
    Dim header As FileHeader
    Dim HdrFormat As WaveFormat2
    Dim chunk As ChunkHeader
    Dim by As Byte
    Dim i As Integer
   
    Get #InFileNum, 1, header
   
    If header.lRiff <> &H46464952 Then Exit Function
    If header.lWave <> &H45564157 Then Exit Function
    If header.lFormat <> &H20746D66 Then Exit Function
   
    If header.lFormatLength < 16 Then Exit Function
   
    Get #InFileNum, , HdrFormat
   
    ' Seek to next chunk by discarding any format bytes.
    For i = 1 To header.lFormatLength - 16
        Get #InFileNum, , by
    Next
   
    ' Ignore chunks until we get to the "data" chunk.
    Get #InFileNum, , chunk
    Do While chunk.lType <> &H61746164
        For i = 1 To chunk.lLen
            Get #InFileNum, , by
        Next
        Get #InFileNum, , chunk
    Loop
   
    lDataLength = chunk.lLen ' Retrieve the size of the data.
   
    WaveReadFormat = HdrFormat
End Function

#Macro macro_PosNeg_TwosCompl(out_,lpSrc_)
  lpInt = lpSrc_
  If (*lpInt And Sign_) Then
    Result_ = -((*lpInt And Mask_ - 1) Xor Mask_)
  Else
    Result_ = (*lpInt And Mask_)
  End If
  out_ = Result_ * mul_
#EndMacro

#Macro macro_To_waveLUT(pSrc,pSrc0)

  Sign_ = 1 Shl (wf_.wBitsPerSample - 1)
  Mask_ = Sign_ - 1
  Dim As Single mul_ = 1 / Sign_
  lChanAdvance = ChanM * ByPS
  lpByt = @pSrc0
 
  For I As integer = 0 to nSamples - 1
    macro_PosNeg_TwosCompl( waveLUT(I).L, lpByt )
    lpBytChan = lpByt + lChanAdvance
    macro_PosNeg_TwosCompl( waveLUT(I).R, lpBytChan )
    lpByt += lChunkSiz
  Next

#EndMacro

#Macro macro_To_waveLUT_Common(pSrc)
 
  ByPS = wf_.wBitsPerSample Shr 3
  lChunkSiz = ByPS * wf_.nChannels
  nSamples = tmpSize \ (lChunkSiz)
  ReDim pSrc(nSamples * wf_.nChannels - 1)
 
  Get #1, , pSrc()
  Close #1 ' Close the file.
  Redim_(waveLUT,nSamples)

  ws_base = 16 * 25 * (wf_.nSamplesPerSec / rate)
  samps_per_cycle = nSamples
   
#EndMacro

#Macro macro_Normalize(waveLUT_,nSamples,vol_mult_pre_)
  dim as single highVal
  For I As integer = 0 to nSamples
    dim as single sngL = abs(waveLUT_(I).L)
    dim as single sngR = abs(waveLUT_(I).R)
    if highVal < sngL  then highVal = sngL
    if highVal < sngR  then highVal = sngR
  Next
  if highVal > 0 Then
    dim as single mul_ = 1 / highVal
    mul_ *= vol_mult_pre_
    For I As integer = 0 to nSamples
      waveLUT_(I).L *= mul_
      waveLUT_(I).R *= mul_
    Next
  end if
#EndMacro

Sub LoadWave(ByRef fileName As String,ByVal Normalize_ as Integer=FALSE, ByVal VolMult as Single=1.0, ByVal PlayOnLoad as integer=FALSE)

  Dim As Single vol_mult_pre = Normalize_Volume * VolMult
 
  ClearPrint(18)

  Open fileName For Binary Access Read As #1

  dim as integer    tmpSize, ByPS, lChunkSiz, lChanAdvance
  dim as WaveFormat2 wf_ = WaveReadFormat( 1, tmpSize )

  dim as integer  nSamples
   
  dim as integer  nSampsPer = samps_per_cycle
  if tmpSize > 0 Then
   
    Dim As Byte Ptr     lpByt, lpBytChan
    Dim As Integer Ptr  lpInt
   
    dim as integer  ChanM = wf_.nChannels - 1
    Dim As Integer  Mask_
    Dim As Integer  Sign_
    Dim As Integer  Result_

    If wf_.wBitsPerSample = 8 Then
   
      dim as byte bsamples()
      macro_To_waveLUT_Common(bsamples)
      macro_To_waveLUT(bsamples,bsamples(0))
     
    ElseIf wf_.wBitsPerSample = 16 Then
   
      Dim As Short lsamples()
      macro_To_waveLUT_Common(lsamples)
      macro_To_waveLUT(lsamples,lsamples(0))
     
    elseif wf_.wBitsPerSample = 24 Then
   
      Type Samp24
        As UByte  F1,F2,F3
      End Type
      Dim As Samp24 L3samples()
      macro_To_waveLUT_Common(L3samples)
      macro_To_waveLUT(L3samples,L3samples(0).F1)
     
    elseif wf_.wBitsPerSample = 32 Then
   
      Dim As Single isamples()
      macro_To_waveLUT_Common(isamples)
      For I As integer = 0 to nSamples - 1
        dim as integer PosL = I*wf_.nChannels
        waveLUT(I).L = isamples(PosL)
        waveLUT(I).R = isamples(PosL+ChanM)
      Next

    Else
      samps_per_cycle = 0
      Close #1 ' Close the file.
    end if
   
  else
    samps_per_cycle = 0
    Close #1 ' Close the file.
  End if
 
  if samps_per_cycle > 0 Then
    if Normalize_ Then
      macro_Normalize(waveLUT,nSamples,vol_mult_pre)
    elseif vol_mult_pre <> 1.0 Then
      For I As integer = 0 to nSamples - 1
        waveLUT(I).L *= vol_mult_pre
        waveLUT(I).R *= vol_mult_pre
      Next
      waveLUT(nSamples) = waveLUT(0)
    end If
    ? "loaded ";fileName
    SynthType = SYNTH_WAV
    AVERT_NEW_NOTES = FALSE
    redundant_to_save_wav = TRUE

    if PlayOnLoad then
      dim as single duration = 1.5
      dim as integer note = 48
      LUT_DEMO note , duration
    end if

  else
    ? fileName; "  error!"
    samps_per_cycle = nSampsPer
  end if
 
End Sub


'' -------------
'   SaveWave
' --------------

#Macro zSaveLoad(pVar)
   If DoSave Then
      Put #nFile,,pVar
   Else
      Get #nFile,,pVar
   EndIf
#EndMacro

type SamplerChunk
  as string * 4   ID = "smpl"
  as integer      chunkSize
  as integer      dwManufacturer
  as integer      dwProduct
  as integer      dwSamplePeriod
  as integer      dwMIDIUnityNote
  as integer      dwMIDIPitchFraction
  as integer      dwSMPTEFormat
  as integer      dwSMPTEOffset
  as integer      cSampleLoops
  as integer      cbSamplerData
end type

type SampleLoop
  as integer      dwIdentifier
  as integer      dwType
  as integer      dwStart
  as integer      dwEnd
  as integer      dwFraction
  as integer      dwPlayCount
end type

Sub SaveWave(ByRef fileName As String, waveLUT() As SngLR)

  If redundant_to_save_wav Then exit sub
  if SynthType = SYNTH_RAW then exit sub
  if samps_per_cycle < 1 then exit sub
 
  ClearPrint(18)
 
  dim as single norm_scale = 32767

  ''often with computer programming, ubound = datasize - 1,
  ''but for sample interpolation, I need one extra sample
  ''at the end.
 
  ''This means that "nSamples" = UBound of softsynth array,
  ''instead of "nSamples" = UBound + 1
 
  Dim As Integer nSamps = UBound(waveLUT)

  ''dafhi's synth
  if samps_per_cycle <> nSamps Then nSamps = samps_per_cycle
 
  ''wav file will not include the redundant sample
  dim as integer UB = nSamps - 1

  dim as SngLR          Temp_(UB)
 
  For I As Integer = 0 To UB
    Temp_(I) = waveLUT(I)
  Next

  macro_Normalize(Temp_,UB,norm_scale)
 
  Dim As STEREO_SAMPLE  SampleLR(UB)
  Dim As Single valu
  For I As Integer = 0 To UB
    valu = Temp_(I).L + 0.5
    SampleLR(I).L = floor(valu)
    valu = Temp_(I).R + 0.5
    SampleLR(I).R = floor(valu)
  Next

  'http://www.topherlee.com/software/pcm-tut-wavformat.html
   
  Dim sampleRate as Integer = 44100
  Dim lenfmt As Integer = 16
  Dim wavetype As Short = 1
  Dim bitSize as Short= 16
  Dim nChannels as Short = 2
  Dim As Integer ByPS = bitSize / 8
  Dim As Short   ByPS_X_Chn = ByPS * nChannels
  Dim As Integer   BytesPerOneSecond = ByPS_X_Chn * rate
  Dim nSamples as Integer = nSamps
  Dim waveSize As Integer = ByPS_X_Chn * nSamples
  Dim fileSize as UInteger = waveSize + 36 + 68 ''68 for loop info
 
  dim as SamplerChunk lSampChunk
  dim as SampleLoop   lSampLoop

  dim as short nFile = FreeFile
 
  Open fileName For Binary Access Write As #nFile
 
  '' Write the header
  dim as integer DoSave = TRUE
  zSaveLoad("RIFF")
  zSaveLoad(filesize)
  zSaveLoad("WAVE")
  zSaveLoad("fmt ")
  zSaveLoad( lenfmt)
  zSaveLoad(wavetype)
  zSaveLoad(nChannels)
  zSaveLoad(sampleRate)
  zSaveLoad(BytesPerOneSecond)
  zSaveLoad(ByPS_X_Chn)
  zSaveLoad(bitSize)
  zSaveLoad("data")
  zSaveLoad(waveSize)

  Put #nFile,, sampleLR()

  '' http://www.sonicspot.com/guide/wavefiles.html#smpl
  lSampChunk.cSampleLoops = 1
  lSampChunk.chunkSize = 36 + 24 * lSampChunk.cSampleLoops
  lSampChunk.dwMIDIUnityNote = 60

  zSaveLoad(lSampChunk.ID)
  zSaveLoad(lSampChunk.chunkSize)
  zSaveLoad(lSampChunk.dwManufacturer)
  zSaveLoad(lSampChunk.dwProduct)
  zSaveLoad(lSampChunk.dwSamplePeriod)
  zSaveLoad(lSampChunk.dwMIDIUnityNote)
  zSaveLoad(lSampChunk.dwMIDIPitchFraction)
  zSaveLoad(lSampChunk.dwSMPTEFormat)
  zSaveLoad(lSampChunk.dwSMPTEOffset)
  zSaveLoad(lSampChunk.cSampleLoops)
  zSaveLoad(lSampChunk.cbSamplerData)
 
  lSampLoop.dwEnd = (nSamples - 1)

  zSaveLoad(lSampLoop.dwIdentifier)
  zSaveLoad(lSampLoop.dwType)
  zSaveLoad(lSampLoop.dwStart)
  zSaveLoad(lSampLoop.dwEnd)
  zSaveLoad(lSampLoop.dwFraction)
  zSaveLoad(lSampLoop.dwPlayCount)
 
  Close #nFile ' Close the file.

  ? "saved "; filename

  redundant_to_save_wav = TRUE
 
End Sub


'' -----------------------
'  softsynth - polyphony
' ------------------------

Dim Shared As Integer   NoteOn_Ref(255)

Sub SetFreq(ByRef nvars as notevars, ByVal scancode As Integer, byval note as single, byval velo as single = 1.0, ByVal freq_ As Single = 0, ByVal duration as single)

    If freq_ = 0 Then 'RAW
      nvars.volume = velo * 22000
      nvars.modval = 1
      nvars.baseFreq = 2 ^ (note / 12)
    Else
      nvars.volume = velo
      dim as integer UB = UBound(waveLUT)
      if samps_per_cycle = UB Then
        ''PADsynth or wave file
        nvars.modval = UB
      else
        ''dafhi's synth
        nvars.modval = rate
      end if
      nvars.baseFreq = freq_
    End If

    nvars.chanL.i.func = basefreq * nvars.baseFreq
   
    If SynthType = SYNTH_RAW Then
       nvars.chanL.func = Rnd * nvars.modval
       nvars.chanR.func = Rnd * nvars.modval
    Else
       nvars.chanL.func = 0
       nvars.chanR.func = 0
       nvars.chanL.func2 = 0
       nvars.chanR.func2 = 0
       nvars.chanL.func3 = 0
       nvars.chanR.func3 = 0
    End If

    nvars.chanR.i.func = nvars.chanL.i.func
    nvars.chanL.i.func2 = nvars.chanL.i.func * (1 + 0.003 * (Rnd - 0.5))
    nvars.chanL.i.func3 = nvars.chanL.i.func * (1 + 0.003 * (Rnd - 0.5))
    nvars.chanR.i.func2 = nvars.chanL.i.func * (1 + 0.003 * (Rnd - 0.5))
    nvars.chanR.i.func3 = nvars.chanL.i.func * (1 + 0.003 * (Rnd - 0.5))
    if duration > 0 then
      nvars.release_samples = duration * rate
    else
      nvars.release_samples = -1
    end if
    nvars.release_iVol = 0
    nvars.scancode = scancode
End Sub

#Macro macro_pRef(scancode_)
   Dim As Integer Ptr pRef = @NoteOn_Ref(scancode_)
#EndMacro

#Macro macro_NoteOn_Common()

  Dim As Integer    SUCCESS = FALSE
  Dim As Integer    Index = 1
  Dim As UInteger   samps = shared_notes(Index).release_samples
  For idx As integer = 1 To Polyphony
    If shared_notes(idx).release_samples < samps Then
      samps = shared_notes(Idx).release_samples
      Index = idx
    End If
  Next
   
#EndMacro

Function ChordType.NoteOn(ByVal scancode As Integer, ByVal noteNr As integer, ByVal Velo as Single, ByVal freq_ As single, ByVal duration as single) As Integer
  if AVERT_NEW_NOTES then exit function
  macro_NoteOn_Common()
  shared_notes(Index).scancode = 0
  NoteOn_Ref(scancode) = Index
  SetFreq shared_notes(Index), scancode, noteNr, velo, freq_, duration
  Return SUCCESS
End Function

Sub ChordType.NoteOff(ByVal scancode As Integer,ByVal ReleaseTime As Single)
  if AVERT_NEW_NOTES then exit sub
  macro_pRef( scancode )
  If scancode = shared_notes(*pRef).scancode Then
    ReleaseTime *= rate
    If ReleaseTime <> 0 Then
       With shared_notes(*pRef)
          If ReleaseTime < .release_samples Then
          .release_samples = ReleaseTime
          .release_iVol = -.volume / (ReleaseTime)
          End If
       End With
    End If
  End If
End Sub

Dim Shared As Single        mPitchBend = 1


'' --------------------------------------------------------------------------- '
'                                                                              '
'                             LUT generators                                   '
'                                                                              '
' ---------------------------------------------------------------------------- '

dim shared as single tmpMod

#Macro Modulus(pValue,pModulus)
  tmpMod = pModulus
  pValue -= tmpMod * floor((pValue / tmpMod))
#EndMacro

#Include Once "vbcompat.bi"
Function Progress( ByVal input_ as single, ByVal input_max_ as single = 100 ) as string
    return Format( 100 * input_ / input_max_ , "###.#" ) & "%"
end function


'' ---------------
'    -~- FFT -~-
' ----------------


''2 ^ 10 = 1024
''2 ^ 18 = 262144
Dim As uByte    lutpow = 14

Dim Shared As Integer MaxPowerOfTwo = 20
If lutpow > MaxPowerOfTwo Then lutpow = MaxPowerOfTwo

Dim As Integer   size_PADLUT = 1 Shl lutpow

Function NumberOfBitsNeeded(ByVal PowerOfTwo as Integer) as Integer
    for I As Integer= 0 to MaxPowerOfTwo
        if (PowerOfTwo and (1 shl I)) <> 0 then
            return I
        End If
    Next
    Return 0
End Function
Function ReverseBits(ByVal Index As Integer,ByVal NumBits As Integer) As Integer
  Dim As Integer Rev
  for I As Integer = 0 to NumBits - 1
    Rev Shl= 1
    Rev Or= Index And 1
    Index Shr= 1
  Next
  Return Rev
End Function

Dim Shared As Integer RevBits(size_PADLUT)

Dim As Integer BitsNeeded = NumberOfBitsNeeded(size_PADLUT)
For I As Integer = 0 To size_PADLUT
  RevBits(I) = ReverseBits(I, BitsNeeded)
Next

Function IsPowerOfTwo(ByVal X as Integer) As Integer
  Dim As Integer  I, Y
  Y = 2
  for I = 1 To MaxPowerOfTwo
    if X = Y then Return TRUE
    Y Shl= 1
  Next
  Return FALSE
End Function

Sub FourierTransform(ByVal AngleNumerator As Single, _
                     ByVal NumSamples As Integer, _
                     lpReal As Single Ptr, _
                     lpImag As Single Ptr, _
                     lpRealOut As Single Ptr, _
                     lpImagOut As Single Ptr)
                     
' http://www.koders.com/delphi/fidB6DD10205DAFD71EFF5093D4916237BB2801DD8D.aspx
 
  Dim As Integer I, J, K, N, BlockSize, BlockEnd', NumBits
  Dim As single  Delta_angle, Delta_ar
  Dim As single  Alpha, Beta
  Dim As single  Tr, Ti, Ar, Ai
 
  if not IsPowerOfTwo(NumSamples) or (NumSamples < 2) then
      ?"Error in procedure Fourier:  NumSamples="; NumSamples
      ?" is not a positive integer power of 2."
      Exit Sub
  End If
 
  'NumBits = NumberOfBitsNeeded(NumSamples)
  for I = 0 to NumSamples
    J = RevBits(I)
    lpRealOut[J] = lpReal[I]
    lpImagOut[J] = lpImag[I]
  Next
 
  BlockEnd = 1
  BlockSize = 2
  while BlockSize <= NumSamples
    Delta_angle = AngleNumerator / BlockSize
    Alpha = Sin(0.5 * Delta_angle)
    Alpha = 2.0 * Alpha * Alpha
    Beta = Sin(Delta_angle)

    I = 0
    while I < NumSamples
      Ar = 1.0 ''cos(0)
      Ai = 0.0 ''sin(0)

      J = I
      for N = 0 to BlockEnd - 1
          K = J + BlockEnd
          Tr = Ar * lpRealOut[K] - Ai * lpImagOut[K]
          Ti = Ar * lpImagOut[K] + Ai * lpRealOut[K]
          lpRealOut[K] = lpRealOut[J] - Tr
          lpImagOut[K] = lpImagOut[J] - Ti
          lpRealOut[J] += Tr
          lpImagOut[J] += Ti
          Delta_ar = Alpha * Ar + Beta * Ai
          Ai -= (Alpha * Ai - Beta * Ar)
          Ar -= Delta_ar
          J += 1
      Next

      I += BlockSize
    Wend
   
    Locate 1,1
    ? "Part - of 3: "; Rnd

    BlockEnd = BlockSize
    BlockSize Shl= 1
  Wend
End Sub

Sub FFT(ByVal NumSamples As Integer, _
        lpReal As Single Ptr, _
        lpImag As Single Ptr, _
        lpRealOut As Single Ptr, _
        lpImagOut As Single Ptr)
    FourierTransform( 2 * PI, NumSamples, lpReal, lpImag, lpRealOut, lpImagOut )
    Dim As Single maxval
    For I As Integer = 0 To NumSamples
      If lpImagOut[I] > maxval Then maxval = lpImagOut[I]
    Next
    maxval = Normalize_Volume / maxval
    For I As Integer = 0 To NumSamples
      lpImagOut[I] *= maxval
    Next
End Sub

Dim Shared As Integer morphPage

Dim shared As Single re_L(1,size_PADLUT)
Dim shared As Single im_L(1,size_PADLUT)
Dim shared As Single re_R(1,size_PADLUT)
Dim shared As Single im_R(1,size_PADLUT)

Dim shared As Single temp_(size_PADLUT)
Dim shared As Single out_L(1,size_PADLUT)
Dim shared As Single out_R(1,size_PADLUT)

#Macro macro_Copy_FFT_Result()
  For I As Integer = 0 To size_PADLUT - 1
    waveLUT(I).L = out_L(morphPage,I)
    waveLUT(I).R = out_R(morphPage,I)
  Next
  waveLUT(size_PADLUT) = waveLUT(0)
#EndMacro
 
#Macro macro_abcd_ptrs()
  Dim As Single Ptr a_ = @Re_L(morphPage,0)
  Dim As Single Ptr b_ = @Re_R(morphPage,0)
  Dim As Single Ptr c_ = @Im_L(morphPage,0)
  Dim As Single Ptr d_ = @Im_R(morphPage,0)
#EndMacro

'' ------------
'  PADsynth
' -------------

#Macro AmpToComplex(lpRe_L,lpRe_R,lpIm_L,lpIm_R)
  FOR i As Integer=0 to UBby2
    Dim As Single phase = Rnd * TwoPi
    lpRe_R[i]=freq_amp(i)*cos(phase)
    lpIm_R[i]=freq_amp(i)*sin(phase)
    phase = Rnd * TwoPi
    lpRe_L[i]=freq_amp(i)*cos(phase)
    lpIm_L[i]=freq_amp(i)*sin(phase)
  Next
#EndMacro

Sub PADsynth_Modified( waveLUT() As SngLR, ByVal size_PADLUT As Integer)
 
  /'
   a re-configuration of
   http://zynaddsubfx.sourceforge.net/doc/PADsynth/PADsynth.htm
  '/

  Dim As Integer UBby2 = size_PADLUT /2 - 1
  Dim As Single   freq_amp(UBby2)
 
  ClearPrint(1)
  ? "Part 1 of 3:"
 
  dim as single scale_mod_ = 12
  dim as integer scale(7)
  dim as single note_mod = ubound(scale)
  scale(0)=0
  scale(1)=2
  scale(2)=4
  scale(3)=5
  scale(4)=7
  scale(5)=9
  scale(6)=11
  scale(7)=scale_mod_
 
  dim as single base_freq = 220.0 * (size_PADLUT / 524288)

  for J as integer = 1 to 3 + floor(Rnd * 3)
    dim as integer octave = floor((Rnd) * 6)
    dim as integer note = floor(rnd * note_mod)
    dim as single cf_ = base_freq * Note2Freq( 12 * octave + scale(note)  )
    dim as single bwid_scale = 0.033 * (0.02 + rnd)
    dim as single bf_ = cf_ - 0.5 * bwid_scale
    dim as single df_ = bwid_scale * cf_
    dim as single amp_ = rnd - 0.1
    FOR J As integer=1 to 2 + Rnd * 60
      dim as single freq_ = cf_ * ( 1 + bwid_scale*(rnd - 0.5) )
      freq_amp(freq_) += amp_ * (Rnd - 0.1)
    next
  Next
 
  macro_abcd_ptrs()
 
  AmpToComplex( a_, b_, c_, d_ )
 
  FFT( size_PADLUT, a_, c_, @temp_(0), @out_L(morphPage,0) )
  FFT( size_PADLUT, b_, d_, @temp_(0), @out_R(morphPage,0) )
 
  Redim_(waveLUT,size_PADLUT)
  macro_Copy_FFT_Result()
 
  morphPage = 1 - morphPage
 
  samps_per_cycle = size_PADLUT
 
  redundant_to_save_wav = FALSE
  SynthType = SYNTH_WAV
  AVERT_NEW_NOTES = FALSE
  ws_base = 16 * 25 * (rate / 44100)
   
End Sub

'' ------------------
'  LUTsynth
' -------------------

#Macro t_wave_macro(a)
  a -= floor(a)
  if a > 0.75 then
    a -= 1
  elseif a > 0.25 then
    a = 0.5 - a
  end if
#EndMacro

function twave(byval input_ as double) as double
  t_wave_macro(input_)
  return input_
End Function

Function twave_mod(ByVal input_ As Single, ByVal mod_ As Single) As Single
  modulus(input_, mod_)
  if input_ > mod_ * 0.75 then
    input_ -= mod_
  elseif input_ > mod_ * 0.25 then
    input_ = mod_ * 0.5 - input_
  end if
  return input_
End Function

Dim shared as single    LUT_precision = 25 /' reduce if you like aliasing (heard in low notes)
.. good values: 1, 2, 5, 10, 25, 50, 125, 250, 1250 '/

#Macro macro_LUTBounds()

  '' Recommended: do not change these values.  These create minimum-size LUT,
  '' as well as modulus for incr and pos
  samps_per_cycle =(LUT_precision * rate) / (10000)
  Dim as single   lut_increm = 10000 / (LUT_precision * rate)
 
  Dim as integer  LutMax = floor(samps_per_cycle+1) * (nSamplesPerBuffer) * 2 + rate

#EndMacro

#Macro macro_ProgressIndicator()
  J += 1
  if J = info_tick then
    locate print_begin,30
    sum = 100 * i / ubound(waveLUT)
    ? Left( Str(sum), 4 ); "%"
    J = 0
  end if
#EndMacro

Sub CalcLUT()
 
  macro_LUTBounds()
  Redim_(waveLUT,LutMax)
 
  Dim As UByte Info_Ticks = 50
  Dim as integer J, info_tick = ubound(waveLUT) / Info_Ticks

  dim as integer print_begin = 1
  ClearPrint(print_begin)
  ? "calculating LUT .."
 
  macro_LUT_Simple()

  macro_Normalize(waveLUT,LutMax,Normalize_Volume)
  waveLUT(LutMax) = waveLUT(0)

  locate print_begin + 1,1: ? space(7) ''erase progress text
  Locate print_begin, 1
  ? "calculating LUT .. DONE": ?
 
  redundant_to_save_wav = FALSE
  SynthType = SYNTH_WAV
  AVERT_NEW_NOTES = FALSE
  ws_base = 16 * LUT_precision * (rate / 44100)
End Sub


'' -----------------------
'  softsynth - render
' ------------------------

#Macro z_WriteSample_LUT_AddDynamics(pChan,iChan,pfunc2,pfunc3)
  sVal += pfunc2
  sVal += pfunc3
  pChan.func2 += iChan.func2
  pChan.func3 += iChan.func3
#EndMacro

#Macro z_WriteSample_LUT_GetVal(pChan,iChan,pfunc)
  sVal = pFunc
  pChan.func += iChan.func
#EndMacro

#Macro macro_PitchWheel(iChan,pChan)
  iChan.func = pChan.i.func * mPitchBend
  iChan.func2 = pChan.i.func2 * mPitchBend
  iChan.func3 = pChan.i.func3 * mPitchBend
#EndMacro

#Macro z_chanMod(pChan, modval)
  Modulus(pChan.func, (modval))
  Modulus(pChan.func2, modval)
  Modulus(pChan.func3, modval)
#EndMacro

#Macro z_WriteSample_RAW_AddDynamics(pChan,iChan,pfunc)
  sVal += pfunc(pChan.func2)
  sVal += pfunc(pChan.func3)
  pChan.func2 += iChan.func2
  pChan.func3 += iChan.func3
#EndMacro

#Macro WriteSample_RAW(pChan,iChan,pDest,pFunc)
  sVal = pFunc(pChan.func)
  pChan.func += iChan.func
  z_WriteSample_RAW_AddDynamics(pChan,iChan,pFunc)
  pDest += sVal * pNote.Volume
#EndMacro

#Macro macro_CheckMod(func,ifunc)
  sng_ = (pNote.modval - func) / ifunc + 1.0
  TestSamps = floor( sng_ )
  if TestSamps < samps then
    samps = TestSamps
    ResetPos = TRUE
    if Loop_ Then
    else
      If SynthType = SYNTH_WAV Then
        if TestSamps > TestSampsGreatest Then
          TestSampsGreatest = TestSamps
        end if
      end if
    End if
  end if
#EndMacro

#Macro zRenderSlice_AddGetCommon(pfunc,ifunc,lpSrc)
  posA = floor(pfunc)
  valA = lpSrc[posA].sval
  lerp = pfunc - posA
  pfunc += ifunc
#EndMacro

#Define zSampleResult(lpSrc) ( valA + lerp * (lpSrc[posA+1].sval - valA) )

#Macro zRenderSlice_AddVal(pfunc,ifunc,lpSrc)
  zRenderSlice_AddGetCommon(pfunc,ifunc,lpSrc)
  sVal += zSampleResult(lpSrc)
#EndMacro

#Macro zRenderSlice_GetVal(pfunc,ifunc,lpSrc)
  zRenderSlice_AddGetCommon(pfunc,ifunc,lpSrc)
  sVal = zSampleResult(lpSrc)
#EndMacro

#Macro zRenderSlice_Channel(pNote,pChan,iChan,lpSrc,lpDest)
  Do
    dim as integer    samps = nSamples
    dim as integer    ResetPos
    macro_CheckMod(pChan.func,iChan.func)
    macro_CheckMod(pChan.func2,iChan.func2)
    macro_CheckMod(pChan.func3,iChan.func3)
   
    If ivol = 0 Then
      For I as integer = 0 to samps - 1
        zRenderSlice_GetVal( pChan.func, iChan.func, lpSrc )
        'zRenderSlice_AddVal( pChan.func2, iChan.func2, lpSrc )
        'zRenderSlice_AddVal( pChan.func3, iChan.func3, lpSrc )
        lpDest[I].sval += sVal * pNote.Volume
      Next
    Else
      For I as integer = 0 to samps - 1
        zRenderSlice_GetVal( pChan.func, iChan.func, lpSrc )
        'zRenderSlice_AddVal( pChan.func2, iChan.func2, lpSrc )
        'zRenderSlice_AddVal( pChan.func3, iChan.func3, lpSrc )
        lpDest[I].sval += sVal * pNote.Volume
        pNote.Volume += ivol
      Next
    EndIf
    nSamples -= samps
    If ResetPos Then
      lpDest += samps
      z_chanMod(pChan, pNote.modval)
    end if
  Loop Until nSamples = 0
  nSamples = save_samps
#EndMacro

Sub RenderSlice(ByRef lpSt As SngLR Ptr, ByVal nSamples As Integer, ByRef pNote As notevars, ByRef iChanL as increments, ByRef iChanR as increments, ByVal Loop_ as integer)
  dim as integer    save_samps = nSamples
  dim as single     sng_
  dim as integer    TestSamps
  dim as integer    TestSampsGreatest
  dim as single     ivol = pNote.release_iVol * 0.5
 
  dim as single     sVal
  dim as integer    posA
  dim as single     lerp
  dim as single     valA
 
  dim as SngLR ptr  lpSrcL = @waveLUT(0).L
  dim as SngLR ptr  lpSrcR = @waveLUT(0).R
  dim as SngLR ptr  lpDstL = @lpSt->L
  dim as SngLR ptr  lpDstR = @lpSt->R
 
  WAVE_BUSY = TRUE
 
  zRenderSlice_Channel(pNote,pNote.ChanL,iChanL,lpSrcL,lpDstL)
  zRenderSlice_Channel(pNote,pNote.ChanR,iChanR,lpSrcR,lpDstR)
 
  WAVE_BUSY = FALSE
 
  if TestSampsGreatest Then
    pNote.release_samples = nSamples
  end if
End Sub

Sub RenderNote(byval lpSt As SngLR ptr, ByVal nSamples as integer, ByRef pNote As notevars, ByVal chord_index as integer)

  If pNote.release_samples <= 0 Then
  Else
   
    '' prevent volume from going nuts if something odd happens
    if pNote.Volume < 0 Then pNote.Volume = 0

    If pNote.release_samples < nSamples Then
      nSamples = pNote.release_samples
    EndIf
    Dim As increments         iChanL
    Dim As increments         iChanR
    macro_PitchWheel( iChanL, pNote.chanL )
    macro_PitchWheel( iChanR, pNote.chanR )
   
    If SynthType = SYNTH_WAV Then
      if samps_per_cycle > 0 Then
        RenderSlice(lpSt,nSamples,pNote,iChanL,iChanR,LoopWave)
      end if

    Else

      dim as single   sVal
     
      For I as integer = 0 to (nSamples - 1)
        WriteSample_RAW( pNote.chanL, iChanL, lpSt[I].L, twave )
        WriteSample_RAW( pNote.chanR, iChanR, lpSt[I].R, twave )
        pNote.Volume += pNote.release_iVol
      Next
      z_chanMod(pNote.chanL, pNote.modval)
      z_chanMod(pNote.chanR, pNote.modval)
     
    End If
    pNote.release_samples -= nSamples
   EndIf
End Sub

'' --------------
'   TimerVars
' ---------------

dim shared as double            gTime

Type TimerVars
    As Double                   destination
    Declare Sub                 Activate( ByVal delay_ as double = 0.0 )
    As Double                   delay
    Declare Property            Update() As Integer
    Declare Property            inside() as integer
    As Double                   remaining
   Private:
    As Integer                  UpdateRequest
End Type
Property TimerVars.Inside() as Integer
    if gTime <= destination Then
        remaining = destination - gTime
        Inside = TRUE
    end if
End Property
Sub TimerVars.Activate( ByVal delay_ as double )
  if SynthRunning Then
    destination = Timer + delay_
    UpdateRequest = TRUE
  End if
End Sub
Property TimerVars.Update() as integer
    If UpdateRequest Then
        If destination < Timer Then
            UpdateRequest = FALSE
            Update = TRUE
        End If
    End if
End Property

dim shared as TimerVars Midi_ReAcquire


'  ########################
' # MIDI->Audio Template #
'########################
#include "windows.bi"
#include "win/mmsystem.bi"

#define DEBUG

#ifdef DEBUG
#define DPRINT(txt) OPEN ERR FOR OUTPUT AS #99:print #99,txt:close #99
#else
#define DPRINT(txt) :
#EndIf

type MIDI_MESSAGE
  union
  type
    as uinteger LNibble :4
    as uinteger HNibble :4
    as uinteger LByte   :7
    as uinteger unussed1:1
    as uinteger HByte   :7
    as uinteger unussed2:9
  end type
  as uinteger value
  end union
end type

const NOTE_OFF = &H8
const NOTE_ON = &H9

' ########################
' # simple MIDI in class #
' ########################
type MIDIIN_DEVICE
  declare Constructor'(DeviceIndex as integer=0) ' default = first MIDI port
  declare destructor
  declare sub ReAcquire
  private:
  declare static sub MidiInProc(byval hMidiIn   as HMIDIIN, _
                                byval DriverMsg as DWORD  , _
                                byval pDevice   as MIDIIN_DEVICE ptr, _
                                byval MidiMsg   as MIDI_MESSAGE, _
                                byval MidiTime  as DWORD)
  as integer  ISOpen,IsRunning
  as MMRESULT LastResult
  as HMIDIIN  hDevice
end type

sub MIDIIN_DEVICE.ReAcquire
  Dim As Integer Dev_
 
  '' -----------------------------------------------------
  ' - midi in caps - modified from a post by alfakilo
  ' -----------------------------------------------------
 
  Dim As Integer nMidis=midiInGetNumDevs()
  Dim As Integer ret
  Dim As MIDiInCAPS caps
 
  If nMidis<1 Then
    ? "error: sorry no midi input on this system!"
    Midi_ReAcquire.Activate 2.5
    MIDI_NOT_RUNNING = TRUE
    'Beep
    Exit sub
  ElseIf nMidis = 1 Then
    Dev_ = 0
    ret=midiInGetDevCaps(Dev_,@caps,Sizeof(MIDiInCAPS))
    ? "MIDI device: "; caps.szPname
  Else
    For i As Integer=0 To nMidis-1
      ret=midiInGetDevCaps(i,@caps,Sizeof(MIDiInCAPS))
      If ret=0 Then
      ? "[" & i & "] =" & caps.szPname
      Else
      Beep:? "warning can't get caps from device[" & i & "] !"
      End If
    Next
    If nMidis>1 Then
      ? "select one midiIn device a number between 0 and " & nMidis-1 & " and press enter/return!"
      Input Dev_
    Else
      Dev_=-1
    End If
  End If
 
  For Purge As Integer = 1 To 2
    LastResult = midiInOpen(@hDevice,_
                      Dev_, _
                      cast(uinteger,@MidiInProc), _
                      cast(uinteger,@This), _
                      CALLBACK_FUNCTION or MIDI_IO_STATUS)
   
    IsOpen = (LastResult = MMSYSERR_NOERROR)
   
    if IsOpen then
    LastResult = midiInStart(hDevice)
    IsRunning = (LastResult = MMSYSERR_NOERROR)
    end If
 
    if (IsOpen=0) or (IsRunning=0) then
      if LastResult = 4 then
        'already connected
      else
      ? "MIDIIN_DEVICE error: "; LastResult
      end if
    end if
    If Purge = 1 Then
       if IsRunning then midiInStop  hDevice
       if IsOpen    then midiInClose hDevice
    End If
  Next

  MIDI_NOT_RUNNING = Not IsRunning
     
End Sub

Constructor MIDIIN_DEVICE
  ReAcquire
End constructor

destructor MIDIIN_DEVICE
  if (hDevice<>NULL) then
    if IsRunning then midiInStop  hDevice
    if IsOpen    then midiInClose hDevice
  end if
end destructor

' the midi in callback
sub MIDIIN_DEVICE.MidiInProc(byval hMidiIn   as HMIDIIN, _
                             byval DriverMsg as DWORD  , _
                             byval pDevice   as MIDIIN_DEVICE ptr, _
                             byval MidiMsg   as MIDI_MESSAGE, _
                             byval MidiTime  as DWORD)

  dim as integer note,vel
  dim as short v16
  select case as const DriverMsg
  case MIM_DATA
    'dprint("MIM_DATA param1=" & hex(MidiMsg,8) & " param2=" & MidiTime)
    select case as const MidiMsg.HNibble
    case &H8
      note = MidiMsg.LByte
      'dprint("Note Off " & note)
      mychord.NoteOff( note, release_time )
    case &H9
      note = MidiMsg.LByte
      vel  = MidiMsg.HByte
      if vel=0 then
        'dprint("Note Off " & note)
        mychord.NoteOff( note, release_time )
      else
        'dprint("Note On  " & note & " vel " & vel)
        NoteON__LUT_VS_RAW note, vel / 127
      end if
    case &HA':dprint("Polyphonic Pressure " & MidiMsg.LByte & "," & MidiMsg.HByte)
    case &HB':dprint("Control Change      " & MidiMsg.LByte & "," & MidiMsg.HByte)
    case &HC':dprint("Program Change      " & MidiMsg.LByte)
    case &HD':dprint("Channel Pressure    " & MidiMsg.LByte)
    case &HE: v16  = MidiMsg.HByte - 63
        If v16 > 0 Then v16 -= 1
        Dim As Single Whole_Step = 2
        mPitchBend = 2 ^ (Whole_Step * (v16 / 63) / 12)
        'dprint("Pitch Wheel Control " & v16)
    case &HF ' (SysEx)
      select case as const MidiMsg.LNibble
      case &h0 : dprint("System Exclusive")
      case &h1 : dprint("Time Code")
      case &h2 : dprint("Song Position Pointer")
      case &h3 : dprint("Song Select")
      case &h6 : dprint("Tune Request")
      case &h8 : dprint("Timing Clock")
      case &hA : dprint("Sart")
      case &hB : dprint("Continue")
      case &hC : dprint("Stop")
      case &HE : dprint("Active Sensing")
      case &HF : dprint("System Reset")
      end select
    end select
  case MIM_OPEN      : dprint("MIM_OPEN")
  case MIM_CLOSE     : dprint("MIM_CLOSE")
    Midi_ReAcquire.Activate 1.0
  case MIM_LONGDATA  : dprint("MIM_LONGDATA")
  case MIM_ERROR     : dprint("MIM_ERROR")
  case MIM_LONGERROR : dprint("MIM_LONGERROR")
  case MIM_MOREDATA  : dprint("MIM_MOREDATA")
  end select
end sub


' ##########################
' # simple AUDIO out class #
' ##########################

type WAVEOUT_DEVICE
  declare constructor(DeviceIndex as integer=-1) ' default = WAVE_MAPPER
  declare destructor
  private:
  declare static sub WaveOutProc(hDevice       as HWAVEOUT, _
                                 DriverMessage as uinteger, _
                                 pDevice       as WAVEOUT_DEVICE ptr, _
                                 pWaveHeader   as PWAVEHDR, _
                                 Param2        as DWORD)
  declare sub PrepareBuffer(pBuffer as PWAVEHDR)
  as WAVEFORMATEX     wfex
  as WAVEOUTCAPS      Caps
  as HWAVEOUT         hDevice
  as MMRESULT         LastResult
  as PWAVEHDR ptr     Buffers
  as integer          IsAccurate,IsOpen,IsRunning
  as integer          nPlayedBuffers
end type


constructor WAVEOUT_DEVICE(DeviceIndex as integer)

  LastResult = waveOutGetDevCaps(DeviceIndex, _
                                 @Caps, _
                                 sizeof(WAVEOUTCAPS))
  if (LastResult=MMSYSERR_NOERROR) then
    with caps
    ISAccurate = (.dwSupport and WAVECAPS_SAMPLEACCURATE)
    end with
  end if
  with wfex
    .wFormatTag      = WAVE_FORMAT_PCM
    .nSamplesPerSec  = rate
    .nChannels       = 2
    .wBitsPerSample  = 16
    .nBlockAlign     = (.wBitsPerSample shr 3) * .nChannels
    .nAvgBytesPerSec = .nBlockAlign * .nSamplesPerSec
    .cbSize          = 0 ' no extra bytes
  end with
  LastResult = waveOutOpen(@hDevice, _
                           DeviceIndex, _
                           cptr(LPCWAVEFORMATEX,@wfex), _
                           cast(uinteger,@WaveOutProc), _
                           cast(uinteger,@this), _
                           CALLBACK_FUNCTION)
 
  ' prepare buffers
  if IsOpen then
    dim as integer size = wfex.nBlockAlign
    size*=nSamplesPerBuffer
    Buffers=callocate(nBuffers*sizeof(PWAVEHDR))
    for i as integer =0 to nBuffers-1
      Buffers[i] = callocate(sizeof(WAVEHDR))
      with *Buffers[i]
        .lpData         = callocate(size)
        .dwBufferLength = size
        .dwUser         = i
        .dwFlags        = 0
      end with
      LastResult = waveOutPrepareHeader(hDevice   , _
                                        Buffers[i], _
                                        sizeof(WAVEHDR))
     
    next
    for i as integer=0 to nBuffers-1
      waveOutWrite(hDevice,Buffers[i],sizeof(WAVEHDR))
    next
    IsRunning=1
  end if
end constructor

' stop the device and free all resources
destructor WAVEOUT_DEVICE
  if (hDevice<>NULL) then
    if (IsOpen<>0) then
      if (IsRunning<>0) then
        IsRunning=0
        waveOutReset hDevice ' mark all buffer as done
        sleep 1100
      end if
      if (Buffers<>NULL) then
        if (nBuffers>0) then
          for i as integer = 0 to nBuffers-1
            if (Buffers[i]<>NULL) then
              if (Buffers[i]->dwFlags and WHDR_PREPARED) then
                waveOutUnprepareHeader(hDevice,Buffers[i],sizeof(WAVEHDR))
              end if
              if Buffers[i]->lpData then deallocate Buffers[i]->lpData
              deallocate Buffers[i]
            end if
          next
        end if
        deallocate Buffers
      end if
      waveOutClose hDevice
    end if
  end if
  dprint("WAVEOUT_DEVICE~")
end destructor

' the audio out callback
sub WAVEOUT_DEVICE.WaveOutProc(hDevice   as HWAVEOUT, _
                               DriverMsg as uinteger, _
                               pDevice   as WAVEOUT_DEVICE ptr, _
                               pBuffer   as PWAVEHDR, _
                               Param2    as DWORD)
  select case as const DriverMsg
  case WOM_DONE
    pDevice->nPlayedBuffers+=1
    if pDevice->IsRunning then
      pDevice->PrepareBuffer(pBuffer)
    else
      DPRINT("WOM_DONE")
    end if
  case WOM_OPEN : dprint("WOM_OPEN")
    pDevice->IsOpen = 1
  case WOM_CLOSE : dprint("WOM_CLOSE")
    pDevice->IsOpen = 0
  end select
end sub

#Macro LimitThenCopy(pSrc,pDest)
  if pSrc > 32767 then
    pSrc = 32767
  elseif pSrc < -32767 then
    pSrc = -32767
  end if
  pSrc += 0.5
  pDest = floor(pSrc)
#EndMacro

'' -----------------
'   Visualization
' ------------------

Dim As Integer                    Wid = 480
Dim As Integer                    Hgt = 360
Dim As Integer                    HgtM: HgtM = Hgt - 1

Dim Shared As Single              half_h: half_h = HgtM / 2

Dim Shared As Integer             VisPos
Dim Shared As Integer             VisBuf_Y(10000)

Dim Shared As STEREO_SAMPLE Ptr   m_lpSampsVis

#Macro macro_SampVis()
  Dim As Integer Ptr lpVis_Y = @VisBuf_Y(VisPos)
  PSet(VisPos,*lpVis_Y),0
  *lpVis_Y = floor(half_h + 0.01 * pSamples[I].L)
  PSet(VisPos,*lpVis_Y),&HFFFFFF
  VisPos += 1
#EndMacro
 
Sub Visualize()

  Dim As Integer DestSamp = nSamplesPerBuffer - 1
  Dim As Integer I
  Dim as STEREO_SAMPLE ptr pSamples  = m_lpSampsVis
 
  ''find zero-crossing
  For I = 0 to DestSamp
    If pSamples[I].L < 0 Then Exit For
  Next
  For I = I to DestSamp
    If pSamples[I].L > 0 Then Exit For
  Next
  VisPos = 0
 
  For I = I To DestSamp
    macro_SampVis()
  Next
 
End Sub

sub WAVEOUT_DEVICE.PrepareBuffer(pBuffer as PWAVEHDR)
   
  waveOutUnprepareHeader(hDevice,pBuffer,sizeof(WAVEHDR))
  pBuffer->dwFlags = 0

  ' pointer to the 16 bit stereo samples
  Dim as STEREO_SAMPLE ptr pSamples  = cptr(STEREO_SAMPLE ptr,pBuffer->lpData)
  m_lpSampsVis = pSamples
 
  Dim as SngLR SngNull

   ' zero left and right channels
  For lpLR as SngLR ptr = @precision_buf(0) to @precision_buf(nSamplesPerBuffer-1)
    *lpLR = SngNull
  Next
   
  For J As integer = 1 To Polyphony
    RenderNote( @precision_buf(0), nSamplesPerBuffer, shared_notes(J), J )
  Next
 
  For I as integer = 0 to nSamplesPerBuffer - 1
    dim as SngLR ptr lpSrcLR = @precision_buf(I)
    LimitThenCopy(lpSrcLR->L, pSamples[I].L)
    LimitThenCopy(lpSrcLR->R, pSamples[I].R)
  Next
 
  ' prepare and write the new buffer
  if (IsRunning<>0) then
    waveOutPrepareHeader(hDevice,pBuffer,sizeof(WAVEHDR))
    waveOutWrite(hDevice,pBuffer,sizeof(WAVEHDR))
  end if
 
End sub

'' -----------------
'   Main
' ------------------

#include "fbgfx.bi"

using FB
dim as event e
dim as integer Ctrl_Key_Down

'' ------------------
'  QWERTY controller
' -------------------

dim shared as ubyte Note_QWERTY(255)
Note_QWERTY(SC_Q) = 48
Note_QWERTY(SC_W) = 50
Note_QWERTY(SC_E) = 52
Note_QWERTY(SC_R) = 53
Note_QWERTY(SC_T) = 55

Note_QWERTY(SC_2) = 49
Note_QWERTY(SC_3) = 51
Note_QWERTY(SC_5) = 54

Note_QWERTY(SC_Z) = 36
Note_QWERTY(SC_X) = 38
Note_QWERTY(SC_C) = 40
Note_QWERTY(SC_V) = 41
Note_QWERTY(SC_B) = 43

Note_QWERTY(SC_S) = 37
Note_QWERTY(SC_D) = 39
Note_QWERTY(SC_G) = 42

#Macro QWERTY_Controller(EVENT_)

  ''SC_S not included here because also used for save wav
 
  Case  SC_Q,SC_W,SC_E,SC_R,SC_T,SC_2,SC_3,SC_5, _
        SC_Z,SC_X,SC_C,SC_V,SC_B,SC_D,SC_G
  If EVENT_ = NOTE_ON Then
    LUT_DEMO( Note_QWERTY(e.scancode) )
  ElseIf EVENT_ = NOTE_OFF Then
    mychord.NoteOff Note_QWERTY(e.scancode)
  End if
#EndMacro

'' ------------------
'  load wavetable
' -------------------

if str_InitialWaveFile <> "" Then
  LoadWave str_InitialWaveFile, NormalizeOnLoad
elseIf SynthType = SYNTH_WAV Then
  CalcLUT
End if

'' ------------------
'  engage hyperdrive
' -------------------

ReDim precision_buf(nSamplesPerBuffer-1)

if waveOutGetNumDevs()<1 then
  ? "sorry no active WAVE output device !"
  beep
End if

dim as WAVEOUT_DEVICE WaveOut
dim as MIDIIN_DEVICE  MidiIn

If Not MIDI_NOT_RUNNING Then
? "play your MIDI keys single notes or chords ..."
? "you can see all messages for pitch wheel"
? "and all other controllers too"
end If

ScreenRes Wid,Hgt,32

If MIDI_NOT_RUNNING Then
  ?"play C D E F G using Q W E R T"
end if

locate 5,1
? "Key Commands:"
?
? "7 - PADsynth LUT"
? "8 - simple LUT"
? "9 - Load mywave.wav"
? "0 - formula"
?
? "Ctrl S - LUT to mywave.wav"
?
? "U - Save randname.wav"
?
'? "Press 'P' at any time to reset the synth engine"

SynthRunning = TRUE

Do While SynthRunning
 
  If (ScreenEvent(@e)) Then
   
    If e.type = EVENT_KEY_PRESS Then
     
      Select Case e.scancode
      QWERTY_Controller(NOTE_ON)
      Case SC_S
        if Ctrl_Key_Down Then
          SaveWave("mywave.wav",waveLUT())
        else
          '' qwerty controller
          LUT_DEMO( Note_QWERTY(e.scancode) )
        End If
      Case SC_P
        MyChord.Panic
      Case SC_7
        PADsynth_Modified( waveLUT(), size_PADLUT )
      Case SC_8
        CalcLUT
      Case SC_9
        LoadWave "mywave.wav", NormalizeOnLoad
      Case SC_0
        ClearPrint(1)
        ? "formula synth"
        SynthType = SYNTH_RAW
      Case SC_U
        SaveWave(left(str(rnd),9) & ".wav",waveLUT())
      Case SC_CONTROL
        Ctrl_Key_Down = TRUE
      case SC_1 ''reduce possibility of accidentally closing app
      case SC_6
      case SC_Y
      case SC_A
      case SC_H
      case SC_N
      Case SC_F
      case SC_SPACE
      case Else
        SynthRunning = FALSE
      End select
     
    elseif e.type = EVENT_KEY_RELEASE Then
     
      Select Case e.scancode
      QWERTY_Controller(NOTE_OFF)
      case SC_S
        '' QWERTY controller
        mychord.NoteOff Note_QWERTY(e.scancode)
      Case SC_CONTROL
        Ctrl_Key_Down = FALSE
      End Select
     
    endif
   
  End If
 
  If Midi_ReAcquire.Update Then
    ?
    ?"Midi connection lost .. attempting reconnect"
    ?
    MidiIn.ReAcquire
    MyChord.Panic
  End if 
 
  Visualize
 
  sleep 10
Loop

dim shared as integer   AUTOSAVE_ONEXIT = FALSE

if AUTOSAVE_ONEXIT Then
  if SynthType = SYNTH_WAV Then
    SaveWave(left(str(rnd),9) & ".wav",waveLUT())
  end if
end if


For a dynamic sound, you can uncomment 4 lines inside zRenderSlice_Channel(), which layer 2 additional off-pitch notes. These techniques are used in a great number of synths.

Return to “Projects”

Who is online

Users browsing this forum: No registered users and 11 guests