home *** CD-ROM | disk | FTP | other *** search
/ Hráč 1997 February / Hrac_09_1997-02_cd.bin / UTILS / PROGRAM / 1SVGA.ZIP / PALETTE.PAS < prev    next >
Pascal/Delphi Source File  |  1994-05-26  |  5KB  |  137 lines
  1. { Show & Change Palette/256 Colors }
  2.  
  3. uses SVGA256,Txt;
  4.  
  5. var File1:file;
  6.     Pal:array[0..767] of byte;
  7.  
  8. { ─────────────── Palette ─────────────── }
  9. procedure Palette;
  10. const
  11.   Color:array[0..2] of string[5]=('Red','Green','Blue');
  12.   Help:array[0..6] of string[12]=(
  13.     'RGB','Shade +1','Shade +10','Shade auto','Change color',
  14.     'Copy color','Save & quit');
  15.   Keys:array[0..6] of string[10]=(
  16.     'Up,down','Left,right','Shift L,R','- +','Tab','*','Esc');
  17.   C:array[1..3] of byte=(104,9,15);    { Text,Title,Select }
  18. var K,I,J,P,No:integer;
  19.     St:string[3];
  20.     Font1:array[0..3071] of byte;
  21. { ─────────────── SelectColor ─────────────── }
  22. procedure SelectColor;
  23. var I:integer;
  24. begin
  25.   repeat
  26.     Box(31+20*(No and 15),69+20*(No shr 4),21,21,C[3]);
  27.     K:=Key;
  28.     Box(31+20*(No and 15),69+20*(No shr 4),21,21,C[1]);
  29.     case K of
  30.       $4800:Dec(No,16); $5000:Inc(No,16);  { Up, Down }
  31.       $4B00:Dec(No);    $4D00:Inc(No);     { Left, Right }
  32.     end;
  33.     if No<0 then Inc(No,256); if No>255 then Dec(No,256);
  34.     Bar(480,80,80,16,C[1]);
  35.     Str(No:3,St); Print(480,80,C[3],St);
  36.     for I:=0 to 2 do begin
  37.       Bar(480,100+20*I,80,16,C[1]);
  38.       Str(Pal[3*No+I]:3,St); Print(480,100+20*I,C[3],St);
  39.     end;
  40.     Bar(381,166,108,72,No);
  41.   until (K=$1C0D) or (K=$011B) or (K=$0F09);  { Enter,Esc,Tab }
  42. end;    { End SelectColor }
  43. { ─────────────── CopyColor ─────────────── }
  44. procedure CopyColor;
  45. var T:integer;
  46. begin
  47.   T:=No;
  48.   repeat
  49.     Box(31+20*(No and 15),69+20*(No shr 4),21,21,C[3]);
  50.     K:=Key;
  51.     Box(31+20*(No and 15),69+20*(No shr 4),21,21,C[1]);
  52.     case K of
  53.       $4800:Dec(No,16); $5000:Inc(No,16);  { Up,Down }
  54.       $4B00:Dec(No);    $4D00:Inc(No);     { Left,Right }
  55.     end;
  56.     if No<0 then Inc(No,256);
  57.     if No>255 then Dec(No,256);
  58.   until (K=$1C0D) or (K=$011B);
  59.   Move(Pal[3*T],Pal[3*No],3);  SetPalette(No,1,Pal[3*T]);
  60.   Bar(32+20*(No and 15),70+20*(No shr 4),20,20,T);
  61.   No:=T;
  62. end;    { End CopyColor }
  63. begin
  64.   SetPalette(0,256,Pal);
  65.   FileRead('1616sim#.fnt',0,96,32,Font1);
  66.   InstallFont(2,16,16,32,96,16,Font1);
  67.   Bar(0,0,640,20,C[2]); Bar(0,20,640,440,C[1]); Bar(0,460,640,20,C[2]);
  68.   Print2(20,  2,64,'Palette V1.1/VESA 640x480, 256 Colors');
  69.   Print2(20,462,64,'Copyright (C) 1994 by Jou-Nan Chen');
  70.   for J:=0 to 15 do for I:=0 to 15 do Bar(20*I+32,20*J+70,19,19,16*J+I);
  71.   K:=0; No:=32; P:=0; J:=0;  { J>=0 --> Inc/dec color value }
  72.   Print(380,80,C[3],'Color'); Print(480,80,C[3],' 32');
  73.   for I:=0 to 2 do begin
  74.     Print(380,100+20*I,C[3],Color[I]);
  75.     Str(Pal[3*No+I]:3,St); Print(480,100+20*I,C[3],St);
  76.   end;
  77.   Box(380,165,110,74,C[3]); Bar(381,166,108,72,No);
  78.   for I:=0 to 6 do begin
  79.     Print(380,250+20*I,C[3],Keys[I]);
  80.     Print(480,250+20*I,C[3],Help[I]);
  81.   end;
  82.   Bar(370,100+20*P,80,16,C[2]); Print(380,100+20*P,C[3],Color[0]);
  83.   repeat    { Main loop }
  84.     case J of
  85.       1:begin I:=3*No+P; if Pal[I]>0  then Dec(Pal[I]) else J:=0; end;
  86.       2:begin I:=3*No+P; if Pal[I]<63 then Inc(Pal[I]) else J:=0; end;
  87.     end;
  88.     if J>0 then begin
  89.       SetPalette(No,1,Pal[3*No]);
  90.       Bar(480,100+20*P,80,16,C[1]);
  91.       Str(Pal[I]:3,St); Print(480,100+20*P,C[3],St);
  92.       Delay(30);
  93.     end;
  94.     if KeyPressed=1 then begin
  95.       K:=Key; J:=0;
  96.       Bar(370,100+20*P,80,16,C[1]); Print(380,100+20*P,C[3],Color[P]);
  97.       case K of
  98.     $4800:begin Dec(P); if P<0 then P:=2; end;  { Up }
  99.     $5000:begin Inc(P); if P>2 then P:=0; end;  { Down }
  100.     $4B00:begin I:=3*No+P; if Pal[I]>0  then Dec(Pal[I]); end;  { Left }
  101.     $4D00:begin I:=3*No+P; if Pal[I]<63 then Inc(Pal[I]); end;  { Right }
  102.     $4B34:begin I:=3*No+P; if Pal[I]>9  then Dec(Pal[I],10); end; { s-L }
  103.     $4D36:begin I:=3*No+P; if Pal[I]<54 then Inc(Pal[I],10); end; { s-R }
  104.     $372A:CopyColor;  { * }
  105.     $4A2D:J:=1;
  106.     $4E2B:J:=2;
  107.     $0F09:SelectColor;
  108.       end;    { Left,Rigft,-,+ }
  109.       if (K=$4B00) or (K=$4D00) or (K=$4B34) or (K=$4D36) then begin
  110.     SetPalette(No,1,Pal[3*No]);
  111.     Bar(480,100+20*P,80,16,C[1]);
  112.     Str(Pal[I]:3,St); Print(480,100+20*P,C[3],St);
  113.       end;
  114.       Bar(370,100+20*P,80,16,C[2]); Print(380,100+20*P,C[3],Color[P]);
  115.     end;
  116.   until K=($011B);  { Esc }
  117. end;
  118.  
  119. var I:integer;
  120.     Pal0:array[0..767] of byte;
  121. begin
  122.   if ParamCount=0 then
  123.     begin Writeln('Usage: Palette Filename'); Halt(1); end;
  124.   if FileLen(ParamStr(1),1)<=0 then
  125.     begin Writeln('Error: File "',ParamStr(1),'" not found !'); Halt(1); end;
  126.   if TestVESA=0 then
  127.     begin Writeln('VESA driver not installed !'); Halt(1); end;
  128.   FileRead(ParamStr(1),0,256,3,Pal);
  129.   SetMode(3); Move(Pal,Pal0,768);
  130.   Palette;
  131.   for I:=0 to 767 do if Pal[I]<>Pal0[I] then begin
  132.     FileWrite(ParamStr(1),0,256,3,Pal);
  133.     I:=767;
  134.   end;
  135.   SetMode(0);
  136. end.
  137.