home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / htscreen / htmix / vgacols / vgacols.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-07-11  |  11.5 KB  |  367 lines
  1. program VGAColors;
  2. {┌──────────────────────────────── INFO ────────────────────────────────────┐}
  3. {│ File    : VGACOLS.PAS                                                    │}
  4. {│ Author  : Harald Thunem                                                  │}
  5. {│ Purpose : Edit VGA text color palettes.                                  │}
  6. {│ Updated : July 11 1992                                                   │}
  7. {└──────────────────────────────────────────────────────────────────────────┘}
  8.  
  9. {────────────────────────── Compiler directives ─────────────────────────────}
  10. {$A+   Word align data                                                       }
  11. {$B-   Short-circuit Boolean expression evaluation                           }
  12. {$E-   Disable linking with 8087-emulating run-time library                  }
  13. {$G+   Enable 80286 code generation                                          }
  14. {$R-   Disable generation of range-checking code                             }
  15. {$S-   Disable generation of stack-overflow checking code                    }
  16. {$V-   String variable checking                                              }
  17. {$X-   Disable Turbo Pascal's extended syntax                                }
  18. {$N+   80x87 code generation                                                 }
  19. {$D-   Disable generation of debug information                               }
  20. {────────────────────────────────────────────────────────────────────────────}
  21.  
  22.  
  23. uses  Dos,
  24.       Screen,
  25.       NBorder,
  26.       NCommon,
  27.       Strings,
  28.       Keyboard,
  29.       Colors;
  30.  
  31.  
  32. var   ActiveColor,
  33.       ActiveRGB   : byte;
  34.       VGAFilename : string;
  35.  
  36.  
  37. procedure About;
  38. const ARow  = 7;
  39.       ACol  = 13;
  40.       ARows = 10;
  41.       ACols = 54;
  42. var A,i,j: byte;
  43. begin
  44.   Fill(1,1,25,80,White+BlueBG,'▒');
  45.   NewBox(ARow,ACol,ARows,ACols,White+LightBlackBG,' ');
  46.   AddShadow(ARow,ACol,ARows,ACols);
  47.   Fill(ARow,ACol,1,ACols,Green+LightWhiteBG,' ');
  48.   WriteC(ARow,ACol+(ACols div 2),SameAttr,'About');
  49.   { Blue }
  50.   Fill(ARow+1,ACol,ARows-2,1,White+LightBlueBG,#184);
  51.   Fill(ARow+ARows-1,ACol,1,1,White+LightBlueBG,#192);
  52.   Fill(ARow+1,ACol+1,ARows-2,2,White+LightBlueBG,' ');
  53.   Fill(ARow+ARows-1,ACol+1,1,2,White+LightBlueBG,#212);
  54.   Fill(ARow+1,ACol+ACols-1,ARows-2,1,White+LightBlueBG,#214);
  55.   Fill(ARow+ARows-1,ACol+ACols-1,1,1,White+LightBlueBG,#208);
  56.   Fill(ARow+1,ACol+ACols-3,ARows-2,2,White+LightBlueBG,' ');
  57.   Fill(ARow+ARows-1,ACol+ACols-3,1,2,White+LightBlueBG,#212);
  58.   { Green }
  59.   Fill(ARow+1,ACol+3,ARows-2,3,White+LightGreenBG,' ');
  60.   Fill(ARow+ARows-1,ACol+3,1,3,White+LightGreenBG,#212);
  61.   Fill(ARow+1,ACol+ACols-6,ARows-2,3,White+LightGreenBG,' ');
  62.   Fill(ARow+ARows-1,ACol+ACols-6,1,3,White+LightGreenBG,#212);
  63.   { Cyan }
  64.   Fill(ARow+1,ACol+6,ARows-2,3,White+LightCyanBG,' ');
  65.   Fill(ARow+ARows-1,ACol+6,1,3,White+LightCyanBG,#212);
  66.   Fill(ARow+1,ACol+ACols-9,ARows-2,3,White+LightCyanBG,' ');
  67.   Fill(ARow+ARows-1,ACol+ACols-9,1,3,White+LightCyanBG,#212);
  68.   { Red }
  69.   Fill(ARow+1,ACol+9,ARows-2,3,White+LightRedBG,' ');
  70.   Fill(ARow+ARows-1,ACol+9,1,3,White+LightRedBG,#212);
  71.   Fill(ARow+1,ACol+ACols-12,ARows-2,3,White+LightRedBG,' ');
  72.   Fill(ARow+ARows-1,ACol+ACols-12,1,3,White+LightRedBG,#212);
  73.   { Magenta }
  74.   Fill(ARow+1,ACol+12,ARows-2,3,White+LightMagentaBG,' ');
  75.   Fill(ARow+ARows-1,ACol+12,1,3,White+LightMagentaBG,#212);
  76.   Fill(ARow+1,ACol+ACols-15,ARows-2,3,White+LightMagentaBG,' ');
  77.   Fill(ARow+ARows-1,ACol+ACols-15,1,3,White+LightMagentaBG,#212);
  78.   { Change middle attribute }
  79.   for i := (ARow+4) to (ARow+6) do
  80.   for j := ACol to (ACol+ACols-1) do
  81.   begin
  82.     A := ReadAttr(i,j);
  83.     A := A and $7F;
  84.     Attr(i,j,1,1,A);
  85.   end;
  86.   { Text }
  87.   WriteC(ARow+4,ACol+(ACols div 2),SameAttr,'VGA Colors');
  88.   WriteC(ARow+5,ACol+(ACols div 2),SameAttr,'by');
  89.   WriteC(ARow+6,ACol+(ACols div 2),SameAttr,'Harald  Thunem');
  90.   Inkey(Ch,Key);
  91.   Key := NullKey;
  92. end;
  93.  
  94.  
  95. procedure WriteColor(ColorNum: byte; FillCh: char);
  96. var A,Row,Col: byte;
  97. begin
  98.   Row := 6+3*(ColorNum div 4);
  99.   Col := 4+18*(ColorNum mod 4);
  100.   if FillCh=#0 then
  101.     NewBox(Row,Col,3,18,15-ColorNum+(ColorNum shl 4),FillCh)
  102.   else Fill(Row,Col,3,18,ColorNum shl 4,FillCh);
  103.   WriteStr(Row+1,Col+8,White+BlackBG,StrLF(ColorNum,2));
  104. end;
  105.  
  106.  
  107. procedure WriteActive(Active: byte);
  108. begin
  109.   case Active of
  110.     1 : begin
  111.           Fill(5,4,1,72,Blue+LightWhiteBG,' ');
  112.           Fill(19,1,1,80,Blue+LightGrayBG,' ');
  113.         end;
  114.     2 : begin
  115.           Fill(5,4,1,72,Blue+LightGrayBG,' ');
  116.           Fill(19,1,1,80,Blue+LightWhiteBG,' ');
  117.         end;
  118.   end;
  119.   WriteC(5,40,SameAttr,'Color Chart');
  120.   WriteC(19,40,SameAttr,'RGB Values');
  121. end;
  122.  
  123.  
  124. procedure WriteRGBValues(R,G,B,Active: byte);
  125. begin
  126.   Fill(21,3,3,1,White+BlackBG,' ');
  127.   Fill(21,4,3,1,White+BlackBG,#195);
  128.   Fill(21,5,3,64,White+BlackBG,#196);
  129.   Fill(21,69,3,1,White+BlackBG,#209);
  130.   Fill(21,79,3,1,White+BlackBG,' ');
  131.   WriteStr(21,5+R,LightRed+BlackBG,'█');
  132.   WriteStr(22,5+G,LightGreen+BlackBG,'█');
  133.   WriteStr(23,5+B,LightBlue+BlackBG,'█');
  134.   WriteStr(21,71,White+BlackBG,StrLF(R,2)+' Red');
  135.   WriteStr(22,71,White+BlackBG,StrLF(G,2)+' Green');
  136.   WriteStr(23,71,White+BlackBG,StrLF(B,2)+' Blue');
  137.   WriteStr(20+Active,3,SameAttr,#16);
  138.   WriteStr(20+Active,79,SameAttr,#17);
  139. end;
  140.  
  141.  
  142. procedure WriteStatus(VGAFilename: string);
  143. begin
  144.   Fill(25,1,1,80,White+CyanBG,' ');
  145.   WriteStr(25,2,Yellow+CyanBG,'F1');
  146.   WriteEos(SameAttr,'-Help  ');
  147.   WriteEos(Yellow+CyanBG,'F2');
  148.   WriteEos(SameAttr,'-Save  ');
  149.   WriteEos(Yellow+CyanBG,'F3');
  150.   WriteEos(SameAttr,'-Load  ');
  151.   WriteEos(Yellow+CyanBG,'Tab');
  152.   WriteEos(SameAttr,'-Switch  ');
  153.   WriteEos(Yellow+CyanBG,#27+#24+#25+#26);
  154.   WriteEos(SameAttr,'-Move  ');
  155.   WriteEos(Yellow+CyanBG,'Esc');
  156.   WriteEos(SameAttr,'-Quit');
  157.   WriteStr(25,80-Length(VGAFilename),SameAttr,VGAFilename);
  158. end;
  159.  
  160.  
  161. procedure Background(VGAFilename: string);
  162. var i: byte;
  163. begin
  164.   Fill(1,1,25,80,White+BlueBG,'▒');
  165.   NewBox(1,30,3,20,White+BlueBG,' ');
  166.   AddShadow(1,30,3,20);
  167.   WriteC(2,40,SameAttr,'VGA Colors 2.0');
  168.   for i := 0 to 15 do
  169.     WriteColor(i,' ');
  170.   WriteColor(0,#0);
  171.   AddShadow(6,4,12,72);
  172.   NewBox(20,1,5,80,White+BlackBG,' ');
  173.   WriteRGBValues(0,0,0,1);
  174.   WriteActive(1);
  175.   WriteStatus(VGAFilename);
  176. end;
  177.  
  178.  
  179. procedure Help;
  180. const HRow = 7;
  181.       HCol = 16;
  182.       HRows= 15;
  183.       HCols= 50;
  184. var Scr    : pointer;
  185.     Size   : word;
  186. begin
  187.   Size := 2*HRows*HCols;
  188.   GetMem(Scr,Size);
  189.   StoreToMem(HRow,HCol,HRows,HCols,Scr^);
  190.   NewBox(HRow,HCol,HRows-1,HCols-2,White+LightBlackBG,' ');
  191.   AddShadow(HRow,HCol,HRows-1,HCols-2);
  192.   Fill(HRow,HCol,1,HCols-2,Green+LightWhiteBG,' ');
  193.   WriteC(HRow,HCol+(HCols div 2),SameAttr,'Help');
  194.   WriteStr(HRow+2,HCol+3,LightCyan+LightBlackBG,'COMMANDS');
  195.   WriteStr(HRow+4,HCol+5,Yellow+LightBlackBG,'F1 ');
  196.   WriteEos(SameAttr,' - This help');
  197.   WriteStr(HRow+5,HCol+5,Yellow+LightBlackBG,'F2 ');
  198.   WriteEos(SameAttr,' - Save palette to file');
  199.   WriteStr(HRow+6,HCol+5,Yellow+LightBlackBG,'F3 ');
  200.   WriteEos(SameAttr,' - Load palette from file');
  201.   WriteStr(HRow+7,HCol+5,Yellow+LightBlackBG,'Tab');
  202.   WriteEos(SameAttr,' - Switch between color selection');
  203.   WriteStr(HRow+8,HCol+11,SameAttr,'and color editing mode');
  204.   WriteStr(HRow+9,HCol+5,Yellow+LightBlackBG,'Esc');
  205.   WriteEos(SameAttr,' - Quit program');
  206.   WriteStr(HRow+11,HCol-4+(HCols div 2),Blue+LightWhiteBG,#16+' OK '+#17);
  207.   WriteStr(HRow+11,HCol+2+(HCols div 2),Black+LightBlackBG,'▄');
  208.   WriteStr(HRow+12,HCol-3+(HCols div 2),Black+LightBlackBG,'▀▀▀▀▀▀');
  209.   repeat
  210.     InKey(Ch,Key);
  211.   until Key=Return;
  212.   StoreToScr(HRow,HCol,HRows,HCols,Scr^);
  213.   FreeMem(Scr,Size);
  214.   Key := NullKey;
  215. end;
  216.  
  217.  
  218. procedure SaveVGAFile(var VGAFilename: string);
  219. const SRow = 11;
  220.       SCol = 26;
  221. var Scr    : pointer;
  222.     Tmp    : string;
  223.     Size   : word;
  224. begin
  225.   Tmp := VGAFilename;
  226.   Size := 2*5*28;
  227.   GetMem(Scr,Size);
  228.   StoreToMem(SRow,SCol,5,28,Scr^);
  229.   NewBox(SRow,SCol,4,26,White+GreenBG,' ');
  230.   AddShadow(Srow,SCol,4,26);
  231.   Fill(SRow,SCol,1,26,Green+LightWhiteBG,' ');
  232.   WriteC(SRow,SCol+13,SameAttr,'Save File');
  233.   WriteStr(SRow+2,SCol+3,SameAttr,'File :');
  234.   InputString(Tmp,SRow+2,SCol+11,12,Yellow+LightBlackBG,[Escape,Return]);
  235.   if Key=Return then
  236.   begin
  237.     VGAFilename := Tmp;
  238.     WriteDACFile(VGAFilename);
  239.   end;
  240.   Key := NullKey;
  241.   StoreToScr(SRow,SCol,5,28,Scr^);
  242.   FreeMem(Scr,Size);
  243. end;
  244.  
  245.  
  246. procedure LoadVGAFile(var VGAFilename: string);
  247. var Tmp : string;
  248.     Dir : DirStr;
  249.     Name: NameStr;
  250.     Ext : ExtStr;
  251. begin
  252.   GetDir(0,CurrentPath);
  253.   if Length(CurrentPath)>3 then
  254.     CurrentPath := CurrentPath+'\';
  255.   SearchPath := '*.VGA';
  256.   Tmp := VGAFilename;
  257.   OpenFile(4,20,Tmp);
  258.   if Key=Return then
  259.     if ReadDACFile(Tmp) then
  260.     begin
  261.       FSplit(Tmp,Dir,Name,Ext);
  262.       VGAFilename := Name+Ext;
  263.     end
  264.     else MessageBox('Error loading file !');
  265.   SetColorList;
  266.   with ColorList[ActiveColor] do
  267.     WriteRGBValues(R,G,B,ActiveRGB);
  268.   WriteStatus(VGAFilename);
  269.   Key := NullKey;
  270. end;
  271.  
  272.  
  273. procedure SelectColor;
  274. begin
  275.   WriteActive(1);
  276.   with ColorList[ActiveColor] do
  277.     WriteRGBValues(R,G,B,ActiveRGB);
  278.   repeat
  279.     InKey(Ch,Key);
  280.     WriteColor(ActiveColor,' ');
  281.     case Key of
  282.       LeftArrow : if ActiveColor>0 then Dec(ActiveColor) else ActiveColor := 15;
  283.       RightArrow: if ActiveColor<15 then Inc(ActiveColor) else ActiveColor := 0;
  284.       UpArrow   : if ActiveColor>3 then Dec(ActiveColor,4) else Inc(ActiveColor,12);
  285.       DownArrow : if ActiveColor<12 then Inc(ActiveColor,4) else Dec(ActiveColor,12);
  286.       F1        : Help;
  287.       F2        : SaveVGAFile(VGAFilename);
  288.       F3        : LoadVGAFile(VGAFilename);
  289.     end;
  290.     WriteColor(ActiveColor,#0);
  291.     with ColorList[ActiveColor] do
  292.       WriteRGBValues(R,G,B,ActiveRGB);
  293.   until Key in [TabKey,Escape,Return];
  294.   WriteColor(ActiveColor,#0);
  295. end;
  296.  
  297.  
  298. procedure EditColor;
  299. var ColVal: byte;
  300. begin
  301.   WriteActive(2);
  302.   repeat
  303.     with ColorList[ActiveColor] do
  304.     case ActiveRGB of
  305.       1: ColVal := R;
  306.       2: ColVal := G;
  307.       3: ColVal := B;
  308.     end;
  309.     InKey(Ch,Key);
  310.     case Key of
  311.       UpArrow   : if ActiveRGB>1 then Dec(ActiveRGB) else ActiveRGB := 3;
  312.       DownArrow : if ActiveRGB<3 then Inc(ActiveRGB) else ActiveRGB := 1;
  313.       LeftArrow : if ColVal>0 then Dec(ColVal) else ColVal := 63;
  314.       RightArrow: if ColVal<63 then Inc(ColVal) else ColVal := 0;
  315.       F1        : Help;
  316.       F2        : SaveVGAFile(VGAFilename);
  317.       F3        : LoadVGAFile(VGAFilename);
  318.     end;
  319.     if Key in [LeftArrow,RightArrow] then
  320.     with ColorList[ActiveColor] do
  321.     case ActiveRGB of
  322.       1: R := ColVal;
  323.       2: G := ColVal;
  324.       3: B := ColVal;
  325.     end;
  326.     with ColorList[ActiveColor] do
  327.       SetDACRegister(CList[ActiveColor],R,G,B);
  328.     with ColorList[ActiveColor] do
  329.       WriteRGBValues(R,G,B,ActiveRGB);
  330.   until Key in [TabKey,Escape];
  331. end;
  332.  
  333.  
  334. procedure MainMenu;
  335. begin
  336.   VGAFilename := 'STANDARD.VGA';
  337.   ActiveColor := 0;
  338.   ActiveRGB := 1;
  339.   Key := NullKey;
  340.   Background(VGAFilename);
  341.   WriteColor(ActiveColor,#0);
  342.   with ColorList[ActiveColor] do
  343.     WriteRGBValues(R,G,B,ActiveRGB);
  344.   repeat
  345.     if Key<>Escape then SelectColor;
  346.     if Key<>Escape then EditColor;
  347.   until Key = Escape;
  348.   if Confirm('Save before quitting',true) then
  349.     SaveVGAFile(VGAFilename);
  350. end;
  351.  
  352.  
  353. begin
  354.   GetDir(0,CurrentPath);
  355.   if Length(CurrentPath)>3 then
  356.     CurrentPath := CurrentPath+'\';
  357.   SetCursor(CursorOff);
  358.   GetColorList;
  359.   SetIntens;
  360.   NewBorder;
  361.   About;
  362.   MainMenu;
  363.   OldBorder;
  364.   SetBlink;
  365.   ClrScr;
  366.   SetCursor(CursorUnderline);
  367. end.