Сглаживание (antialiasing)
01.01.2007
{The parameter "percent" needs an integer between 0 and 100 (include zero and 100). If "Percent" is 0, there will be no effect. If it's 100 there will be the strongest effect.}
procedure Antialising(C: TCanvas; Rect: TRect; Percent: Integer);
var
l, p: Integer;
R, G, B: Integer;
R1, R2, G1, G2, B1, B2: Byte;
begin
with c do
begin
Brush.Style := bsclear;
lineto(200, 100);
moveto(50, 150);
Ellipse(50, 150, 200, 30);
for l := Rect.Top to Rect.Bottom do
begin
for p := Rect.Left to Rect.Right do
begin
R1 := GetRValue(Pixels[p, l]);
G1 := GetGValue(Pixels[p, l]);
B1 := GetBValue(Pixels[p, l]);
//Pixel links
//Pixel left
R2 := GetRValue(Pixels[p - 1, l]);
G2 := GetGValue(Pixels[p - 1, l]);
B2 := GetBValue(Pixels[p - 1, l]);
if (R1 <> R2) or (G1 <> G2) or (B1 <> B2) then
begin
R := Round(R1 + (R2 - R1) * 50 / (Percent + 50));
G := Round(G1 + (G2 - G1) * 50 / (Percent + 50));
B := Round(B1 + (B2 - B1) * 50 / (Percent + 50));
Pixels[p - 1, l] := RGB(R, G, B);
end;
//Pixel rechts
//Pixel right
R2 := GetRValue(Pixels[p + 1, l]);
G2 := GetGValue(Pixels[p + 1, l]);
B2 := GetBValue(Pixels[p + 1, l]);
if (R1 <> R2) or (G1 <> G2) or (B1 <> B2) then
begin
R := Round(R1 + (R2 - R1) * 50 / (Percent + 50));
G := Round(G1 + (G2 - G1) * 50 / (Percent + 50));
B := Round(B1 + (B2 - B1) * 50 / (Percent + 50));
Pixels[p + 1, l] := RGB(R, G, B);
end;
//Pixel oben
//Pixel up
R2 := GetRValue(Pixels[p, l - 1]);
G2 := GetGValue(Pixels[p, l - 1]);
B2 := GetBValue(Pixels[p, l - 1]);
if (R1 <> R2) or (G1 <> G2) or (B1 <> B2) then
begin
R := Round(R1 + (R2 - R1) * 50 / (Percent + 50));
G := Round(G1 + (G2 - G1) * 50 / (Percent + 50));
B := Round(B1 + (B2 - B1) * 50 / (Percent + 50));
Pixels[p, l - 1] := RGB(R, G, B);
end;
//Pixel unten
//Pixel down
R2 := GetRValue(Pixels[p, l + 1]);
G2 := GetGValue(Pixels[p, l + 1]);
B2 := GetBValue(Pixels[p, l + 1]);
if (R1 <> R2) or (G1 <> G2) or (B1 <> B2) then
begin
R := Round(R1 + (R2 - R1) * 50 / (Percent + 50));
G := Round(G1 + (G2 - G1) * 50 / (Percent + 50));
B := Round(B1 + (B2 - B1) * 50 / (Percent + 50));
Pixels[p, l + 1] := RGB(R, G, B);
end;
end;
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Antialising(Image1.Canvas, Image1.Canvas.ClipRect, 100);
end;
Взято с сайта https://www.swissdelphicenter.ch/en/tipsindex.php
{***************************************************************
*
* Project : FastAntiAlias
* Unit : FAAlias
* Purpose : To demonstrate the use of super-sampling technique
* to anti-alias an image, as well to fast access to
* a bitmap image pixels using the ScanLine property
* Author : Nacho Urenda (based on an example project by Rod
* Stephens published on Delphi Informant,
* april 98 issue)
* Date : 15/08/2000
*
***************************************************************}
unit FAAlias;
interface
uses
Windows, SysUtils, Graphics, Controls, Forms, StdCtrls, ExtCtrls,
ComCtrls, ShellApi, Classes;
type
TAntiAliasForm = class(TForm)
PageControl1: TPageControl;
TabSheet1: TTabSheet;
TabSheet2: TTabSheet;
OutBox: TPaintBox;
OrigBox: TPaintBox;
Label1: TLabel;
Label2: TLabel;
Label4: TLabel;
Label5: TLabel;
ProcessBtn: TButton;
ZoomOutBox: TCheckBox;
ZoomOrigBox: TCheckBox;
Method: TRadioGroup;
Memo1: TMemo;
TabSheet3: TTabSheet;
Label3: TLabel;
Label6: TLabel;
Label7: TLabel;
Label8: TLabel;
Label9: TLabel;
Label10: TLabel;
Label11: TLabel;
Label12: TLabel;
OrigVScrollBar: TScrollBar;
OutVScrollBar: TScrollBar;
OrigHScrollBar: TScrollBar;
OutHScrollBar: TScrollBar;
procedure SeparateColor(color : TColor; var r, g, b : Integer);
procedure OutBoxPaint(Sender: TObject);
procedure DrawFace(bm : TBitmap; pen_width : Integer);
procedure OrigBoxPaint(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure ProcessBtnClick(Sender: TObject);
procedure DrawBigBmp;
procedure FormCreate(Sender: TObject);
procedure ZoomOrigBoxClick(Sender: TObject);
procedure ZoomOutBoxClick(Sender: TObject);
procedure Label10Click(Sender: TObject);
procedure Label12Click(Sender: TObject);
procedure OrigScrollBarChange(Sender: TObject);
procedure OutScrollBarChange(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure AntiAliasPicture;
procedure FastAntiAliasPicture;
end;
var
AntiAliasForm: TAntiAliasForm;
const
MaxPixelCount = 32768;
type
pRGBArray = ^TRGBArray;
TRGBArray = ARRAY[0..MaxPixelCount-1] OF TRGBTriple;
implementation
{$R *.DFM}
var
orig_bmp, big_bmp, out_bmp : TBitmap;
{***************************************************************
TAntiAliasForm.SeparateColor
15/08/2000
The original procedure by Rod Stephens has been somewhat
fastened
***************************************************************}
procedure TAntiAliasForm.SeparateColor(color : TColor;
var r, g, b : Integer);
begin
r := Byte(color);
g := Byte(color shr 8);
b := Byte(color shr 16);
end;
{***************************************************************
TAntiAliasForm.AntiAliasPicture
15/08/2000
The original AAliasPicture procedure by Rod Stephens has been
rewritten to improve the supersampling from double to triple
factor, and somewhat simplified...
***************************************************************}
procedure TAntiAliasForm.AntiAliasPicture;
var
x, y: integer;
totr, totg, totb, r, g, b : integer;
i, j: integer;
begin
// For each row
for y := 0 to orig_bmp.Height - 1 do
begin
// For each column
for x := 0 to orig_bmp.Width - 1 do
begin
totr := 0;
totg := 0;
totb := 0;
// Read each of the sample pixels
for i := 0 to 2 do
begin
for j := 0 to 2 do
begin
SeparateColor(big_bmp.Canvas.Pixels[(x*3) + j, (y*3) + i], r, g, b);
totr := totr + r;
totg := totg + g;
totb := totb + b;
end;
end;
out_bmp.Canvas.Pixels[x,y] := RGB(totr div 9,
totg div 9,
totb div 9);
end; // end for columns
end; // end for rows
end;
{***************************************************************
TAntiAliasForm.FastAAliasPicture
20/08/2000
***************************************************************}
procedure TAntiAliasForm.FastAntiAliasPicture;
var
x, y, cx, cy : integer;
totr, totg, totb : integer;
Row1, Row2, Row3, DestRow: pRGBArray;
i: integer;
begin
// For each row
for y := 0 to orig_bmp.Height - 1 do
begin
// We compute samples of 3 x 3 pixels
cy := y*3;
// Get pointers to actual, previous and next rows in supersampled bitmap
Row1 := big_bmp.ScanLine[cy];
Row2 := big_bmp.ScanLine[cy+1];
Row3 := big_bmp.ScanLine[cy+2];
// Get a pointer to destination row in output bitmap
DestRow := out_bmp.ScanLine[y];
// For each column...
for x := 0 to orig_bmp.Width - 1 do
begin
// We compute samples of 3 x 3 pixels
cx := 3*x;
// Initialize result color
totr := 0;
totg := 0;
totb := 0;
// For each pixel in sample
for i := 0 to 2 do
begin
// New red value
totr := totr + Row1[cx + i].rgbtRed
+ Row2[cx + i].rgbtRed
+ Row3[cx + i].rgbtRed;
// New green value
totg := totg + Row1[cx + i].rgbtGreen
+ Row2[cx + i].rgbtGreen
+ Row3[cx + i].rgbtGreen;
// New blue value
totb := totb + Row1[cx + i].rgbtBlue
+ Row2[cx + i].rgbtBlue
+ Row3[cx + i].rgbtBlue;
end;
// Set output pixel colors
DestRow[x].rgbtRed := totr div 9;
DestRow[x].rgbtGreen := totg div 9;
DestRow[x].rgbtBlue := totb div 9;
end;
end;
end;
{***************************************************************
TAntiAliasForm.OrigBoxPaint
TAntiAliasForm.OutBoxPaint
15/08/2000
The original procedures by Rod Stephens have been modified
to allow the zooming and panning effects
***************************************************************}
procedure TAntiAliasForm.OrigBoxPaint(Sender: TObject);
var ZoomRect: TRect;
begin
// If zoomed display an enlarged protion of the bitmap
if ZoomOrigBox.Checked then
begin
ZoomRect := Rect(OrigHScrollBar.Position,
OrigVScrollBar.Position,
OrigHScrollBar.Position+60,
OrigVScrollBar.Position+60);
OrigBox.Canvas.CopyRect(OrigBox.ClientRect, orig_bmp.Canvas, ZoomRect)
end else
OrigBox.Canvas.Draw(0, 0, orig_bmp);
end;
procedure TAntiAliasForm.OutBoxPaint(Sender: TObject);
var ZoomRect: TRect;
begin
if ZoomOutBox.Checked then
begin
ZoomRect := Rect(OutHScrollBar.Position,
OutVScrollBar.Position,
OutHScrollBar.Position+60,
OutVScrollBar.Position+60);
OutBox.Canvas.CopyRect(OutBox.ClientRect, out_bmp.Canvas, ZoomRect)
end else
OutBox.Canvas.Draw(0, 0, out_bmp);
end;
{***************************************************************
TAntiAliasForm.DrawFace
15/08/2000
Procedure written by Rod Stephens (unmodified)
***************************************************************}
procedure TAntiAliasForm.DrawFace(bm : TBitmap;
pen_width : Integer);
var
x1, y1, x2, y2, x3, y3, x4, y4 : Integer;
old_width : Integer;
old_color : TColor;
begin
// Save the original brush color and pen width.
old_width := bm.Canvas.Pen.Width;
old_color := bm.Canvas.Brush.Color;
//orig_bmp.LoadFromFile('c:\1.bmp');
// Erase background;
bm.Canvas.Pen.Color := clwhite;
bm.Canvas.Brush.Color := clwhite;
bm.Canvas.Rectangle(0, 0, bm.width, bm.height);
// Draw the head.
bm.Canvas.Pen.Color := clBlack;
bm.Canvas.Pen.Width := pen_width;
bm.Canvas.Brush.Color := clYellow;
x1 := Round(bm.Width * 0.05);
y1 := x1;
x2 := Round(bm.Height * 0.95);
y2 := x2;
bm.Canvas.Ellipse(x1, y1, x2, y2);
// Draw the eyes.
bm.Canvas.Brush.Color := clWhite;
x1 := Round(bm.Width * 0.25);
y1 := Round(bm.Height * 0.25);
x2 := Round(bm.Width * 0.4);
y2 := Round(bm.Height * 0.4);
bm.Canvas.Ellipse(x1, y1, x2, y2);
x1 := Round(bm.Width * 0.75);
x2 := Round(bm.Width * 0.6);
bm.Canvas.Ellipse(x1, y1, x2, y2);
// Draw the pupils.
bm.Canvas.Brush.Color := clBlack;
bm.Canvas.Refresh;
x1 := Round(bm.Width * 0.275);
y1 := Round(bm.Height * 0.3);
x2 := Round(bm.Width * 0.375);
y2 := Round(bm.Height * 0.4);
bm.Canvas.Ellipse(x1, y1, x2, y2);
x1 := Round(bm.Width * 0.725);
x2 := Round(bm.Width * 0.625);
bm.Canvas.Ellipse(x1, y1, x2, y2);
// Draw the nose.
bm.Canvas.Brush.Color := clAqua;
x1 := Round(bm.Width * 0.425);
y1 := Round(bm.Height * 0.425);
x2 := Round(bm.Width * 0.575);
y2 := Round(bm.Height * 0.6);
bm.Canvas.Ellipse(x1, y1, x2, y2);
// Draw a crooked smile.
x1 := Round(bm.Width * 0.25);
y1 := Round(bm.Height * 0.25);
x2 := Round(bm.Width * 0.75);
y2 := Round(bm.Height * 0.75);
x3 := Round(bm.Width * 0.4);
y3 := Round(bm.Height * 0.6);
x4 := Round(bm.Width * 0.8);
y4 := Round(bm.Height * 0.6);
bm.Canvas.Arc(x1, y1, x2, y2, x3, y3, x4, y4);
bm.Canvas.Brush.Color := old_color;
bm.Canvas.Pen.Width := old_width;
// if pen_width = 6 then Image1.Picture.Assign(bm);
end;
{***************************************************************
TAntiAliasForm.FormDestroy
15/08/2000
We must free the memory bitmaps before exiting
***************************************************************}
procedure TAntiAliasForm.FormDestroy(Sender: TObject);
begin
orig_bmp.Free;
big_bmp.Free;
out_bmp.Free;
end;
{***************************************************************
TAntiAliasForm.Button1Click
15/08/2000
***************************************************************}
procedure TAntiAliasForm.ProcessBtnClick(Sender: TObject);
var IniTime, ElapsedTime: DWord;
begin
// Display the hourglass cursor.
Screen.Cursor := crHourGlass;
// Erase the time elapsed label
Label4.Caption := '';
Label4.Refresh;
// Erase the result PaintBox.
out_bmp.Canvas.Brush.color := clWhite;
out_bmp.Canvas.FillRect(out_bmp.Canvas.ClipRect);
// Force repaint of outbox
OutBox.Refresh;
// Draw the supersampled image
DrawBigBmp;
// Create the anti-aliased version.
if Method.ItemIndex = 0 then
begin
IniTime := GetTickCount;
AntiAliasPicture;
ElapsedTime := GetTickCount - IniTime;
end else begin
IniTime := GetTickCount;
FastAntiAliasPicture;
ElapsedTime := GetTickCount - IniTime;
end;
// Force repaint of output PaintBox
OutBox.Invalidate;
// Just to display calculation time
Label4.Caption := IntToStr(ElapsedTime) + ' ms';
Label4.Refresh;
// Force repaint of outbox
OutBox.Invalidate;
// Remove the hourglass cursor.
Screen.Cursor := crDefault;
end;
{***************************************************************
TAntiAliasForm.DrawBigBmp
15/08/2000
***************************************************************}
procedure TAntiAliasForm.DrawBigBmp;
begin
// Draw the supersampled image
DrawFace(big_bmp, 6);
end;
{***************************************************************
TAntiAliasForm.FormCreate
15/08/2000
***************************************************************}
procedure TAntiAliasForm.FormCreate(Sender: TObject);
begin
// Create the necessary memory bitmaps.
orig_bmp := TBitmap.Create;
orig_bmp.Width := OrigBox.ClientWidth;
orig_bmp.Height := OrigBox.ClientHeight;
// Bitmap MUST be 24 bits to get ScanLine[] to work
orig_bmp.PixelFormat := pf24bit;
// Initialize original bitmap
DrawFace(Orig_bmp, 2);
// Create supersampled bitmap
big_bmp := TBitmap.Create;
big_bmp.Width := orig_bmp.Width * 3;
big_bmp.Height := orig_bmp.Height * 3;
big_bmp.PixelFormat := pf24bit;
// Create output bitmap
out_bmp := TBitmap.Create;
out_bmp.Width := orig_bmp.Width;
out_bmp.Height := orig_bmp.Height;
out_bmp.PixelFormat := pf24bit;
// Make sure the 'Example' page is visible on startup
PageControl1.ActivePage := TabSheet1;
// Initialize Scroll Bars
OrigHScrollBar.Min := 0;
OrigHScrollBar.Max := OrigBox.Width - (OrigBox.Width div 5);
OrigHScrollBar.LargeChange := OrigBox.Width div 5;
OrigVScrollBar.Min := 0;
OrigVScrollBar.Max := OrigBox.Height - (OrigBox.Height div 5);
OrigVScrollBar.LargeChange := OrigBox.Height div 5;
OutHScrollBar.Min := 0;
OutHScrollBar.Max := OutBox.Width - (OutBox.Width div 5);
OutHScrollBar.LargeChange := OutBox.Width div 5;
OutVScrollBar.Min := 0;
OutVScrollBar.Max := OutBox.Height - (OutBox.Height div 5);
OutVScrollBar.LargeChange := OutBox.Height div 5;
// Load text into the 'How it works...' memo
Memo1.Lines.LoadFromFile('ReadMe.txt');
end;
{***************************************************************
TAntiAliasForm.ZoomOrigBoxClick
15/08/2000
***************************************************************}
procedure TAntiAliasForm.ZoomOrigBoxClick(Sender: TObject);
begin
with TCheckBox(Sender) do
begin
OrigHScrollBar.Visible := Checked;
OrigVScrollBar.Visible := Checked;
end;
OrigBox.Invalidate;
end;
{***************************************************************
TAntiAliasForm.ZoomOutBoxClick
15/08/2000
***************************************************************}
procedure TAntiAliasForm.ZoomOutBoxClick(Sender: TObject);
begin
with TCheckBox(Sender) do
begin
OutHScrollBar.Visible := Checked;
OutVScrollBar.Visible := Checked;
end;
OutBox.Invalidate;
end;
{***************************************************************
TAntiAliasForm.Label10Click
16/08/2000
***************************************************************}
procedure TAntiAliasForm.Label10Click(Sender: TObject);
begin
ShellExecute(ValidParentForm(Self).Handle, 'open',
PChar(TLabel(Sender).Caption),
NIL, NIL, SW_SHOWNORMAL);
end;
{***************************************************************
TAntiAliasForm.Label12Click
16/08/2000
***************************************************************}
procedure TAntiAliasForm.Label12Click(Sender: TObject);
begin
ShellExecute(ValidParentForm(Self).Handle, 'open',
PChar('mailto:nurenda@wanadoo.es?subject=Fast antialias'),
NIL, NIL, SW_SHOWNORMAL);
end;
{***************************************************************
TAntiAliasForm.OrigScrollBarChange
20/08/2000
***************************************************************}
procedure TAntiAliasForm.OrigScrollBarChange(Sender: TObject);
begin
OrigBox.Invalidate;
end;
{***************************************************************
TAntiAliasForm.OutScrollBarChange
20/08/2000
***************************************************************}
procedure TAntiAliasForm.OutScrollBarChange(Sender: TObject);
begin
OutBox.Invalidate
end;
end.
***************************************************
Взято из https://forum.sources.ru
{Originally written by Horst Kniebusch, modified by alioth to make it(alot) faster.
}
procedure Antialiasing(Image: TImage; Percent: Integer);
type
TRGBTripleArray = array[0..32767] of TRGBTriple;
PRGBTripleArray = ^TRGBTripleArray;
var
SL, SL2: PRGBTripleArray;
l, m, p: Integer;
R, G, B: TColor;
R1, R2, G1, G2, B1, B2: Byte;
begin
with Image.Canvas do
begin
Brush.Style := bsClear;
Pixels[1, 1] := Pixels[1, 1];
for l := 0 to Image.Height - 1 do
begin
SL := Image.Picture.Bitmap.ScanLine[l];
for p := 1 to Image.Width - 1 do
begin
R1 := SL[p].rgbtRed;
G1 := SL[p].rgbtGreen;
B1 := SL[p].rgbtBlue;
// Left
if (p < 1) then m := Image.Width
else
m := p - 1;
R2 := SL[m].rgbtRed;
G2 := SL[m].rgbtGreen;
B2 := SL[m].rgbtBlue;
if (R1 <> R2) or (G1 <> G2) or (B1 <> B2) then
begin
R := Round(R1 + (R2 - R1) * 50 / (Percent + 50));
G := Round(G1 + (G2 - G1) * 50 / (Percent + 50));
B := Round(B1 + (B2 - B1) * 50 / (Percent + 50));
SL[m].rgbtRed := R;
SL[m].rgbtGreen := G;
SL[m].rgbtBlue := B;
end;
//Right
if (p > Image.Width - 2) then m := 0
else
m := p + 1;
R2 := SL[m].rgbtRed;
G2 := SL[m].rgbtGreen;
B2 := SL[m].rgbtBlue;
if (R1 <> R2) or (G1 <> G2) or (B1 <> B2) then
begin
R := Round(R1 + (R2 - R1) * 50 / (Percent + 50));
G := Round(G1 + (G2 - G1) * 50 / (Percent + 50));
B := Round(B1 + (B2 - B1) * 50 / (Percent + 50));
SL[m].rgbtRed := R;
SL[m].rgbtGreen := G;
SL[m].rgbtBlue := B;
end;
if (l < 1) then m := Image.Height - 1
else
m := l - 1;
//Over
SL2 := Image.Picture.Bitmap.ScanLine[m];
R2 := SL2[p].rgbtRed;
G2 := SL2[p].rgbtGreen;
B2 := SL2[p].rgbtBlue;
if (R1 <> R2) or (G1 <> G2) or (B1 <> B2) then
begin
R := Round(R1 + (R2 - R1) * 50 / (Percent + 50));
G := Round(G1 + (G2 - G1) * 50 / (Percent + 50));
B := Round(B1 + (B2 - B1) * 50 / (Percent + 50));
SL2[p].rgbtRed := R;
SL2[p].rgbtGreen := G;
SL2[p].rgbtBlue := B;
end;
if (l > Image.Height - 2) then m := 0
else
m := l + 1;
//Under
SL2 := Image.Picture.Bitmap.ScanLine[m];
R2 := SL2[p].rgbtRed;
G2 := SL2[p].rgbtGreen;
B2 := SL2[p].rgbtBlue;
if (R1 <> R2) or (G1 <> G2) or (B1 <> B2) then
begin
R := Round(R1 + (R2 - R1) * 50 / (Percent + 50));
G := Round(G1 + (G2 - G1) * 50 / (Percent + 50));
B := Round(B1 + (B2 - B1) * 50 / (Percent + 50));
SL2[p].rgbtRed := R;
SL2[p].rgbtGreen := G;
SL2[p].rgbtBlue := B;
end;
end;
end;
end;
end;
//Example:
procedure TForm1.Button1Click(Sender: TObject);
begin
Antialiasing(Image1, 80);
end;
Взято с сайта: https://www.swissdelphicenter.ch