3D в PascalABC

[Рудко Дмитрий]

Помогите сделать что нить в 3D на PascalABC, или подскажите плиз как сделать

[Рудко Дмитрий]

uses vcl,utils,aboutbox,functions;

const
osi=200;
dmax=10;
rmax=700;
rlmax=120;
trasb=1000;
tbegin=0;
tend=100;
dt=0.1;

type
MyTrackBar=class(panel)
TB:TrackBar;
DV,Value,Name:TextLabel;
constructor create(parent:ContainerControl;h,l, t,min,max:integer;caption:string;tb crocedure(sender:Component);dvc rocedure(Sender:Component;Shift:Shi ftState;x,y:Integer));
begin
inherited create(parent);parent:=self;
bevelinner:=bvnone;
bevelouter:=bvnone;
Width:=30;height:=h;Left:=l;Top:=t;
name:=TextLabel.create(parent);name .setpos(1,t);name.caption:=caption;
TB:=TrackBar.Create(parent);
TB.orientation:=orVertical;TB.TickM arks:=tmTopLeft;
TB.SetPos(1,t+name.height);TB.SetSi ze(Width-4,h-name.height*3);
TB.MarkerSize:=15;TB.Max:=Max;TB.Mi n:=Min;TB.Frequency:=round((Max-Min)/(h/5));
TB.OnChangeExt:=tbc;
Value:=TextLabel.create(parent);
Value.setpos(2,tb.top+tb.height-2);Value.Caption:=inttostr(min);
DV:=TextLabel.create(parent);
DV.setpos(2,Value.top+Value.height) ;DV.Caption:='0.0';dv.onmousedownEx t:=dvc;
end;
function getPosition:Integer; begin result:=tb.Position;end;
procedure setPosition(v:Integer); begin tb.Position:=v;value.caption:=intto str(v);end;
property Position:Integer Read GetPosition write SetPosition;
end;

var f1,foptions:Form;
fabout:FormAboutBox;
field:PaintBox3D;
figures:list3D;
menu:mainmenu;
NFunc3D,NFunc3D2:NaturalFunction3D;
PFunc3D:ParamFunction3D;
l,lshag,lsat:TextLabel;
shagedit:edit;
bshag,babout:button;
t1,t2:timer;
satuhanieb:trackbar;
tba,tbb,tbg,tbd,tbr:mytrackbar;
pncase,nrgbanel;
setkab,osib,rotateb:checkbox;
activefcase,nfcase,pfcase:combobox;
nfcaseb,pfcaseb,dfcaseb:radiobutton ;
satuhanie,shag,t0,tt,da,db,dg,bda,b db,bdg,dd,mx,my,x,y,z,dx,dy,a,b,d,r px,rpy,rpz,cordmax:real;
setka,showosi,moveleft,moveright,fr otate:boolean;
fpsc,fps,i,playicon,pauseicon:integ er;
fpsp:string;
StatusB:StatusBar;
toolB:toolbar;
toolbt,playstopbt:toolbutton;
// frames:ObjectArray;
dynimgindex:integer;

function rotate:boolean;
begin
result:=frotate;
end;
procedure setrotate(v:boolean);
begin
if v<>frotate then begin
frotate:=v;
rotateb.checked:=v;
tba.tb.enabled:=not v;
tbb.tb.enabled:=not v;
tbg.tb.enabled:=not v;
tbd.tb.enabled:=not v;
tbr.tb.enabled:=not v;
if rotate then begin
da:=bda;db:=bdb;dg:=bdg;
playstopbt.setImage('PAUSE');
end else begin
bda:=da;bdb:=db;bdg:=dg;
playstopbt.setImage('PLAY');
end;
end;
end;

procedure f1resize;
begin
if field<>nil then begin
field.centerx:=field.Width/2;
field.centery:=field.Height/2;
end;
end;

procedure createcub;
var i:integer;
c,cm,dm:integer;x1,x2,y1,y2,z1,z2:r eal;
begin
cm:=4000;dm:=200;
for i:=1 to 200 do begin
x1:=random(cm)-cm/2;
y1:=random(cm)-cm/2;
z1:=random(cm)-cm/2;
x2:=random(dm)-dm/2;
y2:=random(dm)-dm/2;
z2:=random(dm)-dm/2;
c:=rgb(random(255),random(255),rand om(255));
figures.addfigure3d(rectangle3d.cre ate(c,x1,y1,z1,x1+x2,y1+y2,z1+z2));
end;
end;

procedure OnMouseDownm(Sender:Component;Shift :ShiftState;x,y:Integer);
begin
dx:=x;dy:=y;
moveleft:=ssLeft in Shift;
moveright:=ssRight in Shift;
// field.savetofile('nj*');
end;
procedure OnMouseMoveField(x,y,button:Integer );
begin
if moveleft then begin
da:=x-dx;db:=y-dy;
if abs(da)>dmax then da:=sign(da)*dmax;
if abs(db)>dmax then db:=sign(db)*dmax;
end;
if moveright then begin
dd:=y-dy;
dg:=-x+dx;
if abs(dg)>dmax then dg:=sign(dg)*dmax;
if abs(dd)>dmax then dd:=sign(dd)*dmax;
end;
dx:=x;dy:=y;
if f1.borderstyle=bsnone then begin
if (y<20)and(not toolb.visible) then toolb.visible:=true;
if (y>20)and(toolb.visible)then toolb.visible:=false;
end;
end;

procedure OnMouseUpField(x,y,button:Integer);
begin
moveleft:=false;
moveright:=false;
end;

procedure MenuItem1Click;
begin
f1.close;
end;
procedure MenuItem2Click;
begin
fabout.show;
end;
procedure MenuItem3Click;
begin
Execute('notepad graph3d.txt');
end;
procedure ShowOptions;
begin
FOptions.show;
end;
procedure WaitMessage;
begin
foptions.caption:='Построение...';
Application.ProcessMessages;
end;

procedure ldclick(Sender:Component;Shift:Shif tState;x,y:Integer);
var pr:^real;
begin
if sender=tba.dv then pr:=@da;
if sender=tbb.dv then pr:=@db;
if sender=tbg.dv then pr:=@dg;
if sender=tbd.dv then pr:=@dd;
if ssleft in shift then pr^:=-pr^;
if ssright in shift then pr^:=0;
end;

[Рудко Дмитрий]

procedure updatefps;
begin
fpsc:=fpsc+1;
if fpsp<>formatdatetime('ss',now) then begin
fps:=fpsc;fpsc:=0;
fpsp:=formatdatetime('ss',now);
end;{}
end;

procedure setdcaption(l:TextLabel;d:real);
begin
l.caption:=formatstr('%1.1f',d);
with l.font do
if abs(d)>dmax/2 then color:=clred
else if d>0 then color:=clgreen
else if d<0 then color:=clblue
else color:=clblack;
end;

procedure ontimer;
var vx,vy,vz:real;
s:string;
begin
if moveleft or rotate then begin
field.alpha:=field.alpha+da;field.b eta:=field.beta+db;
end;
if moveright or rotate then field.gamma:=field.gamma+dg;
if moveright or rotate then field.dist:=field.dist+dd;//sign(dd)*field.dist*0.01;
if moveleft or moveright or rotate then begin
tba.position:=round(field.alpha);
tbb.position:=round(field.beta);
tbg.position:=round(field.gamma);
tbd.position:=round(field.dist);
if nfunc3d.getfunction<>nil then
tbr.position:=round(nfunc3d.rasbien ie);
if pfunc3d.getfunction<>nil then
tbr.position:=round(pfunc3d.rasbien ie);
end;
if rotate then begin
if (abs(da)<dmax)or(satuhanie<1) then da:=da*satuhanie;
if (abs(db)<dmax)or(satuhanie<1) then db:=db*satuhanie;
if (abs(dg)<dmax)or(satuhanie<1) then dg:=dg*satuhanie;
if (abs(dd)<dmax)or(satuhanie<1) then dd:=dd*satuhanie;
field.Line(0,0,0,rpx,rpy,rpz,rgb(10 0,100,100));
end else begin
da:=0;db:=0;dg:=0;
if (nfunc3d.getfunction<>nil)and(nfunc 3d.rasbienie<>tbr.position) then begin
t1.stop;WaitMessage;nfunc3d.rasbien ie:=tbr.position;t1.start;
end;
if (pfunc3d.getfunction<>nil)and(pfunc 3d.rasbienie<>tbr.position) then begin
t1.stop;WaitMessage;pfunc3d.rasbien ie:=tbr.position;t1.start;
end;
end;
if dfcaseb.checked then begin
t:=t+dt;
field.font.color:=cllime;
field.textout(1,1,FormatStr('%1.2f' ,t));
nFunc3D.func:=nil;
nfunc3d.func:=umf;{}
{field.setlist3d(list3d(frames[dynimgindex]));
dynimgindex:=dynimgindex+1;
if dynimgindex>trasb then dynimgindex:=1;}
end;
field.show;
updatefps;
setdcaption(tba.dv,da);setdcaption( tbb.dv,db);setdcaption(tbg.dv,dg);s etdcaption(tbd.dv,dd);
end;


procedure onchangetb(sender:Component);
var l:TextLabel;
begin
if moveleft or moveright then exit;
if sender=tba.tb then tba.value.caption:=inttostr(trackba r(sender).position);
if sender=tbb.tb then tbb.value.caption:=inttostr(trackba r(sender).position);
if sender=tbg.tb then tbg.value.caption:=inttostr(trackba r(sender).position);
if sender=tbd.tb then tbd.value.caption:=inttostr(trackba r(sender).position);
if sender=tbr.tb then tbr.value.caption:=inttostr(trackba r(sender).position);
if sender=satuhanieb then begin
satuhanie:=1+satuhanieb.position/1000;
lsat.caption:=formatstr('%1.3f',sat uhanie);
with lsat.font do
if satuhanie<>1 then color:=rgb(abs(satuhanieb.position* 5),128-abs(satuhanieb.position)*2,0)
else color:=clgreen;
end;
if not rotate then begin
field.alpha:=tba.position;
field.beta:=tbb.position;
field.gamma:=tbg.position;
field.dist:=tbd.position;
end;

end;

procedure rotateclick;
begin
setrotate(not rotate);
end;

procedure pcheckboxclick(sender:Component);
var cb:checkbox;
begin
cb:=checkbox(sender);
if cb=rotateb then
setrotate(cb.checked);
if cb=osib then begin
showosi:=cb.checked;
t1.stop;WaitMessage;
figures.clear;
figures.addfigure3d(nfunc3d);
figures.addfigure3d(nfunc3d2);
figures.addfigure3d(pfunc3d);
if showosi then begin
figures.addfigure3d(line3d.create(c lred, 0,0,0,osi,0,0));
figures.addfigure3d(line3d.create(c lgreen,0,0,0,0,osi,0));
figures.addfigure3d(line3d.create(c lblue, 0,0,0,0,0,osi));
end;
t1.start;
end;
if cb=setkab then begin
t1.stop;
WaitMessage;
setka:=cb.checked;
if setka then tbr.tb.max:=rlmax
else tbr.tb.max:=rmax;
// onchangetb(tbr);
nfunc3d.setka:=setka;
nfunc3d2.setka:=setka;
pfunc3d.setka:=setka;
t1.start;
end;
end;

[Рудко Дмитрий]

procedure MenuItemNewClick;
begin
nfunc3d.func:=nil;pfunc3d.func:=nil ;nfunc3d2.func:=nil;
pcheckboxclick(osib);
field.centerx:=f1.ClientWidth/2;field.centery:=f1.ClientHeight/2;
field.Pen.color:=clGreen;
field.Brush.Color:=f1.color;
field.setrotatepoint(rpx,rpy,rpz);
nfcase.enabled:=false;pfcase.enable d:=false;
nfcaseb.checked:=false;pfcaseb.chec ked:=false;
end;


procedure ChangeFigure(sender:Component);
var i:integer;
dt:real;
begin
t1.stop;
WaitMessage;
if sender=nfcaseb then begin
nfcase.enabled:=true;
pfcase.enabled:=false;
pFunc3D.func:=nil;
foptions.activecontrol:=nfcase;
ChangeFigure(nfcase);
end;
if sender=pfcaseb then begin
pfcase.enabled:=true;
nfcase.enabled:=false;
nFunc3D.func:=nil;
foptions.activecontrol:=pfcase;
ChangeFigure(pfcase);
end;
if sender=dfcaseb then begin
pfcase.enabled:=false;
nfcase.enabled:=false;
pFunc3D.func:=nil;
{ frames.clear;
dt:=(tend-tbegin)/trasb;t:=tbegin;
nfunc3d.func:=umf;
for i:=1 to trasb do begin
frames.add(list3d.create);
field.setlist3d(list3d(frames[frames.size]));
list3d(frames[frames.size]).AddFigure3d(nfunc3d);
t:=t+dt;
writeln('creating...',i)
end;
pFunc3D.func:=nil;
nfunc3d.func:=umf;}
end;
if sender=pfcase then begin
activefcase:=pfcase;
pfunc3d.func:=func_param[pfcase.itemindex].func;
end;
if sender=nfcase then begin
activefcase:=nfcase;
nfunc3d.func:=func_norm[nfcase.itemindex].func;
end;
t:=t0;dt:=0.1;
t1.start;
end;


procedure Form1Close;
begin
end;
procedure FullScreen;
begin
if f1.borderstyle=bssizeable then begin
f1.borderstyle:=bsnone;
f1.windowstate:=wsMaximized;
f1.menu:=nil;
toolb.visible:=false;
toolb.Align:=alnone;
end else begin
f1.windowstate:=wsNormal;
f1.borderstyle:=bssizeable;
f1.autoscroll:=false;
toolb.Align:=alTop;
f1.menu:=menu;
end;
end;
procedure fullscrclick;
begin
FullScreen;
end;
procedure osiclick;
begin
osib.checked:=not osib.checked;
pcheckboxclick(osib);
end;
procedure setkaclick;
begin
setkab.checked:=not setkab.checked;
pcheckboxclick(setkab);
end;
procedure optionsclick;
begin
foptions.show;
end;
procedure f1closeclick;
begin
f1.close;
end;
procedure updatetime;
begin
statusb[2].text:=FormatDateTime('hh:nn:ss',no w);
statusb.caption:=FormatDateTime('dd .mm.yyyy',now);
foptions.caption:=inttostr(fps)+' fps';
end;

[Рудко Дмитрий]

Procedure InitComponents;
var i:integer;
begin
f1:=Form.Create(170,70,800,665);//f1.show;
f1.color:=clblack;
f1.caption:=vcl_info+', версия '+vcl_version;
f1.autoscroll:=false;
f1.onclose:=Form1Close;
f1.onresize:=f1resize;
{ f1.alphablend:=true;
f1.alphablendvalue:=100;{}
{ f1.TransparentColor:=true;
f1.TransparentColorValue:=f1.color; {}

foptions:=Form.Create(1,f1.top,170, f1.height);//foptions.show;
foptions.caption:='Настройки';
foptions.borderstyle:=bssingle;
foptions.bordericons:=[biSystemMenu];
{foptions.alphablend:=true;
foptions.alphablendvalue:=200;{}

figures:=list3d.create;

setka:=false;showosi:=true;shag:=50 ;
field:=PaintBox3d.create(f1,0,0,Scr een.Width,Screen.Height);
field.Brush.Color:=f1.color;
field.Pen.Color:=f1.color;
field.align:=alClient;
field.onmousedownExt:=onmousedownm;
field.onmouseup:=onmouseupfield;
field.OnMouseMove:=OnMouseMoveField ;
field.setlist3d(figures);
// field.ShowMode:=ShowMode;

toolb:=toolbar.create(true);toolb.c olor:=clMenu;toolb.Autosize:=true;
playstopbt:=toolbutton.create(toolb );
playstopbt.onclick:=rotateclick;
playstopbt.hint:='Вращение';
toolb.AddButton(osiclick, 'Graph3D.bmp',2); toolb[2].hint:='Оси';
toolb.AddButton(setkaclick, 'Graph3D.bmp',4); toolb[3].hint:='Сетка';
toolb.AddSeparator;
toolb.AddButton(fullscrclick,'Graph 3D.bmp',1); toolb[5].hint:='Полноэкранный режим';
toolb.AddButton(optionsclick,'OPTIO NS'); toolb[6].hint:='Управление';
toolb.AddSeparator;
toolb.AddButton(f1closeclick,'EXIT' ); toolb[8].hint:='Выход';

menu:=mainMenu.create;
menu.add('Файл'); //1
menu.add('Другие фигуры'); //2
menu.add('Параметры'); //3
menu.add('Помощь'); //4
menu[1].add('Новый', MenuItemNewClick,'NEW');
menu[1].add('Выход', MenuItem1Click, 'EXIT');
menu[2].add('Параллелепипеды',CreateCub, 'Graph3D.bmp',3);
menu[2].add('Управление...', ShowOptions, 'OPTIONS');
menu[3].add('Полный экран', FullScreen, 'Graph3D.bmp',1);
menu[4].add('Справка...', MenuItem3Click, 'HELP');
menu[4].add('О программе...', MenuItem2Click, 'HELP');

FAbout:=FormAboutBox.create('Graph3 D v1.5 (c)Ткачук А.В. 2004-2005');

nrgb:=panel.create(foptions,1,1,fop tions.clientwidth-2,440);
StatusB:=statusBar.create(foptions) ;
StatusB.add;StatusB[1].width:=StatusB.clientwidth div 2;
tba:=mytrackbar.create(nrgb,nrgb.he ight-10,5,1,0,360,'X',onchangetb,ldclick );
tbb:=mytrackbar.create(nrgb,nrgb.he ight-10,tba.left+tba.width,1,0,360,'Y',o nchangetb,ldclick);
tbg:=mytrackbar.create(nrgb,nrgb.he ight-10,tbb.left+tbb.width,1,0,360,'Z',o nchangetb,ldclick);
tbd:=mytrackbar.create(nrgb,nrgb.he ight-10,tbg.left+tbg.width,1,100,2000,'Д ист',onchangetb,ldclick);
tbr:=mytrackbar.create(nrgb,nrgb.he ight-10,tbd.left+tbd.width,1,5,rmax,'Раз б',onchangetb,ldclick);
with satuhanieb do begin
satuhanieb:=trackbar.create(foption s,1,nrgb.height+nrgb.top,foptions.c lientwidth-40,30);
max:=50;min:=-max;Frequency:=max div 10;MarkerSize:=15;onchangeExt:=onch angetb;
lsat:=TextLabel.Create(foptions);ls at.setpos(left+width,top+5);lsat.ca ption:='-0.000';lsat.hint:='Ускорение';
end;
setkab:=checkbox.create(foptions);
setkab.setpos(10,satuhanieb.height+ satuhanieb.top);setkab.width:=55;se tkab.caption:='Сетка';setkab.width: =70;
setkab.onclickExt:=pcheckboxclick;
osib:=checkbox.create(foptions);
osib.setpos(setkab.left+setkab.widt h+25,setkab.top);osib.width:=45;osi b.caption:='Оси';
osib.onclickExt:=pcheckboxclick;
rotateb:=checkbox.create(foptions);
rotateb.setpos(10,setkab.top+setkab .height);rotateb.caption:='Вращение ';
rotateb.onclickExt:=pcheckboxclick;
pncase:=panel.create(foptions);
pncase.setpos(1,rotateb.top+rotateb .height+2);
pncase.setsize(foptions.clientwidth-1,foptions.clientheight-pncase.top-statusb.height);
nfcaseb:=radiobutton.create(pncase) ;
nfcaseb.setpos(10,5);nfcaseb.captio n:='Обычные';
nfcase:=combobox.create(pncase);nfc ase.style:=csDropDownList;
nfcase.setpos(nfcaseb.left,nfcaseb. top+nfcaseb.height);nfcase.DropDown Count:=10;
for i:=1 to max_normf do nfcase.items.add(func_norm[i].name);
pfcaseb:=radiobutton.create(pncase) ;
pfcaseb.setpos(nfcase.left,nfcase.t op+nfcase.height);pfcaseb.caption:= 'Параметрические';
pfcaseb.width:=pncase.clientwidth-nfcase.left-1;
pfcase:=combobox.create(pncase);pfc ase.style:=csDropDownList;pfcase.Dr opDownCount:=nfcase.DropDownCount;
pfcase.setpos(pfcaseb.left,pfcaseb. top+pfcaseb.height);
for i:=1 to max_paramf do pfcase.items.add(func_param[i].name);
dfcaseb:=radiobutton.create(pncase) ;
dfcaseb.setpos(pfcase.left,pfcase.t op+pfcase.height);dfcaseb.caption:= 'Динамические';
dfcaseb.width:=150;
dfcaseb.onclickExt:=ChangeFigure;

t1:=timer.create(ontimer,30,false);
t2:=timer.create(updatetime,500,tru e);
end;

[Рудко Дмитрий]

procedure initfigureslist(natural:boolean;nnu m,pnum:integer);
begin
nfcase.itemindex:=nnum;pfcase.itemi ndex:=pnum;
nfcaseb.checked:=natural;pfcaseb.ch ecked:=not natural;
nfcaseb.onclickExt:=ChangeFigure;pf caseb.onclickExt:=ChangeFigure;
nfcase.onchangeExt:=ChangeFigure;pf case.onchangeExt:=ChangeFigure;
if natural then ChangeFigure(nfcaseb)
else ChangeFigure(pfcaseb);
end;

begin
//Application.EnableVCLDebug;
InitComponents;
rpx:=0;rpy:=0;rpz:=0;
// rpx:=40;rpy:=80;rpz:=100;
cordmax:=field.width;
dynimgindex:=1;
shag:=50;
satuhanie:=1;//0.995;
nFunc3D:=NaturalFunction3D.Create(c llime,-fieldsize/2,-fieldsize/2,fieldsize/2,fieldsize/2,shag,false,nil);
nFunc3D2:=NaturalFunction3D.Create( cllime,-fieldsize/2,-fieldsize/2,fieldsize/2,fieldsize/2,shag,false,{polusharminus}nil);
PFunc3D:=ParamFunction3D.Create(cll ime,0,0,360,360,shag,false,nil);
field.dist:=1000;
osib.checked:=showosi;
MenuItemNewClick;
field.alpha:=-10;field.beta:=20;field.gamma:=0;
bda:=0.1;bdb:=-0.5;bdg:=0;
setrotate(true);{}
satuhanieb.position:=satuhanieb.max *2-round(satuhanie*satuhanieb.max*2);
onchangetb(satuhanieb);
initfigureslist(random(2)=1,4,5);
setkab.checked:=nfcaseb.checked;
t1.start;
foptions.show;
writeln(compiletime,'ms+',milliseco nds,'ms');
updatetime;
end.

[Рудко Дмитрий]

вот за компеліруйте все і увідете 3D графику в паскале, как сделать что то похожое,