How to do 24bit dithering in Delphi

Problem/Question/Abstract:

In my precalculations for some gradient rendering I use a higher bit depths per channel than normal 8bit (actually doubles between 0..1) - how can I dither these to normal 24bit and achieve better quality than just simple scaling to 8bit?

Answer:

This works for me. It reduces 8 bit per channel to 4 bit per channel. If you want 16 bit per channel -> 8 bit, you should change the numbers in the downsampling part, the rest should hold as it stands.

{ ... }
type
  PIntegerArray = ^TIntegerArray;
  TIntegerArray = array[0..maxInt div sizeof(integer) - 2] of integer;
  TColor3 = packed record
    b, g, r: byte;
  end;
  TColor3Array = array[0..maxInt div sizeof(TColor3) - 2] of TColor3;
  PColor3Array = ^TColor3Array;

procedure Swap(var p1, p2: PIntegerArray);
var
  t: PIntegerArray;
begin
  t := p1;
  p1 := p2;
  p2 := t;
end;

function clamp(x, min, max: integer): integer;
begin
  result := x;
  if result < min then
    result := min;
  else
    if result > max then
      result := max;
end;

procedure Dither(bmpS, bmpD: TBitmap);
var
  bmpS, bmpD: TBitmap;
  scanlS, scanlD: PColor3Array;
  error1R, error1G, error1B,
    error2R, error2G, error2B: PIntegerArray;
  x, y: integer;
  dx: integer;
  c, cD: TColor3;
  sR, sG, sB: integer;
  dR, dG, dB: integer;
  eR, eG, eB: integer;
begin
  bmpD.Width := bmpS.Width;
  bmpD.Height := bmpS.Height;
  bmpS.PixelFormat := pf24bit;
  bmpD.PixelFormat := pf24bit;
  error1R := AllocMem((bmpS.Width + 2) * sizeof(integer));
  error1G := AllocMem((bmpS.Width + 2) * sizeof(integer));
  error1B := AllocMem((bmpS.Width + 2) * sizeof(integer));
  error2R := AllocMem((bmpS.Width + 2) * sizeof(integer));
  error2G := AllocMem((bmpS.Width + 2) * sizeof(integer));
  error2B := AllocMem((bmpS.Width + 2) * sizeof(integer));
  {dx holds the delta for each iteration as we zigzag, it'll change between 1 and -1}
  dx := 1;
  for y := 0 to bmpS.Height - 1 do
  begin
    scanlS := bmpS.ScanLine[y];
    scanlD := bmpD.ScanLine[y];
    if dx > 0 then
      x := 0
    else
      x := bmpS.Width - 1;
    while (x >= 0) and (x < bmpS.Width) do
    begin
      c := scanlS[x];
      sR := c.r;
      sG := c.g;
      sB := c.b;
      eR := error1R[x + 1];
      eG := error1G[x + 1];
      eB := error1B[x + 1];
      dR := (sR * 16 + eR) div 16;
      dG := (sR * 16 + eR) div 16;
      dB := (sR * 16 + eR) div 16;
      {actual downsampling}
      dR := clamp(dR, 0, 255) and (255 shl 4);
      dG := clamp(dR, 0, 255) and (255 shl 4);
      dB := clamp(dR, 0, 255) and (255 shl 4);
      cD.r := dR;
      cD.g := dG;
      cD.b := dB;
      scanlD[x] := cD;
      eR := sR - dR;
      eG := sG - dG;
      eB := sB - dB;
      inc(error1R[x + 1 + dx], (eR * 7)); {next}
      inc(error1G[x + 1 + dx], (eG * 7));
      inc(error1B[x + 1 + dx], (eB * 7));
      inc(error2R[x + 1], (eR * 5)); {top}
      inc(error2G[x + 1], (eG * 5));
      inc(error2B[x + 1], (eB * 5));
      inc(error2R[x + 1 + dx], (eR * 1)); {diag forward}
      inc(error2G[x + 1 + dx], (eG * 1));
      inc(error2B[x + 1 + dx], (eB * 1));
      inc(error2R[x + 1 - dx], (eR * 3)); {diag backward}
      inc(error2G[x + 1 - dx], (eG * 3));
      inc(error2B[x + 1 - dx], (eB * 3));
      inc(x, dx);
    end;
    dx := dx * -1;
    Swap(error1R, error2R);
    Swap(error1G, error2G);
    Swap(error1B, error2B);
    FillChar(error2R^, sizeof(integer) * (bmpS.Width + 2), 0);
    FillChar(error2G^, sizeof(integer) * (bmpS.Width + 2), 0);
    FillChar(error2B^, sizeof(integer) * (bmpS.Width + 2), 0);
  end;
  FreeMem(error1R);
  FreeMem(error1G);
  FreeMem(error1B);
  FreeMem(error2R);
  FreeMem(error2G);
  FreeMem(error2B);
end;