Audio library for FreeBasic - Features

General discussion for topics related to the FreeBASIC project or its community.
Post Reply
hhr
Posts: 206
Joined: Nov 29, 2019 10:41

Re: Audio library for FreeBasic - Features

Post by hhr »

This program prints the values given in soundset when used with gas, gas64 and gcc64.
It prints zeros when started with gcc (32 bit).
Is this a bug?

Code: Select all

'' 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
srvaldez
Posts: 3373
Joined: Sep 25, 2005 21:54

Re: Audio library for FreeBasic - Features

Post by srvaldez »

hello hhr :)
FreeBasic is very finicky when it comes to using libraries compiled with FB, if you edit the buildwindows.bat and add -gen gcc then it works with gcc32 but not with gen gas
the only workaround that I can think of is to compile multiple versions of the library naming them accordingly, of course that complicates thing a bit but it's doable.
for reference, the library can be downloaded from https://sourceforge.net/projects/freeba ... ary/files/
--edit-- perhaps the easiest thing to do would be to include all the code in sfx.bi, then you don't have to worry about library compatibilities, this is what I would do.
in the past I could compile a lib using #lang "QB" and use the lib with #lang "FB" but that no longer works, you must compile the lib with the same #lang option as the program using the lib
FB compiled library incompatibilities is the main reason that I am against rewriting the fbrt in FreeBasic, until those issues are resolved stick to libraries written in C
srvaldez
Posts: 3373
Joined: Sep 25, 2005 21:54

Re: Audio library for FreeBasic - Features

Post by srvaldez »

@angros47 and @hhr
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
srvaldez
Posts: 3373
Joined: Sep 25, 2005 21:54

Re: Audio library for FreeBasic - Features

Post by srvaldez »

@angros47
in at least 2 places function/sub parameter declaration or the return type were different, I didn't keep track of them but one of them was long vs integer and another was any ptr vs MidiSequence ptr, there might have been more
it may be worthwhile to make the appropriate corrections to the lib and see if the problem reported by hhr is solved
angros47
Posts: 2321
Joined: Jun 21, 2005 19:04

Re: Audio library for FreeBasic - Features

Post by angros47 »

I might have missed a long/integer mistake when I started developing the library on linux 32 bit (since in 32 bit they are equivalent). If you could point me where it is, it would be helpful.

About the "any ptr": it is not a mistake, when the include files refers to a data type that is not supposed to be touched outside the library opaque pointers can be used
srvaldez
Posts: 3373
Joined: Sep 25, 2005 21:54

Re: Audio library for FreeBasic - Features

Post by srvaldez »

sorry angros47 but I didn't keep track, but one was the sub playbuffer where it's declared as

Code: Select all

declare sub playbuffer (soundBuffer as any ptr, buffersize as long)
but the implementation is

Code: Select all

sub playbuffer (soundBuffer as any ptr, buffersize as integer)
hhr
Posts: 206
Joined: Nov 29, 2019 10:41

Re: Audio library for FreeBasic - Features

Post by hhr »

@srvaldez
Thank you for the answer.
I have tested the include file and it works.
Thereby a problem occurred with the variable names 'Max' and 'Min', which has nothing to do with sfx.
I have to rename this variables.

Code: Select all

#include once "Windows.bi"
#include once "win/mmsystem.bi"
dim as single Max,Min
'dim as single Min,Max
print Max
print Min
sleep
D.J.Peters
Posts: 8586
Joined: May 28, 2005 3:28
Contact:

Re: Audio library for FreeBasic - Features

Post by D.J.Peters »

@hhr min() max() are macros defined in windows include files.
file: "ntdef.bi" line: 76

Code: Select all

#define min(a, b) iif((a) < (b), (a), (b))
#define max(a, b) iif((a) > (b), (a), (b))
and
file: "windef.bi" line: 115

Code: Select all

#define max(a, b) iif((a) > (b), (a), (b))
#define min(a, b) iif((a) < (b), (a), (b))
it's safe to undefine them.

Joshy

Code: Select all

#include once "Windows.bi"
#include once "win/mmsystem.bi"
#ifdef min
 #undef min 
#endif
#ifdef max
 #undef max
#endif
dim as integer min,max
sleep
hhr
Posts: 206
Joined: Nov 29, 2019 10:41

Re: Audio library for FreeBasic - Features

Post by hhr »

@D.J.Peters
Thank you, that solves the problem.
hhr
Posts: 206
Joined: Nov 29, 2019 10:41

Re: Audio library for FreeBasic - Features

Post by hhr »

A simple midistring parser. It reads a to g, p, one digit numbers and stores the values in an array.

Code: Select all

'' https://www.freebasic.net/wiki/ExtLibsfx
'' https://sourceforge.net/projects/freebasic-sfx-library/files/
'' https://en.wikipedia.org/wiki/Piano_key_frequencies

#cmdline "-mt -exx"
#include "sfx.bi"
#inclib "fbsfx"

''===================================================
dim as string s
s="i19t200"
s+="a2g2eeeea2g2aaaa"
s+="a2g2aaaaa2g2eeee"
s+="a2g2agededc<baaaaa2b2>cccecd2e2"
s+="p2"
s+="<a2b2>cccec<b2a2"
'-----------------------------------
's="i19t200"
's+="a2g2eeeea2g2aaaa"
's+="a2g2aaaaa2g2eeee"
's+="a2g2agededc<baaaaa2b2>cccecd2e2"
's+="p1"
's+="a2g2eeeea2g2aaaa"
's+="a2g2aaaaa2g2eeee"
's+="a2g2agededc<baaaaa2b2>cccec<b2a2"
'-----------------------------------
'SoundMidiSet
'dim as any ptr Midi=CreateMidi
'PLAY Midi,s
'SaveMidi("test.mid",Midi)
'PlayMidi(Midi,1)
'sleep
'end
''===================================================

sub Init8BitWave(buffer as WaveHeaderType ptr)
   if (buffer->FmtSpecific) <> 8 then exit sub
   dim as ulong i
   dim as ubyte ptr bptr=cast(ubyte ptr,buffer)
   for i=0 to (buffer->DataLength)-1
      bptr[i+44]=127
   next i
end sub

''===================================================

dim shared as single n(),d() ' n: MIDI note number, d: duration

sub MidiStringToArray(s as string)
   dim as single o
   dim as long i
   for i=0 to len(s)-1
      select case chr(s[i])
      case "a" to "g","p"
         redim preserve n(ubound(n)+1),d(ubound(d)+1) : d(ubound(d))=0.5
      end select
      
      select case chr(s[i])
      case "c"
         n(ubound(n))=48+o
      case "d"
         n(ubound(n))=50+o
      case "e"
         n(ubound(n))=52+o
      case "f"
         n(ubound(n))=53+o
      case "g"
         n(ubound(n))=55+o
      case "a"
         n(ubound(n))=57+o
      case "b"
         n(ubound(n))=59+o
      case "p"
         n(ubound(n))=0
      case "1" to "8"
         if (s[i-1]>=asc("a")) and (s[i-1]<=asc("g")) then d(ubound(d))=2/(s[i]-48) ' "a" to "g"
         if (s[i-1]=asc("p")) then d(ubound(d))=2/(s[i]-48)
      case "<"
         o=o-12
      case ">"
         o=o+12
      end select
   next
end sub

''===================================================

MidiStringToArray(s)

function MidiNoteToFrequency(n as single) as single
   return (2^((n-69)/12))*440
end function

dim as single start,duration,buffersize,i

'fill frequency array, change tones and duration of tones
dim as single f(ubound(n)) ' f: frequency
for i=lbound(n) to ubound(n)
   if n(i)>0 then f(i)=MidiNoteToFrequency(n(i)+3)
   d(i)/=2
next i

print " n"," d"," f"
for i=lbound(n) to ubound(n)
   print n(i),d(i),f(i)
next i

'Calculate duration of the whole example:
duration=0
for i=lbound(d) to ubound(d)
   duration+=d(i)
next i

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

dim as long samplerate,channels,bits
samplerate=44100
channels=1
bits=16

SoundSet(samplerate,channels,bits)

dim shared as WaveHeaderType ptr pWave(1 to 4)
buffersize=samplerate*(duration+0.4)

for i=lbound(pWave) to ubound(pWave)
   pWave(i)=CreateWave(buffersize,samplerate,channels,bits)
   Init8BitWave(pWave(i))
next i

sub tone1(start as single,n as single,d as single,f as single)
   if f=0 then exit sub
   Sound pWave(1),0,HarmonicWave(f,1,1,0,1,0,0,0,1),d
   Sound pWave(2),0,HarmonicWave(16*f,1,0.2),d
   Sound pWave(3),0,MixWaves(DSPWave(pWave(1)),DSPWave(pWave(2))),d
   Sound pWave(4),start,ADSREnvelope(DSPWave(pWave(3)),0.2,0.1,0.8,0.2,d),d
end sub

'fill buffer:
start=0.2
for i=lbound(n) to ubound(n)
   tone1(start,n(i),d(i),f(i))
   start+=d(i)
next i

'SaveWave("test.wav",pWave(4))

PlayWave(pWave(4))

sleep
hhr
Posts: 206
Joined: Nov 29, 2019 10:41

Re: Audio library for FreeBasic - Features

Post by hhr »

Echoes: a shifted copy is created from the original signal. The amplitude of the copy is decreased
and then the copy is mixed together with the original signal.

Code: Select all

'' https://www.freebasic.net/wiki/ExtLibsfx
'' https://sourceforge.net/projects/freebasic-sfx-library/files/

#cmdline "-mt -exx"
#include "sfx.bi"
#inclib "fbsfx"

''===================================================

type MixWavesVolumeFunction extends SoundFunction
   volume as single
   declare function GetNext() as single 
end type

function MixWavesVolumeFunction.GetNext() as single
   return (child->getnext+child2->GetNext*volume)/2
end function

function MixWavesVolume(func1 as any ptr, func2 as any ptr, volume as single=1) as MixWavesVolumeFunction ptr
   dim w as MixWavesVolumeFunction ptr=new MixWavesVolumeFunction
   w->child=func1
   w->child2=func2
   w->volume=volume
   
   return w
end function

''===================================================

sub Init8BitWave(buffer as WaveHeaderType ptr)
   if (buffer->FmtSpecific) <> 8 then exit sub
   dim as ulong i
   dim as ubyte ptr bptr=cast(ubyte ptr,buffer)
   for i=0 to (buffer->DataLength)-1
      bptr[i+44]=127
   next i
end sub

''===================================================

dim as single Delay = 0.25, Volume = 0.25

dim as string s = "test.wav"
dim as WaveHeaderType ptr tWave
tWave = LoadWave(s)
if tWave = 0 then print "Cannot find " & s : sleep : end

dim as long SampleRate, Channels, BitsPerSample, DataLength
SampleRate = tWave->SamplesPerSec
Channels = tWave->Channels
BitsPerSample = tWave->FmtSpecific
DataLength = tWave->DataLength

dim as single Duration
dim as long BufferSize, DeltaBufferSize, NewBufferSize, BytesPerSample
dim as WaveHeaderType ptr pWave1, pWave2, mWave

BytesPerSample = Channels*BitsPerSample/8
BufferSize = DataLength/BytesPerSample
Duration = BufferSize/SampleRate
DeltaBufferSize = SampleRate*Delay+1
NewBufferSize = BufferSize+DeltaBufferSize

pWave1 = CreateWave(NewBufferSize,SampleRate,Channels,BitsPerSample)
Init8BitWave(pWave1) '' initialize 8 bit wave
Sound pWave1,0,DSPWave(tWave),Duration

pWave2 = CreateWave(NewBufferSize,SampleRate,Channels,BitsPerSample)
Init8BitWave(pWave2)
Sound pWave2,Delay,DSPWave(tWave),Duration

mWave = CreateWave(NewBufferSize,SampleRate,Channels,BitsPerSample)
Init8BitWave(mWave)
Sound mWave,0,MixWavesVolume(DSPWave(pWave1),DSPWave(pWave2),Volume),Duration

'SaveWave("test-echo.wav",mWave)

SoundSet(SampleRate,Channels,BitsPerSample)
PlayWave(mWave)

sleep
A variant with 'detune':

Code: Select all

'' https://www.freebasic.net/wiki/ExtLibsfx
'' https://sourceforge.net/projects/freebasic-sfx-library/files/

#cmdline "-mt -exx"
#include "sfx.bi"
#inclib "fbsfx"

''===================================================

type MixWavesEchoFunction extends SoundFunction
   volume as single
   declare function GetNext() as single 
end type

function MixWavesEchoFunction.GetNext() as single
   return (child->getnext*volume+child2->GetNext())/2
end function

function MixWavesEcho(func1 as any ptr, func2 as any ptr, detune as long=0, volume as single=1) as MixWavesEchoFunction ptr
   dim w as MixWavesEchoFunction ptr=new MixWavesEchoFunction
   w->child=func1
   w->child2=func2
   w->volume=volume
   w->child2->t+=detune
   
   return w
end function

''===================================================

sub Init8BitWave(buffer as WaveHeaderType ptr)
   if (buffer->FmtSpecific) <> 8 then exit sub
   dim as ulong i
   dim as ubyte ptr bptr=cast(ubyte ptr,buffer)
   for i=0 to (buffer->DataLength)-1
      bptr[i+44]=127
   next i
end sub

''===================================================

dim as single Delay = 0.25, Volume = 0.25
dim as single Duration
dim as long BufferSize, DeltaBufferSize, NewBufferSize, BytesPerSample
dim as WaveHeaderType ptr tWave, eWave, mWave

dim as string s = "test.wav"
tWave = LoadWave(s)
if tWave = 0 then print "Cannot find " & s : sleep : end

BytesPerSample = (tWave->Channels)*(tWave->FmtSpecific)/8
BufferSize = (tWave->DataLength)/BytesPerSample
Duration = BufferSize/(tWave->SamplesPerSec)
DeltaBufferSize = (tWave->SamplesPerSec)*Delay+1
NewBufferSize = BufferSize+DeltaBufferSize

eWave = CreateWave(NewBufferSize,tWave->SamplesPerSec,tWave->Channels,tWave->FmtSpecific)
Init8BitWave(eWave) '' initialize 8 bit wave
Sound eWave,Delay,DSPWave(tWave),Duration

mWave = CreateWave(NewBufferSize,tWave->SamplesPerSec,tWave->Channels,tWave->FmtSpecific)
Init8BitWave(mWave)
Sound mWave,0,MixWavesEcho(DSPWave(eWave),DSPWave(eWave),DeltaBufferSize,Volume),Duration

'SaveWave("test-echo-detune.wav",mWave)

SoundSet(tWave->SamplesPerSec,tWave->Channels,tWave->FmtSpecific)
PlayWave(mWave)

sleep
@angros47
If you can reproduce the bug in the two sound subroutines in SoundFunction.bas, it would be nice if you could still remove the bug.

Eight times
for i as integer=0 to samples - 1
instead of
for i as integer=0 to samples

This bug causes tedious debugging.

Thanks for sfx and your effort.
angros47
Posts: 2321
Joined: Jun 21, 2005 19:04

Re: Audio library for FreeBasic - Features

Post by angros47 »

Which bug? And what issues does it cause?

Also, thank you for your appreciation
Adigun A. Polack
Posts: 231
Joined: May 27, 2005 15:14
Contact:

Re: Audio library for FreeBasic - Features

Post by Adigun A. Polack »

Hello to you, angros47, and I am glad I finally got a chance to thoroughly check out your wonderful library of FBSFX, especially the DOS version in my building of brand-new MS-DOS games using FreeBasic, too!! :mrgreen: As I recall now as I went through this interesting thread, on that ever-dreaded “DSP failed to reset” error in the DOS version when I first exited the part of your library here where I tested the .WAV files during its run-time, I have just now managed successfully to get rid of the problem by going to “fbsfx\sfx\dos\dma.BAS” where within the command called “ResetDSP”, I made this following all-important fix myself:

Code: Select all

FUNCTION ResetDSP as integer
	' Resets the DSP
	OUT BasePort + 6, 1
	dim Junk as integer
	FOR Count as integer = 1 TO 65535
		Junk  = INP(BasePort + 6)
	NEXT
	OUT BasePort + 6, 0
	FOR Count as integer = 1 TO 65535
		Junk = INP(BasePort + 6)
	NEXT
	IF (INP(BasePort + 14) AND &H80 = &H80) AND (INP(BasePort + 10) = &HAA) THEN
		ResetDSP = -1
	ELSE
		ResetDSP = 0
	END IF

END FUNCTION
...because the DSP has to go through this many rapid-fire cycles (in fact, all 65,535 of them rather than just 10) in order for it to be reset successfully on your SoundBlaster/SB-compatible DOS card for every time the program is run, instead of having to reboot your machine every time just to do it. ;)

Thus, I whipped together a special self-contained piece of code based on your FBSFX lib, angros47, which made a great test for how very well the playing of your .WAV files work... even in 16-bit stereo where it then worked BRILLIANTLY there in the sound department!

(NOTE: this self-running code snippet in FreeBASIC is for the MS-DOS/FreeDOS version ONLY!)

Code: Select all

#Include once "crt/string.bi"
#include "dos/dpmi.bi"
#include "dos/dos.bi"
#include "dos/sys/movedata.bi"

'' from djgpp/include/crt0.h
#define _CRT0_FLAG_LOCK_MEMORY &h1000

'' linker "magic"
extern _crt0_startup_flags alias "_crt0_startup_flags" as Long
dim shared _crt0_startup_flags as Long = _
  _CRT0_FLAG_LOCK_MEMORY


common shared __Samplerate as Long, __channels as Long, __bits_used  as Long


type FnIntHandler as function cdecl( byval as uLong) as Long

declare function fb_isr_set cdecl alias "fb_isr_set"( _
	byval irq_number as uLong, _
    byval pfnIntHandler as FnIntHandler, _
    byval size as uLong, _
    byval stack_size as uLong = 0) as Long

declare function fb_isr_reset cdecl alias "fb_isr_reset"( _
	byval irq_number as uLong ) as Long

declare function fb_isr_get cdecl alias "fb_isr_get"( _
	byval irq_number as uLong ) as FnIntHandler



DECLARE FUNCTION ResetDSP () as Long
DECLARE FUNCTION DSPVersion () as single
DECLARE FUNCTION DMADone () as Long
DECLARE FUNCTION InitBuffer () as Long
DECLARE SUB WriteDSP (byt as ubyte) 
DECLARE SUB DMAPlay (Offset as long, Length as long)

dim shared DosOffset(1) as Long
Dim shared dos_seg(1) As Long, dos_sel(1) As Long

CONST HDSBSIZE= 32768


DIM SHARED AS ULong BasePort, LenPort, IRQ, DMA, DMA16, DspDataAvail, SB16

Dim shared as Long UsedBuffer, stereo, Freq

type QueueWAVEHDR
	_wavehdr as any ptr
	_size as Long
	_next as QueueWAVEHDR ptr
end type

dim shared as QueueWAVEHDR ptr QueueWaveHdrs, PlayWaveHdrs
dim shared waitingBytes as Long

FUNCTION DMADone() as Long
	'----------------------------------------------------------------------------
	'                Use to see if a DMA transfer has been completed
	'----------------------------------------------------------------------------
	dim as Long Count, Count2, junk

	Count = INP(LenPort)
	Count2 = INP(LenPort)
	Count = CLNG(Count + 1) * CLNG(Count2 + 1)
	IF (Count - 1) >= &HFFFF THEN junk = INP(DspDataAvail): return -1
END FUNCTION



SUB DMAPlay (Offset as long, Length as long)

	Length -= 1
	dim as Long Page = 0
	dim as Long PgPort, AddPort, ModeReg


	SELECT CASE DMA
	CASE 0
		PgPort = &H87
		AddPort = &H0
		LenPort = &H1
		ModeReg = &H48
	CASE 1
		PgPort = &H83
		AddPort = &H2
		LenPort = &H3
		ModeReg = &H49
	CASE 2
		PgPort = &H81
		AddPort = &H4
		LenPort = &H5
		ModeReg = &H4A
	CASE 3
		PgPort = &H82
		AddPort = &H6
		LenPort = &H7
		ModeReg = &H4B
	CASE ELSE
		PRINT "DMA channels 0-3 only are supported."
		EXIT SUB
	END SELECT

	OUT &HA, &H4 + DMA
	OUT &HC, &H0
	OUT &HB, ModeReg
	OUT AddPort, Offset AND &HFF
	OUT AddPort, (Offset AND &HFF00&) \ &H100
	IF (Offset AND 65536) THEN Page = Page + 1
	IF (Offset AND 131072) THEN Page = Page + 2
	IF (Offset AND 262144) THEN Page = Page + 4
	IF (Offset AND 524288) THEN Page = Page + 8
	OUT PgPort, Page
	OUT LenPort, Length AND &HFF
	OUT LenPort, (Length AND &HFF00&) \ &H100
	OUT &HA, DMA

	IF Freq <= 22728 THEN
		WriteDSP &H40
		WriteDSP (256 - 1000000 \ Freq)
		WriteDSP &H14
		WriteDSP (Length AND &HFF)
		WriteDSP ((Length AND &HFFFF&) \ &H100)
	ELSE
		WriteDSP &H40
		WriteDSP (256 - 1000000 \ Freq)
		WriteDSP &H48
		WriteDSP (Length AND &HFF)
		WriteDSP ((Length AND &HFF00&) \ &H100)
		WriteDSP &H91
	END IF
END SUB


SUB DMAPlay16 (Offset as long, Length as long)'(Segment&, offset&, L&, Freq&, StereoWav%, sixteenbit%)
	' Transfers and plays the contents of the buffer.
	' Try only on an SoundBlaster 16 !!
	' 1 page=128K in 16 bit mode
	' DMA16% (16-bit DMA channel) passed implicitly

	Length -= 1
	dim as Long Page = 0, Offset2
	dim as Long PgPort, AddPort, ModeReg



	SELECT CASE DMA16
	CASE 4
	   PgPort = &H0
	   AddPort = &HC0
	   LenPort = &HC2
	   ModeReg = &H48: '58h for autoinit/48h for not
	CASE 5
	   PgPort = &H8B
	   AddPort = &HC4
	   LenPort = &HC6
	   ModeReg = &H49
	CASE 6
	   PgPort = &H89
	   AddPort = &HC8
	   LenPort = &HCA
	   ModeReg = &H4A
	CASE 7
	   PgPort= &H8A 'ok
	   AddPort = &HCC 'ok
	   LenPort = &HCE 'ok
	   ModeReg = &H4B 'ok
	CASE ELSE
	   PRINT "16 bit DMA channels 4-7 only!"
	   EXIT SUB
	END SELECT

	page = (Offset \ 131072) * 2
	Offset2 = (Offset - (page * 65536)) \ 2


	OUT &HD8, 0: 'clear flip flop
	OUT &HD6, ModeReg: 'write mode reg
	OUT AddPort, (Offset2 AND &HFF):            'Buffer base offset lo
	OUT AddPort, (Offset2 AND &HFF00&) \ &H100: 'Buffer base offset hi
	OUT PgPort, page:                          'output page of phys. addr of sample block
	OUT LenPort, ((Length \ 2) AND &HFF):                     'DMA count = length of buffer
	OUT LenPort, (((Length \ 2) AND &HFF00) \ &H100):                     'DMA count high byte
	OUT &HD4, DMA16 - 4: 'write single mask (select Channel16)

	WriteDSP &H41: 'set output sampling rate
	WriteDSP (Freq AND &HFF00&) \ &H100
	WriteDSP Freq AND &HFF

	WriteDSP &HB0:  '16 bit DAC, single cycle, FIFO off

	IF Stereo THEN 'subtract 10h for unsigned
		WriteDSP &H30: '30h=Mode byte for 16 bit signed stereo
	ELSE
		WriteDSP &H10: '10h=Mode byte for 16 bit signed mono
	END IF

	WriteDSP ((Length \ 2) AND &HFF)
	WriteDSP (((Length \ 2) AND &HFF00) \ &H100)
END SUB

SUB SpeakerState (OnOff as Long)
	' Turns speaker on or off.
	IF OnOff THEN WriteDSP &HD1 ELSE WriteDSP &HD3
END SUB

SUB SetStereo (OnOff as Long)
		'only needed on SBPro
		stereo=onoff

		OUT Baseport + 4, &HE
		IF OnOff THEN
				OUT Baseport + 5, 2
		ELSE
				OUT Baseport + 5, 0
		END IF
END SUB

FUNCTION ResetDSP as Long
	' Resets the DSP
	OUT BasePort + 6, 1
	dim Junk as Long
	FOR Count as Long = 1 TO 65535
		Junk  = INP(BasePort + 6)
	NEXT
	OUT BasePort + 6, 0
	FOR Count as Long = 1 TO 65535
		Junk = INP(BasePort + 6)
	NEXT
	IF (INP(BasePort + 14) AND &H80 = &H80) AND (INP(BasePort + 10) = &HAA) THEN
		ResetDSP = -1
	ELSE
		ResetDSP = 0
	END IF

END FUNCTION

SUB GetBLASTER
	' This subroutine parses the BLASTER environment string and returns settings.
	IF LEN(ENVIRON("BLASTER")) = 0 THEN PRINT "BLASTER environment variable not set.": EXIT SUB
	FOR Length as Long = 1 TO LEN(ENVIRON("BLASTER"))
	SELECT CASE MID(ENVIRON("BLASTER"), Length, 1)
	CASE "A"
		BasePort = VAL("&H" + MID(ENVIRON("BLASTER"), Length + 1, 3))
	CASE "I"
		IRQ = VAL(MID(ENVIRON("BLASTER"), Length + 1, 1))
	CASE "D"
		DMA = VAL(MID(ENVIRON("BLASTER"), Length + 1, 1))
	CASE "H"
		DMA16 = VAL(MID(ENVIRON("BLASTER"), Length + 1, 1))
	END SELECT
	NEXT
END SUB



FUNCTION InitBuffer as Long

	for I as Long=0 to 1
		dos_seg(i) = __dpmi_allocate_dos_memory((HDSBSIZE*2+15)shr 4, @dos_sel(i))

		If dos_seg(i) = 0 Then return -1
		DosOffset(i)=dos_seg(i) shl 4
		if (DosOffset(i) shr 16) <> ((DosOffset(i) + HDSBSIZE) shr 16) then 
			DosOffset(i) = ((DosOffset(i) + HDSBSIZE) and &Hffffff00)
		end if
	next
	return 0

END FUNCTION


SUB WriteDSP (byt as ubyte)
	' Writes a byte to the DSP
	DO
	LOOP WHILE INP(BasePort + 12) AND &H80
	OUT BasePort + 12, byt
END SUB

FUNCTION ReadDSP as ubyte
	' Reads a byte from the DSP
	DO
	LOOP UNTIL INP(BasePort + 14) AND &H80
	return INP(BasePort + 10)
END FUNCTION

FUNCTION DSPVersion as single
	' Gets the DSP version.
	WriteDSP &HE1
	dim as ubyte byte1, byte2
	byte1=readdsp
	byte2=readdsp

	return VAL(STR(byte1) + "." + STR(byte2))
END FUNCTION


private function isr_dsp_callback cdecl( byval irq_number as uLong) as Long
	dim p as QueueWAVEHDR ptr=PlayWaveHdrs

	OUT &H20,&H20

	if PlayWaveHdrs->_next<>0 then 
		UsedBuffer=1-UsedBuffer
		dosmemput(PlayWaveHdrs->_next->_wavehdr, PlayWaveHdrs->_next->_size, DosOffset(UsedBuffer))
	end if


	PlayWaveHdrs=PlayWaveHdrs->_next
	if PlayWaveHdrs<>0 then 
		if SB16=0 then
			DMAPlay DosOffset(UsedBuffer) , PlayWaveHdrs->_size
		else
			DMAPlay16 DosOffset(UsedBuffer) , PlayWaveHdrs->_size
		end if
	end if

	deallocate(p->_wavehdr)

	if p=QueueWaveHdrs then QueueWaveHdrs=0

	delete p


	return 0
end function
private sub isr_dsp_end cdecl()
end sub




sub playbuffer (soundBuffer as any ptr, buffersize as Long)

  if BufferSize>HDSBSIZE then playbuffer (soundBuffer, BufferSize-HDSBSIZE):SoundBuffer+=BufferSize-HDSBSIZE: BufferSize=HDSBSIZE

	dim p as QueueWAVEHDR ptr=new QueueWAVEHDR
	p->_wavehdr=allocate(buffersize)
	p->_size=buffersize
	p->_next=0

	memcpy(p->_wavehdr, SoundBuffer, buffersize)

	if QueueWaveHdrs<>0 then 
		if PlayWaveHdrs->_next=0 then 
			UsedBuffer=1-UsedBuffer
			dosmemput(p->_wavehdr, p->_size, DosOffset(UsedBuffer))
		end if
		QueueWaveHdrs->_next=p
	else
		UsedBuffer=1-UsedBuffer
		dosmemput(soundbuffer, buffersize, DosOffset(UsedBuffer))

		if SB16=0 then
			DMAPlay DosOffset(UsedBuffer) , buffersize
		else
			DMAPlay16 DosOffset(UsedBuffer) , buffersize
		end if

		PlayWaveHdrs=p
	end if

	QueueWaveHdrs=p

end sub


sub stopbuffer ()

	dim p as QueueWAVEHDR ptr=new QueueWAVEHDR
	p->_next=0

  QueueWaveHdrs=0
	deallocate(p->_wavehdr)
	delete p

end sub


sub SoundSet(frequency as Long, channels as Long, bits as Long)
	__Samplerate=frequency
	__channels=channels
	__bits_used=bits

	GetBlaster
	InitBuffer

	IF ResetDSP = 0  THEN 'resets DSP (returns true if successful)
		PRINT "DSP failed to reset, try another port."
		exit sub
	END IF

	if bits=16 then
		if DSPVersion<4 then 
			PRINT "16 bit mode not supported"
			exit sub
		end if
		SB16=1
		DspDataAvail=Baseport + &HF	'16 bit
	else
		sb16=0
		DspDataAvail=Baseport + &HE	'8 bit
	end if

	

	IF DSPVersion <= 2 AND frequency>22728 THEN 
		PRINT "Unsupported rate"
		exit sub
	END IF

	dim mask as ubyte	'Unmasks the interrupt, to enable it
	if IRQ<8 then
		mask=INP(&H21)
		mask=mask and not (1 shl IRQ)
		OUT &H21,mask
	else
		mask=INP(&HA1)
		mask=mask and not (1 shl (IRQ-8))
		OUT &HA1,mask
	end if

	dim as byte ptr ptr_end = cast( byte ptr, @isr_dsp_end )
	dim as byte ptr ptr_start = cast( byte ptr, @isr_dsp_callback)
	if 0 = fb_isr_set( IRQ, @isr_dsp_callback, ptr_end - ptr_start, 16384 ) then
	    print "Failed to lock ISR"
	    end 1
	end if

	Freq=Frequency

	if channels=2 then 
		SetStereo 1
		if bits=8 then Freq=Frequency*2
	else
		SetStereo 0
	end if

	WriteDSP &HD1  'turn the speaker on

	OUT BasePort + 4, &H22    ' set volume
	OUT BasePort + 5, &HDD    ' Left = HI Nibble, Right = LO nibble (0FF is max)
end sub




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







#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 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 Long 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 Long=0 to noSamples - 1
						convert(i)=(SourcePtr[i*2]+SourcePtr[i*2+1])/2
					next
					playbuffer @convert(0), noSamples*2
				elseif buffer->FmtSpecific=8 then
					dim as Long noSamples=buffer->DataLength/2
					dim as short convert(noSamples)
					dim as ubyte ptr SourcePtr=cast(ubyte ptr,buffer)+44
					for i as Long=0 to noSamples - 1
						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 Long noSamples=buffer->DataLength
					dim as short convert(noSamples)
					dim as ubyte ptr SourcePtr=cast(ubyte ptr,buffer)+44
					for i as Long=0 to noSamples - 1
						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 Long noSamples=buffer->DataLength
					dim as short convert(noSamples)
					dim as ubyte ptr SourcePtr=cast(ubyte ptr,buffer)+44
					for i as Long=0 to noSamples - 1
						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 Long 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 Long=0 to noSamples - 1
						convert(i*2)=SourcePtr[i]
						convert(i*2+1)=SourcePtr[i]
					next
					playbuffer @convert(0), noSamples*4
				elseif buffer->FmtSpecific=8 then
					dim as Long noSamples=buffer->DataLength
					dim as short convert(noSamples*2)
					dim as ubyte ptr SourcePtr=cast(ubyte ptr,buffer)+44
					for i as Long=0 to noSamples - 1
						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 Long 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 Long=0 to noSamples - 1
						convert(i)=(((SourcePtr[i*2]+SourcePtr[i*2+1])/2)/255)+128
					next
					playbuffer @convert(0), noSamples
				elseif buffer->FmtSpecific=8 then
					dim as Long noSamples=buffer->DataLength/2
					dim as ubyte convert(noSamples)
					dim as ubyte ptr SourcePtr=cast(ubyte ptr,buffer)+44
					for i as Long=0 to noSamples - 1
						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 Long 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 Long=0 to noSamples - 1
						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 Long 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 Long=0 to (noSamples*2) - 1
						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 Long 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 Long=0 to noSamples - 1
						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 Long noSamples=buffer->DataLength
					dim as ubyte convert(noSamples*2)
					dim as ubyte ptr SourcePtr=cast(ubyte ptr,buffer)+44
					for i as Long=0 to noSamples - 1
						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















'-------------------------------------------------------------------------------
' Your main program starts below!!  ;)
'-------------------------------------------------------------------------------

Cls
Width 80, 50
Shell "Dir *.wav /w"
dim as string fileinput_wav, fileinput_wav_bitrate

?
Input "What .WAV filename do you want to play"; fileinput_wav

dim as string fileName = fileinput_wav
dim as WaveHeaderType ptr pWave
dim as short countdown_delay, sb_LeftVol, sb_RightVol
dim as short sb_volume = 15
dim as long TotalPlays

pWave = LoadWave(fileName)
if pWave = 0 then
   '? "pWave = 0" 
   screen 0: Width 80, 25
   end
end if

?
Color 14, 0: ? "======== RIFF header ========"
Color 10, 0: ? "RiffID         ";: Color 15, 0: ? using "##############"; pWave->RiffID
Color 10, 0: ? "RiffLength     ";: Color 15, 0: ? using "##############";  pWave->RiffLength
Color 10, 0: ? "WavID          ";: Color 15, 0: ? using "##############";  pWave->WavID
Color 10, 0: ? "FmtID          ";: Color 15, 0: ? using "##############";  pWave->FmtID
Color 10, 0: ? "FmtLength      ";: Color 15, 0: ? using "##############";  pWave->FmtLength
?
Color 14, 0: ? "======= FMT chunk(s) ========"
Color 10, 0: ? "wavformattag   ";: Color 15, 0: ? using "##############";  pWave->wavformattag
Color 10, 0: ? "Channels       ";: Color 15, 0: ? using "##############";  pWave->Channels
Color 10, 0: ? "SamplesPerSec  ";: Color 15, 0: ? using "##############";  pWave->SamplesPerSec
Color 10, 0: ? "avgBytesPerSec ";: Color 15, 0: ? using "##############";  pWave->avgBytesPerSec
Color 10, 0: ? "blockalign     ";: Color 15, 0: ? using "##############";  pWave->blockalign
Color 10, 0: ? "BitsPerSample  ";: Color 15, 0: ? using "##############";  pWave->FmtSpecific
?
Color 14, 0: ? "======= DATA chunk(s) ======="
Color 10, 0: ? "DataID         ";: Color 15, 0: ? using "##############";  pWave->DataID
Color 10, 0: ? "DataLength     ";: Color 15, 0: ? using "##############";  pWave->DataLength
?

Color 7, 0

SoundSet (pWave->SamplesPerSec,pWave->Channels,pWave->FmtSpecific)
?
?
?

Color 15, 0

? "Press [Z] to play your selected .WAV file,"
Locate , 7: ? "[X] for a rapid-fire playing of that same file,"
Locate , 7: ? "[C] to stop the current playing,"
Locate , 4: ? "or [ESC] to exit."

Color 7, 0

OUT BasePort + 4, &H22         ' set volume
OUT Baseport + 5, (sb_volume + sb_volume * 16) AND &HFF

Do
  Locate 45: ? "Current Volume (0 = Silent; 15 = Max Volume): "; using "##"; sb_volume
  Locate 47: ? "Number of total playings of that same file in a row: "; TotalPlays
  ?
  '? DMADone
  If Multikey(&h2C) and countdown_delay <= 0 then
    PlayWave(pWave)
    TotalPlays += 1
    countdown_delay = 20
    While inkey <> "": Wend
  End if
  If Multikey(&h2D) and countdown_delay <= 0 then
    stopbuffer 
    PlayWave(pWave)
    TotalPlays += 1
    countdown_delay = 3
    While inkey <> "": Wend
  End if
  If Multikey(&h2E) and countdown_delay <= 0 then
    ResetDSP
    stopbuffer 
    countdown_delay = 3
    While inkey <> "": Wend
  End if
  If Multikey(&h48) and countdown_delay <= 0 then
    sb_volume +=1
    If sb_volume >= 15 then sb_volume = 15
    OUT Baseport + 4, &H22
    OUT Baseport + 5, (sb_volume + sb_volume * 16) AND &HFF
    countdown_delay = 10
    While inkey <> "": Wend
  End if
  If Multikey(&h50) and countdown_delay <= 0 then
    sb_volume -=1
    If sb_volume <= 0 then sb_volume = 0
    OUT Baseport + 4, &H22
    OUT Baseport + 5, (sb_volume + sb_volume * 16) AND &HFF
    countdown_delay = 10
    While inkey <> "": Wend
  End if
  countdown_delay -= 1
  If countdown_delay <= 0 then countdown_delay = 0
  Wait &H3DA, 8, 8
  Wait &H3DA, 8
Loop Until Multikey(&h01)

ResetDSP
Width 80, 25
cls
Image

And while the DSP resets were successful every time between run-throughs now when I ran it (even without FBSFX at all on my above-mentioned code snippet just now!), there are a few run-time errors that I spotted in some of my deeper testings of it on DOSbox and on real hardware in pure MS-DOS, while there are absolutely ZERO errors period when I ran it on FreeDOS flawlessly on real hardware. Other than that, there are some sound cut-outs on occasion (which thankfully can be reset and restarted again just by hitting the Stop button (“C” key) and replaying that same sound). I find that all a little weird that it happened for some odd reason... :?:

Anyway, here was how it all fared in my tests here on a particular 8-bit sample that I used that ran at a 11025 bit-rate lasting 5.41 seconds long:

Test results on DOSBox Staging v0.81.0:
Image

After 4,385 plays, the program crashed with a “Page Fault” run-time error. Booted straight back to DOS.



Test results on pure MS-DOS (using an HP Thin Client t5710):
Image

After just 517 plays, the program crashed with a “General Protection Fault” run-time error rather quickly! :o Booted straight back to DOS.



Test results on FreeDOS:
Image

Anyway, at least we are making some better progress in helping to support more of your FBSFX lib now, and so am I, angros47, as I would love to see it become even better and better since it has been more than 1½ years since it had last been updated in 2022.

Wow, it has been THAT long; whewwwwwwww!! Anyhow, long time, no see, and finally wonderful to be back in 2024 here with you amazingly quite superb FreeBASIC community!!! :D
VANYA
Posts: 1834
Joined: Oct 24, 2010 15:16
Location: Ярославль
Contact:

Re: Audio library for FreeBasic - Features

Post by VANYA »

Hi angros47!

Have you tried the fbsfx library with a compiler version higher than 1.09 на linux x86-64?

I have a segmentation fault on simple code:

Code: Select all

#include "sfx.bi"
#inclib "fbsfx"

SoundmidiSet ()
PLAY "a4e4g4a4g4e4c2f4f4f2d4d4d2"
The problem occurs in the amidi.bas file:

Code: Select all

sub _FMSoundThread(ByVal userdata As Any Ptr ) ' stop here , segmentation fault
	
	....
	
End Sub

sub MidiSend(event as UByte, a as UByte, b as UByte) 
	...
		if thread_handle=0 then thread_handle = threadcreate( @_FMSoundThread)
	...

END sub
VANYA
Posts: 1834
Joined: Oct 24, 2010 15:16
Location: Ярославль
Contact:

Re: Audio library for FreeBasic - Features

Post by VANYA »

I withdraw my question. It looks like the issue is a faulty compiler assembly. I will study this issue further on my computer.

This assembly puts everything together correctly: FreeBASIC-1.10.1-linux-x86_64.tar.gz
But this one assembles incorrectly: FreeBASIC-1.10.1-ubuntu-22.04-x86_64.tar.xz
Post Reply