here's a rough conglomeration of the library, it need to be cleaned up but it works
Code: Select all
/'
''' #include "midievent.bas"
''' #include "wave.bas"
''' #include "SoundFunction.bas"
''' #include "playtomidi.bas"
''' #include "writemidi.bas"
''' #include "writewav.bas"
''' #include "sequencer.bas"
''' #include "windows\dsp.bas"
''' #include "windows\midi.bas"
''' #include "windows\seqthread.bas"
'/
'=== "midievent.bas" ===
'#include "sequencer.bi"
const MaxTracks=16
TYPE MidiSequence
Tracks as integer
Divisions as integer
Tempo as longint
Track(1 to MaxTracks) as string
END TYPE
DECLARE FUNCTION WriteVarLen(Value as integer) as string
sub MidiEvent(Midi as MidiSequence ptr, track as integer, DeltaTime as integer, event as UByte, a as UByte, b as UByte)
SELECT CASE event shr 4
CASE &H8, &H9, &HA, &HB, &HE
Midi->Track(track)+=WriteVarLen(DeltaTime)+chr(event)+chr(a)+chr(b)
CASE &HC, &HD
Midi->Track(track)+=WriteVarLen(DeltaTime)+chr(event)+chr(a)
END SELECT
if track>Midi->Tracks then Midi->Tracks=track
end sub
'### "midievent.bas" ###
'=== "wave.bas" ===
'#include "sfx.bi"
'#include "sequencer.bi"
'#include "wave.bi"
TYPE WaveHeaderType
RiffID AS ULONG 'should be 'RIFF'
RiffLength AS LONG
'rept. chunk id and size then chunk data
WavID AS ULONG 'should be 'WAVE'
FmtID AS ULONG
FmtLength AS LONG
'FMT ' chunk - common fields
wavformattag AS SHORT ' word - format category e.g. 0x0001=PCM
Channels AS SHORT ' word - number of Channels 1=mono 2=stereo
SamplesPerSec AS LONG 'dword - sampling rate e.g. 44100Hz
avgBytesPerSec AS LONG 'dword - to estimate buffer size
blockalign AS SHORT ' word - buffer size must be int. multiple of this
'FMT - format-specific fields
'e.g. PCM-format-specific has BitsPerSample (word)
' for PCM data,
' wAvgBytesPerSec=RoundUp(wChannels*wBitsPerSec*wBitsPerSample/8)
' wBlockAlign=wBitsPerSample/8
' assuming no FACT, CUE points, Playlist, Assoc. Data List chunks
FmtSpecific AS SHORT ' word
DataID AS ULONG
DataLength AS LONG
'declare property samples() as ubyte ptr
END TYPE
'' This is a trick to obtain a pointer to the pixels data area
''
' property WaveHeaderType.samples() as ubyte ptr
' return cast(ubyte ptr, @this) + sizeof(WaveHeaderType)
' end property
declare sub SoundControl(byval what as long, byref param as string = "")
'declare sub SoundSet(frequency as long, channels as long, bits as long)
declare sub playbuffer (soundBuffer as any ptr, buffersize as long)
declare function SoundQueue() as integer
declare sub SoundMidiControl(byval what as long, byref param as string = "")
declare sub SoundMidiSet
declare sub MidiSend(event as UByte, a as UByte, b as UByte)
'type MidiSequence as any
declare sub PlayMidi(buffer as MidiSequence ptr, background as integer)
declare sub SaveMidi(FileName as string, Midi as MidiSequence ptr)
declare function MidiPlaying() as MidiSequence ptr
declare sub PauseMidi(m as integer)
'declare function LoadMidi(FileName as string) as any ptr
''declare sub MidiEvent(Midi as MidiSequence ptr, track as integer, DeltaTime as integer, event as UByte, a as UByte, b as UByte)
declare sub play overload (Midi as MidiSequence ptr, playstr as string, playstr1 as string="", playstr2 as string="", playstr3 as string="", _
playstr4 as string="", playstr5 as string="", playstr6 as string="", playstr7 as string="", _
playstr8 as string="", playstr9 as string="", playstr10 as string="", playstr11 as string="", _
playstr12 as string="", playstr13 as string="", playstr14 as string="", playstr15 as string="")
declare sub play overload (playstr as string, playstr1 as string="", playstr2 as string="", playstr3 as string="", _
playstr4 as string="", playstr5 as string="", playstr6 as string="", playstr7 as string="", _
playstr8 as string="", playstr9 as string="", playstr10 as string="", playstr11 as string="", _
playstr12 as string="", playstr13 as string="", playstr14 as string="", playstr15 as string="")
'declare FUNCTION CreateMidi() as any ptr
type SoundFunction extends object
t as single
fm as single
Duration as integer
child as SoundFunction ptr
child2 as SoundFunction ptr
declare abstract function GetNext() as single
Declare Destructor()
end type
/'
'declare Function SineWave (Freq as single) as any ptr
'declare Function TriangleWave (Freq as single) as any ptr
declare Function PulseWave Overload(Freq as single, DutyCycle as single=.5) as any ptr
'declare Function PulseWave Overload(Freq as single, DutyCycle as any ptr) as any ptr
declare Function SawtoothWave (Freq as single) as any ptr
declare Function NoiseWave () as any ptr
declare Function HarmonicWave (Freq as single, _
h1 as single=1, h2 as single=0, h3 as single=0, h4 as single=0, h5 as single=0,_
h6 as single=0, h7 as single=0, h8 as single=0, h9 as single=0, h10 as single=0)_
as any ptr
declare Function DSPFilter Overload(func as any ptr, cutoff as single, p as integer=1, res as single=0) as any ptr
declare Function DSPFilter Overload(func as any ptr, cutoff as single, func2 as any ptr, p as integer=1, res as single=0) as any ptr
declare Function SyncWave (func as any ptr, Freq as single) as any ptr
declare function FrequencyModulate(func1 as any ptr, func2 as any ptr, modul as single, detune as integer=0) as any ptr
declare function AmplitudeModulate(func1 as any ptr, func2 as any ptr, ring as integer=0, detune as integer=0) as any ptr
declare function MixWaves(func1 as any ptr, func2 as any ptr, detune as integer=0) as any ptr
declare function Stereo(func1 as any ptr, func2 as any ptr) as any ptr
declare function Panning overload(func1 as any ptr, pan as single=0, gain as single=.5) as any ptr
declare function Panning overload(func1 as any ptr,func2 as any ptr, gain as single=.5) as any ptr
declare function ADSREnvelope Overload(Attack as single, Decay as single, Sustain as single, Release as Single, Dur as single) as any ptr
declare function ADSREnvelope Overload(func as any ptr, Attack as single, Decay as single, Sustain as single, Release as Single, Dur as single) as any ptr
declare sub sound overload (func as SoundFunction ptr, duration as single)
declare function CreateWave(buffersize as long, frequency as long, channels as long, bits as long) as WaveHeaderType ptr
declare FUNCTION LoadWave(FileName as string) as WaveHeaderType ptr
declare sub PlayWave(buffer as WaveHeaderType ptr)
declare sub sound overload(buffer as WaveHeaderType ptr, start as single=0, func as SoundFunction ptr, duration as single)
declare Function DSPWave (buffer as WaveHeaderType ptr, speed as single=1) as SoundFunction ptr
declare sub SaveWave(FileName as string, buffer as WaveHeaderType ptr)
'/
'#include "wave.bi"
common shared __Samplerate as integer, __channels as integer, __bits_used as integer
#define FCC(c) *(cptr(Ulong Ptr,@##c))
function CreateWave(buffersize as long, frequency as long, channels as long, bits as long) as WaveHeaderType ptr
if frequency=0 then frequency=__Samplerate
if channels=0 then channels=__channels
if bits=0 then bits=__bits_used
dim as ulong SampleSize=(bits\8)*channels
dim as ulong DataSize=SampleSize*buffersize
'dim soundbuffer as ubyte ptr=new ubyte[DataSize+44]
dim as ulong ptr s=callocate(DataSize+44) 'cast(ulong ptr,soundbuffer)
s[ 0]=FCC("RIFF")
s[ 1]=36 + DataSize
s[ 2]=FCC("WAVE")
s[ 3]=FCC("fmt ")
s[ 4]=16
s[ 5]=(channels shl 16) or 1
s[ 6]=frequency
s[ 7]=SampleSize*frequency
s[ 8]=(Bits shl 16) or SampleSize
s[ 9]=FCC("data")
s[10]=DataSize
return cast(WaveHeaderType ptr,s)
end function
FUNCTION LoadWave(FileName as string) as WaveHeaderType ptr
' dim f as WaveHeaderType ptr
' Dim idFile As long = Freefile
' Open FileName For input As #idFile
' dim l as uinteger=lof(idFile)
' f=allocate(l)
' Get #idFile,,*cast(ubyte ptr,f),l
' close #idfile
' return f
dim t as ulong, frequency as long, channels as long, bits as long, DataSize as ulong, SampleSize as ulong, hd as string
Dim idFile As long = Freefile
Open FileName For binary access read As #idFile
hd=input(4,idFile): if hd<>"RIFF" then return 0
Get #idFile,,t
hd=input(4,idFile): if hd<>"WAVE" then return 0
do
hd=input(4,idFile)
if hd<>"fmt " then Get #idFile,,t: hd=input(t,idFile)
if eof(idFile) then return 0
loop until hd="fmt "
Get #idFile,,t: if t<>16 then return 0 'Likely a compressed file, not handled by this routine
Get #idFile,,t: channels=t shr 16
Get #idFile,,frequency
Get #idFile,,t
Get #idFile,,t: bits=t shr 16: SampleSize=t and 255
do
hd=input(4,idFile)
if hd<>"data" then Get #idFile,,t: hd=input(t,idFile)
if eof(idFile) then return 0
loop until hd="data"
Get #idFile,,DataSize
dim as ulong ptr s=allocate(DataSize+44)
s[ 0]=FCC("RIFF")
s[ 1]=36 + DataSize
s[ 2]=FCC("WAVE")
s[ 3]=FCC("fmt ")
s[ 4]=16
s[ 5]=(channels shl 16) or 1
s[ 6]=frequency
s[ 7]=SampleSize*frequency
s[ 8]=(Bits shl 16) or SampleSize
s[ 9]=FCC("data")
s[10]=DataSize
Get #idFile,,*(cast(ubyte ptr,s)+44),DataSize
close #idfile
return cast(WaveHeaderType ptr,s)
end function
sub PlayWave(buffer as WaveHeaderType ptr)
if buffer->RiffID<>FCC("RIFF") orelse buffer->WavID<>FCC("WAVE") then exit sub
if __bits_used=16 then
if __channels=1 then
if buffer->Channels = 2 then
if buffer->FmtSpecific=16 then
dim as integer noSamples=buffer->DataLength/4
dim as short convert(noSamples)
dim as short ptr SourcePtr=cast(short ptr,(cast(byte ptr,buffer)+44))
for i as integer=0 to noSamples
convert(i)=(SourcePtr[i*2]+SourcePtr[i*2+1])/2
next
playbuffer @convert(0), noSamples*2
elseif buffer->FmtSpecific=8 then
dim as integer noSamples=buffer->DataLength/2
dim as short convert(noSamples)
dim as ubyte ptr SourcePtr=cast(ubyte ptr,buffer)+44
for i as integer=0 to noSamples
convert(i)=((SourcePtr[i*2]+SourcePtr[i*2+1])/2-128)*255
next
playbuffer @convert(0), noSamples*2
end if
elseif buffer->Channels = 1 then
if buffer->FmtSpecific=16 then
playbuffer cast(byte ptr,buffer)+44, buffer->DataLength
elseif buffer->FmtSpecific=8 then
dim as integer noSamples=buffer->DataLength
dim as short convert(noSamples)
dim as ubyte ptr SourcePtr=cast(ubyte ptr,buffer)+44
for i as integer=0 to noSamples
convert(i)=(SourcePtr[i]-128)*255
next
playbuffer @convert(0), noSamples*2
end if
end if
elseif __channels=2 then
if buffer->Channels = 2 then
if buffer->FmtSpecific=16 then
playbuffer cast(byte ptr,buffer)+44, buffer->DataLength
elseif buffer->FmtSpecific=8 then
dim as integer noSamples=buffer->DataLength
dim as short convert(noSamples)
dim as ubyte ptr SourcePtr=cast(ubyte ptr,buffer)+44
for i as integer=0 to noSamples
convert(i)=(SourcePtr[i]-128)*255
next
playbuffer @convert(0), noSamples*2
end if
elseif buffer->Channels = 1 then
if buffer->FmtSpecific=16 then
dim as integer noSamples=buffer->DataLength/2
dim as short convert(noSamples*2)
dim as short ptr SourcePtr=cast(short ptr,(cast(byte ptr,buffer)+44))
for i as integer=0 to noSamples
convert(i*2)=SourcePtr[i]
convert(i*2+1)=SourcePtr[i]
next
playbuffer @convert(0), noSamples*4
elseif buffer->FmtSpecific=8 then
dim as integer noSamples=buffer->DataLength
dim as short convert(noSamples*2)
dim as ubyte ptr SourcePtr=cast(ubyte ptr,buffer)+44
for i as integer=0 to noSamples
convert(i*2)=(SourcePtr[i]-128)*255
convert(i*2+1)=(SourcePtr[i]-128)*255
next
playbuffer @convert(0), noSamples*4
end if
end if
end if
elseif __bits_used=8 then
if __channels=1 then
if buffer->Channels = 2 then
if buffer->FmtSpecific=16 then
dim as integer noSamples=buffer->DataLength/4
dim as ubyte convert(noSamples)
dim as short ptr SourcePtr=cast(short ptr,(cast(byte ptr,buffer)+44))
for i as integer=0 to noSamples
convert(i)=(((SourcePtr[i*2]+SourcePtr[i*2+1])/2)/255)+128
next
playbuffer @convert(0), noSamples
elseif buffer->FmtSpecific=8 then
dim as integer noSamples=buffer->DataLength/2
dim as ubyte convert(noSamples)
dim as ubyte ptr SourcePtr=cast(ubyte ptr,buffer)+44
for i as integer=0 to noSamples
convert(i)=(SourcePtr[i*2]+SourcePtr[i*2+1])/2
next
playbuffer @convert(0), noSamples
end if
elseif buffer->Channels = 1 then
if buffer->FmtSpecific=16 then
dim as integer noSamples=buffer->DataLength/2
dim as ubyte convert(noSamples)
dim as short ptr SourcePtr=cast(short ptr,(cast(byte ptr,buffer)+44))
for i as integer=0 to noSamples
convert(i)=(SourcePtr[i]/255)+128
next
playbuffer @convert(0), noSamples
elseif buffer->FmtSpecific=8 then
playbuffer cast(byte ptr,buffer)+44, buffer->DataLength
end if
end if
elseif __channels=2 then
if buffer->Channels = 2 then
if buffer->FmtSpecific=16 then
dim as integer noSamples=buffer->DataLength/4
dim as ubyte convert(noSamples*2)
dim as short ptr SourcePtr=cast(short ptr,(cast(byte ptr,buffer)+44))
for i as integer=0 to noSamples*2
convert(i)=(SourcePtr[i]/255)+128
next
playbuffer @convert(0), noSamples*2
elseif buffer->FmtSpecific=8 then
playbuffer cast(byte ptr,buffer)+44, buffer->DataLength
end if
elseif buffer->Channels = 1 then
if buffer->FmtSpecific=16 then
dim as integer noSamples=buffer->DataLength/2
dim as ubyte convert(noSamples*2)
dim as short ptr SourcePtr=cast(short ptr,(cast(byte ptr,buffer)+44))
for i as integer=0 to noSamples
convert(i*2)=(SourcePtr[i]/255)+128
convert(i*2+1)=(SourcePtr[i]/255)+128
next
playbuffer @convert(0), noSamples*2
elseif buffer->FmtSpecific=8 then
dim as integer noSamples=buffer->DataLength
dim as ubyte convert(noSamples*2)
dim as ubyte ptr SourcePtr=cast(ubyte ptr,buffer)+44
for i as integer=0 to noSamples
convert(i*2)=SourcePtr[i]
convert(i*2+1)=SourcePtr[i]
next
playbuffer @convert(0), noSamples*2
end if
end if
end if
end if
end sub
'### wave.bas ###
'' === SoundFunctions.bas ===
'declare sub SoundSet(frequency as long, channels as long, bits as long)
'declare sub playbuffer (soundBuffer as any ptr, buffersize as long)
'common shared __Samplerate as integer, __channels as integer, __bits_used as integer
dim shared diff as single
/'
type SoundFunction extends object
t as single
fm as single
Duration as integer
child as SoundFunction ptr
child2 as SoundFunction ptr
declare abstract function GetNext() as single
Declare Destructor()
end type
'/
Destructor SoundFunction
if child then delete child
if child2 then delete child2
end Destructor
type SineWaveFunction extends SoundFunction
Freq as single
declare function GetNext() as single
end type
function SineWaveFunction.GetNext() as single
t+=1
return sin(6.28/__Samplerate*Freq*t+fm)
end function
Function SineWave (Freq as single) as SineWaveFunction ptr
dim w as SineWaveFunction ptr=new SineWaveFunction
w->Freq=Freq
return w
end function
type TriangleWaveFunction extends SoundFunction
Freq as single
declare function GetNext() as single
end type
function TriangleWaveFunction.GetNext() as single
t+=1
dim r as single
r=1.0/__Samplerate*Freq*t+fm
return (abs((r-int(r))*4-2)-1)
end function
Function TriangleWave (Freq as single) as TriangleWaveFunction ptr
dim w as TriangleWaveFunction ptr=new TriangleWaveFunction
w->Freq=Freq
return w
end function
type PulseWaveFunction extends SoundFunction
Freq as single
DutyCycle as single
declare function GetNext() as single
end type
function PulseWaveFunction.GetNext() as single
t+=1
if child<>0 then DutyCycle=child->GetNext/2+.5
dim r as single
r=1.0/__Samplerate*Freq*t+fm
return (((r-int(r))>DutyCycle)*2+1)
end function
Function PulseWave Overload(Freq as single, DutyCycle as single=.5) as PulseWaveFunction ptr
dim w as PulseWaveFunction ptr=new PulseWaveFunction
w->Freq=Freq
w->DutyCycle=DutyCycle
return w
end function
Function PulseWave Overload(Freq as single, DutyCycle as any ptr) as PulseWaveFunction ptr
dim w as PulseWaveFunction ptr=new PulseWaveFunction
w->Freq=Freq
w->child=DutyCycle
return w
end function
type SawtoothWaveFunction extends SoundFunction
Freq as single
declare function GetNext() as single
end type
function SawtoothWaveFunction.GetNext() as single
t+=1
dim r as single
r=1.0/__Samplerate*Freq*t+fm
return ((r-int(r))*2-1)
end function
Function SawtoothWave (Freq as single) as SawtoothWaveFunction ptr
dim w as SawtoothWaveFunction ptr=new SawtoothWaveFunction
w->Freq=Freq
return w
end function
type NoiseWaveFunction extends SoundFunction
declare function GetNext() as single
end type
function NoiseWaveFunction.GetNext() as single
return rnd*2-1
end function
Function NoiseWave () as NoiseWaveFunction ptr
dim w as NoiseWaveFunction ptr=new NoiseWaveFunction
return w
end function
type HarmonicWaveFunction extends SoundFunction
Freq as single
harmonic(1 to 10) as single
declare function GetNext() as single
end type
function HarmonicWaveFunction.GetNext() as single
t+=1
dim r as single, w as single
w=6.28/__Samplerate*Freq*t+fm
r+=sin(w)*harmonic(1)
r+=sin(2*w)*harmonic(2)
r+=sin(3*w)*harmonic(3)
r+=sin(4*w)*harmonic(4)
r+=sin(5*w)*harmonic(5)
r+=sin(6*w)*harmonic(6)
r+=sin(7*w)*harmonic(7)
r+=sin(8*w)*harmonic(8)
r+=sin(9*w)*harmonic(9)
r+=sin(10*w)*harmonic(10)
return r
end function
Function HarmonicWave (Freq as single, _
h1 as single=1, h2 as single=0, h3 as single=0, h4 as single=0, h5 as single=0,_
h6 as single=0, h7 as single=0, h8 as single=0, h9 as single=0, h10 as single=0)_
as HarmonicWaveFunction ptr
dim w as HarmonicWaveFunction ptr=new HarmonicWaveFunction
w->Freq=Freq
dim as single divisor
divisor=abs(h1)+abs(h2)+abs(h3)+abs(h4)+abs(h5)+abs(h6)+abs(h7)+abs(h8)+abs(h9)+abs(h10)
w->Harmonic(1)=h1/divisor
w->Harmonic(2)=h2/divisor
w->Harmonic(3)=h3/divisor
w->Harmonic(4)=h4/divisor
w->Harmonic(5)=h5/divisor
w->Harmonic(6)=h6/divisor
w->Harmonic(7)=h7/divisor
w->Harmonic(8)=h8/divisor
w->Harmonic(9)=h9/divisor
w->Harmonic(10)=h10/divisor
return w
end function
type FilterFunction extends SoundFunction
cutoffFreq as single
pass as integer
resonance as single
as single pole0, pole1, pole2, pole3, pole4
as single oldpole0,oldpole1,oldpole2,oldpole3,oldpole4
declare function GetNext() as single
end type
function FilterFunction.GetNext() as single
dim as single f,q, p
if child2=0 then
f=sin(3.1415926*cutoffFreq/__Samplerate) 'frequency
else
f=sin(3.1415926*cutoffFreq*(child2->GetNext/2+.5)/__Samplerate) 'frequency
end if
'the following two lines are a quick approx of q=r*e^(1-f)*loge(4)
q=1-f
q=resonance*(1+q+q*q*0.5+q*q*q*0.167)*1.386294
pole0=1e-20 + child->GetNext -pole4*q
p=f+f-1
pole1=(pole0+oldpole0)*f-p*pole1
pole2=(pole1+oldpole1)*f-p*pole2
pole3=(pole2+oldpole2)*f-p*pole3
pole4=(pole3+oldpole3)*f-p*pole4
oldpole0=pole0
oldpole1=pole1
oldpole2=pole2
oldpole3=pole3
if pass=1 then
return pole4
elseif pass=2 then
return pole0-pole4
elseif pass=3 then
return pole1-pole4
elseif pass=4 then
return pole0+pole4-pole1
end if
end function
Function DSPFilter Overload(func as any ptr, cutoff as single, p as integer=1, res as single=0) as FilterFunction ptr
dim w as FilterFunction ptr=new FilterFunction
w->cutoffFreq=cutoff
w->pass=p
w->resonance=res
w->child=func
return w
end function
Function DSPFilter Overload(func as any ptr, cutoff as single, func2 as any ptr, p as integer=1, res as single=0) as FilterFunction ptr
dim w as FilterFunction ptr=new FilterFunction
w->cutoffFreq=cutoff
w->pass=p
w->resonance=res
w->child=func
w->child2=func2
return w
end function
type SyncWaveFunction extends SoundFunction
Freq as single
declare function GetNext() as single
end type
function SyncWaveFunction.GetNext() as single
t+=1
if (1.0/__Samplerate*Freq*t+fm)>1 then child->t=0:t=0
return child->getnext
end function
Function SyncWave (func as any ptr, Freq as single) as SyncWaveFunction ptr
dim w as SyncWaveFunction ptr=new SyncWaveFunction
w->child=func
w->Freq=Freq
return w
end function
type FrequencyModulateFunction extends SoundFunction
modulator as single
declare function GetNext() as single
end type
function FrequencyModulateFunction.GetNext() as single
if Modulator then
child->fm=child2->GetNext()*modulator
return child->getnext
else
child->t+=child2->GetNext()
return child->getnext
end if
end function
function FrequencyModulate(func1 as any ptr, func2 as any ptr, modul as single, detune as integer=0) as FrequencyModulateFunction ptr
dim w as FrequencyModulateFunction ptr=new FrequencyModulateFunction
w->child=func1
w->child2=func2
w->modulator=modul
w->child2->t+=detune
return w
end function
type AmplitudeModulateFunction extends SoundFunction
ringmodulator as integer
declare function GetNext() as single
end type
function AmplitudeModulateFunction.GetNext() as single
if ringmodulator then
return child->getnext*child2->GetNext()
else
return child->getnext*(child2->GetNext()+1)/2
end if
end function
function AmplitudeModulate(func1 as any ptr, func2 as any ptr, ring as integer=0, detune as integer=0) as AmplitudeModulateFunction ptr
dim w as AmplitudeModulateFunction ptr=new AmplitudeModulateFunction
w->child=func1
w->child2=func2
w->ringmodulator=ring
w->child2->t+=detune
return w
end function
type MixWavesFunction extends SoundFunction
declare function GetNext() as single
end type
function MixWavesFunction.GetNext() as single
return (child->getnext+child2->GetNext())/2
end function
function MixWaves(func1 as any ptr, func2 as any ptr, detune as integer=0) as MixWavesFunction ptr
dim w as MixWavesFunction ptr=new MixWavesFunction
w->child=func1
w->child2=func2
w->child2->t+=detune
return w
end function
type StereoFunction extends SoundFunction
declare function GetNext() as single
end type
function StereoFunction.GetNext() as single
dim l as single=child->getnext()
dim r as single=child2->getnext()
diff=(l-r)/2
return (l+r)/2
end function
function Stereo(func1 as any ptr, func2 as any ptr) as StereoFunction ptr
dim w as StereoFunction ptr=new StereoFunction
w->child=func1
w->child2=func2
return w
end function
type PanningFunction extends SoundFunction
Gain as single
Pan as single
declare function GetNext() as single
end type
function PanningFunction.GetNext() as single
dim s as single=child->getnext()*Gain
if child2<>0 then Pan=child2->GetNext()
diff=s*Pan
return s
end function
function Panning overload(func1 as any ptr, pan as single=0, gain as single=.5) as PanningFunction ptr
dim w as PanningFunction ptr=new PanningFunction
w->child=func1
w->Pan=pan
w->Gain=gain
return w
end function
function Panning overload(func1 as any ptr, func2 as any ptr, gain as single=.5) as PanningFunction ptr
dim w as PanningFunction ptr=new PanningFunction
w->child=func1
w->child2=func2
w->Gain=gain
return w
end function
type EnvelopeFunction extends SoundFunction
A as integer
D as integer
S as integer
R as integer
Incr as single
DecD as single
DecR as single
Amplitude as single
declare function GetNext() as single
end type
function EnvelopeFunction.GetNext() as single
IF t <= A THEN
Amplitude+=Incr
ELSEIF t < D THEN
Amplitude-=DecD
ELSEIF t < S THEN
ELSEIF t < R THEN
Amplitude-=DecR
END IF
t+=1
if child=0 then
return Amplitude*2-1
else
return Amplitude*child->getnext
end if
end function
function ADSREnvelope Overload(Attack as single, Decay as single, Sustain as single, Release as Single, Dur as single) as EnvelopeFunction ptr
dim w as EnvelopeFunction ptr=new EnvelopeFunction
w->Duration=dur
dim as single S = 1 - Attack - Decay - Release
w->Incr = 1 / (Dur*__Samplerate * Attack + 1)
w->DecD = (1 - Sustain) / (Dur*__Samplerate * Decay + 1)
w->DecR = Sustain / (Dur*__Samplerate * Release + 1)
w->A = Attack*Dur*__Samplerate
w->D = Decay*Dur*__Samplerate + w->A
w->S = S*Dur*__Samplerate + w->D
w->R = Release*Dur*__Samplerate + w->S
return w
end function
function ADSREnvelope Overload(func as any ptr, Attack as single, Decay as single, Sustain as single, Release as Single, Dur as single) as EnvelopeFunction ptr
dim w as EnvelopeFunction ptr=new EnvelopeFunction
w->child=func
w->Duration=dur
dim as single S = 1 - Attack - Decay - Release
w->Incr = 1 / (Dur*__Samplerate * Attack + 1)
w->DecD = (1 - Sustain) / (Dur*__Samplerate * Decay + 1)
w->DecR = Sustain / (Dur*__Samplerate * Release + 1)
w->A = Attack*Dur*__Samplerate
w->D = Decay*Dur*__Samplerate + w->A
w->S = S*Dur*__Samplerate + w->D
w->R = Release*Dur*__Samplerate + w->S
return w
end function
sub sound overload (func as SoundFunction ptr, duration as single)
dim samples as integer=duration * __Samplerate
dim sbytes as integer
if __bits_used=16 then
if __channels=1 then
sbytes=samples*2
dim SoundBuffer(samples) as short
for i as integer=0 to samples
SoundBuffer(i)= func->GetNext*32767
next
PlayBuffer @SoundBuffer(0), sbytes
else
sbytes=samples*4
dim SoundBuffer(samples*2) as short
for i as integer=0 to samples
diff=0
dim s as short = func->GetNext*32767
diff*=32767
SoundBuffer(i*2)= s+diff
SoundBuffer(i*2+1)= s-diff
next
PlayBuffer @SoundBuffer(0), sbytes
end if
elseif __bits_used=8 then
if __channels=1 then
sbytes=samples
dim SoundBuffer(samples) as ubyte
for i as integer=0 to samples
SoundBuffer(i)= func->GetNext*127+127
next
PlayBuffer @SoundBuffer(0), sbytes
else
sbytes=samples*2
dim SoundBuffer(samples*2) as ubyte
for i as integer=0 to samples
diff=0
dim s as ubyte = func->GetNext*127+127
diff*=127
SoundBuffer(i*2)= s+diff
SoundBuffer(i*2+1)= s-diff
next
PlayBuffer @SoundBuffer(0), sbytes
end if
end if
delete func
end sub
'#define FCC(c) *(cptr(Ulong Ptr,@##c))
sub sound overload(buffer as WaveHeaderType ptr, start as single=0, func as SoundFunction ptr, duration as single)
if buffer->RiffID<>FCC("RIFF") orelse buffer->WavID<>FCC("WAVE") then exit sub
diff=0
dim rate as integer=__Samplerate
__Samplerate=buffer->SamplesPerSec
dim samples as integer=duration * __Samplerate
dim startsample as integer=start * __Samplerate
if buffer->Channels = 2 then
if buffer->FmtSpecific=16 then
dim as short ptr SourcePtr=cast(short ptr,(cast(byte ptr,buffer)+44))
SourcePtr+=startsample*2
for i as integer=0 to samples
diff=0
dim s as short=func->GetNext*32767
diff*=32767
SourcePtr[i*2]=s+diff
SourcePtr[i*2+1]=s-diff
next
elseif buffer->FmtSpecific=8 then
dim as ubyte ptr SourcePtr=cast(ubyte ptr,(cast(byte ptr,buffer)+44))
SourcePtr+=startsample*2
for i as integer=0 to samples
diff=0
dim s as ubyte=func->GetNext*127+127
diff*=127
SourcePtr[i*2]=s+diff
SourcePtr[i*2+1]=s-diff
next
end if
elseif buffer->Channels = 1 then
if buffer->FmtSpecific=16 then
dim as short ptr SourcePtr=cast(short ptr,(cast(byte ptr,buffer)+44))
SourcePtr+=startsample
for i as integer=0 to samples
SourcePtr[i]=func->GetNext*32767
next
elseif buffer->FmtSpecific=8 then
dim as ubyte ptr SourcePtr=cast(ubyte ptr,(cast(byte ptr,buffer)+44))
SourcePtr+=startsample
for i as integer=0 to samples
SourcePtr[i]=func->GetNext*127+127
next
end if
end if
__Samplerate=rate
end sub
type DSPWaveFunction extends SoundFunction
buffer as WaveHeaderType ptr
Speed as single
declare function GetNext() as single
end type
function DSPWaveFunction.GetNext() as single
t+=speed
dim r as single
r=1.0/__Samplerate*buffer->SamplesPerSec*t+fm
' if r<0 then r=cast(single,buffer->DataLength/buffer->blockalign)
' if r>cast(single,buffer->DataLength/buffer->blockalign) then r=0
dim i as uinteger=cast(uinteger,r) mod (buffer->DataLength/buffer->blockalign)
if buffer->Channels = 2 then
if buffer->FmtSpecific=16 then
dim as short ptr SourcePtr=cast(short ptr,(cast(byte ptr,buffer)+44))
diff=cast(single,(SourcePtr[i*2]-SourcePtr[i*2+1])/2)/32767
return (cast(single,(SourcePtr[i*2]+SourcePtr[i*2+1])/2)/32767)
elseif buffer->FmtSpecific=8 then
dim as ubyte ptr SourcePtr=cast(ubyte ptr,(cast(byte ptr,buffer)+44))
diff=cast(single,(SourcePtr[i*2]-SourcePtr[i*2+1])/2)/128
return (cast(single,(SourcePtr[i*2]+SourcePtr[i*2+1])/2-127)/128)
end if
elseif buffer->Channels = 1 then
if buffer->FmtSpecific=16 then
dim as short ptr SourcePtr=cast(short ptr,(cast(byte ptr,buffer)+44))
return (cast(single,SourcePtr[i])/32767)
elseif buffer->FmtSpecific=8 then
dim as ubyte ptr SourcePtr=cast(ubyte ptr,(cast(byte ptr,buffer)+44))
return (cast(single,SourcePtr[i]-127)/128)
end if
end if
end function
Function DSPWave (buffer as WaveHeaderType ptr, speed as single=1) as DSPWaveFunction ptr
dim w as DSPWaveFunction ptr=new DSPWaveFunction
w->Speed=Speed
w->buffer=buffer
return w
end function
'' ### SoundFunctions.bas ###
'' === playtomidi.bas ===
'#include "sequencer.bi"
'declare sub PlayMidi(buffer as MidiSequence ptr, background as integer)
'declare function MidiPlaying() as MidiSequence ptr
'declare sub PauseMidi(m as integer)
FUNCTION WriteVarLen(Value as integer) as string
dim a as string
a=chr(Value AND 127)
DO WHILE (Value > 127)
Value = Value shr 7
a=chr((Value AND 127)or 128)+a
LOOP
return a
END FUNCTION
function _fbplay_internal_translateNote(toTranslate as string) as ubyte
select case toTranslate
case "c" : return 0
case "cs" : return 1
case "db" : return 1
case "d" : return 2
case "ds" : return 3
case "eb" : return 3
case "e" : return 4
case "fb" : return 4
case "f" : return 5
case "es" : return 5
case "fs" : return 6
case "gb" : return 6
case "g" : return 7
case "gs" : return 8
case "ab" : return 8
case "a" : return 9
case "as" : return 10
case "bb" : return 10
case "b" : return 11
case "cb" : return 11
end select
end function
function _fbplay_internal(channel as ubyte, playstr as string) as string
'default tempo is 120 quarter notes per minute
'default note is a quarter note
'as default notes play their full length
'default octave is the 4th
'default instrument is acoustic grand piano |TODO: Find a instrument closer to QB's PLAY sound.
'maximum volume is default
dim Track as string
dim tempo as uinteger = 120
dim note_len as ubyte = 4
dim note_len_mod as double = 1
dim octave as ubyte = 4
dim volume as ubyte = 127
dim note_stack(128) as ubyte
dim chord as ubyte
dim next_event as double
dim duration as double
dim idx as ubyte
dim number as string
dim char as string*1
dim tChar as string*1
dim toTranslate as string
dim p as integer=1
do while p <= len(playstr)
char=lcase(mid(playstr, p, 1))
p+=1
select case char
'basic playing
case "n" 'plays note with next-comming number, if 0 then pause
number=""
do
tchar=mid(playstr, p, 1)
if asc(tchar)>=48 and asc(tchar)<=57 then
p+=1
number+=tchar
else
exit do
end if
loop
idx=val(number)
if idx=0 then 'pause
next_event+=60/tempo*(4/note_len)/60
else 'note
duration=60/tempo*(4/note_len)
Track=Track+WriteVarLen(240*next_event)+chr(&H90 + channel)+chr(idx)+chr(volume)
next_event=duration*(1-note_len_mod)
'stop_note(channel)=t+duration*note_len_mod(channel)
note_stack(0)+=1
note_stack(note_stack(0))=idx
end if
case "a" to "g" 'plays a to g in current octave
duration=60/tempo*(4/note_len)
toTranslate=char
number=""
char=mid(playstr, p, 1)
if char="-" then
toTranslate+="b"
p+=1
elseif char="+" or char="#" then
toTranslate+="s"
p+=1
end if
do
char=mid(playstr, p, 1)
if asc(char)>=48 and asc(char)<=57 then
p+=1
number+=char
else
exit do
end if
loop
if val(number)<>0 then duration=duration*4/val(number)
if char="." then duration=duration*1.5
idx=12*octave+_fbplay_internal_translateNote(toTranslate)
Track=Track+WriteVarLen(240*next_event)+chr(&H90 + channel)+chr(idx)+chr(volume)
next_event=duration*(1-note_len_mod)
note_stack(0)+=1
note_stack(note_stack(0))=idx
case "p" 'pauses for next-comming number of quarter notes
number=""
do
char=mid(playstr, p, 1)
if asc(char)>=48 and asc(char)<=57 then
p+=1
number+=char
else
exit do
end if
loop
next_event+=60/tempo*4/val(number)
'octave handling
case ">" 'up one octave
if octave<7 then octave+=1
case "<" 'down one octave
if octave>1 then octave-=1
case "o" 'changes octave to next-comming number
number=""
do
char=mid(playstr, p, 1)
if asc(char)>=48 and asc(char)<=57 then
p+=1
number+=char
else
exit do
end if
loop
octave=val(number)
'play control
case "t" 'changes tempo (quarter notes per minute)
number=""
do
char=mid(playstr, p, 1)
if asc(char)>=48 and asc(char)<=57 then
p+=1
number+=char
else
exit do
end if
loop
tempo=val(number)
case "l" 'changes note length (1=full note, 4=quarter note, 8 eigth(?) note aso)
number=""
do
char=mid(playstr, p, 1)
if asc(char)>=48 and asc(char)<=57 then
p+=1
number+=char
else
exit do
end if
loop
note_len=val(number)
case "m" 'MS makes note last 3/4, MN is 7/8 and ML sets to normal length
char=lcase(mid(playstr, p, 1))
p+=1
if char="s" then note_len_mod=3/4
if char="n" then note_len_mod=7/8
if char="l" then note_len_mod=1
'new midi fucntions
case "i"
number=""
do
char=mid(playstr, p, 1)
if asc(char)>=48 and asc(char)<=57 then
p+=1
number+=char
else
exit do
end if
loop
Track=Track+WriteVarLen(0)+chr(&HC0 + channel)+chr(val(number))
case "v"
number=""
do
char=mid(playstr, p, 1)
if asc(char)>=48 and asc(char)<=57 then
p+=1
number+=char
else
exit do
end if
loop
volume=val(number)
Case "{" 'enable chords (notes play simultaneously)
chord=1
Case "}" 'disable chords (notes play simultaneously)
chord=0
case else
end select
if chord then
if chord=2 then next_event=0 else chord=2
else
'Stop current note, if still playing
for i as integer=1 to note_stack(0)
Track=Track+WriteVarLen(240*duration*note_len_mod)+chr(&H80 + channel)+chr(note_stack(i))+chr(0)
duration=0
next
note_stack(0)=0
end if
loop
return Track
end function
sub play overload (Midi as MidiSequence ptr, playstr as string, playstr1 as string="", playstr2 as string="", playstr3 as string="", _
playstr4 as string="", playstr5 as string="", playstr6 as string="", playstr7 as string="", _
playstr8 as string="", playstr9 as string="", playstr10 as string="", playstr11 as string="", _
playstr12 as string="", playstr13 as string="", playstr14 as string="", playstr15 as string="")
'if lcase(left(_fbplay_internal_playstr(0),2))="mb" then 'supposed to play in foreground
Midi->Track(1)+=_fbplay_internal (0,playstr)
Midi->Track(2)+=_fbplay_internal (1,playstr1)
Midi->Track(3)+=_fbplay_internal (2,playstr2)
Midi->Track(4)+=_fbplay_internal (3,playstr3)
Midi->Track(5)+=_fbplay_internal (4,playstr4)
Midi->Track(6)+=_fbplay_internal (5,playstr5)
Midi->Track(7)+=_fbplay_internal (6,playstr6)
Midi->Track(8)+=_fbplay_internal (7,playstr7)
Midi->Track(9)+=_fbplay_internal (8,playstr8)
Midi->Track(10)+=_fbplay_internal (9,playstr9)
Midi->Track(11)+=_fbplay_internal (10,playstr10)
Midi->Track(12)+=_fbplay_internal (11,playstr11)
Midi->Track(13)+=_fbplay_internal (12,playstr12)
Midi->Track(14)+=_fbplay_internal (13,playstr13)
Midi->Track(15)+=_fbplay_internal (14,playstr14)
Midi->Track(16)+=_fbplay_internal (15,playstr15)
for i as integer =16 to 1 step -1
if Midi->Track(i)<>"" then Midi->Tracks=i:exit for
next
end sub
sub play overload (playstr as string, playstr1 as string="", playstr2 as string="", playstr3 as string="", _
playstr4 as string="", playstr5 as string="", playstr6 as string="", playstr7 as string="", _
playstr8 as string="", playstr9 as string="", playstr10 as string="", playstr11 as string="", _
playstr12 as string="", playstr13 as string="", playstr14 as string="", playstr15 as string="")
static Midi as MidiSequence
dim AppendMidi as integer, FG as integer
Midi.Divisions=120
Midi.Tempo=60000000/120
if lcase(left(playstr,2))<>"mb" then 'supposed to play in foreground
do until MidiPlaying()=0
sleep 1
loop
FG=1
end if
if MidiPlaying()<>@Midi then
for i as integer=1 to 16
Midi.Track(1)=""
next
else
PauseMidi 1
AppendMidi=1
end if
Midi.Track(1)+=_fbplay_internal (0,playstr)
Midi.Track(2)+=_fbplay_internal (1,playstr1)
Midi.Track(3)+=_fbplay_internal (2,playstr2)
Midi.Track(4)+=_fbplay_internal (3,playstr3)
Midi.Track(5)+=_fbplay_internal (4,playstr4)
Midi.Track(6)+=_fbplay_internal (5,playstr5)
Midi.Track(7)+=_fbplay_internal (6,playstr6)
Midi.Track(8)+=_fbplay_internal (7,playstr7)
Midi.Track(9)+=_fbplay_internal (8,playstr8)
Midi.Track(10)+=_fbplay_internal (9,playstr9)
Midi.Track(11)+=_fbplay_internal (10,playstr10)
Midi.Track(12)+=_fbplay_internal (11,playstr11)
Midi.Track(13)+=_fbplay_internal (12,playstr12)
Midi.Track(14)+=_fbplay_internal (13,playstr13)
Midi.Track(15)+=_fbplay_internal (14,playstr14)
Midi.Track(16)+=_fbplay_internal (15,playstr15)
for i as integer =16 to 1 step -1
if Midi.Track(i)<>"" then Midi.Tracks=i:exit for
next
if FG=1 then
PlayMidi @Midi,0
exit sub
end if
if AppendMidi=0 then
PlayMidi @Midi,1
else
PauseMidi 0
end if
end sub
FUNCTION CreateMidi() as MidiSequence ptr
DIM Midi as MidiSequence ptr=new MidiSequence
Midi->Divisions=120
Midi->Tempo=60000000/120
return Midi
end function
'' ### playtomidi.bas ###
'' === writemidi.bas ===
FUNCTION WriteFourBytes(Value as integer) as string
dim a as string
a=chr(Value and 255)
Value shr= 8
a=chr(Value and 255)+a
Value shr= 8
a=chr(Value and 255)+a
Value shr= 8
a=chr(Value and 255)+a
return a
end function
SUB SaveMidi(FileName as string, Midi as MidiSequence ptr)
DIM buffer as string
DIM F as integer=FreeFile
OPEN FileName for binary access write as F
buffer="MThd"+chr(0)+chr(0)+chr(0)+chr(6)+chr(0)+chr(iif(Midi->Tracks>1,1,0))+_
chr(0)+chr(Midi->Tracks)+chr(Midi->Divisions shr 8)+chr(Midi->Divisions)
for I as integer=1 to Midi->Tracks
buffer=buffer+"MTrk"+WriteFourBytes(len(Midi->Track(I))+4)+Midi->Track(I)+chr(0)+chr(255)+chr(47)+chr(0)
next
' PRINT #F,"MThd"+chr(0)+chr(0)+chr(0)+chr(6)+chr(0)+chr(iif(Midi->Tracks>1,1,0))+_
' chr(0)+chr(Midi->Tracks)+chr(Midi->Divisions shr 8)+chr(Midi->Divisions)+buffer;
PUT #F, 1, buffer
CLOSE F
END SUB
'' ### writemidi.bas ###
'' === writewav.bas ===
SUB SaveWave(FileName as string, buffer as WaveHeaderType ptr)
DIM F as integer=FreeFile
OPEN FileName for binary access write as F
dim as ubyte ptr SourcePtr=cast(ubyte ptr,buffer)
PUT #F, 1, *SourcePtr, buffer->RiffLength + 8
CLOSE F
end sub
'' ### writewav.bas ###
'' === sequencer.bas ===
'#include "sequencer.bi"
'Declare sub MidiSend(event as UByte, a as UByte, b as UByte)
Declare sub _SeqPlay()
Declare function _SeqisPlaying() as integer
Declare sub _SeqStop()
DIM SHARED Midi as MidiSequence ptr
DIM SHARED P(1 to 16) as ubyte ptr
DIM SHARED NextEvent(1 to 16) as double
DIM SHARED InDelay(1 to 16) as ubyte
FUNCTION LoadMidi(FileName as string) as MidiSequence ptr
DIM Midi as MidiSequence ptr=new MidiSequence
DIM F as integer=FreeFile
OPEN FileName for binary access read as F
DIM buffer as string
DIM B as ubyte ptr
buffer=input(8,F)
if buffer <> "MThd"+chr(0)+chr(0)+chr(0)+chr(6) then delete Midi: close F:return 0 'Not a valid MIDI file
buffer=input(6,F)
b=StrPtr(buffer)
if b[1]>1 then delete Midi: close F:return 0 'Not a supported format
Midi->Tracks=b[3]
Midi->Divisions=b[4] shl 8 + b[5]
Midi->Tempo=60000000/120
for I as integer=1 to Midi->Tracks
buffer=input(4,F)
if buffer <> "MTrk" then delete Midi: close F:return 0
buffer=input(4,F):b=StrPtr(buffer)
dim TrackLength as integer=b[0] shl 24+b[1] shl 16 +b[2] shl 8+b[3]
Midi->Track(I)=left(input(TrackLength,F), TrackLength-4)
next
CLOSE F
return Midi
END FUNCTION
FUNCTION ReadVarLen (byref p as ubyte ptr) as integer
dim as integer Value=*p and 127
DO WHILE *p and 128
p=p+1
Value= (Value shl 7)+ (*p and 127)
LOOP
p=p+1
return Value
END FUNCTION
function _Sequencer_update() as integer
static StatusByte(1 to 16) as ubyte
dim playing as integer
for I as integer=1 to Midi->Tracks
if p(i)>=StrPtr(Midi->Track(i))+len(Midi->Track(i)) then continue for
playing=1
dim t as double=timer
if InDelay(I)=0 then
NextEvent(I)=(ReadVarLen(P(I))*Midi->tempo/Midi->Divisions/1e6)+t
InDelay(I)=1
end if
if t>=NextEvent(I) then
InDelay(I)=0
IF *P(I)=&HFF THEN
P(I)+=1
SELECT CASE *P(I)
CASE &H51
P(I)+=2
Midi->tempo=*P(I) shl 16+*(P(I)+1) shl 8 + *(P(I)+2)
P(I)+=3
CASE ELSE
P(I)+=1
DIM Skip as Integer=ReadVarLen(P(I))
P(I)+=Skip
END SELECT
ELSEIF *P(I) = &HF0 OR *P(I) = &HF7 THEN
P(I)+=1
DIM Skip as Integer=ReadVarLen(P(I))
P(I)+=Skip
ELSE
IF *P(I)>127 then StatusByte(I)=*P(I):P(I)+=1
SELECT CASE StatusByte(I) shr 4
CASE &H8, &H9, &HA, &HB, &HE
MidiSend(StatusByte(I), *P(I), *(P(I)+1))
P(I)+=2
CASE &HC, &HD
MidiSend(StatusByte(I), *P(I), 0)
P(I)+=1
CASE ELSE
END SELECT
END IF
end if
next
return playing
end function
sub PlayMidi(buffer as MidiSequence ptr, background as integer)
for I as integer=1 to buffer->Tracks
P(I)=StrPtr(buffer->Track(i))
NextEvent(I)=0
InDelay(I)=0
next
Midi=buffer
if background=0 then
dim p as integer
do
p=_Sequencer_update()
loop until p=0
else
_SeqPlay()
end if
end sub
sub PauseMidi(m as integer)
Static Position(1 to 16) as uinteger
if m=1 then
_SeqStop
for I as integer=1 to Midi->Tracks
Position(I)=cast(uinteger,P(I))-cast(uinteger,StrPtr(Midi->Track(i)))
next
elseif m=0 then
for I as integer=1 to Midi->Tracks
P(I)=StrPtr(Midi->Track(i))+Position(i)
next
_SeqPlay()
end if
end sub
function MidiPlaying() as MidiSequence ptr
if _SeqisPlaying()<>0 then return Midi else return 0
end function
'' ### sequencer.bas ###
'' === windows\dsp.bas ===
#Include once "crt/string.bi"
#include once "Windows.bi"
#include once "win/mmsystem.bi"
''common shared __Samplerate as integer, __channels as integer, __bits_used as integer
#ifndef WAVE_MAPPER
#define WAVE_MAPPER -1
#endif
dim shared _hWaveOut as HWAVEOUT
dim shared cs_ as CRITICAL_SECTION
type QueueWAVEHDR
_wavehdr as WAVEHDR
_next as QueueWAVEHDR ptr
end type
dim shared doneWaveHdrs as QueueWAVEHDR ptr
dim shared waitingBytes as integer
sub dsp_callback StdCall (_hWaveOut as HWAVEOUT, _
msg as UINT, _
instance as DWORD_PTR, _
p1 as DWORD_PTR, _
p2 as DWORD_PTR)
if msg = WOM_DONE then
dim p as QueueWAVEHDR ptr
p = cast(QueueWAVEHDR ptr, p1)
EnterCriticalSection(@cs_)
p->_next = doneWaveHdrs
doneWaveHdrs = p
LeaveCriticalSection(@cs_)
end if
end sub
sub clean_unprepares()
EnterCriticalSection(@cs_)
do while (doneWaveHdrs)
dim p as QueueWAVEHDR ptr
p = doneWaveHdrs
doneWaveHdrs = p->_next
waitingBytes -= p->_wavehdr.dwBufferLength
waveOutUnprepareHeader(_hWaveOut, @p->_wavehdr, sizeof(WAVEHDR))
deallocate(p->_wavehdr.lpData)
deallocate(p)
loop
LeaveCriticalSection(@cs_)
end sub
sub dsp_finalize()
if _hWaveOut then
waveOutPause(_hWaveOut)
waveOutReset(_hWaveOut)
clean_unprepares()
waveOutClose(_hWaveOut)
_hWaveOut = NULL
DeleteCriticalSection(@cs_)
end if
end sub
sub SoundSet(frequency as integer, channels as integer, bits as integer)
__Samplerate=frequency
__channels=channels
__bits_used=bits
dim as WAVEFORMATEX wfx
dsp_finalize()
memset(@wfx, 0, sizeof(wfx))
wfx.wFormatTag = WAVE_FORMAT_PCM
wfx.nChannels = channels
wfx.nSamplesPerSec = frequency
wfx.wBitsPerSample = bits
wfx.nBlockAlign = wfx.nChannels * wfx.wBitsPerSample / 8
wfx.nAvgBytesPerSec = wfx.nBlockAlign * wfx.nSamplesPerSec
wfx.cbSize = 0
if waveOutOpen(@_hWaveOut, _
WAVE_MAPPER, _
@wfx, _
cast(DWORD_PTR, @dsp_callback), _
cptr(DWORD_PTR, 0), _
CALLBACK_FUNCTION) <> MMSYSERR_NOERROR then
_hWaveOut = NULL
else
waveOutRestart(_hWaveOut)
InitializeCriticalSection(@cs_)
end if
end sub
sub playbuffer (soundBuffer as any ptr, buffersize as long)
if _hWaveOut then
dim p as WAVEHDR ptr = allocate(sizeof(QueueWAVEHDR))
memset(p, 0, sizeof(WAVEHDR))
p->lpData = allocate(buffersize)
if p->lpData=0 then
deallocate(p)
else
memcpy(p->lpData, SoundBuffer, buffersize)
p->dwBufferLength = buffersize: p->dwBytesRecorded = buffersize
waveOutPrepareHeader(_hWaveOut, p, sizeof(WAVEHDR))
if waveOutWrite(_hWaveOut, p, sizeof(WAVEHDR)) = MMSYSERR_NOERROR then
waitingBytes += p->dwBufferLength
else
waveOutUnprepareHeader(_hWaveOut, p, sizeof(WAVEHDR))
deallocate(p->lpData)
deallocate(p)
end if
end if
clean_unprepares()
end if
end sub
'' ### windows\dsp.bas ###
'' === windows\midi.bas ===
#include once "windows.bi"
#include once "win\mmsystem.bi"
Dim Shared As HMIDIOUT hMidiDevice
sub SoundMidiSet
midiOutOpen(@hMidiDevice, MIDI_MAPPER, 0, 0, null)
end sub
sub MidiSend(event as UByte, a as UByte, b as UByte)
midiOutShortMsg(hMidiDevice, event + a shl 8 + b shl 16)
end sub
'' ### windows\midi.bas ###
'' === windows\seqthread.bas ===
'declare function _Sequencer_update() as integer
dim shared isPlaying as integer
dim shared stopMidi as integer
sub _SeqThread(ByVal userdata As Any Ptr )
dim p as integer
do
p=_Sequencer_update()
loop until p=0 orelse stopMidi<>0
isPlaying=0:stopMidi=0
end sub
sub _SeqPlay()
static thread_seq as any ptr
isPlaying=1
thread_seq = threadcreate( @_SeqThread)
end sub
function _SeqisPlaying() as integer
return isPlaying
end function
sub _SeqStop()
stopMidi=1
do: loop until stopMidi=0
end sub
'' ### windows\seqthread.bas ###
'' ==============================================================================
'' https://www.freebasic.net/wiki/ExtLibsfx
'#cmdline "-gen gcc"
'#cmdline "-mt -exx"
'#include "sfx.bi"
'#inclib "fbsfx"
'common shared __Samplerate as long, __channels as long, __bits_used as long
SoundSet(6000,2,16) ' samplerate,channels,bits
print __Samplerate, __channels, __bits_used
sleep