Code: Select all
const pi = 4*atn(1)
const pi2 = 8*atn(1)
#define sng as Single
#define dbl as Double
/' period modulation - Windows audio demo by dafhi - 2019 Mar 9
Info: experimenting with waveforms in a software synthesizer,
I discovered this algorithm which produces a signal that sounds
like it converges to noise.
- formula comparison -
frequency modulation: func( t + a * func( t*j ) )
period modulation: func_m( t, m + a * func( t*j ) )
---------------------------------------------------------------- '/
function sine_m(t dbl, period dbl = pi2) sng
return sin(t / period)
end function
function pm_wave(t dbl, amount sng = pi / 50, f_scalar sng = .002) sng
return sine_m( t, pi2 + amount * sin( t * f_scalar ) )
End Function
const GC_sample_FFWD = 1000'000000
'' if audio skips, try different values
Dim shared as integer nBuffers = 5
dim shared as integer nSamplesPerBuffer = 500
const As Integer rate = 44100 \ 2
var Base_Note_Index = 80
var velo = .6
#Ifndef floor '' http://www.freebasic.net/forum/viewtopic.php?p=118633
#Define floor(x) (((x)*2.0-0.5)shr 1)
#define ceil(x) (-((-(x)*2.0-0.5)shr 1))
#EndIf
Union SngLR
sng sval
Type
sng L
sng R
End Type
End Union
dim shared as SngLR precision_buf()
ReDim precision_buf(nSamplesPerBuffer-1)
Type increments
sng func
sng func2
sng func3
end type
type chan field = 4
dbl func
dbl func2
dbl func3
as increments i
end type
type notevars
as chan chanL
as chan chanR
sng volume
sng modval
As Integer scancode
As UInteger release_samples
sng release_iVol
End Type
Dim Shared As notevars shared_notes(1 To 1)
Sub SetFreq(ByRef nvars as notevars, byval note sng, byval velo sng = 1.0)
nvars.volume = velo
nvars.modval = 1
const freq_base = 1 / 128 * 44100 / rate
nvars.chanL.i.func = freq_base * 2 ^ (note / 12)
'nvars.chanL.i.func2 = nvars.chanL.i.func * (1 + 0.0003 * (Rnd - 0.5))
'nvars.chanL.i.func3 = nvars.chanL.i.func * (1 + 0.0003 * (Rnd - 0.5))
nvars.chanR.i.func = nvars.chanL.i.func
'nvars.chanR.i.func2 = nvars.chanL.i.func * (1 + 0.0003 * (Rnd - 0.5))
'nvars.chanR.i.func3 = nvars.chanL.i.func * (1 + 0.0003 * (Rnd - 0.5))
nvars.chanL.func = Rnd * nvars.modval + GC_sample_FFWD * nvars.chanL.i.func
'nvars.chanL.func2 = Rnd * nvars.modval + GC_sample_FFWD * nvars.chanL.i.func
'nvars.chanL.func3 = Rnd * nvars.modval + GC_sample_FFWD * nvars.chanL.i.func
nvars.chanR.func = Rnd * nvars.modval + GC_sample_FFWD * nvars.chanR.i.func
'nvars.chanR.func2 = Rnd * nvars.modval + GC_sample_FFWD * nvars.chanR.i.func
'nvars.chanR.func3 = Rnd * nvars.modval + GC_sample_FFWD * nvars.chanR.i.func
End Sub
SetFreq shared_notes(1), Base_Note_Index, velo
#Macro z_WriteSample_RAW_AddDynamics(pChan,iChan,pfunc)
sVal += pm_wave(pChan.func2)
sVal += pm_wave(pChan.func3)
pChan.func2 += iChan.func2
pChan.func3 += iChan.func3
#EndMacro
#Macro WriteSample_RAW(pChan,iChan,pDest,pFunc,vol)
sval = pm_wave(pchan.func)
pChan.func += iChan.func
#if 0
z_WriteSample_RAW_AddDynamics(pChan,iChan,pFunc)
#endif
pDest += sVal * vol
#EndMacro
Sub RenderNote(byval lpSt As SngLR ptr, ByVal nSamples as integer, ByRef pNote As notevars, vol sng = 12000)
vol *= pnote.volume
dim sng sVal
For I as integer = 0 to (nSamples - 1)
WriteSample_RAW( pNote.chanL, pNote.ChanL.i, lpSt[I].L, tri_wave, vol )
WriteSample_RAW( pNote.chanR, pNote.ChanR.i, lpSt[I].R, tri_wave, vol )
pNote.Volume += pNote.release_iVol
Next
End Sub
'' audio class by D.J. Peters
#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
' ##########################
' # 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
'' dafhi ---------------------------------------
Type STEREO_SAMPLE
union
type
as short L
as short R
end type
as ulong Both '2018 Oct 5
end union
End Type
Dim Shared As STEREO_SAMPLE Ptr m_lpSampsVis
#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)
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(1) )
'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
if waveOutGetNumDevs()<1 then
? "sorry no active WAVE output device !"
beep
End if
dim as WAVEOUT_DEVICE WaveOut
var SynthRunning = TRUE
Do While SynthRunning
var key = inkey
select case key
case chr(27): exit do
case is <>"": exit do
End Select
sleep 1
Loop