unit Patternmain;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls, ExtDlgs, ColorGrd;
type
TForm1 = class(TForm)
Image1: TImage;
OpenPictureDialog1: TOpenPictureDialog;
ColorDialog1: TColorDialog;
ColorGrid1: TColorGrid;
CheckBox1: TCheckBox;
Button1: TButton;
procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure Image1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure ColorGrid1Click(Sender: TObject);
private
{ Private declarations }
procedure FillColors(FBitmap: TBitmap; FWidth: Integer; FHeight: Integer;
Xs: integer; Ys: integer; OldColor, NewColor: Byte);
public
{ Public declarations }
end;
var
Form1: TForm1;
FRendering: boolean;
org, next1: TPoint;
mycolor: byte;
implementation
{$R *.DFM}
procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
pa: pbytearray;
oc: byte;
// n: TPixelFormat;
mybmp: tbitmap;
begin
if CheckBox1.Checked then
begin
mybmp := tbitmap.Create;
mybmp.Width := image1.Picture.Bitmap.Width;
mybmp.Height := image1.Picture.Bitmap.Height;
mybmp.Assign(image1.Picture.Bitmap);
mybmp.PixelFormat := pf8bit;
pa := mybmp.ScanLine[y];
oc := pa[x];
FillColors(mybmp, image1.picture.bitmap.Width,
image1.picture.bitmap.Height,
X, Y, oc, mycolor);
image1.Picture.Bitmap.Assign(mybmp);
mybmp.free;
frendering := false;
end
else
begin
FRendering := true;
org := Point(X, Y);
next1 := Point(X, Y);
end;
end;
procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
var
points: array[1..4] of TPOINT;
// p: pchar;
begin
if FRendering then
begin
next1 := Point(X, Y);
points[1] := org;
points[2] := next1;
points[3] := Point(next1.x + 8, next1.y + 8);
points[4] := Point(org.x + 8, org.y + 8);
Image1.Canvas.Polygon(points);
org := Point(X, Y);
end;
end;
procedure TForm1.Image1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
FRendering := false;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
bmp: tbitmap;
begin
self.DoubleBuffered := true;
bmp := tbitmap.Create;
bmp.Width := image1.Width;
bmp.Height := image1.Height;
bmp.PixelFormat := pf8bit;
image1.Picture.Bitmap.Assign(bmp);
bmp.free;
Image1.Canvas.Brush.Color := clred;
Image1.Canvas.Pen.Color := clred;
end;
procedure TForm1.FillColors(FBitmap: TBitmap; FWidth, FHeight, Xs,
Ys: integer; OldColor, NewColor: Byte);
type
stackfield = record
xl, xr, y: integer;
end;
var
i, X, Xl, Xr, p_Xl, p_Xr, signed_Y: integer;
P: PByteArray;
stack: array of stackfield;
procedure set_stack_empty();
begin
setlength(stack, 1);
stack[0].y := 0;
end;
function stack_not_empty(): boolean;
begin
if stack[0].y = 0 then
result := false
else
result := true;
end;
procedure push(xl, xr, yd: integer);
begin
stack[0].y := stack[0].y + 1;
if stack[0].y > (length(stack) - 1) then
setlength(stack, length(stack) + 1);
stack[stack[0].y].xl := xl;
stack[stack[0].y].xr := xr;
stack[stack[0].y].y := yd
end;
procedure pop(var xl: integer; var xr: integer; var yd: integer);
begin
if stack[0].y > 0 then
begin
xl := stack[stack[0].y].xl;
xr := stack[stack[0].y].xr;
yd := stack[stack[0].y].y;
stack[0].y := stack[0].y - 1;
setlength(stack, length(stack) - 1);
end;
end;
begin
//Fwidth,FHeight为位图的宽度和高度
set_stack_empty; //////////
P := fbitmap.ScanLine[Ys];
i := Xs;
if P = Newcolor then
exit;
while (P = OldColor) do
begin
P := NewColor;
i := i + 1;
if i = fbitmap.Width then
break;
end;
Xr := i - 1;
i := Xs - 1;
while (P = OldColor) do
begin
P := NewColor;
i := i - 1;
if i = -1 then
break;
end;
Xl := i + 1;
if ys > 0 then
push(Xl, Xr, -(Ys - 1));
if ys < fbitmap.height - 1 then
push(Xl, Xr, (Ys + 1));
while stack_not_empty do
begin
pop(p_Xl, p_Xr, signed_Y);
//y:=abs(signed_Y);
P := fbitmap.scanline[abs(signed_y)];
if (P[p_Xl] = OldColor) then //xl处是oldcolor时
if p_xl > 0 then
begin
x := p_Xl - 1; //,xl非边界,否则将会出边界
while (P[x] = OldColor) do
begin
P[x] := NewColor;
x := x - 1;
if x = -1 then
break;
end;
Xl := x + 1;
x := p_Xl;
end
else
begin
xl := 0; // 左边界已是0 时,新的xl自然取0
x := p_xl;
end
else
begin
x := p_Xl;
// 否则xl处非oldcolor,xl的左邻点不为olodcolor时,xl的右邻点可能为oldcolor时 ,向右找xl
if ((x > 0) and (p[x - 1] <> oldcolor)) or (x = 0) then
begin
while (p[x] <> OldColor) do
begin
x := x + 1;
if x = fbitmap.Width then
begin
x := x + 1;
break;
end;
end;
xl := x;
end
else if p_xl > 0 then
//否则xl 的左邻点是oldcolor时,先考虑左边,向左找xl
begin
x := p_Xl - 1;
while (P[x] = OldColor) do
begin
P[x] := NewColor;
x := x - 1;
if x = -1 then
break;
end;
Xl := x + 1;
x := p_Xl;
end
else
begin
xl := 0;
x := p_xl;
end
end;
while x <= (p_Xr + 1) do
begin
while (p[x] = OldColor) do
begin
p[x] := NewColor;
x := x + 1;
if x = fbitmap.Width then
begin
break;
end;
end;
Xr := x - 1;
if (abs(signed_y - 1) <= (fbitmap.Height - 1)) and (abs(signed_y - 1)
>= 0) then
begin
if (Xl <= p_Xl - 1) then
push(xl, p_Xl - 1, -(signed_y - 1));
if (Xr >= p_Xr + 1) then
push(p_xr + 1, xr, -(signed_y - 1));
end;
if (abs(signed_y + 1) <= (fbitmap.Height - 1)) and (abs(signed_y + 1)
>= 0) then
push(Xl, Xr, signed_y + 1);
if x = fbitmap.Width then
x := X + 1;
if x <= (fbitmap.width - 1) then
while (x <= p_xr + 1) and (p[x] <> OldColor) do
begin
x := x + 1;
if x = fbitmap.Width then
begin
x := x + 1;
BREAK;
end;
end;
Xl := x;
end;
end;
// Fbitmap.invalidate;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
bmp: Tbitmap;
begin
if openpicturedialog1.Execute then
begin
bmp := tbitmap.Create;
bmp.LoadFromFile(openpicturedialog1.filename);
bmp.PixelFormat := pf8bit;
image1.Width := bmp.Width;
image1.Height := bmp.Height;
image1.Picture.Bitmap.Assign(bmp);
bmp.free;
end;
end;
procedure TForm1.ColorGrid1Click(Sender: TObject);
var
acolor: tcolor;
begin
acolor := colorgrid1.ForegroundColor;
mycolor := getnearestpaletteindex(image1.Picture.Bitmap.Palette, acolor);
end;
end.