program haromdforg;

uses crt,zbuffun;

const vga=$a000;

      pontszam=8;

      polynum=5;



type hdpont=record

      x,y,z:single;

     end;



     alkdpont=record

      x,y:word;

      z:single;

     end;



     scrt=array[0..63999] of byte;



     zseged=record

      xmin,xmax:integer;

     end;



     vseged=record

      xmin,xmax:integer;

      zbal,zjobb:single;

     end;



     lt=record

      f,t:byte;

     end;



     polyt=record

      vonal:array[1..4] of lt;

      szin:byte;

     end;





var ch,dh:char;     {getkey}

    cv1,cv2,cv3,cv4,vscry:word;  {alt. cikl.valt}

    temppont:hdpont;

    alfa,beta,gamma:integer; {forgatas szoge}

    sinf,cosf:single; {egy fokos forditashoz}

    keppont:array[1..pontszam] of alkdpont; {perspekiv utan}

    sajatz,nagyit:byte;

    temps:single;

    vscr:^scrt;

    vaddr:word;

    zseg:array[0..199] of zseged;

    vseg:array[0..199] of vseged;

    felso,also:alkdpont;

    yhossz,ymax,ymin:byte;

    xakt,zakt,xlep,zlep:single;

    poly:array[1..polynum] of polyt;

    pontok:array[1..pontszam] of hdpont;

    zbuff:^zbuffo;





procedure init;

 begin

  ch:=#0; dh:=#0;

  alfa:=0; beta:=0; gamma:=0;

  sinf:=sin(5*pi/180); cosf:=cos(5*pi/180);

  sajatz:=40; nagyit:=90;

  new(vscr);

  vaddr:=seg(vscr^);

  new(zbuff,init);

  with poly[1] do begin

   vonal[1].f:=1;

   vonal[1].t:=2;

   vonal[2].f:=2;

   vonal[2].t:=6;

   vonal[3].f:=6;

   vonal[3].t:=5;

   vonal[4].f:=5;

   vonal[4].t:=1;

   szin:=green;

  end;

  with poly[2] do begin

   vonal[1].f:=4;

   vonal[1].t:=3;

   vonal[2].f:=3;

   vonal[2].t:=7;

   vonal[3].f:=7;

   vonal[3].t:=8;

   vonal[4].f:=8;

   vonal[4].t:=4;

   szin:=blue;

  end;

  with poly[3] do begin

   vonal[1].f:=2;

   vonal[1].t:=3;

   vonal[2].f:=3;

   vonal[2].t:=7;

   vonal[3].f:=7;

   vonal[3].t:=6;

   vonal[4].f:=6;

   vonal[4].t:=2;

   szin:=red;

  end;

  with poly[4] do begin

   vonal[1].f:=1;

   vonal[1].t:=5;

   vonal[2].f:=5;

   vonal[2].t:=8;

   vonal[3].f:=8;

   vonal[3].t:=4;

   vonal[4].f:=4;

   vonal[4].t:=1;

   szin:=lightblue;

  end;

  with poly[5] do begin

   vonal[1].f:=6;

   vonal[1].t:=7;

   vonal[2].f:=7;

   vonal[2].t:=8;

   vonal[3].f:=8;

   vonal[3].t:=5;

   vonal[4].f:=5;

   vonal[4].t:=6;

   szin:=yellow;

  end;

  with pontok[1] do begin

   x:=10; y:=10; z:=10;

  end;

  with pontok[2] do begin

   x:=-10; y:=10; z:=10;

  end;

  with pontok[3] do begin

   x:=-10; y:=-10; z:=10;

  end;

  with pontok[4] do begin

   x:=10; y:=-10; z:=10;

  end;

  with pontok[5] do begin

   x:=10; y:=10; z:=-10;

  end;

  with pontok[6] do begin

   x:=-10; y:=10; z:=-10;

  end;

  with pontok[7] do begin

   x:=-10; y:=-10; z:=-10;

  end;

  with pontok[8] do begin

   x:=10; y:=-10; z:=-10;

  end;



  asm

   mov ax,0013h

   int 10h

  end;

 end;



procedure shutdown;

 begin

  asm

   mov ax,0003h

   int 10h

  end;

  dispose(zbuff,dest);

  dispose(vscr);

 end;



procedure getkey;

 begin

  ch:=readkey;

  if ch=#0 then dh:=readkey else dh:=#0;

 end;



procedure forgat;

 begin

  if alfa<>0 then

   begin

    for cv1:=1 to pontszam do

     begin

      with pontok[cv1] do

       begin

        temppont.x:=x;

        temppont.y:=y*cosf+z*sinf;

        temppont.z:=z*cosf-y*sinf;

       end;

      pontok[cv1]:=temppont;

     end;

    alfa:=0;

   end

  else if beta<>0 then

   begin

    for cv1:=1 to pontszam do

     begin

      with pontok[cv1] do

       begin

        temppont.x:=x*cosf-z*sinf;

        temppont.y:=y;

        temppont.z:=x*sinf+z*cosf;

       end;

      pontok[cv1]:=temppont;

     end;

    beta:=0;

   end

  else

   if gamma<>0 then

   begin

    for cv1:=1 to pontszam do

     begin

      with pontok[cv1] do

       begin

        temppont.x:=x*cosf-y*sinf;

        temppont.y:=x*sinf+y*cosf;

        temppont.z:=z;

       end;

      pontok[cv1]:=temppont;

     end;

    gamma:=0;

   end;

 end;



procedure levetit;

 begin

  for cv1:=1 to pontszam do

   begin

    temps:=nagyit/(sajatz-pontok[cv1].z);

    keppont[cv1].x:=160+round(pontok[cv1].x*temps*6/5);

    keppont[cv1].y:=100-round(pontok[cv1].y*temps);

    keppont[cv1].z:=pontok[cv1].z;

    {cutting!!!!!}

   end;

 end;



procedure torolvirtual; assembler;

 asm

  mov ax,vaddr

  mov es,ax

  xor di,di

  mov ax,08080h

  mov cx,32000

  cld

  rep stosw

 end;



procedure masol; assembler;

label l1,l2;

 asm

  push ds

  mov ds,vaddr

  mov ax,vga

  mov es,ax

  xor si,si

  mov di,si

  mov cx,32000

  cld

{  mov dx,3dah

l1:

  in al,dx

  and al,08h             {waitretrace

  jnz l1

l2:

  in al,dx

  and al,08h

  jz  l2}

  rep movsw

  pop ds

 end;



{procedure torolzbuff; assembler;

 asm

  mov ax,zaddr

  mov es,ax

  xor di,di

  mov ax,08080h

  mov cx,32000

  cld

  rep stosw

 end;}



procedure kepkeszit;

 begin

  zbuff^.torol;

  for cv1:=0 to 199 do zseg[cv1].xmax:=-1;



  for cv1:=1 to polynum do

   begin     {minden polyra}

    for cv2:=0 to 199 do vseg[cv2].xmax:=-1;

    ymin:=199; ymax:=0;

    with poly[cv1] do

     begin

      for cv2:=1 to 4 do    {vonal seged keszites}

       with vonal[cv2] do

        begin    {vonalak egyenkent }

         if keppont[f].y>=keppont[t].y then

          begin

           felso:=keppont[t];

           also:=keppont[f];

          end

         else

          begin

           felso:=keppont[f];

           also:=keppont[t];

          end;

         yhossz:=also.y-felso.y;

         if ymin>felso.y then ymin:=felso.y;

         if ymax<also.y then ymax:=also.y;

         xakt:=felso.x; zakt:=felso.z;

         if yhossz=0 then

          begin

           xlep:=0; zlep:=0;

          end

         else

          begin

           xlep:=(also.x-xakt)/yhossz; zlep:=(also.z-zakt)/yhossz;

          end;

         for cv3:=felso.y to also.y do

          with vseg[cv3] do begin

           if xmax=-1 then

            begin

             xmax:=round(xakt); xmin:=xmax;

             zbal:=zakt; zjobb:=zakt;

            end

           else

            if xakt>xmax then begin

              xmax:=round(xakt);

              zjobb:=zakt; end

            else if xakt<xmin then begin

              xmin:=round(xakt);

              zbal:=zakt;

            end;

           xakt:=xakt+xlep; zakt:=zakt+zlep;

          end;    {vegig a sorokon }

        end;     {vonalveg}

      vscry:=ymin*320;

      for cv2:=ymin to ymax do {vscr keszites zbuff es vonalsegeddel}

       begin  {vscr kezd}

        zakt:=vseg[cv2].zbal;

        if vseg[cv2].xmax=vseg[cv2].xmin then zlep:=0

        else zlep:=(vseg[cv2].zjobb-vseg[cv2].zbal)/(vseg[cv2].xmax-vseg[cv2].xmin);

        if zseg[cv2].xmax=-1 then   {ures sor}

         begin

          zseg[cv2].xmin:=vseg[cv2].xmin;

          zseg[cv2].xmax:=vseg[cv2].xmax;

          for cv3:=vseg[cv2].xmin to vseg[cv2].xmax do

           begin

            vscr^[vscry+cv3]:=round(zakt);

            zbuff^.be(cv3,cv2,zakt);

            zakt:=zakt+zlep;

           end;

         end

        else      {a sor nem ures mar}

         begin

          for cv3:=vseg[cv2].xmin to vseg[cv2].xmax do

           begin

            if zakt>zbuff^.ki(cv3,cv2) then

             begin

              vscr^[vscry+cv3]:=round(zakt);

              zbuff^.be(cv3,cv2,zakt);

             end;

            zakt:=zakt+zlep;

           end;

          if zseg[cv2].xmin>vseg[cv2].xmin then zseg[cv2].xmin:=vseg[cv2].xmin;

          if zseg[cv2].xmax<vseg[cv2].xmax then zseg[cv2].xmax:=vseg[cv2].xmax;

         end; {nem ures sor;- vege}

        vscry:=vscry+320;

       end;   {vscr vege egy polyra}

     end;    {poly hivatkozas veg}

   end;      {egy poly kesz}

 end; {kesz a vscr rajzolasra}



procedure setrgb(szin,r,g,b:byte); assembler;

  asm

   mov dx,3c8h

   mov al,szin

   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 setpal;

var i:byte;



 begin

  for i:=0 to 63 do setrgb(((i-31) mod 255),i,i,i);

  setrgb(128,0,0,0);

 end;



procedure main;

 begin

  setpal;

  repeat

   forgat;

   levetit;

   torolvirtual;

   kepkeszit;

   masol;

   getkey;

   case ch of

    'a': alfa:=1;

    's': beta:=1;

    'd': gamma:=1;

    'f': dec(sajatz);

    'v': inc(sajatz);

    'g': inc(nagyit);

    'b': dec(nagyit);

   end;

  until ch=#27;   {escape}

 end;



begin

 init;

 main;

 shutdown;

end.