uses graph,crt;
const maxz=500;ux=20;uy=20;uz=20;oux=150;ouy=150;ouz=0;k nkt=25;tknkt=knkt*knkt;
type xyz=record
...........x,y,z:real;
.........end;
.....xy=record
..........x,y:real;
........end;
.....cizgi=record
.............n1,n2:xyz;
...........end;
.....dortgen=array[1..4] of cizgi;
.....cisim=array[1..4] of dortgen;
.....kure=array[1..tknkt] of xyz;
var gd,gm,ox,oy:integer;cis:array[1..50] of cisim;c:char;sil:boolean;say:byte;ku:kure;
procedure kureyap(x,y,z,r:real;var k:kure);
var i,j,xx:integer;
begin
..xx:=0;
..for i:=1 to knkt do
..for j:=1 to knkt do
..begin
....inc(xx);
....k[xx].x:=x+r*cos(j*2*pi/knkt)*cos(i*2*pi/knkt);
....k[xx].y:=y-r*cos(j*2*pi/knkt)*sin(i*2*pi/knkt);
....k[xx].z:=z-r*sin(j*2*pi/knkt);
..end;
end;
procedure otele(var c:cisim;x,y,z:real);
var i,j:byte;
begin
..for i:=1 to 4 do
..for j:=1 to 4 do
..with c[i,j] do
..begin
....n1.x:=n1.x+x;n1.y:=n1.y+y;n1.z:=n1.z+z;
....n2.x:=n2.x+x;n2.y:=n2.y+y;n2.z:=n2.z+z;
..end;
end;
procedure kureotele(var k:kure;x,y,z:real);
var i:integer;
begin
..for i:=1 to tknkt do begin k[i].x:=k[i].x+x;k[i].y:=k[i].y+y;k[i].z:=k[i].z+z;end;
end;
procedure cevir(a:xyz;var b:xy);
begin
..b.x:=ox+a.x*(1-a.z/maxz);b.y:=oy-a.y*(1-a.z/maxz);
end;
procedure cizgic(c:cizgi);
var c1,c2:xy;
begin
..cevir(c.n1,c1);cevir(c.n2,c2);line(round(c1.x),r ound(c1.y),round(c2.x),round(c2.y));
end;
procedure karec(c:dortgen);
var c1,c2:xy;i:byte;
begin
..for i:=1 to 4 do
..begin
....cevir(c[i].n1,c1);cevir(c[i].n2,c2);
....line(round(c1.x),round(c1.y),round(c2.x),round (c2.y));
..end;
end;
procedure ciz(c:cisim;r:byte);
var i:byte;
begin
..setcolor(r);for i:=1 to 4 do karec(c[i]);
end;
procedure kureciz(k:kure;r:byte);
var i:integer;kk:xy;
begin
..for i:=1 to tknkt do
..begin
....cevir(k[i],kk);putpixel(round(kk.x),round(kk.y),r);
..end;
end;
procedure don(var a,b:real;aci:real);
var c:real;
begin
..c:=a;
..a:=c*cos(aci*pi/180)-b*sin(aci*pi/180);
..b:=b*cos(aci*pi/180)+c*sin(aci*pi/180);
end;
procedure donc(var k:xyz;axy,ayz,axz:real);
begin
..don(k.x,k.y,axy);
..don(k.y,k.z,ayz);
..don(k.z,k.x,axz);
end;
procedure donkure(var k:kure;axy,ayz,axz:real);
var i:integer;
begin
..for i:=1 to tknkt do donc(k[i],axy,ayz,axz);
end;
procedure doncizgi(var c:cizgi;a1,a2,a3:real);
begin
..donc(c.n1,a1,a2,a3);
..donc(c.n2,a1,a2,a3);
end;
procedure donk(var c:dortgen;a1,a2,a3:real);
var i:byte;
begin
..for i:=1 to 4 do doncizgi(c[i],a1,a2,a3);
end;
procedure dondur(var d:cisim;xy,xz,yz:real);
var i:byte;
begin
..for i:=1 to 4 do begin donk(d[i],xy,yz,xz);donk(d[i],xy,yz,xz);end;
end;
procedure cizgiol(var c:cizgi;n1,n2:xyz);
begin
..c.n1:=n1;c.n2:=n2;
end;
procedure dortgenolustur(var k:dortgen;n1,n2,n3,n4:xyz);
begin
..cizgiol(k[1],n1,n2);
..cizgiol(k[2],n2,n3);
..cizgiol(k[3],n3,n4);
..cizgiol(k[4],n4,n1);
end;
procedure cisimolustur(var c:cisim;n1,n2,n3,n4,n5,n6,n7,n8:xyz);
begin
..dortgenolustur(c[1],n1,n2,n3,n4);
..dortgenolustur(c[2],n1,n2,n7,n6);
..dortgenolustur(c[3],n4,n3,n8,n5);
..dortgenolustur(c[4],n7,n6,n5,n8);
end;
procedure ck(var c:cisim;x,y,z,ux,uy,uz:real);
var n1,n2,n3,n4,n5,n6,n7,n8:xyz;
begin
..n1.x:=x;n1.y:=y;n1.z:=z;
..n2.x:=x;n2.y:=y+uy;n2.z:=z;
..n3.x:=x+ux;n3.y:=y+uy;n3.z:=z;
..n4.x:=x+ux;n4.y:=y;n4.z:=z;
..n5.x:=x+ux;n5.y:=y;n5.z:=uz;
..n6.x:=x;n6.y:=y;n6.z:=uz;
..n7.x:=x;n7.y:=y+uy;n7.z:=uz;
..n8.x:=x+ux;n8.y:=y+uy;n8.z:=uz;
..cisimolustur(c,n1,n2,n3,n4,n5,n6,n7,n8);
end;
procedure init;
var i,j,k,l,m:byte;
begin
{..say:=27;for i:=1 to say do ck(cis[i],i*50-say*25-50,0,0,50,50,50);}
{..say:=27;for i:=1 to say do ck(cis[i],cos(i*pi/18)*oux,sin(i*pi/18)*ouy,ouz,ux,uy,uz);}
{..say:=27;m:=20;l:=0;for i:=0 to 2 do for j:=0 to 2 do for k:=0 to 2 do begin inc(l);ck(cis[l],i*m-m,j*m-m,-k*m,m,m,m);end;}
{..say:=1;ck(cis[1],40,0,0,45,70,50);}
..kureyap(0,0,0,50,ku);
..ox:=320;oy:=240;
end;
procedure cizim(b:byte);
var i:byte;
begin
..for i:=1 to say do ciz(cis[i],b);
end;
procedure cdondur(x,y,z:real);
var i:byte;
begin
..for i:=1 to say do dondur(cis[i],x,y,z);
end;
var k:byte;x,y,z,vx,vy,vz:real;
begin
..gd:=detect;initgraph(gd,gm,'');if graphresult<>0 then halt;init;x:=0;y:=0;z:=0;k:=1;vx:=0;vy:=0;vz:=0;si l:=true;
..repeat
....kureciz(ku,15);
....{cizim(15);}delay(10);{if sil then cizim(0);}kureciz(ku,0);
....if keypressed then
....begin
......c:=upcase(readkey);
......case c of
........'T':vx:=vx+0.2;
........'G':vx:=vx-0.2;
........'Y':vy:=vy+0.2;
........'H':vy:=vy-0.2;
........'U':vz:=vz+0.2;
........'J':vz:=vz-0.2;
........'B':begin vx:=0;vy:=0;vz:=0;end;
........'+':if k<27 then inc(k);
........'-':if k>1 then dec(k);
........'A':x:=x+0.2;
........'Q':x:=x-0.2;
........'W':y:=y+0.2;
........'S':y:=y-0.2;
........'E':z:=z+0.2;
........'D':z:=z-0.2;
........'X':begin x:=0;y:=0;z:=0;end;
........'C':cleardevice;
........#32:sil:=not sil;
......end;
....end;
....donkure(ku,x,y,z);kureotele(ku,vx,vy,vz);
{....cdondur(x,y,z);otele(cis[k],vx,vy,vz);}
..until c=#27;
..closegraph;
end.
Ağaç şeklinde