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 X0) do begin J := Random(100); for I := 1 to 4 do if (J0) 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. readme TFractalImage This is a decendent of TImage and has all the properties of TImage. Furthermore it has the following extra Properties and methods: property Active:Boolean; This is a property for Designtime displaying of the chosen fractal. If you set it to true, it will paint the fractal and then set it back to false.(It calls the method: PaintFractal) property FractalProperties:TFractalProperties; This is where you set all the Fractal Properties (type etc.) Just look in the sourcecode for further instructions. procedure PaintFractal; This is the key method in this component. As the name states, this method paints the Fractal. If you have the IncrementalDisplay property set to true, you will see the Fractal getting painted, but this might take a long time!!! procedure Stop; This method stops the painting of the fractal. But it only works if you have the IncrementalDisplay property set to true. All the other properties and methods of TImage works. (SaveToFile etc.) BTW. I only use 16 colors!!! If you think this is interresting or you make some corrections to my source or you have some questions regarding TFractalImage or ... (You get the point) you can contact me via email: kim@eurosoft.dk Kim Friis Pedersen