Убрать зазубринки при рисовании линий

Убрать зазубринки при рисовании линий При рисовании линии, особенно под маленьким углом, хорошо различимы отдельные точки. Для устранения этого недостатка я использую уменьшение изображения, как в предыдущем совете.

procedure TForm1.Button1Click(Sender: TObject);
var
 x, y: integer;
 i, j: integer;
 r, g, b: integer;
begin
 Form1.Canvas.Pen.Width := 10;
 Form1.Canvas.MoveTo(10, 10);
 Form1.Canvas.LineTo(90, 20);
 for y := 0 to 10 do
 begin
  for x := 0 to 25 do
  begin
  r := 0;
  for i := 0 to 3 do
  for j := 0 to 3 do
  r := r + GetRValue(Form1.Canvas.Pixels[4*x+i, 4*y+j]);
  r := round(r / 16);
  g := 0;
  for i := 0 to 3 do
  for j := 0 to 3 do
  g := g + GetGValue(Form1.Canvas.Pixels[4*x+i, 4*y+j]);
  g := round(g / 16);
  b := 0;
  for i := 0 to 3 do
  for j := 0 to 3 do
  b := b + GetBValue(Form1.Canvas.Pixels[4*x+i, 4*y+j]);
  b := round(b / 16);
  Form1.Canvas.Pixels[x,y+50] := RGB(r, g, b)
  end;
  Application.ProcessMessages;
 end;
end;
DelphiWorld 6.0

{
 This code draws an anti-aliased line on a bitmap
 This means that the line is not jagged like the
 lines drawn using the LineTo() function
}

 uses
  Graphics, Windows;
 type
  TRGBTripleArray = array[0..1000] of TRGBTriple;
  PRGBTripleArray = ^TRGBTripleArray;
 // anti-aliased line
procedure WuLine(ABitmap : TBitmap ; Point1, Point2 : TPoint ; AColor : TColor);
 var
  deltax, deltay, loop, start, finish : integer;
  dx, dy, dydx : single; // fractional parts
 LR, LG, LB : byte;
  x1, x2, y1, y2 : integer;
 begin
  x1 := Point1.X; y1 := Point1.Y;
  x2 := Point2.X; y2 := Point2.Y;
  deltax := abs(x2 - x1); // Calculate deltax and deltay for initialisation
 deltay := abs(y2 - y1);
  if (deltax = 0) or (deltay = 0) then begin // straight lines
  ABitmap.Canvas.Pen.Color := AColor;
  ABitmap.Canvas.MoveTo(x1, y1);
  ABitmap.Canvas.LineTo(x2, y2);
  exit;
  end;
  LR := (AColor and $000000FF);
  LG := (AColor and $0000FF00) shr 8;
  LB := (AColor and $00FF0000) shr 16;
  if deltax > deltay then
  begin // horizontal or vertical
  if y2 > y1 then // determine rise and run
  dydx := -(deltay / deltax)
  else
  dydx := deltay / deltax;
  if x2 < x1 then
  begin
  start := x2; // right to left
  finish := x1;
  dy := y2;
  end else
  begin
  start := x1; // left to right
  finish := x2;
  dy := y1;
  dydx := -dydx; // inverse slope
  end;
  for loop := start to finish do
  begin
  AlphaBlendPixel(ABitmap, loop, trunc(dy), LR, LG, LB, 1 - frac(dy));
  AlphaBlendPixel(ABitmap, loop, trunc(dy) + 1, LR, LG, LB, frac(dy));
  dy := dy + dydx; // next point
  end;
  end else
  begin
  if x2 > x1 then // determine rise and run
  dydx := -(deltax / deltay)
  else
  dydx := deltax / deltay;
  if y2 < y1 then
  begin
  start := y2; // right to left
  finish := y1;
  dx := x2;
  end else
  begin
  start := y1; // left to right
  finish := y2;
  dx := x1;
  dydx := -dydx; // inverse slope
  end;
  for loop := start to finish do
  begin
  AlphaBlendPixel(ABitmap, trunc(dx), loop, LR, LG, LB, 1 - frac(dx));
  AlphaBlendPixel(ABitmap, trunc(dx) + 1, loop, LR, LG, LB, frac(dx));
  dx := dx + dydx; // next point
  end;
  end;
 end;
 // blend a pixel with the current colour
procedure AlphaBlendPixel(ABitmap : TBitmap ; X, Y : integer ; R, G, B : byte ; ARatio : Real);
 Var
  LBack, LNew : TRGBTriple;
  LMinusRatio : Real;
  LScan : PRGBTripleArray;
 begin
  if (X < 0) or (X > ABitmap.Width - 1) or (Y < 0) or (Y > ABitmap.Height - 1) then
  Exit; // clipping
 LScan := ABitmap.Scanline[Y];
  LMinusRatio := 1 - ARatio;
  LBack := LScan[X];
  LNew.rgbtBlue := round(B*ARatio + LBack.rgbtBlue*LMinusRatio);
  LNew.rgbtGreen := round(G*ARatio + LBack.rgbtGreen*LMinusRatio);
  LNew.rgbtRed := round(R*ARatio + LBack.rgbtRed*LMinusRatio);
  LScan[X] := LNew;
 end;

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

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