درخت فیثاغورس

[**MR**]

سلام
من یه برنامه گرافیکی نوشتم که کارش ترسیم درخت فیثاغورس ولی اشکال داره چون تنها یه شاخه را می کشد فایلش در زیر قرار دادم
اگه کسی بلده ممنون میشم راهنمایی ام بکنه
متشکرم

[مصطفی ساتکی]

این سورس کاملش تست شده با دلفی سال 87 نوشتم این سوال تو همین فروم مطرح شده بود توضیحات کاملش تو این تاپیکه http://barnamenevis.org/forum/showthread.php?p=961350

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ComCtrls;

type
TPoints = Array of TPoint;
Tline = record
p1,p2 : TPoint;
end;
TForm1 = class(TForm)
Button2: TButton;
procedure Button2Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
private
{ Private declarations }
public
p1,p2 : TPoint;
function NormDegre(Degre : integer):integer;
procedure DrawPoint(Pnts : TPoints);
procedure FillTringle(Pnts : TPoints);
function LineLen(p1,p2 : TPoint) : Integer;
function GetDegre(P1,p2 : TPoint):integer;
function InterSection(P1, p2: TPoint; Deg1, Deg2: Real): TPoint;
procedure DrawTree(p1,p2 : TPoint;counter : integer);
function Square1(p1,p2 : TPoint):TPoints;
function Tringle1(p1,p2 : TPoint):TPoints;
end;

var
Form1: TForm1;

implementation

uses Math, Types;

{$R *.dfm}


procedure TForm1.Button2Click(Sender: TObject);
var p1,p2 : TPoint;

begin
p1 := Point(400,400);
p2 := Point(450,400);
DrawTree(p1,p2,1);
end;

function TForm1.InterSection(P1, p2: TPoint; Deg1, Deg2: Real): TPoint;
begin
Deg1 := Tan( DegToRad(Deg1));
Deg2 := Tan(DegToRad(Deg2));

Result.X := round( ((P1.Y - P2.Y)+(Deg2*p2.X- Deg1*P1.X))/(-Deg1+Deg2)) ;
Result.Y :=round( Deg2*(Result.X - P2.X)+P2.Y);
{
Result.X := round((-p1.Y+p2.Y+p1.X*Deg1-p2.X*Deg2)/(Deg1-Deg2));
Result.Y :=round( Deg1*(Result.X - P1.X)+P1.Y);
}
end;

function TForm1.GetDegre(P1, p2: TPoint): Integer;
begin
Result := round( RadToDeg( ArcTan2(p2.Y-p1.Y,p2.X-p1.X)));
if Result <0 then Result := 360 + Result;
end;

function TForm1.LineLen(p1, p2: TPoint):Integer ;
begin
if p2.X = p1.X then Result := abs(p2.Y-p1.Y)
else if p2.Y = p1.Y then Result := abs(p2.x-p1.x)
else Result := trunc( sqrt( sqr(p2.Y-p1.Y)+sqr(p2.X-p1.X)));
end;




procedure TForm1.DrawPoint(Pnts: TPoints);
var i , j : integer;
colors:array[0..2] of byte;
begin
Canvas.Pen.Color := clBlack;
Canvas.MoveTo(Pnts[0].x,Pnts[0].y);
for i := 1 to Length(Pnts)-1 do
Canvas.LineTo(Pnts[i].X,Pnts[i].Y);

Canvas.LineTo(Pnts[0].X,Pnts[0].Y);

if Length(Pnts)=3 then
begin
end;

end;

procedure TForm1.DrawTree(p1,p2 : TPoint;counter : integer);
var SqrPnts ,TringPnts : TPoints;
begin
if counter> 16 then Exit;
counter := counter+1;
SqrPnts := Square1(p1,p2);
DrawPoint(SqrPnts);
TringPnts := Tringle1(SqrPnts[3],SqrPnts[2]);
DrawPoint(TringPnts);
FillTringle(TringPnts);
DrawTree(TringPnts[2],TringPnts[1],counter+1);
DrawTree(TringPnts[0],TringPnts[2],counter+1);

end;

procedure TForm1.FormCreate(Sender: TObject);
begin
Randomize;
p1 := Point(-1,-1);
p2 := Point(-1,-1);
end;

function TForm1.NormDegre(Degre: Integer): integer;
begin
Result := Degre;
if Degre< 0 then Result := 360 + Degre
else if Degre> 360 then Result := Degre mod 360;

end;

function TForm1.Square1(p1, p2: TPoint):TPoints;
var G1,G2 : integer;
r : integer;
p3,p4 : TPoint;
begin
G1 := GetDegre(p1,p2);
G2 := GetDegre(p2,p1);

r := LineLen(p1,p2);
SetLength(Result,4);

Result[0] := p1;
Result[1] := p2;

Result[2].X := p2.X+ round( r*cos(DegToRad(NormDegre( g2+90 ))));
Result[2].Y := p2.Y+ round(r*sin(DegToRad(NormDegre( g2+90))));

Result[3].X :=p1.X+ round( r*cos(DegToRad(NormDegre( g1-90) )));
Result[3].Y := p1.Y+ round(r*sin(DegToRad(NormDegre( g1-90) )));


end;

function TForm1.Tringle1(p1, p2: TPoint): TPoints;
var g : Integer;
r , l ,r2 : Real;
begin
SetLength(Result,3);
Result[0] := p1;
Result[1] := p2;
g := GetDegre(p1,p2);
r := LineLen(p1,p2);
r2 := r /2;

l := r2/ sin(DegToRad(45)) ;

Result[2].X := round(p1.X +l*cos(DegToRad(NormDegre( g-45 ))));
Result[2].Y := round(p1.Y +l*sin(DegToRad(NormDegre( g-45 ))));

end;

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if p1.X=-1 then p1 := Point(x,y)
else if p2.X=-1 then p2 := Point(x,y);

if (p1.X<>-1) and (p2.X<>-1) then
begin
Refresh;
DrawTree(p1,p2,1);
p1 := Point(-1,-1);
p2 := Point(-1,-1);
end;
end;

procedure TForm1.FillTringle(Pnts: TPoints);
var
g ,r : integer;
p ,q: TPoint;
tempB : TBrush;
begin
g := GetDegre(Pnts[0],Pnts[1]);
r := LineLen(Pnts[0],Pnts[1]) div 2;
p.X := Pnts[0].X+ round( r*cos(DegToRad(NormDegre( g ))));
p.Y := Pnts[0].Y+ round(r*sin(DegToRad(NormDegre( g))));

g := GetDegre(P,Pnts[2]);
r := LineLen(P,Pnts[2]) div 2;
q.X := P.X+ round( r*cos(DegToRad(NormDegre( g ))));
q.Y := P.Y+ round(r*sin(DegToRad(NormDegre( g))));

// tempB := Canvas.Brush;
// Canvas.Brush.Style := bsSolid;
Canvas.Brush.Color := clBlack;

Canvas.FloodFill(q.X,q.Y,clBlack,fsBorder);
// Canvas.Brush := tempB;

end;

end.