home *** CD-ROM | disk | FTP | other *** search
/ Collection of Hack-Phreak Scene Programs / cleanhpvac.zip / cleanhpvac / GFXFX2.ZIP / SPRITES2.PAS < prev    next >
Pascal/Delphi Source File  |  1995-02-14  |  4KB  |  133 lines
  1.  
  2. program testsprites; { SPRITES2.PAS }
  3. { Sprites demo, version 2, by Bas van Gaalen,
  4.   inspired on a transparancy-demo by David Dahl }
  5. uses u_vga,u_pal,u_kb;
  6.  
  7. type
  8.   imgstruc=array[0..8*8-1] of byte;
  9.  
  10. const
  11.   nofsprites=100;
  12.   template:imgstruc=(
  13.     0,0,0,7,6,0,0,0,
  14.     0,7,7,3,3,5,4,0,
  15.     0,7,3,3,3,3,3,0,
  16.     7,3,3,3,3,3,3,2,
  17.     6,3,3,3,3,3,3,1,
  18.     0,5,3,3,3,3,1,0,
  19.     0,4,3,3,3,1,1,0,
  20.     0,0,0,2,1,0,0,0);
  21.  
  22. var
  23.   stab1,stab2:array[0..255] of integer;
  24.   bobs:array[0..2] of imgstruc;
  25.   virscr,bckscr:pointer;
  26.  
  27. {----------------------------------------------------------------------------}
  28.  
  29. procedure initbobs;
  30. const tbl:array[0..2] of byte=(8,16,32);
  31. var i,x,y:byte;
  32. begin
  33.   for i:=0 to 2 do begin
  34.     bobs[i]:=template;
  35.     for x:=0 to 7 do
  36.       for y:=0 to 7 do
  37.         if bobs[i][y*8+x]>0 then bobs[i][y*8+x]:=bobs[i][y*8+x] or tbl[i];
  38.   end;
  39. end;
  40.  
  41. procedure buildpal;
  42. var pal:pal_type; i:byte;
  43. begin
  44.   fillchar(pal,sizeof(pal),0);
  45.   for i:=0 to 7 do begin
  46.     { make red, green, and blue bobs }
  47.     pal[i or 08].r:=21+(i*6);
  48.     pal[i or 16].g:=21+(i*6);
  49.     pal[i or 32].b:=21+(i*6);
  50.     { make colors where red and green bobs overlap }
  51.     pal[i or 08 or 16].r:=21+(i*6);
  52.     pal[i or 08 or 16].g:=21+(i*6);
  53.     { make colors where red and blue bobs overlap }
  54.     pal[i or 08 or 32].r:=21+(i*6);
  55.     pal[i or 08 or 32].b:=21+(i*6);
  56.     { make colors where green and blue bobs overlap }
  57.     pal[i or 16 or 32].g:=21+(i*6);
  58.     pal[i or 16 or 32].b:=21+(i*6);
  59.     { make colors where red, green and blue bobs overlap }
  60.     pal[i or 08 or 16 or 32].r:=21+(i*6);
  61.     pal[i or 08 or 16 or 32].g:=21+(i*6);
  62.     pal[i or 08 or 16 or 32].b:=21+(i*6);
  63.   end;
  64.   { make colors where the grey square overlaps the bobs }
  65.   for i:=128 to 255 do begin
  66.     pal[i].r:=(pal[i-128].r div 3)+14;
  67.     pal[i].g:=(pal[i-128].g div 3)+14;
  68.     pal[i].b:=(pal[i-128].b div 3)+14;
  69.   end;
  70.   setpal(pal);
  71. end;
  72.  
  73. procedure createsprite(nr:byte);
  74. begin
  75.   with sprite[nr] do begin
  76.     xpos:=0; ypos:=0;
  77.     xsize:=8; ysize:=8;
  78.     buf:=@bobs[nr mod 3];
  79.     seethru:=-1;
  80.     transparant:=true;
  81.   end;
  82. end;
  83.  
  84. {----------------------------------------------------------------------------}
  85.  
  86. var idxarr1,idxarr2:array[1..maxsprites] of byte; ci,cis,i,j:word;
  87. begin
  88.   setvideo($13);
  89.   initbobs;
  90.   buildpal;
  91.   for i:=1 to nofsprites do begin
  92.     createsprite(i);
  93.     idxarr1[i]:=20+i*3; idxarr2[i]:=50-i*5;
  94.   end;
  95.   for i:=0 to 255 do begin
  96.     stab1[i]:=round(sin(i*2*pi/255)*100)+100;
  97.     stab2[i]:=round(cos(i*2*pi/255)*50)+50;
  98.   end;
  99.   getmem(virscr,64000); cls(virscr,64000);
  100.   getmem(bckscr,64000); cls(bckscr,64000);
  101.   for i:=160 to 319 do for j:=0 to 199 do
  102.     mem[seg(bckscr^):j*320+i]:=128;
  103.   destenation:=bckscr;
  104.   getfont(font8x16);
  105.   writetxt('Apperantly',10,80,255);
  106.   writetxt('this is',20,100,255);
  107.   writetxt('possible',18,120,255);
  108.   flip(bckscr,virscr,64000);
  109.   destenation:=virscr;
  110.   ci:=0; cis:=0;
  111.   {u_border:=true;}
  112.   repeat
  113.     for i:=1 to nofsprites do begin
  114.       movesprabs(i,stab1[idxarr1[i]]+stab2[idxarr2[i]],120+(stab2[idxarr1[i]]-stab1[idxarr2[i]]) shr 1);
  115.       inc(idxarr1[i],1); inc(idxarr2[i],2);
  116.     end;
  117.     vretrace;
  118.     setborder(15);
  119.     for i:=1 to nofsprites do putback(bckscr,virscr,i);
  120.     for i:=1 to nofsprites do putsprite(i);
  121.     setborder(0);
  122.     flip(virscr,vidptr,64000);
  123.     if ci<63 then begin
  124.       setrgb(255,128+ci,128+ci,128+ci);
  125.       inc(cis);
  126.       if cis=2 then begin cis:=0; inc(ci); end;
  127.     end;
  128.   until keypressed;
  129.   freemem(virscr,64000); freemem(bckscr,64000);
  130.   clearkeybuf;
  131.   setvideo(u_lm);
  132. end.
  133.