Plot a huge number of points per second on a TBitmap without flicker

Problem/Question/Abstract:

I need to visualize 50K points of SmallInt each second, so what are my options to accomplish that?

Answer:

This project was able to handle the 50K points you specified. An 800x600 bitmap was populated with these points 10 times a second without flicker. The points are chosen at random.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls;

const
  MAX_POINTS = 50000;

type
  PRGBTriad = ^TRGBTriad;
  TRGBTriad = record
    B, G, R: byte;
  end;

  TForm1 = class(TForm)
    Image1: TImage;
    Timer1: TTimer;
    procedure Timer1Timer(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
    FPoints: array of TPoint;
    procedure DrawBatch(ycoord: integer; var points: array of TPoint);
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure Sorty(var A: array of TPoint);

  procedure QuickSort(var A: array of TPoint; iLo, iHi: Integer);
  var
    Lo, Hi, Mid: Integer;
    T: TPoint;
  begin
    Lo := iLo;
    Hi := iHi;
    Mid := A[(Lo + Hi) div 2].y;
    repeat
      while A[Lo].y < Mid do
        Inc(Lo);
      while A[Hi].y > Mid do
        Dec(Hi);
      if Lo <= Hi then
      begin
        T := A[Lo];
        A[Lo] := A[Hi];
        A[Hi] := T;
        Inc(Lo);
        Dec(Hi);
      end;
    until
      Lo > Hi;
    if Hi > iLo then
      QuickSort(A, iLo, Hi);
    if Lo < iHi then
      QuickSort(A, Lo, iHi);
  end;

begin
  QuickSort(A, Low(A), High(A));
end;

procedure Sortx(var A: array of TPoint);

  procedure QuickSort(var A: array of TPoint; iLo, iHi: Integer);
  var
    Lo, Hi, Mid: Integer;
    T: TPoint;
  begin
    Lo := iLo;
    Hi := iHi;
    Mid := A[(Lo + Hi) div 2].x;
    repeat
      while A[Lo].x < Mid do
        Inc(Lo);
      while A[Hi].x > Mid do
        Dec(Hi);
      if Lo <= Hi then
      begin
        T := A[Lo];
        A[Lo] := A[Hi];
        A[Hi] := T;
        Inc(Lo);
        Dec(Hi);
      end;
    until
      Lo > Hi;
    if Hi > iLo then
      QuickSort(A, iLo, Hi);
    if Lo < iHi then
      QuickSort(A, Lo, iHi);
  end;

begin
  QuickSort(A, Low(A), High(A));
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var
  i: integer;
  lastY: integer;
  batch: array of TPoint;
  batchLength: integer;
begin
  for i := Low(FPoints) to High(FPoints) do
  begin
    FPoints[i].x := Random(800);
    FPoints[i].y := Random(600);
  end;
  Sorty(FPoints); {Quicksort by y}
  lastY := -1;
  i := Low(FPoints);
  batchLength := 0;
  Image1.Picture.Bitmap.Canvas.TryLock;
  while i <= High(FPoints) do
  begin
    if lastY = FPoints[i].y then
    begin
      Inc(batchLength);
      SetLength(batch, batchLength);
      batch[batchLength] := FPoints[i];
    end
    else
    begin
      DrawBatch(lastY, batch);
      batchLength := 0;
      lastY := FPoints[i].y;
      Inc(batchLength);
      SetLength(batch, batchLength);
      batch[batchLength - 1] := FPoints[i];
    end;
    Inc(i);
  end;
  Image1.Picture.Bitmap.Canvas.Unlock;
  Image1.Invalidate;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  SetLength(FPoints, MAX_POINTS);
  Randomize;
  Image1.Picture.Bitmap.PixelFormat := pf24bit;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  FPoints := nil;
end;

procedure TForm1.DrawBatch(ycoord: integer; var points: array of TPoint);
var
  yScanLine: PRGBTriad;
  pixelpos: PRGBTriad;
  i: integer;
begin
  if Length(points) = 0 then
    exit;
  Sortx(points);
  yScanLine := Image1.Picture.Bitmap.ScanLine[ycoord];
  FillChar(yScanLine^, 3 * 800, 255);
  for i := Low(points) to High(points) do
  begin
    pixelpos := yScanLine;
    Inc(pixelPos, points[i].x);
    PixelPos^.R := 255;
    PixelPos^.G := 0;
    PixelPos^.B := 0;
  end;
end;

end.