period modulation (windows audio)

Post your FreeBASIC tips and tricks here. Please don’t post your code without including an explanation.
dafhi
Posts: 1258
Joined: Jun 04, 2005 9:51

period modulation (windows audio)

Postby dafhi » Oct 04, 2018 22:27

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
Last edited by dafhi on Mar 23, 2019 7:07, edited 8 times in total.
adele
Posts: 47
Joined: Jun 13, 2015 19:33

Re: period modulation (windows audio)

Postby adele » Oct 05, 2018 13:51

Hi,

I tried with FBC 1.05/x64, " -s console", no other settings.
the Program compiles w/o Error or warnings. But:
I hear a sound like "BLB", and after having printed "WOM_OPEN" : WIN error message: (translated) "<progname> doesn´t work anymore."
This normally is indicating a hard error like access violation.

Adi
dafhi
Posts: 1258
Joined: Jun 04, 2005 9:51

Re: period modulation (windows audio)

Postby dafhi » Oct 05, 2018 14:23

fixed
h4tt3n
Posts: 686
Joined: Oct 22, 2005 21:12
Location: Denmark

Re: period modulation (windows audio)

Postby h4tt3n » Oct 05, 2018 20:30

Cool thanks!
adele
Posts: 47
Joined: Jun 13, 2015 19:33

Re: period modulation (windows audio)

Postby adele » Oct 08, 2018 11:08

dafhi wrote:fixed

indeed. Now it sounds like an angry synthi :)
Adi

Return to “Tips and Tricks”

Who is online

Users browsing this forum: No registered users and 1 guest