フラクタルサンプル
フラクタル図形のサンプル的プログラムを集めてみました。
図形の保存は無いので、直接FormのCanvasに書きこんでいます、その為に、最小化した後、復帰させると作図した図形は失われます。
図形が失われた場合は、再度作図すれば問題はありません、図形が失われないようにする為には、TBittmaを使用してForm.canvasにbitmapを割り付けるか、Timageを使用します。
フラクタル三角形からPythagoras
Tree迄の４個の図形は、作図の工程を分かり易くするために、作図の待ち時間の設定ができるようになっています。
作図時間の値は、作図中でも変更が可能です。
一旦作図を始めると、作図が終了するまでプログラムの終了はできません、待ち時間を大きくしすぎてしまった場合は、作図中でも値を小さくできます。
ピタゴラス Tree
と コッホ曲線内回りです。
プログラム
unit FractalU;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls, Vcl.ComCtrls, system.UITypes;
type
TFormFractal = class(TForm)
Panel1: TPanel;
ButtonClose: TButton;
ButtonClear: TButton;
ButtonDraw1: TButton;
EditLevel: TEdit;
UpDownLevel: TUpDown;
ButtonDraw2: TButton;
ButtonDraw3: TButton;
ButtonDraw4: TButton;
ButtonDraw5: TButton;
CheckBox1: TCheckBox;
ButtonDraw6: TButton;
ButtonDraw7: TButton;
ButtonDraw8: TButton;
Edit1: TEdit;
UpDown1: TUpDown;
Label1: TLabel;
procedure ButtonClearClick(Sender: TObject);
procedure ButtonDraw1Click(Sender: TObject);
procedure ButtonCloseClick(Sender: TObject);
procedure ButtonDraw2Click(Sender: TObject);
procedure ButtonDraw3Click(Sender: TObject);
procedure ButtonDraw4Click(Sender: TObject);
procedure ButtonDraw5Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure ButtonDraw6Click(Sender: TObject);
procedure ButtonDraw7Click(Sender: TObject);
procedure ButtonDraw8Click(Sender: TObject);
procedure UpDown1Click(Sender: TObject; Button: TUDBtnType);
private
{ Private 宣言 }
XNow, YNow: extended; // 現在の位
public
{ Public 宣言 }
procedure StandBy(X, Y: Integer); // 出発点を指定する。
procedure Move(Muki, Kyori: extended); // Muki 方向に Kyori だけ進む
procedure Line(Muki, Kyori: extended); // Muki 方向に Kyori だけ線を引く
procedure Koch(Level: Byte; Muki, Nagasa: extended);
procedure DrawKoch(Level: Byte);
procedure KochThree(Level: Byte);
procedure Sierpinski;
procedure DrawTriangle(aCanvas: TCanvas; x, y, size: extended; n: byte);
procedure drawTree(g: TCanvas; a, b: Tpoint ;n: byte);
procedure drawDragon(g: TCanvas; a, b: TPoint; n: byte);
procedure makeTree(ax, ay, bx, by : smallInt; depth : byte);
end;
var
FormFractal: TFormFractal;
implementation
{$R *.dfm}
uses system.Math, system.Types;
var waittime : integer;
//------------------------------- Pythagoras tree -----------------------------------
// http://www.davdata.nl/math/pythtree.html
procedure TFormFractal.makeTree(ax, ay, bx, by : smallInt; depth : byte);
var
cx, cy, dx, dy, ex, ey : smallInt;
x, y, zx, zy : smallInt;
begin
x := bx - ax;
y := ay - by;
cx := ax - y;
cy := ay - x;
dx := bx - y;
dy := by - x;
zx := (cx + dx) div 2;
zy := (cy + dy) div 2;
ex := zx - (y div 2);
ey := zy - (x div 2);
with Canvas do
begin
pen.color := $FF0000 + depth; // 塗りつぶしを正しく行うためのペン色設定
pen.width := 1;
moveto(bx, by); // 四角形描画
lineto(ax, ay);
lineto(cx, cy);
lineto(dx, dy);
lineto(bx, by);
ax := (cx + bx) div 2; // 塗りつぶし起点座標
ay := (cy + by) div 2;
brush.Color := depth * 256 * 16 + $FF; // 塗りつぶし色
FloodFill(ax, ay, pen.Color, fsBorder);
if depth > 0 then
begin
maketree(cx, cy, ex, ey, depth - 1);
maketree(ex, ey, dx, dy, depth - 1);
end;
end;
if waittime > 0 then begin
sleep(waittime);
application.ProcessMessages;
end;
end;
//------------------------------- Dragon --------------------------------------------
procedure TFormFractal.drawDragon(g: TCanvas; a, b: TPoint; n: byte);
var
c : TPoint;
xx, yy: integer;
begin
xx := b.x - a.x;
yy := -(b.y - a.y);
c.x := round(a.x + (xx + yy) / 2);
c.y := round(b.y + (xx + yy) / 2);
//最後なので、実際に線を引きます
if n <= 0 then begin
g.MoveTo(a.x, a.y); //点Aから点Cへ
g.LineTo(c.x, c.y);
g.LineTo(b.x, b.y); //点cから点bへ
end
//最後ではないので、さらにメソッドを呼び出します（再帰処理）
else begin
drawDragon(g, a, c, n - 1); //点Aから点Cへ
drawDragon(g, b, c, n - 1); //点Bから点Cへ
end;
if waittime > 0 then begin
sleep(waittime);
application.ProcessMessages;
end;
end;
//------------------------------- Tree ----------------------------------------------
procedure TFormFractal.drawTree(g: TCanvas; a, b: TPoint ;n: byte);
const
STEM_RATIO = 0.25;
BRANCH_RATIO = 0.6;
var
c, d, e: Tpoint;
xsign, xx, yy : integer;
angle1, angle2, center_length, branch_length: double;
begin
xx := b.x - a.x;
yy := -(b.y - a.y);
if xx <> 0 then begin
angle1 := arctan(yy / xx) + PI / 3;
angle2 := arctan(yy / xx) - PI / 3;
end
else begin
angle1 := Pi / 2 + PI / 3;
angle2 := Pi / 2 - PI / 3;
end;
center_length := sqrt(xx * xx + yy * yy) * (1 - STEM_RATIO);
branch_length := BRANCH_RATIO * center_length;
//元の直線が右下がりなら符号をマイナスにします
if xx >= 0 then xsign := 1 else xsign := -1;
c.x := round((a.x + STEM_RATIO * xx));
c.y := round((a.y - STEM_RATIO * yy));
d.x := c.x + xsign * round((branch_length * cos(angle1)));
d.y := c.y - xsign * round((branch_length * sin(angle1)));
e.x := c.x + xsign * round((branch_length * cos(angle2)));
e.y := c.y - xsign * round((branch_length * sin(angle2)));
//幹の部分は再帰を行わないので、点Aから点Cへ実際に線を引きます
g.MoveTo(a.x, a.y);
g.LineTo(c.x, c.y);
//最後なので、実際に線を引きます
if n <= 1 then begin
g.MoveTo(c.x, c.y);
g.LineTo(b.x, b.y); //中央部（点Cから点Bへ）
g.MoveTo(c.x, c.y);
g.LineTo(d.x, d.y); //左の枝（点Cから点Dへ）
g.MoveTo(c.x, c.y);
g.LineTo(e.x, e.y); //右の枝（点Cから点Eへ）
end
//最後ではないので、更にメソッドを呼び出します（再帰処理）
else begin
n := n - 1;
drawTree(g, c, b, n); //中央部（点Cから点Bへ）
drawTree(g, c, d, n); //左の枝（点Cから点Dへ）
drawTree(g, c, e, n); //右の枝（点Cから点Eへ）
end;
if waittime > 0 then begin
sleep(waittime);
application.ProcessMessages;
end;
end;
//------------------------------- フラクタル三角形 -----------------------------------------
procedure TFormFractal.DrawTriangle(aCanvas: TCanvas; x, y, size: extended; n: byte);
var
h: extended;
w: extended;
x1, x2, x3, y1, y2, y3: extended;
px1, px2, px3: integer;
py1, py2: integer;
procedure Triangle(xp, yp: extended); // 三角形
begin
px1 := Round(xp); // 底辺 左 x
px2 := Round(xp + w * 2); // 底辺 右 x
px3 := Round(xp + w); // 頂点 x
py1 := Round(yp); // 底辺 y
py2 := Round(yp - h); // 頂点 y
aCanvas.MoveTo(px1, py1);
aCanvas.LineTo(px2, py1);
aCanvas.LineTo(px3, py2);
aCanvas.LineTo(px1, py1);
end;
begin
// 三角形３個描画
w := size;
h := size * 1.5744;
// left
x1 := x;
y1 := y;
Triangle(x1, y1);
// right
x2 := x1 + w * 2;
y2 := y1;
Triangle(x2, y2);
// top
x3 := x2 - w;
y3 := y2 - h;
Triangle(x3, y3);
// 再帰描画
if n > 1 then
begin
dec(n);
size := size / 2;
DrawTriangle(aCanvas, x1, y1, size, n);
DrawTriangle(aCanvas, x2, y2, size, n);
DrawTriangle(aCanvas, x3, y3, size, n);
end;
if waittime > 0 then begin
sleep(waittime);
application.ProcessMessages;
end;
end;
//--------------------------- シェルピンスキーのギャスケット -------------------
procedure TFormFractal.Sierpinski;
var
i, count, x, y: integer;
xcoord, ycoord: array[0..2] of integer;
begin
xcoord[0] := 275; // 三角形の頂点X
ycoord[0] := 40; // 三角形の頂点y
xcoord[1] := 40; // 三角形の底辺左x
ycoord[1] := 410; // 三角形の底辺左y
xcoord[2] := 510; // 三角形の底辺右x
ycoord[2] := 410; // 三角形の底辺右y
x := 40; // 初期値x
y := 410; // 初期値y
for count:= 0 to 10000 do
begin
i := random(3); // 乱数0～2 乱数でないと図形は表示されません
x := (x + xcoord[i]) div 2;
y := (y + ycoord[i]) div 2;
case i of
0: canvas.pixels[x,y] := clred;
1: canvas.pixels[x,y] := clgreen;
2: canvas.pixels[x,y] := clblue;
end;
end;
end;
//------------------------- コッホ曲線 ------------------------------------------
procedure TFormFractal.StandBy(X, Y: Integer);
begin
Canvas.MoveTo(X, Y);
XNow := X;
YNow := Y;
end;
procedure TFormFractal.Move(Muki, Kyori: extended);
begin
XNow := XNow + Kyori * Cos(Muki);
YNow := YNow + Kyori * Sin(Muki);
Canvas.MoveTo(Round(XNow), Round(YNow));
end;
procedure TFormFractal.Line(Muki, Kyori: extended);
begin
XNow := XNow + Kyori * Cos(Muki);
YNow := YNow + Kyori * Sin(Muki);
Canvas.LineTo(Round(XNow), Round(YNow));
end;
procedure TFormFractal.Koch(Level: Byte; Muki, Nagasa: extended);
begin
if Level <= 1 then Line(Muki,Nagasa) // 実際に線を引く
else begin // 長さ 1/3，Level-1 コッホ曲線を描く
Koch(Level-1, Muki, Nagasa / 3); // 指定方向に描く
Koch(Level-1, Muki - Pi / 3, Nagasa / 3); // 左に 60 ゜方向に描く
Koch(Level-1, Muki + Pi / 3, Nagasa / 3); // 右に 60 ゜方向に描く
Koch(Level-1, Muki, Nagasa / 3); // 指定方向に描く
end;
end;
procedure TFormFractal.DrawKoch(Level: Byte);
begin
StandBy(50, 250); // 始点
Koch(Level, 0, 400); // コッホ曲線
end;
procedure TFormFractal.KochThree(Level: Byte);
var
Leveled: byte;
begin
canvas.Pen.Color := clBlack;
Leveled := Level and $0F;
if Level and $80 = 0 then begin // 内回り三角
Koch(Leveled, 0, 300); // コッホ曲線
Koch(Leveled,pi * 2 / 3 * 2, 300); // コッホ曲線
Koch(Leveled,pi * 2 / 3, 300); // コッホ曲線
end
else begin // 外回り三角
Koch(Leveled, 0, 300); // コッホ曲線
Koch(Leveled,-pi * 2 / 3 * 2, 300); // コッホ曲線
Koch(Leveled,-pi * 2 / 3, 300); // コッホ曲線
Canvas.Brush.Color := clBlue;
Canvas.FloodFill(250 , 220, clBlack, fsBorder);
end;
end;
//-------------------------------------------------------------------------------
procedure TFormFractal.ButtonDraw1Click(Sender: TObject);
var
Level: byte;
begin
ButtonDraw1.Enabled := False;
if checkbox1.Checked = true then ButtonClearClick(nil);
Level := UpDownLevel.Position;
DrawKoch(Level);
ButtonDraw1.Enabled := True;
end;
procedure TFormFractal.ButtonDraw2Click(Sender: TObject);
var
Level: byte;
begin
ButtonDraw2.Enabled := False;
if checkbox1.Checked = true then ButtonClearClick(nil);
Level := UpDownLevel.Position;
StandBy(100, 300); // 始点
KochThree(Level);
ButtonDraw2.Enabled := True;
end;
procedure TFormFractal.ButtonDraw3Click(Sender: TObject);
var
Level: byte;
begin
ButtonDraw3.Enabled := False;
if checkbox1.Checked = true then ButtonClearClick(nil);
Level := UpDownLevel.Position;
StandBy(100, 120); // 始点
KochThree(Level or $80); // 三角形作図方向フラグセット
ButtonDraw3.Enabled := True;
end;
procedure TFormFractal.ButtonDraw4Click(Sender: TObject);
var
Level : byte;
i : byte;
begin
ButtonDraw4.Enabled := False;
if checkbox1.Checked = true then ButtonClearClick(nil);
Level := UpDownLevel.Position;
for i := 1 to Level do Sierpinski;
ButtonDraw4.Enabled := True;
end;
procedure TFormFractal.ButtonDraw5Click(Sender: TObject);
var
Level : byte;
size : extended;
x,y : extended;
begin
ButtonDraw5.Enabled := False;
if checkbox1.Checked = true then ButtonClearClick(nil);
Level := UpDownLevel.Position;
size := 117.5;
x := 40;
y := 410;
Canvas.Pen.Color := clFuchsia;
DrawTriangle(Canvas, x, y, size, Level);
ButtonDraw5.Enabled := True;
end;
procedure TFormFractal.ButtonDraw6Click(Sender: TObject);
var
Level : byte;
B, T: Tpoint;
begin
ButtonDraw6.Enabled := False;
if checkbox1.Checked = true then ButtonClearClick(nil);
Level := UpDownLevel.Position;
//３対の点を指定します
B := Point(250, 400);
T := Point(250, 50);
//それぞれの対をなす２点間に樹木曲線を描きます
canvas.Pen.Color := clBlue;
drawTree(canvas, B, T, Level);
ButtonDraw6.Enabled := True;
end;
procedure TFormFractal.ButtonDraw7Click(Sender: TObject);
var
Level : byte;
B, T: Tpoint;
begin
ButtonDraw7.Enabled := False;
if checkbox1.Checked = true then ButtonClearClick(nil);
Level := UpDownLevel.Position;
//出発点となる一対の点を指定します
B := Point(220, 100);
T := Point(430, 310);
//対となる二点の間にドラゴン曲線を描きます
canvas.Pen.Color := clBlue;
drawDragon(canvas, B, T, Level);
ButtonDraw7.Enabled := True;
end;
procedure TFormFractal.ButtonDraw8Click(Sender: TObject);
var
Level : byte;
begin
ButtonDraw8.Enabled := False;
if checkbox1.Checked = true then ButtonClearClick(nil);
Level := UpDownLevel.Position;
// 最初の四角形の底辺の座標を指定します
makeTree(250, 400, 330, 400, Level);
ButtonDraw8.Enabled := True;
end;
procedure TFormFractal.ButtonClearClick(Sender: TObject);
begin
with Canvas do
begin
Brush.Color := clBtnface;
FillRect(ClipRect);
end;
end;
procedure TFormFractal.UpDown1Click(Sender: TObject; Button: TUDBtnType);
begin
Waittime := updown1.Position * 10;
end;
procedure TFormFractal.ButtonCloseClick(Sender: TObject);
begin
close;
end;
procedure TFormFractal.FormCreate(Sender: TObject);
begin
Clientheight := 500;
ClientWidth := 743;
end;
end.
Fractal_V1.zip
画像処理プログラム 作図 に戻る