home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 18 / CD_ASCQ_18_111294_W.iso / dos / prg / pas / gfxfx / copper4.pas < prev    next >
Pascal/Delphi Source File  |  1994-04-20  |  2KB  |  64 lines
  1.  
  2. {$g+}
  3. program copper;
  4. { Graphics version of copper-stuff (4), by Bas van Gaalen, Holland, PD }
  5. uses crt;
  6. const
  7.  size=1; { 1 or 2 }
  8.  dither=2; { 0 though 5 }
  9.  pal1 : array [0..3*28-1] of byte =
  10.    (4,4,2,8,8,4,12,12,6,16,16,8,20,20,10,24,24,12,28,28,14,32,32,16,
  11.     36,36,18,40,40,20,44,44,22,48,48,24,52,52,26,52,52,26,56,56,28,
  12.     56,56,28,60,60,30,60,60,30,60,60,30,63,63,33,63,63,33,63,63,33,
  13.     63,63,33,63,63,33,60,60,30,56,56,28,52,52,26,48,48,24);
  14.  pal2 : array [0..3*28-1] of byte =
  15.    (4,2,2,8,4,4,12,6,6,16,8,8,20,10,10,24,12,12,28,14,14,32,16,16,
  16.     36,18,18,40,20,20,44,22,22,48,24,24,52,26,26,52,26,26,56,28,28,
  17.     56,28,28,60,30,30,60,30,30,60,30,30,63,33,33,63,33,33,63,33,33,
  18.     63,33,33,63,33,33,60,30,30,56,28,28,52,26,26,48,24,24);
  19. var fofs,fseg:word;
  20.  
  21. procedure getfont; assembler; asm
  22.   mov ax,1130h; mov bh,6; int 10h; mov fseg,es; mov fofs,bp; end;
  23.  
  24. procedure setpal(var p;start:byte); assembler; asm
  25.   push ds; lds si,[p]; mov al,start; mov dx,03c8h; out dx,al
  26.   inc dx; mov cx,3*28-1; rep outsb; pop ds; end;
  27.  
  28. procedure copperbars;
  29. var l,x:word; lo,lc,cc:byte;
  30. begin
  31.   l:=0; lo:=1;
  32.   while l<>190 do begin
  33.     lc:=lo; inc(lo,size); cc:=0;
  34.     while (lc<>0) and (l<>190) do begin
  35.       for x:=0 to 319 do mem[sega000:l*320+x]:=16+cc+random(dither);
  36.       inc(cc); dec(lc); inc(l);
  37.     end;
  38.   end;
  39. end;
  40.  
  41. procedure writetxt(x,y:word; txt:string);
  42. var i,j,k:byte;
  43. begin
  44.   for i:=1 to length(txt) do for j:=0 to 15 do for k:=0 to 7 do
  45.     if ((mem[fseg:fofs+ord(txt[i])*16+j] shl k) and 128) <> 0 then begin
  46.       mem[$a000:(y+j+1)*320+(i*8)+x+k+1]:=0;
  47.       mem[$a000:(y+j)*320+(i*8)+x+k]:=70-j-k+random(2*dither);
  48.     end;
  49. end;
  50.  
  51. begin
  52.   asm mov ax,13h; int 10h; end;
  53.   setpal(pal1,16); { try pal2 }
  54.   setpal(pal2,50); { try pal1 }
  55.   getfont;
  56.   copperbars;
  57.   writetxt(10,100,'Nothing special...');
  58.   writetxt(10,116,'Looks very gamish, though. ;-)');
  59.   writetxt(10,132,'So-called ''copper''');
  60.   writetxt(10,148,'seems to be working alright.');
  61.   repeat until keypressed;
  62.   textmode(lastmode);
  63. end.
  64.