ewsdr/WaterfallViewOpengl.pas

unit WaterfallViewOpengl;

{
  OpenGL renderer for the waterfall pane.

  The CPU path rebuilds a full bitmap after scrolling rows in memory. This
  renderer keeps one GL texture and uploads only the newest waterfall row.
}

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

interface

uses
  Classes, SysUtils, Graphics, Controls, Math,
  OpenGLContextEx, GL,
  AppTheme, WaterfallView;

type
  TWaterfallViewOpenGL = class(TWaterfallView)
  private
    FGLControl: TOpenGLControl;
    FTexture: GLuint;
    FTexW: Integer;
    FTexH: Integer;
    FLatestRow: Integer;
    FRowPixels: array of Byte;
    FMarkerTex: GLuint;
    FMarkerTexW: Integer;
    FMarkerTexH: Integer;
    FMarkerText: string;

    procedure DeleteTexture(var Tex: GLuint);
    procedure EnsureTexture(W, H: Integer);
    procedure UploadCurrentRow(W: Integer);
    procedure DrawTextureWrapped(W, H: Integer);
    procedure DrawMarker(W, H: Integer);
    procedure UploadMarkerText(const S: string);
    function FormatFreqGL(Hz: Double): string;
  public
    constructor Create;
    destructor Destroy; override;
    procedure AttachControl(C: TOpenGLControl);
    procedure SetWaterfallBitmapSize(W, H: Integer); override;
    procedure DrawWaterfall; override;
    procedure PaintWaterfall(Sender: TObject); override;
    procedure SetTheme(const T: TAppTheme); override;
    procedure ResetWfBuf; override;
    procedure ResetWfAvgBuf; override;
    // Контекст умер (reparent/пересоздание хэндла): обнулить id БЕЗ glDelete.
    procedure ResetGLCache;
  end;

implementation

function EnsureByte(V: Integer): Byte;
begin
  if V < 0 then Result := 0
  else if V > 255 then Result := 255
  else Result := V;
end;

function TWaterfallViewOpenGL.FormatFreqGL(Hz: Double): string;
var Mhz: Int64; KHz, Rest: Integer;
begin
  Mhz := Trunc(Hz / 1000000);
  KHz := Trunc((Hz - Mhz * 1000000) / 1000);
  Rest := Trunc(Hz) mod 1000;
  Result := Format('%d.%3.3d.%3.3d', [Mhz, KHz, Rest]);
end;

constructor TWaterfallViewOpenGL.Create;
begin
  inherited Create;
  FTexture := 0;
  FMarkerTex := 0;
  FTexW := 0;
  FTexH := 0;
  FLatestRow := 0;
end;

destructor TWaterfallViewOpenGL.Destroy;
begin
  if Assigned(FGLControl) and FGLControl.MakeCurrent then
  begin
    DeleteTexture(FTexture);
    DeleteTexture(FMarkerTex);
  end;
  inherited Destroy;
end;

procedure TWaterfallViewOpenGL.AttachControl(C: TOpenGLControl);
begin
  FGLControl := C;
end;

procedure TWaterfallViewOpenGL.ResetGLCache;
begin
  FTexture := 0;
  FMarkerTex := 0;
  FTexW := 0;
  FTexH := 0;
  FMarkerText := '';
end;

procedure TWaterfallViewOpenGL.DeleteTexture(var Tex: GLuint);
begin
  if Tex <> 0 then glDeleteTextures(1, @Tex);
  Tex := 0;
end;

procedure TWaterfallViewOpenGL.EnsureTexture(W, H: Integer);
var
  Bg: LongWord;
  Pixels: array of Byte;
  I: Integer;
begin
  if (W <= 0) or (H <= 0) then Exit;
  if (FTexture <> 0) and (FTexW = W) and (FTexH = H) then Exit;
  DeleteTexture(FTexture);
  FTexW := W;
  FTexH := H;
  FLatestRow := 0;
  SetLength(FRowPixels, W * 4);
  SetLength(Pixels, W * H * 4);
  Bg := PaletteColor(0.0);   // «холодный» конец палитры = фон
  for I := 0 to W * H - 1 do
  begin
    Pixels[I * 4] := Byte(Bg shr 16);
    Pixels[I * 4 + 1] := Byte(Bg shr 8);
    Pixels[I * 4 + 2] := Byte(Bg);
    Pixels[I * 4 + 3] := $FF;
  end;
  glGenTextures(1, @FTexture);
  glBindTexture(GL_TEXTURE_2D, FTexture);
  glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_NEAREST);
  glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_NEAREST);
  glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_CLAMP);
  glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP);
  glTexImage2D(GL_TEXTURE_2D, 0, GL_RGBA, W, H, 0, GL_RGBA,
    GL_UNSIGNED_BYTE, @Pixels[0]);
  glBindTexture(GL_TEXTURE_2D, 0);
end;

procedure TWaterfallViewOpenGL.UploadCurrentRow(W: Integer);
var
  X, SrcCount, S0, S1, Off, Idx: Integer;
  SrcF, Step, Frac, DBV, WfHigh, WfLow, LutScale: Double;
  Pal: LongWord;
begin
  if (FTexture = 0) or (W <= 0) then Exit;
  UpdateAutoLevels;
  GetEffectiveLevels(WfLow, WfHigh);
  LutScale := High(FWfLut) / (WfHigh - WfLow);
  if LutNeedsRebuild(WfLow, WfHigh) then
    BuildWfLut(WfLow, WfHigh);

  SrcCount := EnsureRange(FWaterfallBufCount, 2, WF_MAX_PIXELS);
  Step := (SrcCount - 1.0) / Max(1, W - 1);
  SrcF := 0.0;
  for X := 0 to W - 1 do
  begin
    if FTXMode and (FTXSpanHz > 0) and (FSpanHz > 0) then
    begin
      DBV := FCenterFreq - FSpanHz * 0.5 + X * FSpanHz / Max(1, W - 1) - FTXFreq;
      if (DBV < -FTXSpanHz * 0.5) or (DBV > FTXSpanHz * 0.5) then
        DBV := WfLow
      else
      begin
        SrcF := (DBV + FTXSpanHz * 0.5) / FTXSpanHz * (SrcCount - 1);
        S0 := Min(Trunc(SrcF), SrcCount - 2);
        S1 := S0 + 1;
        Frac := SrcF - S0;
        DBV := FWaterfallBuf[S0] * (1.0 - Frac) + FWaterfallBuf[S1] * Frac;
      end;
    end
    else
    begin
      S0 := Min(Trunc(SrcF), SrcCount - 2);
      S1 := S0 + 1;
      Frac := SrcF - S0;
      DBV := FWaterfallBuf[S0] * (1.0 - Frac) + FWaterfallBuf[S1] * Frac;
    end;
    Idx := Round((DBV - WfLow) * LutScale);
    if Idx < 0 then Idx := 0 else if Idx > High(FWfLut) then Idx := High(FWfLut);
    Pal := FWfLutARGB[Idx];
    Off := X * 4;
    FRowPixels[Off] := Byte(Pal shr 16);
    FRowPixels[Off + 1] := Byte(Pal shr 8);
    FRowPixels[Off + 2] := Byte(Pal);
    FRowPixels[Off + 3] := $FF;
    SrcF := SrcF + Step;
  end;

  Dec(FLatestRow);
  if FLatestRow < 0 then FLatestRow := FTexH - 1;
  glBindTexture(GL_TEXTURE_2D, FTexture);
  glTexSubImage2D(GL_TEXTURE_2D, 0, 0, FLatestRow, W, 1, GL_RGBA,
    GL_UNSIGNED_BYTE, @FRowPixels[0]);
  glBindTexture(GL_TEXTURE_2D, 0);
end;

procedure TWaterfallViewOpenGL.DrawTextureWrapped(W, H: Integer);
var
  FirstRows, SecondRows: Integer;
  V0, V1: GLFloat;
begin
  if FTexture = 0 then Exit;
  glEnable(GL_TEXTURE_2D);
  glBindTexture(GL_TEXTURE_2D, FTexture);
  glColor4f(1, 1, 1, 1);

  FirstRows := FTexH - FLatestRow;
  V0 := FLatestRow / FTexH;
  V1 := 1.0;
  glBegin(GL_QUADS);
    glTexCoord2f(0, V0); glVertex2f(0, 0);
    glTexCoord2f(1, V0); glVertex2f(W, 0);
    glTexCoord2f(1, V1); glVertex2f(W, FirstRows);
    glTexCoord2f(0, V1); glVertex2f(0, FirstRows);
  glEnd;

  SecondRows := FLatestRow;
  if SecondRows > 0 then
  begin
    V0 := 0.0;
    V1 := FLatestRow / FTexH;
    glBegin(GL_QUADS);
      glTexCoord2f(0, V0); glVertex2f(0, FirstRows);
      glTexCoord2f(1, V0); glVertex2f(W, FirstRows);
      glTexCoord2f(1, V1); glVertex2f(W, H);
      glTexCoord2f(0, V1); glVertex2f(0, H);
    glEnd;
  end;
  glBindTexture(GL_TEXTURE_2D, 0);
  glDisable(GL_TEXTURE_2D);
end;

procedure TWaterfallViewOpenGL.UploadMarkerText(const S: string);
var
  B: TBitmap;
  X, Y, I: Integer;
  Src: PByte;
  Buf: array of Byte;
  A: Byte;
begin
  if S = '' then Exit;
  B := TBitmap.Create;
  try
    B.PixelFormat := pf32bit;
    B.SetSize(8, 8);
    B.Canvas.Font.Name := 'Courier New';
    B.Canvas.Font.Size := 7;
    FMarkerTexW := B.Canvas.TextWidth(S) + 4;
    FMarkerTexH := B.Canvas.TextHeight(S) + 2;
    B.SetSize(FMarkerTexW, FMarkerTexH);
    B.Canvas.Brush.Color := clBlack;
    B.Canvas.FillRect(0, 0, FMarkerTexW, FMarkerTexH);
    B.Canvas.Font.Name := 'Courier New';
    B.Canvas.Font.Size := 7;
    B.Canvas.Font.Color := clWhite;
    B.Canvas.Brush.Style := bsClear;
    B.Canvas.TextOut(2, 1, S);
    SetLength(Buf, FMarkerTexW * FMarkerTexH * 4);
    I := 0;
    B.BeginUpdate(False);
    try
      for Y := 0 to FMarkerTexH - 1 do
      begin
        Src := PByte(B.ScanLine[Y]);
        for X := 0 to FMarkerTexW - 1 do
        begin
          A := Max(Src[0], Max(Src[1], Src[2]));
          Buf[I] := $FF;
          Buf[I + 1] := $44;
          Buf[I + 2] := $44;
          Buf[I + 3] := A;
          Inc(Src, 4);
          Inc(I, 4);
        end;
      end;
    finally
      B.EndUpdate(False);
    end;
    if FMarkerTex = 0 then glGenTextures(1, @FMarkerTex);
    glBindTexture(GL_TEXTURE_2D, FMarkerTex);
    glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR);
    glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR);
    glTexImage2D(GL_TEXTURE_2D, 0, GL_RGBA, FMarkerTexW, FMarkerTexH, 0,
      GL_RGBA, GL_UNSIGNED_BYTE, @Buf[0]);
    glBindTexture(GL_TEXTURE_2D, 0);
    FMarkerText := S;
  finally
    B.Free;
  end;
end;

procedure TWaterfallViewOpenGL.DrawMarker(W, H: Integer);
var
  MX, TX: Integer;
  MarkerFreq: Double;
  S: string;
begin
  if not FMarkerActive then Exit;
  MX := Round(FMarkerX / 1000.0 * W);
  if (MX < 0) or (MX >= W) then Exit;
  glColor4f(1.0, $44 / 255.0, $44 / 255.0, 1);
  glBegin(GL_LINES);
    glVertex2f(MX + 0.5, 0);
    glVertex2f(MX + 0.5, H);
  glEnd;
  MarkerFreq := (FCenterFreq - FSpanHz / 2) + FMarkerX / 1000.0 * FSpanHz;
  S := FormatFreqGL(Round(MarkerFreq));
  if (S <> FMarkerText) or (FMarkerTex = 0) then UploadMarkerText(S);
  if FMarkerTex = 0 then Exit;
  if MX + 4 + FMarkerTexW < W then TX := MX + 4
  else TX := MX - 4 - FMarkerTexW;
  glEnable(GL_TEXTURE_2D);
  glBindTexture(GL_TEXTURE_2D, FMarkerTex);
  glColor4f(1, 1, 1, 1);
  glBegin(GL_QUADS);
    glTexCoord2f(0, 0); glVertex2f(TX, 4);
    glTexCoord2f(1, 0); glVertex2f(TX + FMarkerTexW, 4);
    glTexCoord2f(1, 1); glVertex2f(TX + FMarkerTexW, 4 + FMarkerTexH);
    glTexCoord2f(0, 1); glVertex2f(TX, 4 + FMarkerTexH);
  glEnd;
  glBindTexture(GL_TEXTURE_2D, 0);
  glDisable(GL_TEXTURE_2D);
end;

procedure TWaterfallViewOpenGL.SetWaterfallBitmapSize(W, H: Integer);
begin
  if (W <= 0) or (H <= 0) then Exit;
  // Ширина текстуры — в физических пикселях (HiDPI): строка водопада должна
  // ложиться 1:1 на пиксели фреймбуфера, иначе GL размажет её при увеличении.
  if Assigned(FGLControl) and FGLControl.MakeCurrent then
    EnsureTexture(Round(W * FGLControl.PixelScale), H);
  FWaterfallDirty := True;
end;

procedure TWaterfallViewOpenGL.DrawWaterfall;
begin
  if Assigned(FGLControl) then FGLControl.Invalidate;
end;

procedure TWaterfallViewOpenGL.PaintWaterfall(Sender: TObject);
var
  W, H, TexW: Integer;
  Scale: Double;
  R, G, B: GLFloat;
begin
  if Sender is TOpenGLControl then FGLControl := TOpenGLControl(Sender);
  if (FGLControl = nil) or (not FGLControl.MakeCurrent) then Exit;
  W := FGLControl.Width;
  H := FGLControl.Height;
  if (W <= 0) or (H <= 0) then Exit;
  // HiDPI: viewport покрывает весь FBO (физические пиксели), координаты
  // остаются логическими; строка водопада строится в физической ширине.
  Scale := FGLControl.PixelScale;
  TexW := Round(W * Scale);

  glViewport(0, 0, TexW, Round(H * Scale));
  glMatrixMode(GL_PROJECTION);
  glLoadIdentity;
  glOrtho(0, W, H, 0, -1, 1);
  glMatrixMode(GL_MODELVIEW);
  glLoadIdentity;
  glDisable(GL_DEPTH_TEST);
  glEnable(GL_BLEND);
  glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA);
  R := (FTheme.Panel and $FF) / 255.0;
  G := ((FTheme.Panel shr 8) and $FF) / 255.0;
  B := ((FTheme.Panel shr 16) and $FF) / 255.0;
  glClearColor(R, G, B, 1);
  glClear(GL_COLOR_BUFFER_BIT);

  EnsureTexture(TexW, H);
  if FWaterfallDirty then
  begin
    UploadCurrentRow(TexW);
    FWaterfallDirty := False;
  end;
  DrawTextureWrapped(W, H);
  DrawMarker(W, H);
  FGLControl.SwapBuffers;
end;

procedure TWaterfallViewOpenGL.SetTheme(const T: TAppTheme);
begin
  inherited SetTheme(T);
  if Assigned(FGLControl) and FGLControl.MakeCurrent then
    DeleteTexture(FTexture);
  FTexW := 0;
  FTexH := 0;
end;

procedure TWaterfallViewOpenGL.ResetWfBuf;
begin
  inherited ResetWfBuf;
  if Assigned(FGLControl) and FGLControl.MakeCurrent then
    DeleteTexture(FTexture);
  FTexW := 0;
  FTexH := 0;
end;

procedure TWaterfallViewOpenGL.ResetWfAvgBuf;
begin
  inherited ResetWfAvgBuf;
end;

end.