{ gouraud shaded 2-color flagi
  optimized with a banana }

unit flag;

interface
uses routines,polygons;

const vidseg = $a000;
      offi = 24;
      muli = 32;
      depth = 24;
      points = 5*4;
      faces = 4*6;
      face : array[1..faces,1..3] of byte =
      ((1,2,6),(2,6,7),(2,3,7),(3,7,8),(3,4,8),(4,8,9),(4,5,9),(5,9,10),
       (6,7,11),(7,11,12),(7,8,12),(8,12,13),(8,9,13),(9,13,14),(9,10,14),(10,14,15),
       (11,12,16),(12,16,17),(12,13,17),(13,17,18),(13,14,18),(14,18,19),(14,15,19),(15,19,20));
      fcol : array[1..faces] of byte =
       (1,1,2,2,1,1,1,1,
        2,2,2,2,2,2,2,2,
        1,1,2,2,1,1,1,1);

procedure line (x1,y1,x2,y2:word ; col:byte);
procedure initflag;
procedure DrawFlagw;
procedure DrawFlags;
procedure wireflag;
procedure do_gouraud_flag(nosound:boolean);

var point : array[1..points,1..3] of integer;
    trans : array[1..points,1..3] of integer;
    loop : word;
    virscr : pointer;
    virseg : word;
    ctab : array[0..255] of integer;
    sitab,cotab : array[0..255] of real;
    kosi : array[1..points] of byte;
    phi : word;

implementation

procedure line (x1,y1,x2,y2:word ; col:byte); assembler;
var ddx,ddy : word;
    sx,sy : word;                {  This procedure has not been  }
asm                              {  made by me... It came from   }
        mov     ax,virseg        {  some nameless source.        }
        mov     es,ax
        mov     ax,[y1]
        mov     bx,320
        imul    bx
        mov     di,[x1]
        add     di,ax
        mov     ax,[x2]
        clc
        mov     bx,1
        sub     ax,[x1]
        jnc     @@1
        neg     ax
        mov     bx,0ffffh
@@1:    mov     [ddx],ax
        mov     [sx],bx
        mov     ax,[y2]
        clc
        mov     bx,320
        sub     ax,[y1]
        jnc     @@2
        neg     ax
        mov     bx,-320
@@2:    mov     [ddy],ax
        mov     [sy],bx

        cmp     ax,[ddx]
        ja      @@yGrtr
        mov     cx,[ddx]
        inc     cx
        mov     bx,[ddx]
        shr     bx,1
        mov     al,[col]
@@x1:   mov     byte ptr [es:di],al
        add     di,[sx]
        clc
        sub     bx,[ddy]
        jnc     @@xg
        add     di,[sy]
        add     bx,[ddx]
@@xg:   loop    @@x1
        jmp     @@ret
@@yGrtr:mov     cx,[ddy]
        inc     cx
        mov     bx,[ddy]
        shr     bx,1
        mov     al,[col]
@@y1:   mov     byte ptr [es:di],al
        add     di,[sy]
        clc
        sub     bx,[ddx]
        jnc     @@yg
        add     di,[sx]
        add     bx,[ddy]
@@yg:   loop    @@y1
@@ret:
end;

procedure DrawFlagw;
var f,p : word;
    sx,sy : array[1..3] of integer;
    dx,dy,dz:integer;
    za : integer;
    col : integer;
    av : word;

begin
  for f:=1 to faces do begin
    za:=0;

    dx:=point[face[f,1],1];
    dy:=point[face[f,1],2];
    dz:=point[face[f,1],3];
    sx[1]:=round(dx*(256/dz));
    sy[1]:=round(dy*(256/dz));
    za:=za+dz;

    dx:=point[face[f,2],1];
    dy:=point[face[f,2],2];
    dz:=point[face[f,2],3];
    sx[2]:=round(dx*(256/dz));
    sy[2]:=round(dy*(256/dz));
    za:=za+dz;

    dx:=point[face[f,3],1];
    dy:=point[face[f,3],2];
    dz:=point[face[f,3],3];
    sx[3]:=round(dx*(256/dz));
    sy[3]:=round(dy*(256/dz));
    za:=za+dz;

    if fcol[f] = 1 then av := 64 else av := 128+64;

    asm
      mov ax,[av]
      mov bx,256
      mov cx,[za]
      sub bx,cx
      shr bx,1
      sub ax,bx
      mov [col],ax
    end;
    { col:=64-(256-za)shr 1; }
    line(sx[1],sy[1],sx[2],sy[2],col);
    line(sx[2],sy[2],sx[3],sy[3],col);
    line(sx[3],sy[3],sx[1],sy[1],col);
  end;
end;

procedure DrawFlags;
var f,p : word;
    c,sx,sy : array[1..3] of integer;
    dx,dy,dz:integer;
    za : integer;
    col : integer;
    av : word;

begin
  for f:=1 to faces do begin
    if fcol[f] = 1 then av := 64 else av := 128+64;

    for p:=1 to 3 do begin
      dx:=point[face[f,p],1];
      dy:=point[face[f,p],2];
      dz:=point[face[f,p],3];
      sx[p]:=round(dx*(256/dz));
      sy[p]:=round(dy*(256/dz));
      za:=dz;
      asm
        mov ax,[av]
        mov bx,256
        mov cx,[za]
        sub bx,cx
        sub ax,bx
        mov [col],ax
      end;
    { col:=av-(256-za); }
      c[p]:=col;
    end;

    gouraud_poly_real(virseg,sx[1],sy[1],sx[2],sy[2],sx[3],sy[3],c[1],c[2],c[3]);
  end;
end;

procedure rollcos;
begin
  for loop:=0 to points do begin
    if kosi[loop]<254 then inc(kosi[loop],2) else kosi[loop]:=0;
    point[loop,3]:=256+ctab[kosi[loop]];
  end;
end;

procedure initflag;
begin
  for loop:=0 to 255 do ctab[loop]:=round(-cos(loop*pi/128)*depth);
  for loop:=0 to 255 do sitab[loop]:=sin(loop*pi/128);
  for loop:=0 to 255 do cotab[loop]:=cos(loop*pi/128);
  for loop := 1 to 5 do begin
    point[loop,1]:=10+loop*50;
    point[loop,2]:=40;
    kosi[loop]:=offi*0+loop*muli;
    point[loop,3]:=256+ctab[kosi[loop]];
  end;
  for loop := 1 to 5 do begin
    point[loop+5,1]:=10+loop*50;
    point[loop+5,2]:=80;
    kosi[loop+5]:=offi*1+loop*muli;
    point[loop+5,3]:=256+ctab[kosi[loop+5]];
  end;
  for loop := 1 to 5 do begin
    point[loop+10,1]:=10+loop*50;
    point[loop+10,2]:=120;
    kosi[loop+10]:=offi*2+loop*muli;
    point[loop+10,3]:=256+ctab[kosi[loop+10]];
  end;
  for loop := 1 to 5 do begin
    point[loop+15,1]:=10+loop*50;
    point[loop+15,2]:=160;
    kosi[loop+15]:=offi*3+loop*muli;
    point[loop+15,3]:=256+ctab[kosi[loop+15]];
  end;
end;

procedure wireflag;
begin
  initflag;
  mode($13);
  for loop := 1 to 128 do setcol(loop,63-loop div 2,63-loop div 2,63-loop div 2);
  for loop := 1 to 127 do setcol(128+loop,0,0,63-loop div 2);
  getmem(virscr,64000);
  virseg := seg(virscr^);
  repeat
    cls(virseg);
    DrawFlagw;
    rollcos;
    retrace;
    flip(virseg,vidseg);
  until keypressed; flushkb;
  freemem(virscr,64000);
end;

procedure do_gouraud_flag(nosound:boolean);
begin
  cls(vidseg);
  initflag;
  for loop := 1 to 127 do setcol(loop,63-loop div 2,63-loop div 2,63-loop div 2);
  for loop := 1 to 127 do setcol(128+loop,0,0,63-loop div 2);
  getmem(virscr,64000);
  virseg := seg(virscr^);
  phi:=0;
  repeat
    cls(virseg);
    DrawFlags;
    rollcos;
    retrace;
    flip(virseg,vidseg);
  until keypressed;
  freemem(virscr,64000);
end;

end.
