ewsdr/DMRDiagnostics.pas

unit DMRDiagnostics;

{$IFDEF FPC}
  {$MODE Delphi}
{$ENDIF}

interface

uses
  Classes, SysUtils, SyncObjs;

type
  TDMRDiagnosticCapture = class;

  TDMRDumpWriter = class(TThread)
  private
    FOwner: TDMRDiagnosticCapture;
  protected
    procedure Execute; override;
  public
    constructor Create(AOwner: TDMRDiagnosticCapture);
  end;

  TDMRDiagnosticCapture = class
  private
    FLock: TCriticalSection;
    FWake: PRTLEvent;
    FThread: TDMRDumpWriter;
    FAccepting: Boolean;
    FDeadline: QWord;
    FBasePath: string;
    FIQ, FDemod, FBursts: TBytes;
    FIQRead, FIQWrite, FDemodRead, FDemodWrite: Integer;
    FBurstRead, FBurstWrite: Integer;
    FIQDropped, FDemodDropped, FBurstDropped: QWord;
    FIQStream, FDemodStream, FBurstStream: TFileStream;
    function RingWrite(var Ring: TBytes; var ReadPos, WritePos: Integer;
      Source: Pointer; Count: Integer; var Dropped: QWord): Boolean;
    function RingRead(var Ring: TBytes; var ReadPos, WritePos: Integer;
      Dest: Pointer; MaxCount: Integer): Integer;
    function RingsEmpty: Boolean;
    procedure WriterExecute;
    procedure CloseStreams;
    procedure WriteStats;
  public
    constructor Create;
    destructor Destroy; override;
    function Start(DurationSeconds: Integer; SampleRate: Integer;
      CenterHz, VfoHz: Double; const Directory: string = ''): string;
    procedure Stop;
    procedure FeedIQ24BE(const Data: array of Byte; Count: Integer);
    procedure FeedDemod(const Left, Right: array of Single; Count: Integer);
    procedure FeedBurst(const Dibits: array of Byte; Count: Integer);
    function Active: Boolean;
    property BasePath: string read FBasePath;
  end;

implementation

const
  IQ_RING_BYTES = 32 * 1024 * 1024;
  DEMOD_RING_BYTES = 4 * 1024 * 1024;
  BURST_RING_BYTES = 1024 * 1024;
  WRITER_BLOCK_BYTES = 256 * 1024;

constructor TDMRDumpWriter.Create(AOwner: TDMRDiagnosticCapture);
begin
  inherited Create(True);
  FreeOnTerminate := False;
  FOwner := AOwner;
end;

procedure TDMRDumpWriter.Execute;
begin
  FOwner.WriterExecute;
end;

constructor TDMRDiagnosticCapture.Create;
begin
  inherited Create;
  FLock := TCriticalSection.Create;
  FWake := RTLEventCreate;
  SetLength(FIQ, IQ_RING_BYTES);
  SetLength(FDemod, DEMOD_RING_BYTES);
  SetLength(FBursts, BURST_RING_BYTES);
end;

destructor TDMRDiagnosticCapture.Destroy;
begin
  Stop;
  SetLength(FIQ, 0);
  SetLength(FDemod, 0);
  SetLength(FBursts, 0);
  RTLEventDestroy(FWake);
  FLock.Free;
  inherited Destroy;
end;

function TDMRDiagnosticCapture.RingWrite(var Ring: TBytes;
  var ReadPos, WritePos: Integer; Source: Pointer; Count: Integer;
  var Dropped: QWord): Boolean;
var
  FreeBytes, First: Integer;
begin
  Result := False;
  if (Source = nil) or (Count <= 0) or (Length(Ring) = 0) then Exit;
  if WritePos >= ReadPos then FreeBytes := Length(Ring) - (WritePos - ReadPos) - 1
  else FreeBytes := ReadPos - WritePos - 1;
  if Count > FreeBytes then
  begin
    Inc(Dropped, Count);
    Exit;
  end;
  First := Count;
  if First > Length(Ring) - WritePos then First := Length(Ring) - WritePos;
  Move(Source^, Ring[WritePos], First);
  if Count > First then
    Move(PByte(Source)[First], Ring[0], Count - First);
  WritePos := (WritePos + Count) mod Length(Ring);
  Result := True;
end;

function TDMRDiagnosticCapture.RingRead(var Ring: TBytes;
  var ReadPos, WritePos: Integer; Dest: Pointer; MaxCount: Integer): Integer;
var
  Available, First: Integer;
begin
  Result := 0;
  if (Dest = nil) or (MaxCount <= 0) then Exit;
  if WritePos >= ReadPos then Available := WritePos - ReadPos
  else Available := Length(Ring) - ReadPos + WritePos;
  Result := Available;
  if Result > MaxCount then Result := MaxCount;
  First := Result;
  if First > Length(Ring) - ReadPos then First := Length(Ring) - ReadPos;
  if First > 0 then Move(Ring[ReadPos], Dest^, First);
  if Result > First then Move(Ring[0], PByte(Dest)[First], Result - First);
  ReadPos := (ReadPos + Result) mod Length(Ring);
end;

function TDMRDiagnosticCapture.RingsEmpty: Boolean;
begin
  Result := (FIQRead = FIQWrite) and (FDemodRead = FDemodWrite) and
            (FBurstRead = FBurstWrite);
end;

procedure TDMRDiagnosticCapture.CloseStreams;
begin
  FreeAndNil(FIQStream);
  FreeAndNil(FDemodStream);
  FreeAndNil(FBurstStream);
end;

procedure TDMRDiagnosticCapture.WriteStats;
var
  Stats: TStringList;
begin
  if FBasePath = '' then Exit;
  Stats := TStringList.Create;
  try
    Stats.Add(Format('iq_dropped_bytes=%d', [FIQDropped]));
    Stats.Add(Format('demod_dropped_bytes=%d', [FDemodDropped]));
    Stats.Add(Format('burst_dropped_bytes=%d', [FBurstDropped]));
    Stats.SaveToFile(FBasePath + '.stats.txt');
  finally
    Stats.Free;
  end;
end;

function TDMRDiagnosticCapture.Start(DurationSeconds: Integer;
  SampleRate: Integer; CenterHz, VfoHz: Double; const Directory: string): string;
var
  Dir, Stamp: string;
  Meta: TStringList;
begin
  Stop;
  if DurationSeconds < 1 then DurationSeconds := 1;
  if Directory <> '' then Dir := IncludeTrailingPathDelimiter(Directory)
  else Dir := IncludeTrailingPathDelimiter(GetTempDir(False));
  ForceDirectories(Dir);
  Stamp := FormatDateTime('yyyymmdd-hhnnss-zzz', Now);
  FBasePath := Dir + 'ewsdr-dmr-' + Stamp;
  FIQStream := TFileStream.Create(FBasePath + '.iq24be', fmCreate);
  FDemodStream := TFileStream.Create(FBasePath + '.demod_f32le', fmCreate);
  FBurstStream := TFileStream.Create(FBasePath + '.bursts_u8', fmCreate);

  Meta := TStringList.Create;
  try
    Meta.Add('{');
    Meta.Add('  "format": "EWSDR DMR diagnostic capture v1",');
    Meta.Add('  "iq_format": "interleaved signed 24-bit big-endian I,Q",');
    Meta.Add('  "demod_format": "mono float32 little-endian, 48000 Hz",');
    Meta.Add('  "burst_format": "144 uint8 dibits per record",');
    Meta.Add(Format('  "iq_sample_rate": %d,', [SampleRate]));
    Meta.Add(Format('  "center_hz": %.0f,', [CenterHz]));
    Meta.Add(Format('  "vfo_hz": %.0f,', [VfoHz]));
    Meta.Add(Format('  "duration_seconds": %d', [DurationSeconds]));
    Meta.Add('}');
    Meta.SaveToFile(FBasePath + '.json');
  finally
    Meta.Free;
  end;

  FLock.Enter;
  try
    FIQRead := 0; FIQWrite := 0;
    FDemodRead := 0; FDemodWrite := 0;
    FBurstRead := 0; FBurstWrite := 0;
    FIQDropped := 0; FDemodDropped := 0; FBurstDropped := 0;
    FDeadline := GetTickCount64 + QWord(DurationSeconds) * 1000;
    FAccepting := True;
  finally
    FLock.Leave;
  end;
  FThread := TDMRDumpWriter.Create(Self);
  FThread.Start;
  Result := FBasePath;
end;

procedure TDMRDiagnosticCapture.Stop;
begin
  if FThread = nil then
  begin
    CloseStreams;
    Exit;
  end;
  FLock.Enter;
  try
    FAccepting := False;
  finally
    FLock.Leave;
  end;
  RTLEventSetEvent(FWake);
  FThread.WaitFor;
  FreeAndNil(FThread);
  CloseStreams;
  WriteStats;
end;

procedure TDMRDiagnosticCapture.WriterExecute;
var
  IQBuf, DemodBuf, BurstBuf: TBytes;
  NIQ, NDemod, NBurst: Integer;
  AcceptingNow, EmptyNow: Boolean;
begin
  SetLength(IQBuf, WRITER_BLOCK_BYTES);
  SetLength(DemodBuf, WRITER_BLOCK_BYTES);
  SetLength(BurstBuf, WRITER_BLOCK_BYTES);
  repeat
    FLock.Enter;
    try
      if FAccepting and (GetTickCount64 >= FDeadline) then FAccepting := False;
      NIQ := RingRead(FIQ, FIQRead, FIQWrite, @IQBuf[0], Length(IQBuf));
      NDemod := RingRead(FDemod, FDemodRead, FDemodWrite,
        @DemodBuf[0], Length(DemodBuf));
      NBurst := RingRead(FBursts, FBurstRead, FBurstWrite,
        @BurstBuf[0], Length(BurstBuf));
      AcceptingNow := FAccepting;
      EmptyNow := RingsEmpty;
    finally
      FLock.Leave;
    end;
    if NIQ > 0 then FIQStream.WriteBuffer(IQBuf[0], NIQ);
    if NDemod > 0 then FDemodStream.WriteBuffer(DemodBuf[0], NDemod);
    if NBurst > 0 then FBurstStream.WriteBuffer(BurstBuf[0], NBurst);
    if (NIQ = 0) and (NDemod = 0) and (NBurst = 0) and AcceptingNow then
      RTLEventWaitFor(FWake, 100);
  until (not AcceptingNow) and EmptyNow;
  CloseStreams;
  WriteStats;
end;

procedure TDMRDiagnosticCapture.FeedIQ24BE(const Data: array of Byte;
  Count: Integer);
var
  Wrote: Boolean;
begin
  if Count > Length(Data) then Count := Length(Data);
  if Count <= 0 then Exit;
  FLock.Enter;
  try
    if not FAccepting then Exit;
    Wrote := RingWrite(FIQ, FIQRead, FIQWrite, @Data[0], Count, FIQDropped);
  finally
    FLock.Leave;
  end;
  if Wrote then RTLEventSetEvent(FWake);
end;

procedure TDMRDiagnosticCapture.FeedDemod(const Left, Right: array of Single;
  Count: Integer);
var
  Mono: array[0..2047] of Single;
  i, N: Integer;
  Wrote: Boolean;
begin
  N := Count;
  if N > Length(Left) then N := Length(Left);
  if N > Length(Right) then N := Length(Right);
  if N > Length(Mono) then N := Length(Mono);
  if N <= 0 then Exit;
  for i := 0 to N - 1 do Mono[i] := 0.5 * (Left[i] + Right[i]);
  FLock.Enter;
  try
    if not FAccepting then Exit;
    Wrote := RingWrite(FDemod, FDemodRead, FDemodWrite, @Mono[0],
      N * SizeOf(Single), FDemodDropped);
  finally
    FLock.Leave;
  end;
  if Wrote then RTLEventSetEvent(FWake);
end;

procedure TDMRDiagnosticCapture.FeedBurst(const Dibits: array of Byte;
  Count: Integer);
var
  Wrote: Boolean;
begin
  if Count > Length(Dibits) then Count := Length(Dibits);
  if Count <= 0 then Exit;
  FLock.Enter;
  try
    if not FAccepting then Exit;
    Wrote := RingWrite(FBursts, FBurstRead, FBurstWrite, @Dibits[0], Count,
      FBurstDropped);
  finally
    FLock.Leave;
  end;
  if Wrote then RTLEventSetEvent(FWake);
end;

function TDMRDiagnosticCapture.Active: Boolean;
begin
  FLock.Enter;
  try
    Result := FAccepting;
  finally
    FLock.Leave;
  end;
end;

end.