home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 18 / CD_ASCQ_18_111294_W.iso / dos / prg / pas / gfxfx / bops.pas < prev    next >
Pascal/Delphi Source File  |  1994-06-22  |  5KB  |  266 lines
  1.  
  2. {$g+}
  3.  
  4. program vectorballs;
  5. { Try to make vectorballs, by Bas van Gaalen, Holland, PD }
  6. uses crt;
  7. const
  8.   vseg : word = $a000;
  9.   spd = 1;
  10.   dist = 100;
  11.   dots = 9;
  12.   divd = 1024;
  13.   dims : array[0..5,0..1] of byte = ((16,13),(14,11),(12,9),(8,7),(6,5),(3,3));
  14.   bal0 : array[0..12,0..15] of byte =
  15.    ((0,0,0,0,0,2,2,2,2,2,2,0,0,0,0,0),
  16.     (0,0,0,2,2,1,1,1,1,1,1,2,2,0,0,0),
  17.     (0,0,2,1,1,1,1,1,1,1,1,1,1,2,0,0),
  18.     (0,2,1,1,1,1,1,1,1,1,1,1,1,1,2,0),
  19.     (0,2,1,1,3,1,1,1,1,1,1,1,1,1,2,0),
  20.     (2,1,1,1,1,1,1,1,1,1,1,1,1,1,1,2),
  21.     (2,1,1,1,1,1,1,1,1,1,1,1,1,1,1,2),
  22.     (2,1,1,1,1,1,1,1,1,1,1,1,1,1,1,2),
  23.     (0,2,1,1,1,1,1,1,1,1,1,1,1,1,2,0),
  24.     (0,2,1,1,1,1,1,1,1,1,1,1,1,1,2,0),
  25.     (0,0,2,1,1,1,1,1,1,1,1,1,1,2,0,0),
  26.     (0,0,0,2,2,1,1,1,1,1,1,2,2,0,0,0),
  27.     (0,0,0,0,0,2,2,2,2,2,2,0,0,0,0,0));
  28.   bal1 : array[0..10,0..13] of byte =
  29.    ((0,0,0,0,2,2,2,2,2,2,0,0,0,0),
  30.     (0,0,2,2,1,1,1,1,1,1,2,2,0,0),
  31.     (0,2,1,1,1,1,1,1,1,1,1,1,2,0),
  32.     (0,2,1,3,1,1,1,1,1,1,1,1,2,0),
  33.     (2,1,1,1,1,1,1,1,1,1,1,1,1,2),
  34.     (2,1,1,1,1,1,1,1,1,1,1,1,1,2),
  35.     (2,1,1,1,1,1,1,1,1,1,1,1,1,2),
  36.     (0,2,1,1,1,1,1,1,1,1,1,1,2,0),
  37.     (0,2,1,1,1,1,1,1,1,1,1,1,2,0),
  38.     (0,0,2,2,1,1,1,1,1,1,2,2,0,0),
  39.     (0,0,0,0,2,2,2,2,2,2,0,0,0,0));
  40.   bal2 : array[0..8,0..11] of byte =
  41.    ((0,0,0,0,2,2,2,2,0,0,0,0),
  42.     (0,0,2,2,1,1,1,1,2,2,0,0),
  43.     (0,2,1,1,1,1,1,1,1,1,2,0),
  44.     (2,1,1,3,1,1,1,1,1,1,1,2),
  45.     (2,1,1,1,1,1,1,1,1,1,1,2),
  46.     (2,1,1,1,1,1,1,1,1,1,1,2),
  47.     (0,2,1,1,1,1,1,1,1,1,2,0),
  48.     (0,0,2,2,1,1,1,1,2,2,0,0),
  49.     (0,0,0,0,2,2,2,2,0,0,0,0));
  50.   bal3 : array[0..6,0..7] of byte =
  51.    ((0,0,2,2,2,2,0,0),
  52.     (2,2,1,1,1,1,2,2),
  53.     (2,1,3,1,1,1,1,2),
  54.     (2,1,1,1,1,1,1,2),
  55.     (2,1,1,1,1,1,1,2),
  56.     (2,2,1,1,1,1,2,2),
  57.     (0,0,2,2,2,2,0,0));
  58.   bal4 : array[0..4,0..5] of byte =
  59.    ((0,2,2,2,2,0),
  60.     (2,2,1,1,2,2),
  61.     (2,1,1,1,1,2),
  62.     (2,2,1,1,2,2),
  63.     (0,2,2,2,2,0));
  64.   bal5 : array[0..2,0..2] of byte =
  65.    ((0,2,0),
  66.     (2,1,2),
  67.     (0,2,0));
  68.   pics : array[0..5] of pointer = (addr(bal0),addr(bal1),addr(bal2),
  69.                                    addr(bal3),addr(bal4),addr(bal5));
  70.  
  71. type
  72.   prec = record x,y,z : integer; end;
  73.   ppos = array[0..dots] of prec;
  74.   styp = array[0..255] of integer;
  75.  
  76. var
  77.   stab : styp;
  78.   dot : ppos;
  79.  
  80. {--------}
  81.  
  82. procedure setpal(col,r,g,b : byte); assembler;
  83. asm
  84.   mov dx,03c8h
  85.   mov al,col
  86.   out dx,al
  87.   inc dx
  88.   mov al,r
  89.   out dx,al
  90.   mov al,g
  91.   out dx,al
  92.   mov al,b
  93.   out dx,al
  94. end;
  95.  
  96. {--------}
  97.  
  98. procedure csin; var i : byte; begin
  99.   for i := 0 to 255 do stab[i] := round(sin(2*i*pi/255)*divd); end;
  100.  
  101. {--------}
  102.  
  103. procedure init;
  104. var i : byte;
  105. begin
  106.   setpal(1,10,10,45);
  107.   setpal(2,0,0,25);
  108.   setpal(3,20,20,60);
  109.   csin;
  110.   for i := 0 to dots do begin
  111.     dot[i].x := 0;
  112.     dot[i].y := 0;
  113.     dot[i].z := -25+i*5;
  114.   end;
  115. end;
  116.  
  117. {--------}
  118.  
  119. procedure drawsprite(x,y : integer; w,h : byte; sprite : pointer); assembler;
  120. asm
  121.   push ds
  122.   lds si,[sprite]
  123.   mov es,vseg
  124.   cld
  125.   mov ax,[y]
  126.   shl ax,6
  127.   mov di,ax
  128.   shl ax,2
  129.   add di,ax
  130.   add di,[x]
  131.   mov bh,[h]
  132.   mov cx,320
  133.   sub cl,[w]
  134.   sbb ch,0
  135.  @l:
  136.   mov bl,[w]
  137.  @l2:
  138.   lodsb
  139.   or al,al
  140.   jz @s
  141.   mov [es:di],al
  142.  @s:
  143.   inc di
  144.   dec bl
  145.   jnz @l2
  146.   add di,cx
  147.   dec bh
  148.   jnz @l
  149.   pop ds
  150. end;
  151.  
  152. {--------}
  153.  
  154. procedure clear(x,y : integer; w,h : byte); assembler;
  155. asm
  156.   push ds
  157.   mov es,vseg
  158.   cld
  159.   mov ax,[y]
  160.   shl ax,6
  161.   mov di,ax
  162.   shl ax,2
  163.   add di,ax
  164.   add di,[x]
  165.   mov bh,[h]
  166.   mov cx,320
  167.   sub cl,[w]
  168.   sbb ch,0
  169.  @l:
  170.   mov bl,[w]
  171.  @l2:
  172.   xor al,al
  173.   mov [es:di],al
  174.  @s:
  175.   inc di
  176.   dec bl
  177.   jnz @l2
  178.   add di,cx
  179.   dec bh
  180.   jnz @l
  181.   pop ds
  182. end;
  183.  
  184.  
  185. {--------}
  186.  
  187. function sinus(i : byte) : integer; begin
  188.   sinus := stab[i]; end;
  189.  
  190. function cosin(i : byte) : integer; begin
  191.   cosin := stab[(i+192) mod 255]; end;
  192.  
  193. {--------}
  194.  
  195. procedure rotate;
  196. const
  197.   xst = 1; yst = 1; zst = 2;
  198. var
  199.   xp,yp,zp : array[0..dots] of integer;
  200.   x,y,z,i,j,k : integer;
  201.   n,phix,phiy,phiz,bnr : byte;
  202. begin
  203.   fillchar(xp,sizeof(xp),0);
  204.   fillchar(yp,sizeof(yp),0);
  205.   fillchar(zp,sizeof(zp),0);
  206.   phix := 0; phiy := 0; phiz := 0;
  207.   repeat
  208.  
  209.     asm
  210.       mov dx,03dah
  211.      @l1:
  212.       in al,dx
  213.       test al,8
  214.       jnz @l1
  215.      @l2:
  216.       in al,dx
  217.       test al,8
  218.       jz @l2
  219.     end; { retrace }
  220.  
  221.     setpal(0,0,0,20);
  222.  
  223.     for n := 0 to dots do begin
  224.       bnr := 3+zp[n] div 16;
  225.       clear(xp[n],yp[n],16,16);
  226.     end;
  227.  
  228.     for n := 0 to dots do begin
  229.       i := (cosin(phiy)*dot[n].x - sinus(phiy)*dot[n].z) div divd;
  230.       j := (cosin(phiz)*dot[n].y - sinus(phiz)*i) div divd;
  231.       k := (cosin(phiz)*dot[n].z + sinus(phiy)*dot[n].x) div divd;
  232.       x  := (cosin(phiz)*i + sinus(phiz)*dot[n].y) div divd;
  233.       y  := (cosin(phix)*j + sinus(phix)*k) div divd;
  234.       z  := (cosin(phix)*k - sinus(phix)*j) div divd;
  235.  
  236.       xp[n] := 160+(-x*dist) div (z-dist);
  237.       yp[n] := 100+(-y*dist) div (z-dist);
  238.       zp[n] := z;
  239.     end;
  240.  
  241.     for n := 0 to dots do begin
  242.       bnr := 3+zp[n] div 16;
  243.       drawsprite(xp[n],yp[n],dims[bnr,0],dims[bnr,1],pics[bnr]);
  244.     end;
  245.  
  246.     inc(phix,xst);
  247.     inc(phiy,yst);
  248.     inc(phiz,zst);
  249.  
  250.     setpal(0,0,0,0);
  251.  
  252.   until keypressed;
  253. end;
  254.  
  255. {--------}
  256.  
  257. begin
  258.   asm mov ax,13h; int 10h; end;
  259.   init;
  260.   rotate;
  261.   while keypressed do readkey;
  262.   textmode(lastmode);
  263. end.
  264.  
  265. { A not very affactive approuch to make vectorballs }
  266.