Umístnení souboru www.TrSek.com/cover/benkovic/texure_p.pas
{ TEXURE_P.PAS                                                      }
{ Vykresli texturu a otacajuci sa stvorec.                          }
{                                                                   }
{ Datum:07.11.2000                             http://www.trsek.com }

{$r-,g+}
program texure_poly;
uses crt;

Type TE = Record  X : Integer; px, py : Byte; End;
  Table = Array[0..199] of TE; PTable = ^Table;

Var
  Left, Right : Table;  stab:array[0..255] of integer;
  polyz:array[0..7] of integer; pind:array[0..7] of byte;
  page,virscr:pointer; pageseg,virseg:word; Frame, St, Et : Longint;
  Time : Longint Absolute $0000:$046c; pxVal, pxStep : Integer;
  pyVal, pyStep : Integer; Count, res : Integer; O1 : Word; b:byte;

Const
  Bitmap :Array[0..16*16-1] of Byte = (
  2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,5,5,5,5,5,5,5,5,5,5,5,5,5,5,2,
  2,5,5,1,1,1,1,1,1,1,1,1,1,5,5,2,2,5,1,5,1,1,1,1,1,1,1,1,5,1,5,2,
  2,5,1,1,5,1,1,1,1,1,1,5,1,1,5,2,2,5,1,1,1,5,1,1,1,1,5,1,1,1,5,2,
  2,5,1,1,1,1,5,1,1,5,1,1,1,1,5,2,2,5,1,1,1,1,1,5,5,1,1,1,1,1,5,2,
  2,5,1,1,1,1,1,5,5,1,1,1,1,1,5,2,2,5,1,1,1,1,5,1,1,5,1,1,1,1,5,2,
  2,5,1,1,1,5,1,1,1,1,5,1,1,1,5,2,2,5,1,1,5,1,1,1,1,1,1,5,1,1,5,2,
  2,5,1,5,1,1,1,1,1,1,1,1,5,1,5,2,2,5,5,1,1,1,1,1,1,1,1,1,1,5,5,2,
  2,5,5,5,5,5,5,5,5,5,5,5,5,5,5,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2);
  pointnum=11; planenum=7; border=false; vidseg:word=$a000;
  divd=128; dist=200; points:array[0..pointnum,0..2] of integer=(
    (-20,-20, 30),( 20,-20, 30),( 40,-40,  0),( 20,-20,-30),
    (-20,-20,-30),(-40,-40,  0),(-20, 20, 30),( 20, 20, 30),
    ( 40, 40,  0),( 20, 20,-30),(-20, 20,-30),(-40, 40,  0));
  planes:array[0..planenum,0..3] of byte=(
    (1,2,8,7),(9,8,2,3),(10,4,5,11),(6,11,5,0),
    (0,1,2,5),(5,2,3,4),(6,7,8,11),(11,8,9,10));
{ -------------------------------------------------------------------------- }
Procedure TextureHLine(X1, X2, px1, py1, px2, py2, Y : Integer; Dim : Word);
 Begin pxStep := ((px2-px1) Shl 8) Div (x2-x1+1);
  pyStep := ((py2-py1) Shl 8) Div (x2-x1+1);
  asm
   mov     bx, px1;
   shl bx, 8;
   mov pxval,bx;  {  pxVal := px1 Shl 8;}
   mov     bx, py1;
   shl bx, 8;
   mov pyval,bx;  {  pyVal := py1 Shl 8;}
   mov     ax,y;
   shl     ax,6;
   mov     di,ax;
   shl     ax,2
   add     di,ax;
   add     di,x1;
   mov     o1, di; End;

  For Count := X1 to X2 do
    Begin
     b:= Bitmap[Hi(pxVal)+(Hi(pyVal)) Shl 4];
     Asm mov ax,virseg;
     mov es,ax;
     mov ax,o1;
     mov di,ax;
     mov al, b;
     mov es:[di],al;
     mov ax, pxval;
     add ax, pxstep;
     mov pxval, ax;
     mov ax, pyval;
     add ax, pystep;
     mov pyval, ax;
     inc o1;
     end;
     End;
     End;

Procedure Swap(Var A, B : Integer);
Var t : Integer; Begin t := a; a := b; b := t; End;

Procedure Texture4Poly(X1, Y1, X2, Y2, X3, Y3, X4, Y4 : Integer; Dim : Byte);
Var yMin, yMax : Integer; xStart, xEnd : Integer; yStart, yEnd : Integer;
  pxStart, pxEnd : Integer; pyStart,pyEnd  : Integer; XVal, XStep : Longint;
  pxVal, pxStep : Integer; pyVal, pyStep : Integer; Count : Integer;
  Side : PTable;
Begin
  yMin := Y1; yMax := Y1;
  If Y2 > yMax Then yMax := Y2; If Y3 > yMax Then yMax := Y3;
  If Y4 > yMax Then yMax := Y4; If Y2 < yMin Then yMin := Y2;
  If Y3 < yMin Then yMin := Y3; If Y4 < yMin Then yMin := Y4;
  xStart := X1; yStart := Y1; xEnd := X2; yEnd := Y2;
  pxStart := 0; pyStart := 0; pxEnd := Dim-1; pyEnd := 0;
  If yStart > yEnd Then Begin
      Swap(xStart, xEnd); Swap(yStart, yEnd); Swap(pxStart, pxEnd);
      Side := @Left; End Else Side := @Right;
  XVal := Longint(xStart) Shl 8;
  XStep := (Longint(xEnd-xStart) Shl 8) Div (yEnd-yStart+1);
  pxVal := pxStart Shl 8;
  pxStep := ((pxEnd-pxStart) Shl 8) Div (yEnd-yStart+1);
  For Count := yStart to yEnd do
    Begin Side^[Count].x := XVal Shr 8; Side^[Count].px := pxVal Shr 8;
      Side^[Count].py := pyStart; XVal := XVal + XStep;
      pxVal := pxVal + pxStep; End;
  xStart := X2; yStart := Y2; xEnd := X3; yEnd := Y3;
  pxStart := Dim-1; pyStart := 0; pxEnd := Dim-1; pyEnd := Dim-1;
  If yStart > yEnd Then Begin Swap(xStart, xEnd); Swap(yStart, yEnd);
      Swap(pyStart, pyEnd); Side := @Left; End Else Side := @Right;
  XVal := Longint(xStart) Shl 8;
  XStep := (Longint(xEnd-xStart) Shl 8) Div (yEnd-yStart+1);
  pyVal := pyStart Shl 8;
  pyStep := ((pyEnd-pyStart) Shl 8) Div (yEnd-yStart+1);
  For Count := yStart to yEnd do
    Begin Side^[Count].x := XVal Shr 8; Side^[Count].py := pyVal Shr 8;
      Side^[Count].px := pxStart; XVal := XVal + XStep;
      pyVal := pyVal + pyStep; End;
  xStart := X3; yStart := Y3; xEnd := X4; yEnd := Y4;
  pxStart := Dim-1; pyStart := Dim-1; pxEnd := 0; pyEnd := Dim-1;
  If yStart > yEnd Then Begin Swap(xStart, xEnd); Swap(yStart, yEnd);
      Swap(pxStart, pxEnd); Side := @Left; End Else Side := @Right;
  XVal := Longint(xStart) Shl 8;
  XStep := (Longint(xEnd-xStart) Shl 8) Div (yEnd-yStart+1);
  pxVal := pxStart Shl 8;
  pxStep := ((pxEnd-pxStart) Shl 8) Div (yEnd-yStart+1);
  For Count := yStart to yEnd do
    Begin Side^[Count].x := XVal Shr 8; Side^[Count].px := pxVal Shr 8;
      Side^[Count].py := pyStart; XVal := XVal + XStep;
      pxVal := pxVal + pxStep; End;
  xStart := X4; yStart := Y4;xEnd := X1; yEnd := Y1;
  pxStart := 0;  pyStart := Dim-1; pxEnd := 0; pyEnd := 0;
  If yStart > yEnd
    Then Begin Swap(xStart, xEnd); Swap(yStart, yEnd);
      Swap(pyStart, pyEnd); Side := @Left; End
    Else Side := @Right;
  XVal := Longint(xStart) Shl 8;
  XStep := (Longint(xEnd-xStart) Shl 8) Div (yEnd-yStart+1);
  pyVal := pyStart Shl 8;
  pyStep := ((pyEnd-pyStart) Shl 8) Div (yEnd-yStart+1);
  For Count := yStart to yEnd do
    Begin Side^[Count].x := XVal Shr 8; Side^[Count].py := pyVal Shr 8;
      Side^[Count].px := pxStart; XVal := XVal + XStep;
      pyVal := pyVal + pyStep; End;
  For Count := yMin to yMax do
    If Left[Count].x < Right[Count].x
      Then TextureHLine(Left[Count].x, Right[Count].x, Left[Count].px, Left[Count].py,
              Right[Count].px, Right[Count].py, Count, Dim)
      Else TextureHLine(Right[Count].x, Left[Count].x, Right[Count].px, Right[Count].py,
              Left[Count].px, Left[Count].py, Count, Dim);
End;

{Asi sa zastrelim..........}

procedure setpal(c,r,g,b:byte); assembler;
asm; mov dx,3c8h; mov al,[c]; out dx,al; inc dx; mov al,[r]; out dx,al
  mov al,[g]; out dx,al; mov al,[b]; out dx,al; end;

procedure flip(src,dst:word); assembler; asm
push ds; mov es,[dst]; mov ds,[src]; xor si,si; xor di,di; mov cx,320*200/2
rep movsw; pop ds; 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=2; yst=3; zst=-4;
var
  xp,yp,z:array[0..11] of integer;
  x,y,i,j,k:integer;
  n,Key,phix,phiy,phiz:byte;
begin
  phix:=0; phiy:=0; phiz:=40; fillchar(xp,sizeof(xp),0);
  fillchar(yp,sizeof(yp),0); Frame := 0; St := Time;
  repeat
    flip(pageseg,virseg);
    for n:=0 to pointnum do begin
      i:=(cosinus(phiy)*points[n,0]-sinus(phiy)*points[n,2]) div divd;
      j:=(cosinus(phiz)*points[n,1]-sinus(phiz)*i) div divd;
      k:=(cosinus(phiy)*points[n,2]+sinus(phiy)*points[n,0]) div divd;
      x:=(cosinus(phiz)*i+sinus(phiz)*points[n,1]) div divd;
      y:=(cosinus(phix)*j+sinus(phix)*k) div divd;
      z[n]:=(cosinus(phix)*k-sinus(phix)*j) div divd+cosinus(phix) div 3;
      xp[n]:=160+sinus(phix) div 2+(-x*dist) div (z[n]-dist);
      yp[n]:=100+(-y*dist) div (z[n]-dist);
    end;
    for n:=0 to planenum do begin
      polyz[n]:=(z[planes[n,0]]+z[planes[n,2]]) div 2; pind[n]:=n; end;
    quicksort(0,planenum);
    for n:=0 to planenum do
      texture4poly(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]],16);
    inc(phix,xst); inc(phiy,yst); inc(phiz,zst); flip(virseg,vidseg);
    inc(frame);
    delay(15);
    until keypressed; Et:=time; end;

var i,j:word;
{$Q-}
begin
  asm mov ax,13h; int 10h; end;
  getmem(virscr,64000);
  virseg:=seg(virscr^);
  getmem(page,64000);
  pageseg:=seg(page^);
  for i:=0 to 255 do stab[i]:=round(sin(i*pi/128)*divd);
  for i:=1 to 104 do setpal(150+i,0,20+i div 4,30+i div 5);
  for i:=0 to 319 do for j:=0 to 199 do mem[pageseg:j*320+i]:=151+(i*i+j*j) mod 104;
  rotate_cube;
  freemem(page,64000);
  freemem(virscr,64000);
  textmode(lastmode);
  Writeln(Frame*18.2/(Et-St):5:2, ' fps');
end.
Copyrigth by Zdeno Sekerak 2007, http://www.trsek.com