home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 18 / CD_ASCQ_18_111294_W.iso / dos / prg / pas / gfxfx / copper6.pas < prev    next >
Pascal/Delphi Source File  |  1994-06-22  |  1KB  |  55 lines
  1.  
  2. program copper;
  3. { Real-time color-mix-copper (6 for slow systems),
  4.   by Bas van Gaalen, Holland, PD }
  5. uses crt;
  6. const size=300; step=25; bars=3;
  7. var
  8.   pal:array[0..3*size-1] of byte;
  9.   stab:array[0..255] of word;
  10.   bartab:array[0..bars-1] of word;
  11.  
  12. procedure createtab; var i:byte; begin
  13.   for i:=0 to 255 do stab[i]:=round(sin(2*pi*i/255)*86)+86; end;
  14.  
  15. procedure movebars;
  16. var n,i:word;
  17. begin
  18.   fillchar(pal,3*size,0);
  19.   for n:=0 to bars-1 do begin
  20.     for i:=0 to 63 do pal[n mod 3+3*stab[bartab[n]]+3*i]:=i;
  21.     for i:=0 to 63 do pal[n mod 3+3*stab[bartab[n]]+3*64+3*i]:=63-i;
  22.     bartab[n]:=1+bartab[n] mod 255;
  23.   end;
  24. end;
  25.  
  26. procedure copperbars;
  27. var cc,l:word;
  28. begin
  29.   asm cli end;
  30.   while (port[$3da] and 8)<>0 do;
  31.   while (port[$3da] and 8)=0 do;
  32.   cc:=0;
  33.   for l:=0 to size-1 do begin
  34.     port[$3c8]:=0;
  35.     port[$3c9]:=pal[cc];
  36.     port[$3c9]:=pal[cc+1];
  37.     while (port[$3da] and 1)<>0 do;
  38.     while (port[$3da] and 1)=0 do;
  39.     port[$3c9]:=pal[cc+2];
  40.     inc(cc,3);
  41.   end;
  42.   asm sti end;
  43. end;
  44.  
  45. var i:byte;
  46. begin
  47.   fillchar(pal,sizeof(pal),0);
  48.   for i:=0 to bars-1 do bartab[i]:=step*i;
  49.   createtab;
  50.   repeat
  51.     movebars;
  52.     copperbars;
  53.   until keypressed;
  54. end.
  55.