发信人: ardye (Protoss), 信区: Science
标 题: Delphi分形程序
发信站: 哈工大紫丁香 (2001年11月05日13:09:33 星期一), 站内信件
unit FractalImage;
{
Current Version 1.2
TFractalImage
History:
1.0 Created core component and added support for MandelBrot and Julia fracta
ls
1.1 Added support for B/W Moire (Not a fractal but it looks cool)
1.2 Added support for Sierpinski
1.3 Added support for Other IFS fractals (There might be something wrong wit
h some
of them, but I can't quite figure out what it is right now)
Thanks to the writers of Tips and Tricks of the Graphics gurus.
Kim Friis Pedersen
kim@eurosoft.dk
}
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls;
const
Leaf:Array[1..112] of Double=(
//Fern
0.03, 0.31, 0.35, -0.05, 0.50, -0.92, 0.13
,-0.02, 0.00, -0.27, 0.33, -0.12, -1.28, 0.01
,0.80, 0.02, -0.04, 0.80, -0.02, 0.87, 0.74
,-0.03, -0.30, 0.35, -0.04, -0.68, -0.94, 0.12
{ 0.0,0.0,0.0,0.16,0.0,0.0,0.01
,0.85,0.04,-0.04,0.85,0.0,1.6,0.85
,0.2,-0.26,0.23,0.22,0.0,1.6,0.07
,-0.15,0.28,0.26,0.24,0.0,0.44,0.07
}
//Leaf
,0.14, 0.01, 0.00, 0.51, -0.08, -1.31, 0.06
,0.43, 0.52, -0.45, 0.50, 1.49, -0.75, 0.37
,0.45, -0.49, 0.47, 0.47, -1.62, -0.74, 0.36
,0.49, 0.00, 0.00, 0.51, 0.02, 1.62, 0.21
//Curl
,0.04, 0.22, 0.31, -0.03, 0.63, -1.74, 0.13
,-0.02, 0.00, -0.32, 0.26, -0.17, -1.35, 0.01
,0.79, 0.06, -0.03, 0.73, -0.02, 1.03, 0.74
,-0.03, -0.30, 0.35, -0.04, -0.68, -0.94, 0.12
//Koch
,0.34, 0.00, 0.00, 0.34, 2.14, 0.02, 0.25
,0.17, 0.29, -0.29, 0.17, 0.55, 0.94, 0.25
,0.16, -0.29, 0.29, 0.16, -0.54, 0.95, 0.24
,0.34, 0.00, 0.00, 0.34, -2.15, 0.01, 0.25
);
type
TFractalImage = class;
TFractalTypes = (ftMandelBrot,ftJulian,ftMoire,ftSierpinski,ftFern,ftLeaf,ft
Curl,ftKoch);
TFractalProperties = class(TPersistent)
private
FFractalImage:TFractalImage;
FFractalType:TFractalTypes;
FX0:Double;
FY0:Double;
FX1:Double;
FY1:Double;
FNumberOfIterations:Integer;
FLineIncremental:Boolean;
procedure WriteFractalType(FT:TFractalTypes);
protected
public
constructor Create(AOwner: TFractalImage);
published
property FractalType:TFractalTypes read FFractalType write WriteFractalType;
property X0:Double read FX0 write FX0;
property Y0:Double read FY0 write FY0;
property X1:Double read FX1 write FX1;
property Y1:Double read FY1 write FY1;
property NumberOfIterations:Integer read FNumberOfIterations write FNumberOf
Iterations;
property LineIncremental:Boolean read FLineIncremental write FLineIncrementa
l;
end;
TFractalImage = class(TImage)
private
{ Private declarations }
OldCursor:TCursor;
OldCaption:String;
Palette:array[0..15] of TColor;
KeepOn:Boolean;
FFractalProperties:TFractalProperties;
FActive:Boolean;
function ConvertColor(Value:Integer):TColor;
procedure DrawMandelJulia(Mandel:Boolean);
procedure DrawMoire;
procedure DrawIFS(Index:Integer);
procedure DrawSierPinski;
procedure WriteActive(A:Boolean);
protected
{ Protected declarations }
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure PaintFractal;
procedure Stop;
published
{ Published declarations }
property Active:Boolean read FActive write WriteActive;
property FractalProperties:TFractalProperties read FFractalProperties write
FFractalProperties;
end;
procedure Register;
implementation
{TFractalProperties}
constructor TFractalProperties.Create(AOwner: TFractalImage);
begin
inherited Create;
if AOwner <> nil then
FFractalImage := AOwner;
//These are the most commenly used numbers for the Mandelbrot fractal
X0:=(-2.25);
Y0:=(-1.5);
X1:=(0.75);
Y1:=(1.5);
NumberOfIterations := 16;
LineIncremental := True;
end;
procedure TFractalProperties.WriteFractalType(FT:TFractalTypes);
begin
//Here I am just changing the Properties according to the fractal type.
if FT<>FFractalType then begin
if ((FT=ftMandelBrot)and(FFractalType=ftJulian)) or ((FT=ftMandelBrot)and(FF
ractalType=ftJulian)) then begin
//Nothing
end else if (FT=ftMoire) then begin
NumberOfIterations := 4;
end else if ((FT=ftMandelBrot) or (FT=ftJulian)) then begin
NumberOfIterations := 16;
end else begin
NumberOfIterations := 30000;
end;
FFractalType := FT;
end;
end;
{TFractalImage}
procedure TFractalImage.PaintFractal;
begin
//Workaround so that the fractal fills the whole picture
Canvas.Pixels[0,0] := clBlack;
Picture.Graphic.Width := Width;
Picture.Graphic.Height := Height;
//Setting the Caption of Delphi to my caption
//Thanks to Marco Cantu for his GREAT presentation at BorCon97
if csDesigning in ComponentState then begin
OldCaption := Application.MainForm.Caption;
Application.MainForm.Caption := 'Creating Fractal. Please wait....';
end;
//Paint the chosen fractal
if FractalProperties.FFractalType = ftMandelBrot then
DrawMandelJulia(True) else
if FractalProperties.FFractalType = ftJulian then
DrawMandelJulia(False) else
if FractalProperties.FFractalType = ftMoire then
DrawMoire else
if FractalProperties.FFractalType = ftFern then
DrawIFS(0) else
if FractalProperties.FFractalType = ftLeaf then
DrawIFS(1) else
if FractalProperties.FFractalType = ftCurl then
DrawIFS(2) else
if FractalProperties.FFractalType = ftKoch then
DrawIFS(3) else
if FractalProperties.FFractalType = ftSierpinski then
DrawSierpinski;
//Setting the Caption back to where we came from
if csDesigning in ComponentState then begin
Application.MainForm.Caption := OldCaption;
end;
//Turn off the active property after paint
Active := False;
end;
procedure TFractalImage.WriteActive(A:Boolean);
begin
if A <> FActive then begin
FActive := A;
if FActive = True then
PaintFractal;
end;
end;
procedure TFractalImage.DrawMandelJulia(Mandel:Boolean);
const
//Number if colors. If this is changed, the number of mapped colors must als
o be changed
nc=16;
var
X,XX,Y,YY,Cx,Cy,Dx,Dy,XSquared,YSquared:Double;
Nx,Ny,Py,Px,I,NIter:Integer;
X0,Y0,X1,Y1:Double;
begin
NIter := FractalProperties.NumberOfIterations;
X0 := FractalProperties.X0;
Y0 := FractalProperties.Y0;
X1 := FractalProperties.X1;
Y1 := FractalProperties.Y1;
OldCursor := Screen.Cursor;
Screen.Cursor := crHourGlass;
try
Nx := Width;
Ny := Height;
KeepOn := True;
Cx := 0;
Cy := 1;
Dx := (x1 - x0) / nx;
Dy := (y1 - y0) / ny;
Py := 0;
while (PY < Ny) and (KeepOn) do begin
PX := 0;
while (Px < Nx) and (KeepOn) do begin
x := x0 + px * dx;
y := y0 + py * dy;
if (mandel) then begin
cx := x;cy := y;
x := 0; y := 0;
end;
xsquared := 0;ysquared := 0;
I := 0;
while (I <= niter) and (xsquared + ysquared < (4)) do begin
xsquared := x*x;
ysquared := y*y;
xx := xsquared - ysquared + cx;
yy := (2*x*y) + cy;
x := xx ; y := yy;
I := I + 1;
end;
I := I - 1;
if (i = niter) then i := 0
else i := round(i / (niter / nc));
Canvas.Pixels[PX,PY] := ConvertColor(I);
if IncrementalDisplay and (not FractalProperties.LineIncremental) then
Application.ProcessMessages;
Px := Px + 1;
end;
if IncrementalDisplay and FractalProperties.LineIncremental then
Application.ProcessMessages;
Py := Py + 1;
end;
finally
Screen.Cursor := OldCursor;
end;
end;
//This procedure is very slow with NumberOfIterations bigger than 0
//It ignores X0->Y1!!!
//This routine is VERY slow with Incremental display
procedure TFractalImage.DrawMoire;
var
a,i,j,x,y,cx,cy,size:Integer;
Col:TColor;
begin
OldCursor := Screen.Cursor;
Screen.Cursor := crHourGlass;
try
X := 0; I := Width-1;
while X<Width do begin
Canvas.Pen.Color := ConvertColor((X mod 2)*15);
Canvas.MoveTo(X,0);
Canvas.LineTo(I,Height);
X := X + 1;
I := I - 1;
if IncrementalDisplay then
Application.ProcessMessages;
end;
Y := 0; J := Height-1;
while Y<Height do begin
Canvas.Pen.Color := ConvertColor((Y mod 2)*15);
Canvas.MoveTo(0,Y);
Canvas.LineTo(Width,J);
Y := Y + 1;
J := J - 1;
if IncrementalDisplay then
Application.ProcessMessages;
end;
cx := Width div 2;
cy := Height div 2;
size := cy;
for a := 1 to FractalProperties.NumberOfIterations do begin
x := a;
for i := 0 to size do begin
Y := X;
for J := I to size do begin
col := ConvertColor(((( x * x + y * y) div 1024) mod 2)*15);
Canvas.pixels[cx + i, cy + j]:= col;
Canvas.pixels[cx + j, cy + i]:= col;
Canvas.pixels[cx + j, cy - i]:= col;
Canvas.pixels[cx + i, cy - j]:= col;
Canvas.pixels[cx - i, cy - j]:= col;
Canvas.pixels[cx - j, cy - i]:= col;
Canvas.pixels[cx - j, cy + i]:= col;
Canvas.pixels[cx - i, cy + j]:= col;
Y := Y + A;
if IncrementalDisplay and (NOT FractalProperties.LineIncremental) then
Application.ProcessMessages;
end;
X := X + A;
if IncrementalDisplay and FractalProperties.LineIncremental then
Application.ProcessMessages;
end;
end;
finally
Screen.Cursor := OldCursor;
end;
end;
procedure TFractalImage.DrawIFS(Index:Integer);
var
I,J,ct:Integer;
XX,YY:longint;
X1,Y1,X2,Y2:Double;
Col:TColor;
P:Array[1..4] of Integer;
Fa,Fb,Fc,Fd,MoveX,MoveY:Array[1..4] of double;
begin
Randomize;
Canvas.FillRect(Rect(0,0,Width,Height));
X1 := 0; Y1 := 0;
ct := FractalProperties.NumberOfIterations;
Col := clBlack;
OldCursor := Screen.Cursor;
Screen.Cursor := crHourGlass;
try
P[1] := Round(Leaf[7+(Index*28)]*100);
for I := 2 to 4 do begin
P[I] := P[I-1]+Round(Leaf[(I*7)+(Index*28)]*100);
end;
for I := 1 to 4 do begin
Fa[I] := Leaf[(((I-1)*7)+1)+(Index*28)];
end;
for I := 1 to 4 do begin
Fb[I] := Leaf[(((I-1)*7)+2)+(Index*28)];
end;
for I := 1 to 4 do begin
Fc[I] := Leaf[(((I-1)*7)+3)+(Index*28)];
end;
for I := 1 to 4 do begin
Fd[I] := Leaf[(((I-1)*7)+4)+(Index*28)];
end;
for I := 1 to 4 do begin
MoveX[I] := Leaf[(((I-1)*7)+5)+(Index*28)];
end;
for I := 1 to 4 do begin
MoveY[I] := Leaf[(((I-1)*7)+6)+(Index*28)];
end;
for J := 0 to 7 do begin
I := Random(4)+1;
X2 := ((X1*Fa[I])+(Y1*Fb[I])+MoveX[I]);
Y2 := ((X1*Fc[I])+(Y1*Fd[I])+MoveY[I]);
X1 := X2; Y1 := Y2;
end;
dec(ct);
while (ct>0) do begin
J := Random(100);
for I := 1 to 4 do if (J<P[I]) then break;
X2 := ((X1*Fa[I])+(Y1*Fb[I])+MoveX[I]);
Y2 := ((X1*Fc[I])+(Y1*Fd[I])+MoveY[I]);
X1 := X2; Y1 := Y2;
XX := round(X1 * Height/11 + Width shr 1);
YY := round(Y1 * -Height/11 + (Height shr 1));
Canvas.pixels[XX,YY] := Col;
dec(ct);
end;
finally
Screen.Cursor := OldCursor;
end;
end;
//I strongly recommend NOT setting IncrementalDisplay to true when
//Drawing this fractal, because it fires a ProcessMessages on every pixel.
procedure TFractalImage.DrawSierPinski;
var
XX,YY,ct,J,HalfWidth:Integer;
Col:TColor;
begin
Randomize;
Canvas.FillRect(Rect(0,0,Width,Height));
XX := Width div 2; YY := 0;
ct := FractalProperties.NumberOfIterations;
Col := clBlack;
OldCursor := Screen.Cursor;
Screen.Cursor := crHourGlass;
try
dec(ct);
HalfWidth := Width shr 1;
while (ct>0) do begin
J := Random(4);
case J of
1:begin XX := ((XX + HalfWidth) shr 1);
YY := YY shr 1;
end;
2:begin XX := ((XX + Width) shr 1);
YY := (YY +Height) shr 1;
end;
3:begin XX := (XX shr 1);
YY := (YY+Height) shr 1;
end;
end;
Canvas.pixels[XX,YY] := Col;
if (IncrementalDisplay = True) then
Application.ProcessMessages;
dec(ct);
end;
finally
Screen.Cursor := OldCursor;
end;
end;
constructor TFractalImage.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FFractalProperties := TFractalProperties.Create(self);
//Creating palette. This palette is not used yet but it might be
//in the future. It looks like the Array and the case statement
//is equally fast (or slow if you want?)
Palette[0] := clBlack;
Palette[1] := clNavy;
Palette[2] := clGreen;
Palette[3] := clAqua;
Palette[4] := clRed;
Palette[5] := clPurple;
Palette[6] := clMaroon;
Palette[7] := clSilver;
Palette[8] := clGray;
Palette[9] := clBlue;
Palette[10] := clLime;
Palette[11] := clOlive;
Palette[12] := clFuchsia;
Palette[13] := clTeal;
Palette[14] := clYellow;
Palette[15] := clWhite;
end;
destructor TFractalImage.Destroy;
begin
FFractalProperties.Free;
inherited destroy;
end;
//Just a small function to map the numbers to colors
function TFractalImage.ConvertColor(Value:Integer):TColor;
begin
case Value of
0:Result := clBlack;
1:Result := clNavy;
2:Result := clGreen;
3:Result := clAqua;
4:Result := clRed;
5:Result := clPurple;
6:Result := clMaroon;
7:Result := clSilver;
8:Result := clGray;
9:Result := clBlue;
10:Result := clLime;
11:Result := clOlive;
12:Result := clFuchsia;
13:Result := clTeal;
14:Result := clYellow;
15:Result := clWhite;
else Result := clWhite;
end;
end;
//This procedure only works if you have IncrementalDisplay set to true!
procedure TFractalImage.Stop;
begin
KeepOn := False;
end;
procedure Register;
begin
RegisterComponents('Samples', [TFractalImage]);
end;
end.
--
酒酣或化庄生蝶，饭饱甘为孺子牛
※ 来源:·哈工大紫丁香 bbs.hit.edu.cn·[FROM: 61.167.245.19]