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.