DUzun's Web
Programare, proiecte personale, divertisment

uses crt,graph,dos;

type xrec=record x,y,z:integer;

        s:record x,y,z,a,b,c:real;end;

                 diag:boolean;end;

var i,gd,gm,ex,ey,mx,my:integer;

    rat:integer; k,k1:char;  ki:array[1..9]of char;

    h,m,sa,ms,s1:word;page,cl:boolean;

    ra,rb,rc:real;Fig:array[1..3]of boolean;

   s:record

     x,y,z,a,b,c:real;

     end;

   oct,tetr:Xrec;

​

function r(g:real):real;

begin

r:=g*pi/180;

end;

function g(r:real):real;

begin

g:=r*180/pi;

end;

​

  procedure PSp(x,y,z,a,b,c:real;var tx,ty,tz:real);

var cx,cy,cz:real;

 procedure sppl(o:char;x,y:real;var ox,oy:real);

var u:real;

begin

case o of

'x':u:=r(a);

'y':u:=r(b);

'z':u:=r(c);end;

ox:=x*cos(u)-y*sin(u);

oy:=y*cos(u)+x*sin(u);

end;

begin

sppl('z',x,y,tx,ty);

sppl('y',z,tx,tz,tx);

sppl('x',ty,tz,ty,tz);

end;

​

Procedure LinP(c:char;x,y,z,l:integer;sa,sb,sc:real);

var x1,x2,y1,y2,z1,z2:real;

begin

PSp(x,y,z,sa,sb,sc,x1,y1,z1);

   case c of

'x','X':PSp(x+l,y,z,sa,sb,sc,x2,y2,z2);

'y','Y':PSp(x,y+l,z,sa,sb,sc,x2,y2,z2);

'z','Z':PSp(x,y,z+l,sa,sb,sc,x2,y2,z2);

   end;

line(ex+round(x1),ey+round(y1),ex+round(x2),ey+round(y2));

end;

​

  Procedure LSp(x1,y1,z1,x2,y2,z2:integer;a,b,c:real);

var px1,px2,py1,py2,pz:real;

begin

psp(x1,y1,z1,a,b,c,px1,py1,pz);

psp(x2,y2,z2,a,b,c,px2,py2,pz);

line(ex+round(px1),ey+round(py1),ex+round(px2),ey+round(py2));

end;

​

procedure SPlt;

begin

for i:=1 to 254 do SetRGBPalette(i,i div 5+random($ffffff)+$ff,random($aaaaaa),i div 2+random($ffffff)+$ffff);

end;

​

function hour:string;

var sh,sm,ss:string;

begin

str(h:0,sh);str(m:0,sm);str(sa:0,ss);

if length(sh)=1 then sh:='0'+sh;

if length(sm)=1 then sm:='0'+sm;

if length(ss)=1 then ss:='0'+ss;

hour:=sh+':'+sm+':'+ss;

end;

​

procedure ChangePage;

begin

  if Page then begin

    SetActivePage(0);

    SetVisualPage(1,true);

    Page:=false;

  end else begin

    SetActivePage(1);

    SetVisualPage(0,true);

    Page:=true;

  end;

  ClearPage;

   OutTextXY(mx div 2-textwidth(hour)div 2, 3, hour);

end;

​

 Procedure Crux;

begin

with s do begin

linp('x',-3*rat,-rat,3*rat,2*rat,a,b,c);linp('x',-3*rat,rat,3*rat,2*rat,a,b,c);

linp('x',-3*rat,-rat,-3*rat,2*rat,a,b,c);linp('x',-3*rat,rat,-3*rat,2*rat,a,b,c);

linp('x',rat,-rat,3*rat,2*rat,a,b,c);linp('x',rat,rat,3*rat,2*rat,a,b,c);

linp('x',rat,-rat,-3*rat,2*rat,a,b,c);linp('x',rat,rat,-3*rat,2*rat,a,b,c);

linp('x',-rat,-3*rat,3*rat,2*rat,a,b,c);linp('x',-rat,3*rat,3*rat,2*rat,a,b,c);

linp('x',-rat,-3*rat,-3*rat,2*rat,a,b,c);linp('x',-rat,3*rat,-3*rat,2*rat,a,b,c);

linp('y',-rat,rat,3*rat,2*rat,a,b,c);linp('y',rat,rat,3*rat,2*rat,a,b,c);

linp('y',-rat,rat,-3*rat,2*rat,a,b,c);linp('y',rat,rat,-3*rat,2*rat,a,b,c);

linp('y',-3*rat,-rat,3*rat,2*rat,a,b,c);linp('y',3*rat,-rat,3*rat,2*rat,a,b,c);

linp('y',-3*rat,-rat,-3*rat,2*rat,a,b,c);linp('y',3*rat,-rat,-3*rat,2*rat,a,b,c);

linp('y',-rat,-3*rat,3*rat,2*rat,a,b,c);linp('y',rat,-3*rat,3*rat,2*rat,a,b,c);

linp('y',-rat,-3*rat,-3*rat,2*rat,a,b,c);linp('y',rat,-3*rat,-3*rat,2*rat,a,b,c);

​

linp('z',3*rat,-rat,-3*rat,2*rat,a,b,c);linp('z',3*rat,rat,-3*rat,2*rat,a,b,c);

linp('z',-3*rat,-rat,-3*rat,2*rat,a,b,c);linp('z',-3*rat,rat,-3*rat,2*rat,a,b,c);

linp('z',3*rat,-rat,rat,2*rat,a,b,c);linp('z',3*rat,rat,rat,2*rat,a,b,c);

linp('z',-3*rat,-rat,rat,2*rat,a,b,c);linp('z',-3*rat,rat,rat,2*rat,a,b,c);

linp('z',3*rat,-3*rat,-rat,2*rat,a,b,c);linp('z',3*rat,3*rat,-rat,2*rat,a,b,c);

linp('z',-3*rat,-3*rat,-rat,2*rat,a,b,c);linp('z',-3*rat,3*rat,-rat,2*rat,a,b,c);

linp('y',3*rat,rat,-rat,2*rat,a,b,c);linp('y',3*rat,rat,rat,2*rat,a,b,c);

linp('y',-3*rat,rat,-rat,2*rat,a,b,c);linp('y',-3*rat,rat,rat,2*rat,a,b,c);

linp('y',3*rat,-3*rat,-rat,2*rat,a,b,c);linp('y',3*rat,-3*rat,rat,2*rat,a,b,c);

linp('y',-3*rat,-3*rat,-rat,2*rat,a,b,c);linp('y',-3*rat,-3*rat,rat,2*rat,a,b,c);

​

linp('x',-3*rat,3*rat,-rat,2*rat,a,b,c);linp('x',-3*rat,3*rat,rat,2*rat,a,b,c);

linp('x',-3*rat,-3*rat,-rat,2*rat,a,b,c);linp('x',-3*rat,-3*rat,rat,2*rat,a,b,c);

linp('x',rat,3*rat,-rat,2*rat,a,b,c);linp('x',rat,3*rat,rat,2*rat,a,b,c);

linp('x',rat,-3*rat,-rat,2*rat,a,b,c);linp('x',rat,-3*rat,rat,2*rat,a,b,c);

linp('z',-rat,3*rat,rat,2*rat,a,b,c);linp('z',rat,3*rat,rat,2*rat,a,b,c);

linp('z',-rat,-3*rat,rat,2*rat,a,b,c);linp('z',rat,-3*rat,rat,2*rat,a,b,c);

linp('z',-rat,3*rat,-3*rat,2*rat,a,b,c);linp('z',rat,3*rat,-3*rat,2*rat,a,b,c);

linp('z',-rat,-3*rat,-3*rat,2*rat,a,b,c);linp('z',rat,-3*rat,-3*rat,2*rat,a,b,c);

​

linp('x',rat,rat,rat,2*rat,a,b,c);linp('x',-rat,rat,rat,-2*rat,a,b,c);

linp('y',rat,rat,rat,2*rat,a,b,c);linp('y',rat,-rat,rat,-2*rat,a,b,c);

linp('x',rat,-rat,rat,2*rat,a,b,c);linp('x',-rat,-rat,rat,-2*rat,a,b,c);

linp('y',-rat,rat,rat,2*rat,a,b,c);linp('y',-rat,-rat,rat,-2*rat,a,b,c);

linp('x',rat,rat,-rat,2*rat,a,b,c);linp('x',-rat,rat,-rat,-2*rat,a,b,c);

linp('y',rat,rat,-rat,2*rat,a,b,c);linp('y',rat,-rat,-rat,-2*rat,a,b,c);

linp('x',rat,-rat,-rat,2*rat,a,b,c);linp('x',-rat,-rat,-rat,-2*rat,a,b,c);

linp('y',-rat,rat,-rat,2*rat,a,b,c);linp('y',-rat,-rat,-rat,-2*rat,a,b,c);

​

linp('z',rat,rat,rat,2*rat,a,b,c);linp('z',rat,rat,-rat,-2*rat,a,b,c);

linp('z',rat,-rat,rat,2*rat,a,b,c);linp('z',rat,-rat,-rat,-2*rat,a,b,c);

linp('z',-rat,rat,rat,2*rat,a,b,c);linp('z',-rat,rat,-rat,-2*rat,a,b,c);

linp('z',-rat,-rat,rat,2*rat,a,b,c);linp('z',-rat,-rat,-rat,-2*rat,a,b,c);

end;end;

​

  Procedure Octaedru;

var p:array[1..6] of record x,y,z:integer;end;

    c:integer;

begin

for c:=1 to 6 do with p[c] do begin x:=0;y:=0;z:=0;end;

   with oct do begin

p[1].y:=round(y*rat);p[2].y:=-p[1].y;

p[3].x:=round(x*rat);p[4].x:=-p[3].x;

p[5].z:=round(z*rat);p[6].z:=-p[5].z;

if diag then for c:=1 to 6 do with p[c] do lsp(0,0,0,x,y,z,s.a,s.b,s.c);

   end;

for c:=3 to 6 do with oct do lsp(p[1].x,p[1].y,p[1].z,p[c].x,p[c].y,p[c].z,s.a,s.b,s.c);

for c:=3 to 6 do with oct do lsp(p[2].x,p[2].y,p[2].z,p[c].x,p[c].y,p[c].z,s.a,s.b,s.c);

for c:=5 to 6 do with oct do lsp(p[3].x,p[3].y,p[3].z,p[c].x,p[c].y,p[c].z,s.a,s.b,s.c);

for c:=5 to 6 do with oct do lsp(p[4].x,p[4].y,p[4].z,p[c].x,p[c].y,p[c].z,s.a,s.b,s.c);

end;

​

  Procedure Tetraedru;

var p:array[1..4] of record x,y,z:integer;end;

    c,c1:integer;

    fac:array[1..4,1..3] of byte;

  Procedure spTriangle(x1,y1,z1,x2,y2,z2,x3,y3,z3:real);

var v:array[1..3] of record x,y,z:integer;end;x,y,z:real;c:word;

begin

 SetColor(120);

with tetr.s do begin

psp(x1,y1,z1,a,b,c,x,y,z);v[1].x:=Round(x)+ex;v[1].y:=Round(y)+ey;v[1].z:=Round(z);

psp(x2,y2,z2,a,b,c,x,y,z);v[2].x:=Round(x)+ex;v[2].y:=Round(y)+ey;v[2].z:=Round(z);

psp(x3,y3,z3,a,b,c,x,y,z);v[3].x:=Round(x)+ex;v[3].y:=Round(y)+ey;v[3].z:=Round(z);

SetFillColor(trunc(a/10));end;

FillTriangle(v[1].x,v[1].y,v[2].x,v[2].y,v[3].x,v[3].y);

end;

begin

for c:=1 to 4 do with p[c] do begin x:=0;y:=0;z:=0;end;

   with tetr do begin

p[1].y:=-round(y*rat*sqrt(6)*2/9);

p[2].y:=round(y*rat*sqrt(6)/9);p[2].z:=round(z*rat*sqrt(3)/3);

p[3]:=p[2];p[3].z:=round(-p[3].z/2);p[3].x:=-round(x*rat/2);

p[4]:=p[3];p[4].x:=-p[3].x;

if diag then for c:=1 to 4 do with p[c] do lsp(0,0,0,x,y,z,s.a,s.b,s.c);

   end;

for c:=1 to 3 do begin fac[1,c]:=c;fac[4,c+1]:=c;fac[2,c]:=c;fac[3,c]:=c;end;

fac[2,3]:=4;fac[3,3]:=4;fac[3,2]:=3;

for c:=1 to 4 do spTriangle(p[fac[c,1]].x,p[fac[c,1]].y,p[fac[c,1]].z,

                            p[fac[c,2]].x,p[fac[c,2]].y,p[fac[c,2]].z,

                            p[fac[c,3]].x,p[fac[c,3]].y,p[fac[c,3]].z);

end;

​

  pROCEDURE atr;

begin

 for i := 1 to 126 do

    SetRGBPalette (i, i div 5, i div 3, (20 + i) div 3);

mx:=getmaxx;my:=getmaxy;

ex:=mx div 2;ey:=my div 2;

rat:=30;s1:=0;

s.a:=0;s.b:=0; s.c:=0;

ra:=0;rb:=ra;rc:=ra;

ki[1]:='1';ki[2]:='2';ki[3]:='3';ki[4]:='4';ki[5]:='5';

ki[6]:='6';ki[7]:='7';ki[8]:='8';ki[9]:='9';k1:='3';

fig[1]:=false;

fig[2]:=false;

fig[3]:=true;

with oct do begin x:=6;y:=x;z:=x;diag:=false;s.a:=45;s.b:=45;s.c:=0;end;

with tetr do begin x:=6;y:=x;z:=x;diag:=false;s.a:=45;s.b:=45;s.c:=0;end;

end;

begin

SetSVGAMode(640, 480, 8, LfbOrBanked);

  OutTextXY(270, 230, 'Please wait...');

randomize;

  SPlt;

drawborder:=false;

atr;

repeat

changepage;

rectangle(1,1,mx,my);

putpixel(ex,ey,7);

if fig[1]=true then crux;

if fig[2]=true then Octaedru;

if fig[3]=true then TETRAEDRU;

gettime(h,m,sa,ms);

with tetr do begin

s.a:=s.a+ra;

s.b:=s.b+rb;

s.c:=s.c+rc;

if s.a>=360 then s.a:=s.a-360;

if s.b>=360 then s.b:=s.b-360;

if s.c>=360 then s.c:=s.c-360;end;

with oct do begin

s.a:=s.a+ra;

s.b:=s.b+rb;

s.c:=s.c+rc;

if s.a>=360 then s.a:=s.a-360;

if s.b>=360 then s.b:=s.b-360;

if s.c>=360 then s.c:=s.c-360;end;

s.a:=s.a+ra;

s.b:=s.b+rb;

s.c:=s.c+rc;

if s.a>=360 then s.a:=s.a-360;

if s.b>=360 then s.b:=s.b-360;

if s.c>=360 then s.c:=s.c-360;

if keypressed then  begin

k:=readkey;

case k of

'+':rat:=rat+1;'-':rat:=rat-1;#27:halt(1);

#72:ey:=ey-1;#75:ex:=ex-1;#77:ex:=ex+1;#80:ey:=ey+1;

'x':oct.x:=oct.x+1; 'X':oct.x:=oct.x-1;

'y':oct.y:=oct.y+1; 'Y':oct.y:=oct.y-1;

'z':oct.z:=oct.z+1; 'Z':oct.z:=oct.z-1;

'5':SPlt;

'8':ra:=ra+1;'2':ra:=ra-1;

'6':rb:=rb+1;'4':rb:=rb-1;

'9':rc:=rc+1;'1':rc:=rc-1;

'3':tetr.diag:=not tetr.diag;'7':oct.diag:=not oct.diag;

'0':begin ra:=0;rb:=0;rc:=0;end;

's':begin delay(100);readkey;end;

'n':atr;

'c':fig[1]:=not fig[1];

'd':fig[2]:=not fig[2];

't':fig[3]:=not fig[3];

end;end;

until   k=#27;

closegraph;

end.

​