Как сделать greyscale dithering?

procedure Greyscale(dib8, dib24: TFastDIB; Colors: Byte);
type
 TDiv3 = array[0..767] of Byte;
 TScale = array[0..255] of Byte;
 TLineErrors = array[-1.. - 1] of DWord;
 PDiv3 = ^TDiv3;
 PScale = ^TScale;
 PLineErrors = ^TLineErrors;
var
 x, y, i, Ln, Nxt: Integer;
 pc: PFColor;
 pb: PByte;
 Lines: array[0..1] of PLineErrors;
 Div3: PDiv3;
 Scale: PScale;
 pti: PDWord;
 dir: ShortInt;
begin
 dib8.FillColors(0, Colors, tfBlack, tfWhite);
 New(Div3);
 pb := Pointer(Div3);
 for i := 0 to 255 do
 begin
  pb^ := i;
  Inc(pb);
  pb^ := i;
  Inc(pb);
  pb^ := i;
  Inc(pb);
 end;
 New(Scale);
 pb := Pointer(Scale);
 x := (Colors shl 16) shr 8;
 y := x;
 for i := 0 to 255 do
 begin
  pb^ := y shr 16;
  Inc(y, x);
  Inc(pb);
 end;
 GetMem(Lines[0], 24 * (dib24.Width + 2));
 GetMem(Lines[1], 24 * (dib24.Width + 2));
 pc := PFColor(dib24.Bits);
 for x := 0 to dib24.Width - 1 do
 begin
  Lines[0, x] := Div3[pc.r + pc.g + pc.b] * 16;
  Inc(pc);
 end;
 pc := Ptr(Integer(pc) + dib24.Gap);
 dir := 1;
 for y := 1 to dib24.Height do
 begin
  Nxt := y mod 2;
  Ln := 1 - Nxt;
  if y < dib24.Height then
  begin
  for x := 0 to dib24.Width - 1 do
  begin
  Lines[Nxt, x] := Div3[pc.r + pc.g + pc.b] * 16;
  Inc(pc);
  end;
  pc := Ptr(Integer(pc) + dib24.Gap);
  end;
  x := 0;
  if dir = -1 then
  x := dib24.Width - 1;
  pti := @Lines[Ln, x];
  pb := @dib8.Pixels8[y - 1, x];
  while ((x > -1) and (x < dib24.Width)) do
  begin
  pti^ := pti^ div 16;
  if pti^ > 255 then
  pti^ := 255
  else if pti^ < 0 then
  pti^ := 0;
  pb^ := Scale[pti^];
  i := pti^ - dib8.Colors[pb^].r;
  if i <> 0 then
  begin
  Inc(Lines[Ln, x + dir], i * 7);
  Inc(Lines[Nxt, x - dir], i * 3);
  Inc(Lines[Nxt, x], i * 5);
  Inc(Lines[Nxt, x + dir], i);
  end;
  Inc(pb, dir);
  Inc(pti, dir);
  Inc(x, dir);
  end;
  Inc(pb, dib8.Gap);
  dir := -dir;
 end;
 Dispose(Lines[0]);
 Dispose(Lines[1]);
 Dispose(Scale);
 Dispose(Div3);
end;
Взято с Delphi Knowledge Base: http://www.baltsoft.com/

Отправить комментарий

Проверка
Антиспам проверка
Image CAPTCHA
...