Ребят, у кого есть возможность - сабж:

program polygoned_and_shaded_cube;
uses
 crt, dos;
const
 vidseg:word=$a000;
 divd=128;
 dist=150;
 point:array[0..7,0..2] of integer=(
   (-30,-30,-30),(-30,-30,30),(30,-30,30),(30,-30,-30),
   (-30, 30,-30),(-30, 30,30),(30, 30,30),(30, 30,-30));
 planes:array[0..5,0..3] of byte=(
   (0,4,5,1),(0,3,7,4),(0,1,2,3),(4,5,6,7),(7,6,2,3),(1,2,6,5));
var
 stab:array[0..255] of integer;
 polyz:array[0..5] of integer;
 pind:array[0..5] of byte;
 virscr:pointer;
 virseg:word;

{ ------------------------------------------------------------------------ -- }

{ ждём подхода эл. луча к началу экрана (т.е. начало кадра) }
procedure retrace;
begin
 repeat until port[$3da] and 8 <> 0;
 repeat until port[$3da] and 8 = 0
end;

{ ------------------------------------------------------------------------ -- }

{ устанавливаем элемент палитры }
procedure setpal(c,r,g,b:byte);
begin
 port[$3c8] := c;
 port[$3c9] := r;
 port[$3c9] := g;
 port[$3c9] := b
end;

{ ------------------------------------------------------------------------ -- }

{ очистка экрана }
procedure cls(lvseg:word);
begin
 fillchar(mem[lvseg:0], 320*200, 0)
end;

{ копировать область src в dest }
procedure flip(src,dst:word);
begin
 move(mem[src:0], mem[dst:0], 320*200)
end;

{ ------------------------------------------------------------------------ -- }

{ рисуем горизонтальную линию в строке y от xb до xe цветом c }
procedure horline(xb,xe,y:integer; c:byte; where:word);
begin
 if xb > xe then
 begin
   xb := xb xor xe;
   xe := xb xor xe;
   xb := xb xor xe
 end;
 fillchar(mem[where:y*320+xb], xe-xb+1, c)
end;

{ четырёхугольник }
procedure polygon(x1,y1,x2,y2,x3,y3,x4,y4:integer; c:byte);
var
 xpos:array[0..199,0..1] of integer;
 mny,mxy,y:integer;
 i:word;
 s1,s2,s3,s4:shortint;
begin
 mny:=y1;
 if y2<mny then mny:=y2;
 if y3<mny then mny:=y3;
 if y4<mny then mny:=y4;
 mxy:=y1;
 if y2>mxy then mxy:=y2;
 if y3>mxy then mxy:=y3;
 if y4>mxy then mxy:=y4;
 s1:=byte(y1<y2)*2-1;
 s2:=byte(y2<y3)*2-1;
 s3:=byte(y3<y4)*2-1;
 s4:=byte(y4<y1)*2-1;
 y:=y1;
 if y1<>y2 then repeat
   xpos[y,byte(y1<y2)]:=integer(x2-x1)*(y-y1) div (y2-y1)+x1;
   inc(y,s1);
 until y=y2+s1 else xpos[y,byte(y1<y2)]:=x1;
 y:=y2;
 if y2<>y3 then repeat
   xpos[y,byte(y2<y3)]:=integer(x3-x2)*(y-y2) div (y3-y2)+x2;
   inc(y,s2);
 until y=y3+s2 else xpos[y,byte(y2<y3)]:=x2;
 y:=y3;
 if y3<>y4 then repeat
   xpos[y,byte(y3<y4)]:=integer(x4-x3)*(y-y3) div (y4-y3)+x3;
   inc(y,s3);
 until y=y4+s3 else xpos[y,byte(y3<y4)]:=x3;
 y:=y4;
 if y4<>y1 then repeat
   xpos[y,byte(y4<y1)]:=integer(x1-x4)*(y-y4) div (y1-y4)+x4;
   inc(y,s4);
 until y=y1+s4 else xpos[y,byte(y1<y4)]:=x4;
 for y:=mny to mxy do
   horline(xpos[y,0],xpos[y,1],y,c,virseg);
end;

{ ------------------------------------------------------------------------ -- }

procedure quicksort(lo,hi:integer);

procedure sort(l,r:integer);
var i,j,x,y:integer;
begin
 i:=l; j:=r; x:=polyz[(l+r) div 2];
 repeat
   while polyz[i]<x do inc(i);
   while x<polyz[j] do dec(j);
   if i<=j then begin
     y:=polyz[i]; polyz[i]:=polyz[j]; polyz[j]:=y;
     y:=pind[i]; pind[i]:=pind[j]; pind[j]:=y;
     inc(i); dec(j);
   end;
 until i>j;
 if l<j then sort(l,j);
 if i<r then sort(i,r);
end;

begin
 sort(lo,hi);
end;

{ ------------------------------------------------------------------------ -- }

function sinus(i:byte):integer; begin sinus:=stab[i]; end;
function cosinus(i:byte):integer; begin cosinus:=stab[(i+192) mod 255]; end;

{ ------------------------------------------------------------------------ -- }

procedure rotate_cube;
const xst=1; yst=1; zst=-1;
var xp,yp,zp:array[0..7] of integer; x,y,z,i,j,k:integer; n,Key,phix,phiy,phiz:byte;
 done: boolean;
begin
 phix:=0; phiy:=0; phiz:=0;
 fillchar(xp,sizeof(xp),0);
 fillchar(yp,sizeof(yp),0);
 done := false;
 repeat
   retrace;
   for n:=3 to 5 do
     polygon(xp[planes[pind[n],0]],yp[planes[pind[n],0]],
             xp[planes[pind[n],1]],yp[planes[pind[n],1]],
             xp[planes[pind[n],2]],yp[planes[pind[n],2]],
             xp[planes[pind[n],3]],yp[planes[pind[n],3]],0);
   for n:=0 to 7 do begin
     i:=(cosinus(phiy)*point[n,0]-sinus(phiy)*point[n,2]) div divd;
     j:=(cosinus(phiz)*point[n,1]-sinus(phiz)*i) div divd;
     k:=(cosinus(phiy)*point[n,2]+sinus(phiy)*point[n,0]) div divd;
     x:=(cosinus(phiz)*i+sinus(phiz)*point[n,1]) div divd;
     y:=(cosinus(phix)*j+sinus(phix)*k) div divd;
     z:=(cosinus(phix)*k-sinus(phix)*j) div divd;
     xp[n]:=160+(-x*dist) div (z-dist);
     yp[n]:=100+(-y*dist) div (z-dist);
     zp[n]:=z;
   end;
   for n:=0 to 5 do begin
     polyz[n]:=(zp[planes[n,0]]+zp[planes[n,1]]+zp[planes[n,2]]+zp[planes[n,3]]) div 4;
     pind[n]:=n;
   end;
   quicksort(0,5);
   for n:=3 to 5 do
     polygon(xp[planes[pind[n],0]],yp[planes[pind[n],0]],
             xp[planes[pind[n],1]],yp[planes[pind[n],1]],
             xp[planes[pind[n],2]],yp[planes[pind[n],2]],
             xp[planes[pind[n],3]],yp[planes[pind[n],3]],polyz[n]+25);
   flip(virseg,vidseg);
   case port[$60] of
      72: inc(phix); {up}
      80: dec(phix); {down}
      75: dec(phiy); {left}
      77: inc(phiy); {right}
(*
      71,79: inc(phiz); {home,end}
      73,81: dec(phiz); {pgup,pgdn}
*)
      1: done := true {esc}
   end;
   while keypressed do readkey
 until done
end;

{ ------------------------------------------------------------------------ -- }

var i:word;
 r:registers;
begin
 r.ax := $13;
 intr($10, r);
 getmem(virscr,64000);
 virseg:=seg(virscr^);
 cls(virseg);
 for i:=0 to 255 do stab[i]:=round(sin(i*pi/128)*divd);
 for i:=1 to 63 do setpal(i,i div 4,i div 2,i);
 rotate_cube;
 freemem(virscr,64000);
 textmode(lastmode);
end.