{$G+}

{
 *****************************************************
   VIRTUAL BALLS by PARADiSE ( aka Marcin Jaskowiak )
   1994.22.08 9.10am

   Very BIG thanx to WELTI for his asm routines.
   Greetz to all who need it...
 *****************************************************
}

uses crt,dos;
Const
 tekst = 'VIRTUAL BALLS (C) 1994 by PARADiSE ';
Const
 BP : Array [1..24,1..3] of Byte =
 (( 0, 0, 0),  ( 0, 0,12),  ( 4, 4,12),  ( 4, 4,16),  ( 4, 4,20),
  ( 4, 4,24),  ( 8, 8,24),  ( 8, 8,28),  ( 8, 8,32),  ( 8, 8,36),
  (12,12,40),  (12,12,44),  (12,12,48),  (12,12,52),  (16,16,48),
  (16,16,52),  (16,16,56),  (20,20,56),  (20,20,60),  (24,24,60),
  (28,28,60),  (32,32,60),  (36,36,60),  (60,60,60));
 VBall: Array [1..33,1..25] of Byte =
 ((0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0),
  (0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 8, 9,10,10,10, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0),
  (0, 0, 0, 0, 0, 0, 0, 0, 8, 9,10,11,11,12,12,12,11, 0, 0, 0, 0, 0, 0, 0, 0),
  (0, 0, 0, 0, 0, 0, 5, 8, 9,10,11,11,12,12,13,13,12,12,10, 0, 0, 0, 0, 0, 0),
  (0, 0, 0, 0, 0, 5, 7, 9,10,11,11,12,12,13,15,15,15,15,12,11, 0, 0, 0, 0, 0),
  (0, 0, 0, 0, 4, 7, 8, 9,10,11,12,12,13,15,15,16,16,15,15,12,10, 0, 0, 0, 0),
  (0, 0, 0, 0, 5, 7, 8, 9,10,11,12,12,13,15,16,16,16,16,15,13,12, 0, 0, 0, 0),
  (0, 0, 0, 4, 6, 8, 9,10,10,11,12,12,13,15,16,16,16,16,16,15,12,11, 0, 0, 0),
  (0, 0, 2, 4, 7, 8, 9,10,10,11,12,12,13,15,15,16,16,16,16,15,13,12, 8, 0, 0),
  (0, 0, 3, 5, 7, 8, 9,10,10,11,12,12,13,15,15,16,16,16,16,15,13,12,10, 0, 0),
  (0, 0, 3, 5, 7, 8, 9, 9,10,11,11,12,12,15,16,16,16,16,15,15,13,12,11, 0, 0),
  (0, 2, 4, 5, 7, 8, 9, 9,10,11,11,12,12,19,22,18,15,15,15,15,13,12,11, 8, 0),
  (0, 2, 4, 5, 7, 8, 8, 9,10,10,11,11,14,22,23,22,15,15,15,13,12,12,11, 9, 0),
  (0, 2, 4, 5, 6, 7, 8, 9, 9,10,11,11,12,21,23,22,15,13,13,12,12,12,11, 9, 0),
  (0, 2, 3, 4, 6, 7, 8, 9, 9,10,10,11,11,15,20,17,12,12,12,12,12,11,10, 9, 0),
  (0, 2, 3, 4, 5, 7, 8, 8, 9, 9,10,10,11,11,12,12,12,12,12,12,11,11,10, 9, 0),
  (0, 2, 3, 4, 5, 7, 7, 8, 8, 9,10,10,10,11,11,11,11,11,11,11,11,10,10, 8, 0),
  (0, 2, 3, 4, 4, 6, 7, 8, 8, 9, 9,10,10,10,11,11,11,11,11,11,10,10, 9, 8, 0),
  (0, 2, 3, 3, 4, 5, 7, 7, 8, 8, 9, 9, 9,10,10,10,10,10,10,10,10, 9, 9, 7, 0),
  (0, 2, 2, 3, 4, 5, 5, 7, 7, 8, 8, 9, 9, 9,10,10,10,10,10,10, 9, 9, 8, 7, 0),
  (0, 1, 2, 3, 4, 4, 5, 6, 7, 7, 8, 8, 9, 9, 9, 9, 9, 9, 9, 9, 9, 8, 7, 5, 0),
  (0, 1, 2, 3, 3, 4, 4, 5, 6, 7, 7, 8, 8, 8, 8, 9, 9, 9, 9, 8, 8, 8, 7, 4, 0),
  (0, 1, 2, 2, 3, 3, 4, 4, 5, 6, 7, 7, 7, 8, 8, 8, 8, 8, 8, 8, 7, 7, 5, 3, 0),
  (0, 0, 1, 2, 3, 3, 4, 4, 4, 5, 6, 7, 7, 7, 7, 7, 8, 8, 7, 7, 7, 6, 4, 0, 0),
  (0, 0, 1, 2, 2, 3, 3, 4, 4, 4, 5, 5, 6, 7, 7, 7, 7, 7, 7, 6, 5, 4, 3, 0, 0),
  (0, 0, 1, 1, 2, 2, 3, 3, 4, 4, 4, 5, 5, 5, 5, 6, 6, 6, 5, 5, 4, 4, 2, 0, 0),
  (0, 0, 0, 1, 1, 2, 2, 3, 3, 3, 4, 4, 4, 4, 5, 5, 5, 5, 4, 4, 4, 3, 0, 0, 0),
  (0, 0, 0, 0, 1, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 3, 3, 0, 0, 0, 0),
  (0, 0, 0, 0, 1, 1, 1, 2, 2, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 2, 0, 0, 0, 0),
  (0, 0, 0, 0, 0, 1, 1, 1, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 2, 2, 0, 0, 0, 0, 0),
  (0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 1, 0, 0, 0, 0, 0, 0),
  (0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0),
  (0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0));

TYPE  obj = OBJECT
        xres,yres : WORD;
        data : POINTER;
        posx,posy,oldx,oldy: Integer;
        CONSTRUCTOR init;
        PROCEDURE clear;
        PROCEDURE new(xr,yr : WORD);
        DESTRUCTOR done;
        PROCEDURE put;
        PROCEDURE cls;
        PROCEDURE move(nx,ny: Integer);
      END;


VAR
 kt : ARRAY[0..128] OF BOOLEAN;
Var
 ch: char;
 old9: procedure;
 ball: array [1..8] of obj;
 paleta: pointer;
 incx,incy,wspx,wspy: integer;
 decsize,lastkey,i,j,k: integer;
 fillcolor: byte;
 S: String;
 bmp: array[0..199,1..20] of byte;
Const
  MaxBalls = 8;
  xangle: Integer =   160;
  yangle: Integer =    20;
  zangle: Integer =   300;
  distance: Integer = 256;
  direction: Integer =  1;
Type
 VectBallType = Record
                 X,Y,Z,Color: longint;
                End;
Const
    grafseg = $a000;
Var
    Cosine,Sine: Array[0..360] of Real;
    Objects,temp: Array [1..8] of VectBallType;
    dummy: VectBallType;
    color : byte;

PROCEDURE bar(x1,y1,x2,y2 : INTEGER); ASSEMBLER;
VAR i,h,ende : INTEGER;
ASM
  mov   ax, x2
  cmp   ax, x1       { x1 mit x2 vergleichen }
  jae   @l1          { Wenn x2>=x1, dann Vertauschen berspringen }
  xchg  x1, ax       { Hier wird x1 mit x2 vertauscht }
  xchg  x2, ax
  xchg  x1, ax
@l1:
  mov   ax, y2
  cmp   ax, y1       { y1 mit y2 vergleichen }
  jae   @l2          { Wenn y2>=y1, dann Vertauschen berspringen }
  xchg  y1, ax       { Hier wird y1 mit y2 vertauscht }
  xchg  y2, ax
  xchg  y1, ax
@l2:
  mov   ax, x2       { WHILE-Abbruchbedingung }
  mov   ende, ax
  mov   cx, y2       { FOR-Abbruchbedingung }
  sub   cx, y1
  inc   cx
  mov   ax, grafseg  { VioSegment nach ES }
  mov   es, ax
  mov   ax, 320      { VioOffset ausrechnen ... }
  mul   y1
  add   ax, x1
  mov   di, ax       { ... und nach DI }
  mov   dx, x2       { Rechteckbreite ausrechnen ... }
  sub   dx, x1
  inc   dx           { ... und nach DX }
  mov   ah, color    { Farbe fr STOSW nach AX }
  mov   al, color
@forschleife:
  mov  bx, x1
  cmp  dx, 1         { wenn bar nur 1 breit ist, ... }
  je   @while2       { ... dann STOSW berspringen }
  @while1:           { in 2-Pixel-Schritten malen }
    stosw
    add   bx, 2
    cmp   bx, ende
  jb @while1
  mov  h, dx         { berprfen ob Breit gerade ist ... }
  and  h, 1          { wenn ungerade, dann weiter, sonst ... }
  cmp  h, 1          { STOSB berspringen }
  jne  @gerade
  @while2:
  stosb              { Ungeraden Pixel setzen }
  @gerade:
  add   di, 320
  sub   di, dx
loop @forschleife
END;

PROCEDURE vsync;
BEGIN
  REPEAT UNTIL PORT[$03DA] AND 8 = 0;
  REPEAT UNTIL PORT[$03DA] AND 8 <> 0; { Wartet auf vertikalen Rcklauf }
END;

{$F+}
PROCEDURE new9; INTERRUPT;
VAR c : BYTE; ch : CHAR;
BEGIN
  c := PORT[$60];
  IF c>128 THEN kt[c-128] := FALSE ELSE kt[c] := TRUE;
  ASM    mov  al,$20 ;   out  $20,al  END;
END;
{$F-}

PROCEDURE install_readkey;
VAR i : INTEGER;
BEGIN
  FOR i := 0 to 128 DO kt[i] := FALSE;
  GETINTVEC($9,@old9);  SETINTVEC($9,ADDR(new9));
END;

PROCEDURE release_readkey;
BEGIN  SETINTVEC($9,@old9);  END;

function checkkey:boolean;
var oki: boolean; nn: byte;
begin
 oki:=false;
 for nn:=0 to 128 do
  if kt[nn] then begin lastkey:=nn; oki:=true; end;
 checkkey:=oki;
end;

procedure create_lookup_tables;
var i: Integer;
begin
 for i:=0 to 360 do
 begin
   sine[i]  := cos(i*3.13159265/180);
   cosine[i]:= sin(i*3.13159265/180);
 end;
end;

procedure create_vector_object;
begin
 objects[1].x:=-30;
 objects[1].y:=-30;
 objects[1].z:= 30;
 objects[2].x:= 30;
 objects[2].y:=-30;
 objects[2].z:= 31;
 objects[3].x:=-30;
 objects[3].y:= 30;
 objects[3].z:= 32;
 objects[4].x:= 30;
 objects[4].y:= 30;
 objects[4].z:= 33;
 objects[5].x:=-30;
 objects[5].y:=-30;
 objects[5].z:=-30;
 objects[6].x:= 30;
 objects[6].y:=-30;
 objects[6].z:=-31;
 objects[7].x:=-30;
 objects[7].y:= 30;
 objects[7].z:=-32;
 objects[8].x:= 30;
 objects[8].y:= 30;
 objects[8].z:=-33;
 for i:=1 to 8 do
 begin
  objects[i].x:=  objects[i].x;
  objects[i].y:=  objects[i].y;
  objects[i].z:=  objects[i].z;
 end;
end;

procedure drawballs;
begin
 for i:=1 to 8 do ball[i].put;
end;

procedure drawbmp;
var y: integer;
begin
 for y:=0 to 199 do
  move(bmp[y],mem[$a000:y*320+300],20);
end;

procedure draw_vector_object;
var nx,ny,nz,i,j,k,a,b: longint;
    so,ko: Word;
begin
 for i:=1 to 8 do
 begin
  ny:=trunc(objects[i].y*cosine[xangle]-objects[i].z*sine[xangle]);
  nz:=trunc(objects[i].y*sine[xangle]+objects[i].z*cosine[xangle]);
  nx:=trunc(objects[i].x);
  temp[i].x:=nx;
  temp[i].y:=ny;
  temp[i].z:=nz;
  nx:=trunc(temp[i].x*cosine[yangle]+temp[i].z*sine[yangle]);
  nz:=trunc(-temp[i].x*sine[yangle]+temp[i].z*cosine[yangle]);
  temp[i].x:=nx;
  temp[i].z:=nz;
  nx:=trunc(temp[i].x*cosine[zangle]-temp[i].y*sine[zangle]);
  ny:=trunc(temp[i].x*sine[zangle]+temp[i].y*cosine[zangle]);
  temp[i].x:=nx;
  temp[i].y:=ny;
  dec(temp[i].z,distance);
  temp[i].x:=trunc((temp[i].x*256)/temp[i].z+160);
  temp[i].y:=trunc((temp[i].y*256)/temp[i].z+100);
  temp[i].color:=objects[i].color;
 end;
 for j:=1 to 7 do
 begin
  for k:=j+1 to 8 do
  begin
   a:=temp[j].z;
   b:=temp[k].z;
   if (a>=b) then
   begin
    dummy:=temp[j];
    temp[j]:=temp[k];
    temp[k]:=dummy;
   end;
  end;
 end;
 for i:=1 to 8 do
 begin
   ball[i].move(temp[i].x-11-decsize,temp[i].y-15);
   with objects[i] do
   begin
    if x>320 then x:=x mod 320;
    if y>200 then y:=y mod 200;
    if z>200 then z:=z mod 200;
   end;
 end;
 color:=fillcolor;
 bar(90-decsize,20,230-decsize,170);
 vsync;
 drawballs;
end;

PROCEDURE writedac(nr,r,g,b:BYTE); ASSEMBLER;
ASM
  mov dx,$03C8;  mov al,nr;  out dx,al
  mov dx,$03C9;  mov al,r;   out dx,al
  mov dx,$03C9;  mov al,g;   out dx,al
  mov dx,$03C9;  mov al,b;   out dx,al
END;

PROCEDURE sxy(scradr,xgr,ygr:WORD; spr:POINTER); ASSEMBLER;
ASM
    push  ds
    mov   ax, grafseg
    mov   es, ax
    mov   di, scradr
    lds   si, spr
    cld
    mov   bx, 320
    sub   bx, xgr
    mov   dx, ygr
    @yloop:
      mov   cx, xgr
      @xloop:
        lodsb
        cmp al, 0
        je  @schwarz
        mov  es:[di], al
        @schwarz:
        inc  di
      loop @xloop
      add   di, bx
      dec   dx
      cmp   dx, 0
    ja   @yloop;
    pop  ds
END;

CONSTRUCTOR obj.init;
BEGIN
 xres := 0;
 yres := 0;
 data := NIL;
 posx:=0;
 posy:=0;
 oldx:=0;
 oldy:=0;
END;

PROCEDURE obj.move;
BEGIN
 oldx:=posx;
 oldy:=posy;
 posx:=nx;
 posy:=ny;
END;

PROCEDURE obj.new(xr,yr : WORD);
BEGIN
  clear;
  GETMEM(data,xr*yr);
  xres := xr; yres := yr;
END;

PROCEDURE obj.put;
BEGIN
  sxy(posx+320*posy,xres,yres,data);
END;

PROCEDURE obj.cls;
BEGIN
  color:=0;
  bar(oldx,oldy,oldx+xres,oldy+yres);
END;

PROCEDURE obj.clear;
BEGIN
  IF (xres>0) AND (yres>0) THEN FREEMEM(data,xres*yres);
  init;
END;

DESTRUCTOR obj.done;
BEGIN clear; END;






begin
 asm mov ax,0013h; int 10h; end;
 s:=tekst;

 for i:=1 to 24 do writedac(i-1,bp[i,1],bp[i,2],bp[i,3]);
 create_lookup_tables;
 create_vector_object;
 color:=3;
 fillcolor:=0;
 decsize:=0;
 fillchar(bmp,sizeof(bmp),3);

 { sprite : ball - initialize }
 for i:=1 to 8 do
 begin
  ball[i].init;
  ball[i].new(25,33);
  move(vball,ball[i].data^,825);
 end;

 {install_readkey;}
 repeat
  if direction=1 then
  begin
   inc(distance);
   if distance>=600 then
   begin
    direction:=0;
    distance:=600;
   end;
  end else
  begin
   dec(distance);
   if distance<=256 then
   begin
    direction:=1;
    distance:=256;
   end;
  end;
  inc(xangle,3);
  if xangle>=360 then xangle:=0;
  inc(yangle,3);
  if yangle>=360 then yangle:=0;
  dec(zangle,2);
  if zangle<=0 then zangle:=359;
  draw_vector_object;
 until keypressed{checkkey};
 {release_readkey;}

 for i:=1 to 8 do ball[i].done;
 asm mov ax,0003h; int 10h; end;
end.