home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1991 / 01 / asm_eck / setcolor.pas < prev   
Encoding:
Pascal/Delphi Source File  |  1990-10-09  |  3.7 KB  |  157 lines
  1. (* ------------------------------------------------------ *)
  2. (*                     SETCOLOR.PAS                       *)
  3. (*         (c) 1990 by Ralph Seelig & toolbox             *)
  4. (* ------------------------------------------------------ *)
  5. program SetColors;
  6.  
  7. uses crt,dos,graph;
  8.  
  9. const
  10.   raster  : array[0..7] of byte=
  11.     ( $aa, $55, $aa, $55, $aa, $55, $aa, $55 );
  12.   farben  : array[0..4] of byte=
  13.     ( 0, 9, 12, 14, 0);
  14.   farbmuster : array[0..8] of byte=
  15.     ( $13, $10, $11, $32, $30, $33, $21, $20, $22 );
  16.  
  17.   graphpath = '';  { Verzeichnis der BGI Dateien }
  18.   r         : integer = 4;
  19.   xp        = 110;
  20.   yp        = 70;
  21.   a         = 25;
  22.  
  23. var
  24.   gd,gm,
  25.   x,y       : integer;
  26.   f,i       : byte;
  27.   ch        : char;
  28.   datpuffer : array[0..1000] of byte;
  29.   dat       : file;
  30.   datlang   : word;
  31.  
  32. procedure NewPalette(var cf);
  33. { setzt Farben aus der EGA Palette im CGA 4 Farbenmodus }
  34.  
  35. var
  36.   reg     : registers;
  37.   CFarben : array[0..16] of byte;
  38.   i       : byte;
  39. begin
  40.   move(CF,CFarben[0],5);
  41.   cfarben[16]:= cfarben[4];
  42.   for i:= 0 to 16 do
  43.     if cfarben[i]>7 then inc(cfarben[i],8);
  44.   reg.es:= seg(CFarben);
  45.   reg.dx:= ofs(Cfarben);
  46.   reg.al:= 2;
  47.   reg.ah:= $10;
  48.   intr($10,reg);
  49. end;
  50.  
  51. procedure ZeigeEintraege;
  52. begin
  53.   TextColor(3);
  54.   gotoxy(21,1);
  55.   for i:= 0 to 3 do
  56.     write(farben[i],' ');
  57. end;
  58.  
  59. procedure NeueFarben(nr : byte; zeich : char);
  60. begin
  61.   if ord(zeich)> 96 then
  62.     if farben[nr]< 15 then inc(farben[nr])
  63.                       else farben[nr]:= 0
  64.   else
  65.     if farben[nr]> 0 then dec(farben[nr])
  66.                      else farben[nr]:= 15;
  67.   NewPalette(farben);
  68.   ZeigeEintraege;
  69. end;
  70.  
  71.  
  72. function IsBit(zahl : word; stelle : byte) : boolean;
  73. begin
  74.   if odd(zahl shr stelle) then IsBit:= true else IsBit:= false;
  75. end;
  76.  
  77. procedure SetBB(x1,y1,x2,y2 :integer; fa :byte; var muster);
  78. var
  79.   mus      : array[0..7] of byte absolute muster;
  80.   x,y      : integer;
  81.   bz,hz,st : byte;
  82. begin
  83.   hz:= 0;
  84.   for y:= y1 to y2 do
  85.   begin
  86.     st:= 7;
  87.     for x:= x1 to x2 do
  88.     begin
  89.       if isbit(mus[hz],st) then putpixel(x,y,(fa and $0f))
  90.        else putpixel(x,y,(fa shr 4));
  91.       if st> 0 then dec(st) else st:= 7;
  92.     end;
  93.     if hz<7 then inc(hz) else hz:= 0;
  94.   end;
  95. end;
  96.  
  97. begin
  98.   directvideo:= false;
  99.   gd:= 1; gm:= 1;
  100.   initgraph(gd,gm,graphpath);
  101.   NewPalette(farben);
  102.   TextColor(2);
  103.   gotoxy(1,1);  write('Paletteneintraege : ');
  104.   ZeigeEintraege;
  105.   TextColor(1);
  106.   gotoxy(15,6); write('EGA Farben');
  107.   TextColor(2);
  108.   gotoxy(14,7); write('im CGA Modus');
  109.   SetColor(3);
  110.   SetLineStyle(4,$8888,1);
  111.   rectangle(xp-r,yp-r,xp+(3*(r+a)),yp+(3*(r+a)));
  112.   r:= r+a;
  113.   for y:= 0 to 2 do
  114.    for x:= 0 to 2 do
  115.    begin
  116.     f:= Farbmuster[x+(y*3)];
  117.     SetBB((x*r)+xp,(y*r)+yp,(x*r)+xp+a,(y*r)+yp+a,f,raster);
  118.    end;
  119.   ch:= #0;
  120.   repeat
  121.     ch:= readkey;
  122.     case ch of
  123.       'a','A' : neuefarben(0,ch);
  124.       's','S' : neuefarben(1,ch);
  125.       'd','D' : neuefarben(2,ch);
  126.       'f','F' : neuefarben(3,ch);
  127.     end;
  128.   until ch= #27;
  129.    textcolor(3);
  130.    gotoxy(1,25);
  131.    write('Farben in CGACOLOR.COM speichern (J/N) ?');
  132.   repeat
  133.     ch:= upcase(readkey);
  134.   until ch in [#74,#78];
  135.   closegraph;
  136.   if ch = #74 then
  137.   begin
  138.     assign(dat,'cgacolor.com');
  139.     {$I-} reset(dat,1); {$I+}
  140.     if ioresult<> 0 then
  141.     begin
  142.       writeln(#13,#10,'CGACOLOR.COM nicht gefunden',#13,#10);
  143.       halt;
  144.     end;
  145.     datlang:= filesize(dat);
  146.     blockread(dat,datpuffer,datlang);
  147.     close(dat);
  148.     move(farben,datpuffer[$ad],4);
  149.     assign(dat,'cgacolor.com');
  150.       rewrite(dat,1);
  151.       blockwrite(dat,datpuffer,datlang);
  152.     close(dat);
  153.   end;
  154. end.
  155. (* ------------------------------------------------------ *)
  156. (*                 Ende von SETCOLOR.PAS                  *)
  157.