home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 18 / CD_ASCQ_18_111294_W.iso / dos / prg / pas / gfxfx / 3dcubesh.pas < prev    next >
Pascal/Delphi Source File  |  1994-06-22  |  7KB  |  261 lines
  1.  
  2. {$r-}
  3. program polygoned_and_shaded_cube;
  4. uses
  5.   crt;
  6. const
  7.   border=false;
  8.   vidseg:word=$a000;
  9.   divd=128;
  10.   dist=150;
  11.   point:array[0..7,0..2] of integer=(
  12.     (-30,-30,-30),(-30,-30,30),(30,-30,30),(30,-30,-30),
  13.     (-30, 30,-30),(-30, 30,30),(30, 30,30),(30, 30,-30));
  14.   planes:array[0..5,0..3] of byte=(
  15.     (0,4,5,1),(0,3,7,4),(0,1,2,3),(4,5,6,7),(7,6,2,3),(1,2,6,5));
  16. var
  17.   stab:array[0..255] of integer;
  18.   polyz:array[0..5] of integer;
  19.   pind:array[0..5] of byte;
  20.   virscr:pointer;
  21.   virseg:word;
  22.  
  23. { -------------------------------------------------------------------------- }
  24.  
  25. procedure setborder(col:byte); assembler;
  26. asm
  27.   xor ch,ch
  28.   mov cl,border
  29.   jcxz @out
  30.   mov dx,3dah
  31.   in al,dx
  32.   mov dx,3c0h
  33.   mov al,11h+32
  34.   out dx,al
  35.   mov al,col
  36.   out dx,al
  37.  @out:
  38. end;
  39.  
  40. { -------------------------------------------------------------------------- }
  41.  
  42. procedure retrace; assembler;
  43. asm
  44.   mov dx,3dah
  45.  @vert1:
  46.   in al,dx
  47.   test al,8
  48.   jz @vert1
  49.  @vert2:
  50.   in al,dx
  51.   test al,8
  52.   jnz @vert2
  53. end;
  54.  
  55. { -------------------------------------------------------------------------- }
  56.  
  57. procedure setpal(c,r,g,b:byte); assembler;
  58. asm
  59.   mov dx,3c8h
  60.   mov al,[c]
  61.   out dx,al
  62.   inc dx
  63.   mov al,[r]
  64.   out dx,al
  65.   mov al,[g]
  66.   out dx,al
  67.   mov al,[b]
  68.   out dx,al
  69. end;
  70.  
  71. { -------------------------------------------------------------------------- }
  72.  
  73. procedure cls(lvseg:word); assembler;
  74. asm
  75.   mov es,[lvseg]
  76.   xor di,di
  77.   xor ax,ax
  78.   mov cx,320*200/2
  79.   rep stosw
  80. end;
  81.  
  82. procedure flip(src,dst:word); assembler;
  83. asm
  84.   push ds
  85.   mov ax,[dst]
  86.   mov es,ax
  87.   mov ax,[src]
  88.   mov ds,ax
  89.   xor si,si
  90.   xor di,di
  91.   mov cx,320*200/2
  92.   rep movsw
  93.   pop ds
  94. end;
  95.  
  96. { -------------------------------------------------------------------------- }
  97.  
  98. procedure horline(xb,xe,y:integer; c:byte; where:word); assembler;
  99. asm
  100.   mov bx,[xb]
  101.   cmp bx,0              { if zero don't draw }
  102.   jz @out
  103.   mov cx,[xe]
  104.   jcxz @out
  105.   cmp bx,cx             { see if x-end is smaller than x-begin }
  106.   jb @skip
  107.   xchg bx,cx            { yes: switch coords }
  108.  @skip:
  109.   dec bx                { atatch planes }
  110.   inc cx
  111.   sub cx,bx             { length of line in cx }
  112.   mov es,[where]        { segment to draw in }
  113.   mov ax,[y]            { heigth of line }
  114.   shl ax,6
  115.   mov di,ax
  116.   shl ax,2
  117.   add di,ax             { y*320 in di (offset) }
  118.   add di,bx             { add x-begin }
  119.   mov al,[c]            { get color }
  120.   shr cx,1              { div length by 2 }
  121.   jnc @skip2            { carry set? }
  122.   stosb                 { draw byte }
  123.  @skip2:
  124.   mov ah,al             { copy color in hi-byte }
  125.   rep stosw             { draw (rest of) line }
  126.  @out:
  127. end;
  128.  
  129. procedure polygon(x1,y1,x2,y2,x3,y3,x4,y4:integer; c:byte);
  130. var
  131.   xpos:array[0..199,0..1] of integer;
  132.   mny,mxy,y:integer;
  133.   i:word;
  134.   s1,s2,s3,s4:shortint;
  135. begin
  136.   mny:=y1;
  137.   if y2<mny then mny:=y2;
  138.   if y3<mny then mny:=y3;
  139.   if y4<mny then mny:=y4;
  140.   mxy:=y1;
  141.   if y2>mxy then mxy:=y2;
  142.   if y3>mxy then mxy:=y3;
  143.   if y4>mxy then mxy:=y4;
  144.   s1:=byte(y1<y2)*2-1;
  145.   s2:=byte(y2<y3)*2-1;
  146.   s3:=byte(y3<y4)*2-1;
  147.   s4:=byte(y4<y1)*2-1;
  148.   y:=y1;
  149.   if y1<>y2 then repeat
  150.     xpos[y,byte(y1<y2)]:=integer(x2-x1)*(y-y1) div (y2-y1)+x1;
  151.     inc(y,s1);
  152.   until y=y2+s1 else xpos[y,byte(y1<y2)]:=x1;
  153.   y:=y2;
  154.   if y2<>y3 then repeat
  155.     xpos[y,byte(y2<y3)]:=integer(x3-x2)*(y-y2) div (y3-y2)+x2;
  156.     inc(y,s2);
  157.   until y=y3+s2 else xpos[y,byte(y2<y3)]:=x2;
  158.   y:=y3;
  159.   if y3<>y4 then repeat
  160.     xpos[y,byte(y3<y4)]:=integer(x4-x3)*(y-y3) div (y4-y3)+x3;
  161.     inc(y,s3);
  162.   until y=y4+s3 else xpos[y,byte(y3<y4)]:=x3;
  163.   y:=y4;
  164.   if y4<>y1 then repeat
  165.     xpos[y,byte(y4<y1)]:=integer(x1-x4)*(y-y4) div (y1-y4)+x4;
  166.     inc(y,s4);
  167.   until y=y1+s4 else xpos[y,byte(y1<y4)]:=x4;
  168.   for y:=mny to mxy do
  169.     horline(xpos[y,0],xpos[y,1],y,c,virseg);
  170. end;
  171.  
  172. { -------------------------------------------------------------------------- }
  173.  
  174. procedure quicksort(lo,hi:integer);
  175.  
  176. procedure sort(l,r:integer);
  177. var i,j,x,y:integer;
  178. begin
  179.   i:=l; j:=r; x:=polyz[(l+r) div 2];
  180.   repeat
  181.     while polyz[i]<x do inc(i);
  182.     while x<polyz[j] do dec(j);
  183.     if i<=j then begin
  184.       y:=polyz[i]; polyz[i]:=polyz[j]; polyz[j]:=y;
  185.       y:=pind[i]; pind[i]:=pind[j]; pind[j]:=y;
  186.       inc(i); dec(j);
  187.     end;
  188.   until i>j;
  189.   if l<j then sort(l,j);
  190.   if i<r then sort(i,r);
  191. end;
  192.  
  193. begin
  194.   sort(lo,hi);
  195. end;
  196.  
  197. { -------------------------------------------------------------------------- }
  198.  
  199. function sinus(i:byte):integer; begin sinus:=stab[i]; end;
  200. function cosinus(i:byte):integer; begin cosinus:=stab[(i+192) mod 255]; end;
  201.  
  202. { -------------------------------------------------------------------------- }
  203.  
  204. procedure rotate_cube;
  205. const xst=1; yst=1; zst=-1;
  206. var xp,yp,zp:array[0..7] of integer; x,y,z,i,j,k:integer; n,Key,phix,phiy,phiz:byte;
  207. begin
  208.   phix:=0; phiy:=0; phiz:=0;
  209.   fillchar(xp,sizeof(xp),0);
  210.   fillchar(yp,sizeof(yp),0);
  211.   repeat
  212.     {retrace;}
  213.     setborder(5);
  214.     for n:=3 to 5 do
  215.       polygon(xp[planes[pind[n],0]],yp[planes[pind[n],0]],
  216.               xp[planes[pind[n],1]],yp[planes[pind[n],1]],
  217.               xp[planes[pind[n],2]],yp[planes[pind[n],2]],
  218.               xp[planes[pind[n],3]],yp[planes[pind[n],3]],0);
  219.     for n:=0 to 7 do begin
  220.       i:=(cosinus(phiy)*point[n,0]-sinus(phiy)*point[n,2]) div divd;
  221.       j:=(cosinus(phiz)*point[n,1]-sinus(phiz)*i) div divd;
  222.       k:=(cosinus(phiy)*point[n,2]+sinus(phiy)*point[n,0]) div divd;
  223.       x:=(cosinus(phiz)*i+sinus(phiz)*point[n,1]) div divd;
  224.       y:=(cosinus(phix)*j+sinus(phix)*k) div divd;
  225.       z:=(cosinus(phix)*k-sinus(phix)*j) div divd;
  226.       xp[n]:=160+(-x*dist) div (z-dist);
  227.       yp[n]:=100+(-y*dist) div (z-dist);
  228.       zp[n]:=z;
  229.     end;
  230.     for n:=0 to 5 do begin
  231.       polyz[n]:=(zp[planes[n,0]]+zp[planes[n,1]]+zp[planes[n,2]]+zp[planes[n,3]]) div 4;
  232.       pind[n]:=n;
  233.     end;
  234.     quicksort(0,5);
  235.     for n:=3 to 5 do
  236.       polygon(xp[planes[pind[n],0]],yp[planes[pind[n],0]],
  237.               xp[planes[pind[n],1]],yp[planes[pind[n],1]],
  238.               xp[planes[pind[n],2]],yp[planes[pind[n],2]],
  239.               xp[planes[pind[n],3]],yp[planes[pind[n],3]],polyz[n]+25);
  240.     inc(phix,xst); inc(phiy,yst); inc(phiz,zst);
  241.     setborder(3);
  242.     flip(virseg,vidseg);
  243.     setborder(0);
  244.   until keypressed;
  245. end;
  246.  
  247. { -------------------------------------------------------------------------- }
  248.  
  249. var i:word;
  250. begin
  251.   asm mov ax,13h; int 10h; end;
  252.   getmem(virscr,64000);
  253.   virseg:=seg(virscr^);
  254.   cls(virseg);
  255.   for i:=0 to 255 do stab[i]:=round(sin(i*pi/128)*divd);
  256.   for i:=1 to 63 do setpal(i,i div 4,i div 2,i);
  257.   rotate_cube;
  258.   freemem(virscr,64000);
  259.   textmode(lastmode);
  260. end.
  261.