Delphi分形程式 |
|
conundrum
尊榮會員 發表:893 回覆:1272 積分:643 註冊:2004-01-06 發送簡訊給我 |
http://www.hrbust.edu.cn/xywz/east_new/fxxx/fxxx011.htm Delphi分形程式
unit FractalImage;
{
Current Version 1.2
TFractalImage
History:
1.0 Created core component and added support for MandelBrot and Julia fractals
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 with 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,ftCurl,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 FNumberOfIterations;
property LineIncremental:Boolean read FLineIncremental write FLineIncremental;
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(FFractalType=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 also 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
|
本站聲明 |
1. 本論壇為無營利行為之開放平台,所有文章都是由網友自行張貼,如牽涉到法律糾紛一切與本站無關。 2. 假如網友發表之內容涉及侵權,而損及您的利益,請立即通知版主刪除。 3. 請勿批評中華民國元首及政府或批評各政黨,是藍是綠本站無權干涉,但這裡不是政治性論壇! |