WASAPI: added CaptureSST.pas

This commit is contained in:
Michael Schimmel
2026-02-04 12:19:58 +01:00
parent 25de673557
commit 90a4bbdd6b
3 changed files with 62 additions and 461 deletions
+58 -459
View File
@@ -4,63 +4,11 @@ interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Winapi.MMSystem, Vcl.ComCtrls, Vcl.ExtCtrls,
System.SyncObjs, System.Math, System.Net.HttpClient, System.Net.HttpClientComponent,
System.Net.Mime, System.JSON, System.IOUtils, System.Generics.Collections, Vcl.Samples.Spin;
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ComCtrls, Vcl.ExtCtrls,
System.SyncObjs, System.Math, Vcl.Samples.Spin,
CaptureSTT;
type
TTranscriptionTask = record
TaskID: string;
SequenceIndex: Int64;
end;
(* Polling worker for async API tasks *)
TTranscriptionWorker = class(TThread)
strict private
fQueue: TThreadedQueue<TTranscriptionTask>;
fClient: TNetHTTPClient;
procedure ProcessTask(const ATask: TTranscriptionTask);
protected
procedure Execute; override;
public
constructor Create;
destructor Destroy; override;
procedure Enqueue(const ATaskID: string; AIndex: Int64);
end;
TAudioCaptureThread = class(TThread)
private
FWaveIn: HWAVEIN;
FHeaders: array[0..1] of TWaveHdr;
FBuffers: array[0..1] of array of Byte;
FEvent: THandle;
fCurrentRms: Integer;
fIsSilent: Boolean;
fDbThreshold: Double;
fSilenceCounter: Integer;
fRequiredSilencePackets: Integer;
fActiveFragment: TMemoryStream;
fTotalSegmentsSent: Int64;
fForceUploadFlag: Integer; // Atomic flag
procedure PrepareBuffers;
procedure UnprepareBuffers;
function CalculateRms(ABuffer: PByte; ALength: Cardinal): Integer;
procedure ProcessSilence(ARms: Integer; ABuffer: PByte; ALength: Cardinal);
procedure WriteWavHeader(AStream: TStream; ADataSize: Cardinal);
procedure TrimSilentStart(AOffset: Int64);
procedure SyncUploadAndEnqueue(AStream: TMemoryStream);
procedure PerformUpload(AStream: TMemoryStream);
protected
procedure Execute; override;
public
constructor Create;
destructor Destroy; override;
procedure ForceUpload;
property CurrentRms: Integer read fCurrentRms;
end;
TForm1 = class(TForm)
Button1: TButton;
ResultMemo: TMemo;
@@ -79,423 +27,93 @@ type
procedure UpdateButtonClick(Sender: TObject);
private
fCaptureThread: TAudioCaptureThread;
fWorker: TTranscriptionWorker;
procedure Log(const AMsg: string);
procedure HandleTranscriptionResult(const AText: string);
public
end;
var
Form1: TForm1;
GlobalTranscriptionWorker: TTranscriptionWorker;
implementation
{$R *.dfm}
{ TTranscriptionWorker }
constructor TTranscriptionWorker.Create;
begin
inherited Create(False);
fQueue := TThreadedQueue<TTranscriptionTask>.Create(100, 1000, 100);
fClient := TNetHTTPClient.Create(nil);
end;
destructor TTranscriptionWorker.Destroy;
begin
Terminate;
fQueue.DoShutDown;
fClient.Free;
fQueue.Free;
inherited;
end;
procedure TTranscriptionWorker.Enqueue(const ATaskID: string; AIndex: Int64);
var
task: TTranscriptionTask;
begin
task.TaskID := ATaskID;
task.SequenceIndex := AIndex;
fQueue.PushItem(task);
end;
procedure TTranscriptionWorker.Execute;
var
task: TTranscriptionTask;
begin
while not Terminated do
begin
if (fQueue.PopItem(task) = TWaitResult.wrSignaled) and (not Terminated) then
ProcessTask(task);
end;
end;
procedure TTranscriptionWorker.ProcessTask(const ATask: TTranscriptionTask);
var
resp: IHTTPResponse;
jsonResult: TJSONObject;
status, transcriptionText, sText: string;
resVal, segmentsVal: TJSONValue;
segmentsArray: TJSONArray;
i: Integer;
isDone: Boolean;
begin
isDone := False;
repeat
if Terminated then exit;
try
resp := fClient.Get('http://minerva.lan:8000/task/' + ATask.TaskID);
if (resp.StatusCode = 200) then
begin
jsonResult := TJSONObject.ParseJSONValue(resp.ContentAsString(TEncoding.UTF8)) as TJSONObject;
if Assigned(jsonResult) then
try
if jsonResult.TryGetValue('status', status) then
begin
if (status = 'completed') then
begin
if jsonResult.TryGetValue('result', resVal) and (resVal is TJSONObject) and
TJSONObject(resVal).TryGetValue('segments', segmentsVal) then
begin
segmentsArray := segmentsVal as TJSONArray;
transcriptionText := '';
for i := 0 to segmentsArray.Count - 1 do
if (segmentsArray.Items[i] as TJSONObject).TryGetValue('text', sText) then
transcriptionText := transcriptionText + sText;
sText := transcriptionText.Trim;
TThread.Queue(nil, procedure begin
Form1.ResultMemo.Lines.Add(sText);
end);
isDone := True;
end;
end
else if (status = 'failed') or (status = 'error') then
isDone := True;
end;
finally
jsonResult.Free;
end;
end;
except
on E: Exception do isDone := True;
end;
if not isDone then Sleep(500);
until isDone;
end;
{ TAudioCaptureThread }
constructor TAudioCaptureThread.Create;
var
format: TWaveFormatEx;
begin
inherited Create(True);
FEvent := CreateEvent(nil, False, False, nil);
fActiveFragment := TMemoryStream.Create;
fDbThreshold := -35.0;
fRequiredSilencePackets := 30;
fIsSilent := True;
fTotalSegmentsSent := 0;
fForceUploadFlag := 0;
FillChar(format, sizeof(format), 0);
format.wFormatTag := WAVE_FORMAT_PCM;
format.nChannels := 1;
format.nSamplesPerSec := 16000;
format.wBitsPerSample := 16;
format.nBlockAlign := 2;
format.nAvgBytesPerSec := 32000;
if waveInOpen(@FWaveIn, WAVE_MAPPER, @format, FEvent, 0, CALLBACK_EVENT) <> MMSYSERR_NOERROR then
raise Exception.Create('waveInOpen failed');
PrepareBuffers;
end;
destructor TAudioCaptureThread.Destroy;
begin
waveInStop(FWaveIn);
UnprepareBuffers;
waveInClose(FWaveIn);
CloseHandle(FEvent);
fActiveFragment.Free;
inherited;
end;
procedure TAudioCaptureThread.ForceUpload;
begin
TInterlocked.Exchange(fForceUploadFlag, 1);
end;
procedure TAudioCaptureThread.SyncUploadAndEnqueue(AStream: TMemoryStream);
var
client: TNetHTTPClient;
formData: TMultipartFormData;
resp: IHTTPResponse;
jsonResp: TJSONObject;
taskID: string;
urlParams: string;
begin
client := TNetHTTPClient.Create(nil);
formData := TMultipartFormData.Create;
try
AStream.Position := 0;
formData.AddStream('file', AStream, False, 'fragment.wav', 'audio/wav');
// Build query string from OptsMemo settings
urlParams := '';
TThread.Synchronize(nil, procedure
begin
for var i := 0 to Form1.OptsMemo.Lines.Count - 1 do
begin
if (urlParams <> '') then
urlParams := urlParams + '&';
urlParams := urlParams + Form1.OptsMemo.Lines[i];
end;
end);
resp := client.Post(
'http://minerva.lan:8000/speech-to-text?' + urlParams,
formData
);
if (resp.StatusCode = 200) then
begin
jsonResp := TJSONObject.ParseJSONValue(resp.ContentAsString(TEncoding.UTF8)) as TJSONObject;
try
if Assigned(jsonResp) and jsonResp.TryGetValue('identifier', taskID) then
GlobalTranscriptionWorker.Enqueue(taskID, fTotalSegmentsSent);
finally
jsonResp.Free;
end;
end;
finally
formData.Free;
client.Free;
AStream.Free; // Stream is freed here as it was passed to this method
end;
end;
procedure TAudioCaptureThread.PerformUpload(AStream: TMemoryStream);
begin
inc(fTotalSegmentsSent);
SyncUploadAndEnqueue(AStream);
end;
procedure TAudioCaptureThread.WriteWavHeader(AStream: TStream; ADataSize: Cardinal);
type
TWavHeader = packed record
RIFF: array[0..3] of AnsiChar;
FileSize: Cardinal;
WAVE: array[0..3] of AnsiChar;
fmt: array[0..3] of AnsiChar;
FormatSize: Cardinal;
FormatTag: Word;
Channels: Word;
SamplesPerSec: Cardinal;
AvgBytesPerSec: Cardinal;
BlockAlign: Word;
BitsPerSample: Word;
DataMark: array[0..3] of AnsiChar;
DataSize: Cardinal;
end;
var
header: TWavHeader;
begin
header.RIFF := 'RIFF';
header.FileSize := ADataSize + sizeof(TWavHeader) - 8;
header.WAVE := 'WAVE';
header.fmt := 'fmt ';
header.FormatSize := 16;
header.FormatTag := 1;
header.Channels := 1;
header.SamplesPerSec := 16000;
header.BitsPerSample := 16;
header.BlockAlign := 2;
header.AvgBytesPerSec := 32000;
header.DataMark := 'data';
header.DataSize := ADataSize;
AStream.WriteBuffer(header, sizeof(TWavHeader));
end;
function TAudioCaptureThread.CalculateRms(ABuffer: PByte; ALength: Cardinal): Integer;
var
i, count: Integer;
pSamples: PSmallInt;
sum, sampleVal: Double;
begin
sum := 0;
pSamples := PSmallInt(ABuffer);
count := ALength div 2;
for i := 0 to count - 1 do
begin
sampleVal := pSamples^;
sum := sum + (sampleVal * sampleVal);
inc(pSamples);
end;
if (count > 0) then Result := Round(Sqrt(sum / count)) else Result := 0;
end;
procedure TAudioCaptureThread.TrimSilentStart(AOffset: Int64);
var
newSize: Int64;
begin
newSize := fActiveFragment.Size - AOffset;
if (newSize > 0) then
Move(PByte(fActiveFragment.Memory)[AOffset], fActiveFragment.Memory^, newSize);
fActiveFragment.Size := newSize;
fActiveFragment.Position := newSize;
end;
procedure TAudioCaptureThread.ProcessSilence(ARms: Integer; ABuffer: PByte; ALength: Cardinal);
var
uploadStream: TMemoryStream;
currentDb: Double;
maxIdleSize, keepSize, sendSize: Int64;
forceRequested: Boolean;
begin
forceRequested := TInterlocked.CompareExchange(fForceUploadFlag, 0, 1) = 1;
fActiveFragment.WriteBuffer(ABuffer^, ALength);
if (ARms > 0) then currentDb := 20 * Log10(ARms / 32768) else currentDb := -100.0;
if (currentDb > fDbThreshold) then
begin
if fIsSilent then
begin
fIsSilent := False;
TThread.Queue(nil, procedure begin Form1.Log('Activity detected...'); end);
end;
fSilenceCounter := 0;
end
else
begin
inc(fSilenceCounter);
if fIsSilent then
begin
maxIdleSize := Int64(fRequiredSilencePackets) * ALength;
if (fActiveFragment.Size > maxIdleSize) then
TrimSilentStart(fActiveFragment.Size - maxIdleSize);
end
else if (fSilenceCounter >= fRequiredSilencePackets) or forceRequested then
begin
fIsSilent := True;
keepSize := (Int64(fRequiredSilencePackets) div 2) * ALength;
if forceRequested then keepSize := 0;
sendSize := fActiveFragment.Size - keepSize;
if (sendSize > 0) then
begin
uploadStream := TMemoryStream.Create;
WriteWavHeader(uploadStream, sendSize);
fActiveFragment.Position := 0;
uploadStream.CopyFrom(fActiveFragment, sendSize);
PerformUpload(uploadStream);
TrimSilentStart(sendSize);
end;
fSilenceCounter := 0;
TThread.Queue(nil, procedure begin Form1.Log('Fragment uploaded.'); end);
end;
end;
end;
procedure TAudioCaptureThread.PrepareBuffers;
var
i: Integer;
bufferSize: Cardinal;
begin
bufferSize := 3200;
for i := 0 to High(FBuffers) do
begin
SetLength(FBuffers[i], bufferSize);
FHeaders[i].lpData := PAnsiChar(@FBuffers[i][0]);
FHeaders[i].dwBufferLength := bufferSize;
FHeaders[i].dwFlags := 0;
waveInPrepareHeader(FWaveIn, @FHeaders[i], sizeof(TWaveHdr));
waveInAddBuffer(FWaveIn, @FHeaders[i], sizeof(TWaveHdr));
end;
end;
procedure TAudioCaptureThread.UnprepareBuffers;
var
i: Integer;
begin
waveInReset(FWaveIn);
for i := 0 to High(FHeaders) do
waveInUnprepareHeader(FWaveIn, @FHeaders[i], sizeof(TWaveHdr));
end;
procedure TAudioCaptureThread.Execute;
var
i: Integer;
rmsValue: Integer;
begin
waveInStart(FWaveIn);
while (not Terminated) do
begin
if (WaitForSingleObject(FEvent, 100) = WAIT_OBJECT_0) then
begin
for i := 0 to High(FHeaders) do
begin
if (not Terminated) and ((FHeaders[i].dwFlags and WHDR_DONE) <> 0) then
begin
rmsValue := CalculateRms(PByte(FHeaders[i].lpData), FHeaders[i].dwBytesRecorded);
TInterlocked.Exchange(fCurrentRms, rmsValue);
ProcessSilence(rmsValue, PByte(FHeaders[i].lpData), FHeaders[i].dwBytesRecorded);
FHeaders[i].dwFlags := FHeaders[i].dwFlags and not WHDR_DONE;
waveInAddBuffer(FWaveIn, @FHeaders[i], sizeof(TWaveHdr));
end;
end;
end;
end;
end;
{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
begin
RmsBar.Min := 0;
RmsBar.Max := 100;
GlobalTranscriptionWorker := TTranscriptionWorker.Create;
// List settings for the Post on FormCreate in OptsMemo
// Initialize worker with result callback
fWorker := TTranscriptionWorker.Create(HandleTranscriptionResult);
// Default API options
OptsMemo.Lines.Clear;
OptsMemo.Lines.Add('language=de');
OptsMemo.Lines.Add('task=transcribe');
OptsMemo.Lines.Add('model=large-v3');
OptsMemo.Lines.Add('device=cuda');
OptsMemo.Lines.Add('device_index=0');
OptsMemo.Lines.Add('threads=0');
OptsMemo.Lines.Add('batch_size=8');
OptsMemo.Lines.Add('chunk_size=20');
OptsMemo.Lines.Add('compute_type=float16');
OptsMemo.Lines.Add('beam_size=5');
OptsMemo.Lines.Add('best_of=5');
OptsMemo.Lines.Add('patience=1');
OptsMemo.Lines.Add('length_penalty=1');
OptsMemo.Lines.Add('temperatures=0');
OptsMemo.Lines.Add('compression_ratio_threshold=2.4');
OptsMemo.Lines.Add('log_prob_threshold=-1');
OptsMemo.Lines.Add('no_speech_threshold=0.6');
OptsMemo.Lines.Add('initial_prompt=null');
OptsMemo.Lines.Add('suppress_tokens=-1');
OptsMemo.Lines.Add('suppress_numerals=false');
OptsMemo.Lines.Add('hotwords=Absatz');
OptsMemo.Lines.Add('vad_onset=0.5');
OptsMemo.Lines.Add('vad_offset=0.363');
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
if Assigned(fCaptureThread) then
begin
fCaptureThread.Terminate;
fCaptureThread.WaitFor;
fCaptureThread.Free;
end;
if Assigned(fWorker) then
begin
fWorker.Terminate;
fWorker.WaitFor;
fWorker.Free;
end;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
if Assigned(fCaptureThread) then
begin
fCaptureThread.Terminate;
fCaptureThread.WaitFor;
end;
end;
procedure TForm1.Log(const AMsg: string);
begin
if LoggingCheckBox.Checked then
ResultMemo.Lines.Add(FormatDateTime('hh:nn:ss', Now) + ': ' + AMsg);
end;
procedure TForm1.HandleTranscriptionResult(const AText: string);
begin
ResultMemo.Lines.Add(AText);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if not Assigned(fCaptureThread) then
begin
fCaptureThread := TAudioCaptureThread.Create;
fCaptureThread := TAudioCaptureThread.Create(
fWorker,
'http://minerva.lan:8000/speech-to-text',
OptsMemo.Lines,
procedure(const Msg: string)
begin
TThread.Queue(nil, procedure begin Log(Msg); end);
end
);
// Apply initial silence settings
SilenceEditChange(nil);
fCaptureThread.Start;
Button1.Caption := 'Stop Recording';
end
@@ -509,22 +127,6 @@ begin
end;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
if Assigned(fCaptureThread) then begin fCaptureThread.Terminate; fCaptureThread.WaitFor; end;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
if Assigned(fCaptureThread) then fCaptureThread.Free;
if Assigned(GlobalTranscriptionWorker) then
begin
GlobalTranscriptionWorker.Terminate;
GlobalTranscriptionWorker.WaitFor;
GlobalTranscriptionWorker.Free;
end;
end;
procedure TForm1.RmsTimerTimer(Sender: TObject);
var
rawRms: Integer;
@@ -532,23 +134,22 @@ var
begin
if Assigned(fCaptureThread) then
begin
rawRms := TInterlocked.CompareExchange(fCaptureThread.fCurrentRms, 0, 0);
rawRms := fCaptureThread.CurrentRms;
if (rawRms > 0) then
begin
dbValue := 20 * Log10(rawRms / 32768);
// Map -60dB..0dB to 0..100%
RmsBar.Position := Max(0, Round((dbValue + 60) * (100 / 60)));
end
else RmsBar.Position := 0;
else
RmsBar.Position := 0;
end;
end;
procedure TForm1.SilenceEditChange(Sender: TObject);
begin
if Assigned(fCaptureThread) then
begin
// Conversion: SpinEdit Value (seconds) to packets (approx 100ms per packet)
fCaptureThread.fRequiredSilencePackets := Max(1, SilenceEdit.Value * 10);
end;
fCaptureThread.RequiredSilencePackets := Max(1, SilenceEdit.Value * 10);
end;
procedure TForm1.UpdateButtonClick(Sender: TObject);
@@ -557,6 +158,4 @@ begin
fCaptureThread.ForceUpload;
end;
initialization
finalization
end.
+2 -1
View File
@@ -2,7 +2,8 @@ program WASAPITest;
uses
Vcl.Forms,
MainForm in 'MainForm.pas' {Form1};
MainForm in 'MainForm.pas' {Form1},
CaptureSTT in 'CaptureSTT.pas';
{$R *.res}
+1
View File
@@ -127,6 +127,7 @@
<Form>Form1</Form>
<FormType>dfm</FormType>
</DCCReference>
<DCCReference Include="CaptureSTT.pas"/>
<BuildConfiguration Include="Base">
<Key>Base</Key>
</BuildConfiguration>