[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