old/PAS/VGATEST.PAS

Uses CRT;
Const
  xSize = 320;
  ySize = 200;
  dist = 320;

Type Vertex = record
  X,Y,Z : longint;
  sx,sy : longint;
End;

Type Face = record
  V : array [0..2] of Vertex;
  color : byte
end;

Var
  vmem : array [0..199,0..319] of byte absolute $A000:$0000;
  buff : array [0..199,0..319] of byte;
  fa : array [0..11] of face;
{------------------------------------------------}
Procedure rHorLine(X1,X2,Y:word;color:byte);
Begin
  If X1>X2 then
   begin
     X2 := X1 xor X2;
     X1 := X1 xor X2;
     X2 := X1 xor X2;
   end;
  for X1 := X1 to X2 do buff[Y,X1] := color;
End;{rLine}
{----------------------------------}
Procedure rSetFace;
Begin
  fa[0].v[1].x := -25;
  fa[0].v[1].y := -25;
  fa[0].v[1].z := 25;

  fa[0].v[2].x := 25;
  fa[0].v[2].y := -25;
  fa[0].v[2].z := 25;

  fa[0].v[0].x := -25;
  fa[0].v[0].y := 25;
  fa[0].v[0].z := 25;
  fa[0].color := 1;
  fa[1].color := 1;
  fa[2].color := 2;
  fa[3].color := 2;
  fa[4].color := 3;
  fa[5].color := 3;
  fa[6].color := 4;
  fa[7].color := 4;
  fa[8].color := 5;
  fa[9].color := 5;
  fa[10].color := 6;
  fa[11].color := 6;

  fa[1].v[1].x := -25;
  fa[1].v[1].y := 25;
  fa[1].v[1].z := 25;

  fa[1].v[2].x := 25;
  fa[1].v[2].y := -25;
  fa[1].v[2].z := 25;

  fa[1].v[0].x := 25;
  fa[1].v[0].y := 25;
  fa[1].v[0].z := 25;

  fa[2].v[1].x := 25;
  fa[2].v[1].y := 25;
  fa[2].v[1].z := 25;

  fa[2].v[2].x := 25;
  fa[2].v[2].y := -25;
  fa[2].v[2].z := 25;

  fa[2].v[0].x := 25;
  fa[2].v[0].y := -25;
  fa[2].v[0].z := -25;

  fa[3].v[1].x := 25;
  fa[3].v[1].y := 25;
  fa[3].v[1].z := 25;

  fa[3].v[2].x := 25;
  fa[3].v[2].y := 25;
  fa[3].v[2].z := -25;

  fa[3].v[0].x := 25;
  fa[3].v[0].y := -25;
  fa[3].v[0].z := 25;

  fa[4].v[1].x := 25;
  fa[4].v[1].y := 25;
  fa[4].v[1].z := -25;

  fa[4].v[2].x := 25;
  fa[4].v[2].y := -25;
  fa[4].v[2].z := -25;

  fa[4].v[0].x := -25;
  fa[4].v[0].y := -25;
  fa[4].v[0].z := -25;

  fa[5].v[1].x := -25;
  fa[5].v[1].y := 25;
  fa[5].v[1].z := -25;

  fa[5].v[2].x := 25;
  fa[5].v[2].y := 25;
  fa[5].v[2].z := 25;

  fa[5].v[0].x := -25;
  fa[5].v[0].y := -25;
  fa[5].v[0].z := -25;

  fa[6].v[1].x := -25;
  fa[6].v[1].y := 25;
  fa[6].v[1].z := -25;

  fa[6].v[2].x := -25;
  fa[6].v[2].y := -25;
  fa[6].v[2].z := -25;

  fa[6].v[0].x := -25;
  fa[6].v[0].y := -25;
  fa[6].v[0].z := 25;

  fa[7].v[1].x := -25;
  fa[7].v[1].y := 25;
  fa[7].v[1].z := -25;

  fa[7].v[2].x := -25;
  fa[7].v[2].y := 25;
  fa[7].v[2].z := 25;

  fa[7].v[0].x := -25;
  fa[7].v[0].y := -25;
  fa[7].v[0].z := 25;

  fa[8].v[1].x := -25;
  fa[8].v[1].y := 25;
  fa[8].v[1].z := 25;

  fa[8].v[2].x := 25;
  fa[8].v[2].y := 25;
  fa[8].v[2].z := 25;

  fa[8].v[0].x := 25;
  fa[8].v[0].y := 25;
  fa[8].v[0].z := -25;

  fa[9].v[1].x := 25;
  fa[9].v[1].y := 25;
  fa[9].v[1].z := -25;

  fa[9].v[2].x := -25;
  fa[9].v[2].y := 25;
  fa[9].v[2].z := -25;

  fa[9].v[0].x := -25;
  fa[9].v[0].y := 25;
  fa[9].v[0].z := 25;

  fa[10].v[1].x := 25;
  fa[10].v[1].y := -25;
  fa[10].v[1].z := 25;

  fa[10].v[2].x := 25;
  fa[10].v[2].y := -25;
  fa[10].v[2].z := -25;

  fa[10].v[0].x := -25;
  fa[10].v[0].y := -25;
  fa[10].v[0].z := 25;

  fa[11].v[1].x := -25;
  fa[11].v[1].y := -25;
  fa[11].v[1].z := 25;

  fa[11].v[2].x := -25;
  fa[11].v[2].y := -25;
  fa[11].v[2].z := -25;

  fa[11].v[0].x := 25;
  fa[11].v[0].y := -25;
  fa[11].v[0].z := -25;

End;
{-----------------------------------}
Procedure rRotateX(var f:face;angle : real);
Var
 cs,sn,NewX,NewY,NewZ : real;
 i : integer;
Begin
 cs:=cos(angle*3.14/180);
 sn:=sin(angle*3.14/180);
 for i:=0 to 2 do
  Begin
    NewX:=f.v[i].x;
    NewY:=f.v[i].y*cs-f.v[i].z*sn;
    NewZ:=f.v[i].y*sn+f.v[i].z*cs;
    f.v[i].x:=round(NewX);
    f.v[i].y:=round(NewY);
    f.v[i].z:=round(NewZ);
  End;
End;
{----------------------------------}
Procedure rRotateY(var f:face;angle : real);
Var
 cs,sn,NewX,NewY,NewZ : real;
 i : integer;
Begin
 cs:=cos(angle*3.14/180);
 sn:=sin(angle*3.14/180);

 for i:=0 to 2 do
  Begin
    NewX:=f.v[i].x*cs-f.v[i].y*sn;
    NewY:=f.v[i].x*sn+f.v[i].y*cs;
    NewZ:=f.v[i].z;
    f.v[i].x:=round(NewX);
    f.v[i].y:=round(NewY);
    f.v[i].z:=round(NewZ);
  End;
End;
{-----------------------------------------}
Procedure rRotateZ(var f:face;angle : real);
Var
 cs,sn,NewX,NewY,NewZ : real;
 i : integer;
Begin
 cs:=cos(angle*3.14/180);
 sn:=sin(angle*3.14/180);

 for i:=0 to 2 do
  Begin
    NewX:=f.v[i].x*cs-f.v[i].z*sn;
    NewY:=f.v[i].y;
    NewZ:=f.v[i].x*sn+f.v[i].z*cs;

    f.v[i].x:=round(NewX);
    f.v[i].y:=round(NewY);
    f.v[i].z:=round(NewZ);
  End;
End;
{-------------------------------------}
Procedure rProjectVertex(var v : vertex);
Begin
  v.sx := round(xSize/2 + v.x * dist / (v.z + dist));
  v.sy := round(ySize/2 - v.y * dist / (v.z + dist));
End;
{--------------------------------}
Procedure rTreug(X1,Y1,X2,Y2,X3,Y3: longint;color:byte);
Var
  tmx,tmy,_x1,_x2,sx,sy,tmp : longint;

Begin
  if Y1>Y3 then
   Begin
    tmx := X1;
    tmy := Y1;
    X1:=X3;
    Y1:=Y3;
    X3:=tmx;
    Y3:=tmy;
   End;
  if (Y1 > Y2) then
   Begin
    tmx := X1;
    tmy := Y1;
    X1:=X2;
    Y1:=Y2;
    X2:=tmx;
    Y2:=tmy;
   End;
  if (Y2 > Y3) then
   Begin
    tmx := X2;
    tmy := Y2;
    X2:=X3;
    Y2:=Y3;
    X3:=tmx;
    Y3:=tmy;
   End;
  for sy := Y1 to Y3 do
   Begin
     if (Y3<>Y1) then
     _x1 := round(X1 + (sy - Y1) * (X3 - X1) / (Y3 - Y1));
     if sy < Y2 then _x2 := round(X1 + (sy - Y1) * (X2 - X1) / (Y2 - Y1))
     else
      Begin
       if (Y3 = Y2) then _x2 := X2
       else _x2 := round(X2 + (sy - Y2) * (X3 - X2) / (Y3 - Y2));
   End;
   rHorLine(_x1,_x2,sy,color);
  End;
End;

{--------------------------------}
Procedure rShowFace(var f:face);
Var
  a,b,c: vertex;

Begin
  a := f.v[0];
  b := f.v[1];
  c := f.v[2];

  rProjectVertex(a);
  rProjectVertex(b);
  rProjectVertex(c);

  rTreug(a.sx,a.sy,b.sx,b.sy,c.sx,c.sy,f.color);
End;
{--------------}

procedure rSetMode(mode:byte);assembler;
 asm
  pushf
  mov ah,00h
  mov al,mode
  int 10h
  popf
end;{rSetMode}
{---------------------------------}
Procedure rShowScr;
Begin
  move(buff,vmem,sizeof(buff));
End;{ShowScr}
{---------------------------------}

Var
  i,j : byte;
  ch : char;
Begin
  rSetFace;
  rSetMode($13);
  for i := 0 to 11 do rShowFace(fa[1]);
  rShowScr;
  while (ch <> #27) do
  begin
    if keypressed then
    begin
      ch:=readkey;
      if ch = #0 then ch := readkey;
      case ch of
        #72: for j:=0 to 11 do rRotateX(fa[j],5);
	#80: for j:=0 to 11 do rRotateX(fa[j],-5);
	#75: for j:=0 to 11 do rRotateY(fa[j],5);
	#77: for j:=0 to 11 do rRotateY(fa[j],-5);
	#73: for j:=0 to 11 do rRotateZ(fa[j],5);
	#81: for j:=0 to 11 do rRotateZ(fa[j],-5);
      end;
      fillchar(buff,sizeof(buff),0);
      for j:=0 to 11 do rShowFace(fa[j]);
      rShowScr;
    end;
  end;
  rSetMode($03);
End.