From 90a4bbdd6bc6862cda2469c4951501d6ef918852 Mon Sep 17 00:00:00 2001 From: Michael Schimmel Date: Wed, 4 Feb 2026 12:19:58 +0100 Subject: [PATCH] WASAPI: added CaptureSST.pas --- WASAPI/MainForm.pas | 519 +++++----------------------------------- WASAPI/WASAPITest.dpr | 3 +- WASAPI/WASAPITest.dproj | 1 + 3 files changed, 62 insertions(+), 461 deletions(-) diff --git a/WASAPI/MainForm.pas b/WASAPI/MainForm.pas index 096b1e0..8b22705 100644 --- a/WASAPI/MainForm.pas +++ b/WASAPI/MainForm.pas @@ -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; - 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; @@ -69,7 +17,7 @@ type UpdateButton: TButton; SilenceEdit: TSpinEdit; OptsMemo: TMemo; - LoggingCheckBox: TCheckBox; + LoggingCheckBox: TCheckBox; procedure FormCreate(Sender: TObject); procedure Button1Click(Sender: TObject); procedure FormClose(Sender: TObject; var Action: TCloseAction); @@ -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.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. diff --git a/WASAPI/WASAPITest.dpr b/WASAPI/WASAPITest.dpr index 228537b..68f3b0f 100644 --- a/WASAPI/WASAPITest.dpr +++ b/WASAPI/WASAPITest.dpr @@ -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} diff --git a/WASAPI/WASAPITest.dproj b/WASAPI/WASAPITest.dproj index 291cc99..37e3735 100644 --- a/WASAPI/WASAPITest.dproj +++ b/WASAPI/WASAPITest.dproj @@ -127,6 +127,7 @@
Form1
dfm + Base