home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The World of Computer Software
/
World_Of_Computer_Software-02-387-Vol-3of3.iso
/
h
/
htmix20.zip
/
VGACOLS.ZIP
/
VGACOLS.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1992-07-11
|
12KB
|
367 lines
program VGAColors;
{┌──────────────────────────────── INFO ────────────────────────────────────┐}
{│ File : VGACOLS.PAS │}
{│ Author : Harald Thunem │}
{│ Purpose : Edit VGA text color palettes. │}
{│ Updated : July 11 1992 │}
{└──────────────────────────────────────────────────────────────────────────┘}
{────────────────────────── Compiler directives ─────────────────────────────}
{$A+ Word align data }
{$B- Short-circuit Boolean expression evaluation }
{$E- Disable linking with 8087-emulating run-time library }
{$G+ Enable 80286 code generation }
{$R- Disable generation of range-checking code }
{$S- Disable generation of stack-overflow checking code }
{$V- String variable checking }
{$X- Disable Turbo Pascal's extended syntax }
{$N+ 80x87 code generation }
{$D- Disable generation of debug information }
{────────────────────────────────────────────────────────────────────────────}
uses Dos,
Screen,
NBorder,
NCommon,
Strings,
Keyboard,
Colors;
var ActiveColor,
ActiveRGB : byte;
VGAFilename : string;
procedure About;
const ARow = 7;
ACol = 13;
ARows = 10;
ACols = 54;
var A,i,j: byte;
begin
Fill(1,1,25,80,White+BlueBG,'▒');
NewBox(ARow,ACol,ARows,ACols,White+LightBlackBG,' ');
AddShadow(ARow,ACol,ARows,ACols);
Fill(ARow,ACol,1,ACols,Green+LightWhiteBG,' ');
WriteC(ARow,ACol+(ACols div 2),SameAttr,'About');
{ Blue }
Fill(ARow+1,ACol,ARows-2,1,White+LightBlueBG,#184);
Fill(ARow+ARows-1,ACol,1,1,White+LightBlueBG,#192);
Fill(ARow+1,ACol+1,ARows-2,2,White+LightBlueBG,' ');
Fill(ARow+ARows-1,ACol+1,1,2,White+LightBlueBG,#212);
Fill(ARow+1,ACol+ACols-1,ARows-2,1,White+LightBlueBG,#214);
Fill(ARow+ARows-1,ACol+ACols-1,1,1,White+LightBlueBG,#208);
Fill(ARow+1,ACol+ACols-3,ARows-2,2,White+LightBlueBG,' ');
Fill(ARow+ARows-1,ACol+ACols-3,1,2,White+LightBlueBG,#212);
{ Green }
Fill(ARow+1,ACol+3,ARows-2,3,White+LightGreenBG,' ');
Fill(ARow+ARows-1,ACol+3,1,3,White+LightGreenBG,#212);
Fill(ARow+1,ACol+ACols-6,ARows-2,3,White+LightGreenBG,' ');
Fill(ARow+ARows-1,ACol+ACols-6,1,3,White+LightGreenBG,#212);
{ Cyan }
Fill(ARow+1,ACol+6,ARows-2,3,White+LightCyanBG,' ');
Fill(ARow+ARows-1,ACol+6,1,3,White+LightCyanBG,#212);
Fill(ARow+1,ACol+ACols-9,ARows-2,3,White+LightCyanBG,' ');
Fill(ARow+ARows-1,ACol+ACols-9,1,3,White+LightCyanBG,#212);
{ Red }
Fill(ARow+1,ACol+9,ARows-2,3,White+LightRedBG,' ');
Fill(ARow+ARows-1,ACol+9,1,3,White+LightRedBG,#212);
Fill(ARow+1,ACol+ACols-12,ARows-2,3,White+LightRedBG,' ');
Fill(ARow+ARows-1,ACol+ACols-12,1,3,White+LightRedBG,#212);
{ Magenta }
Fill(ARow+1,ACol+12,ARows-2,3,White+LightMagentaBG,' ');
Fill(ARow+ARows-1,ACol+12,1,3,White+LightMagentaBG,#212);
Fill(ARow+1,ACol+ACols-15,ARows-2,3,White+LightMagentaBG,' ');
Fill(ARow+ARows-1,ACol+ACols-15,1,3,White+LightMagentaBG,#212);
{ Change middle attribute }
for i := (ARow+4) to (ARow+6) do
for j := ACol to (ACol+ACols-1) do
begin
A := ReadAttr(i,j);
A := A and $7F;
Attr(i,j,1,1,A);
end;
{ Text }
WriteC(ARow+4,ACol+(ACols div 2),SameAttr,'VGA Colors');
WriteC(ARow+5,ACol+(ACols div 2),SameAttr,'by');
WriteC(ARow+6,ACol+(ACols div 2),SameAttr,'Harald Thunem');
Inkey(Ch,Key);
Key := NullKey;
end;
procedure WriteColor(ColorNum: byte; FillCh: char);
var A,Row,Col: byte;
begin
Row := 6+3*(ColorNum div 4);
Col := 4+18*(ColorNum mod 4);
if FillCh=#0 then
NewBox(Row,Col,3,18,15-ColorNum+(ColorNum shl 4),FillCh)
else Fill(Row,Col,3,18,ColorNum shl 4,FillCh);
WriteStr(Row+1,Col+8,White+BlackBG,StrLF(ColorNum,2));
end;
procedure WriteActive(Active: byte);
begin
case Active of
1 : begin
Fill(5,4,1,72,Blue+LightWhiteBG,' ');
Fill(19,1,1,80,Blue+LightGrayBG,' ');
end;
2 : begin
Fill(5,4,1,72,Blue+LightGrayBG,' ');
Fill(19,1,1,80,Blue+LightWhiteBG,' ');
end;
end;
WriteC(5,40,SameAttr,'Color Chart');
WriteC(19,40,SameAttr,'RGB Values');
end;
procedure WriteRGBValues(R,G,B,Active: byte);
begin
Fill(21,3,3,1,White+BlackBG,' ');
Fill(21,4,3,1,White+BlackBG,#195);
Fill(21,5,3,64,White+BlackBG,#196);
Fill(21,69,3,1,White+BlackBG,#209);
Fill(21,79,3,1,White+BlackBG,' ');
WriteStr(21,5+R,LightRed+BlackBG,'█');
WriteStr(22,5+G,LightGreen+BlackBG,'█');
WriteStr(23,5+B,LightBlue+BlackBG,'█');
WriteStr(21,71,White+BlackBG,StrLF(R,2)+' Red');
WriteStr(22,71,White+BlackBG,StrLF(G,2)+' Green');
WriteStr(23,71,White+BlackBG,StrLF(B,2)+' Blue');
WriteStr(20+Active,3,SameAttr,#16);
WriteStr(20+Active,79,SameAttr,#17);
end;
procedure WriteStatus(VGAFilename: string);
begin
Fill(25,1,1,80,White+CyanBG,' ');
WriteStr(25,2,Yellow+CyanBG,'F1');
WriteEos(SameAttr,'-Help ');
WriteEos(Yellow+CyanBG,'F2');
WriteEos(SameAttr,'-Save ');
WriteEos(Yellow+CyanBG,'F3');
WriteEos(SameAttr,'-Load ');
WriteEos(Yellow+CyanBG,'Tab');
WriteEos(SameAttr,'-Switch ');
WriteEos(Yellow+CyanBG,#27+#24+#25+#26);
WriteEos(SameAttr,'-Move ');
WriteEos(Yellow+CyanBG,'Esc');
WriteEos(SameAttr,'-Quit');
WriteStr(25,80-Length(VGAFilename),SameAttr,VGAFilename);
end;
procedure Background(VGAFilename: string);
var i: byte;
begin
Fill(1,1,25,80,White+BlueBG,'▒');
NewBox(1,30,3,20,White+BlueBG,' ');
AddShadow(1,30,3,20);
WriteC(2,40,SameAttr,'VGA Colors 2.0');
for i := 0 to 15 do
WriteColor(i,' ');
WriteColor(0,#0);
AddShadow(6,4,12,72);
NewBox(20,1,5,80,White+BlackBG,' ');
WriteRGBValues(0,0,0,1);
WriteActive(1);
WriteStatus(VGAFilename);
end;
procedure Help;
const HRow = 7;
HCol = 16;
HRows= 15;
HCols= 50;
var Scr : pointer;
Size : word;
begin
Size := 2*HRows*HCols;
GetMem(Scr,Size);
StoreToMem(HRow,HCol,HRows,HCols,Scr^);
NewBox(HRow,HCol,HRows-1,HCols-2,White+LightBlackBG,' ');
AddShadow(HRow,HCol,HRows-1,HCols-2);
Fill(HRow,HCol,1,HCols-2,Green+LightWhiteBG,' ');
WriteC(HRow,HCol+(HCols div 2),SameAttr,'Help');
WriteStr(HRow+2,HCol+3,LightCyan+LightBlackBG,'COMMANDS');
WriteStr(HRow+4,HCol+5,Yellow+LightBlackBG,'F1 ');
WriteEos(SameAttr,' - This help');
WriteStr(HRow+5,HCol+5,Yellow+LightBlackBG,'F2 ');
WriteEos(SameAttr,' - Save palette to file');
WriteStr(HRow+6,HCol+5,Yellow+LightBlackBG,'F3 ');
WriteEos(SameAttr,' - Load palette from file');
WriteStr(HRow+7,HCol+5,Yellow+LightBlackBG,'Tab');
WriteEos(SameAttr,' - Switch between color selection');
WriteStr(HRow+8,HCol+11,SameAttr,'and color editing mode');
WriteStr(HRow+9,HCol+5,Yellow+LightBlackBG,'Esc');
WriteEos(SameAttr,' - Quit program');
WriteStr(HRow+11,HCol-4+(HCols div 2),Blue+LightWhiteBG,#16+' OK '+#17);
WriteStr(HRow+11,HCol+2+(HCols div 2),Black+LightBlackBG,'▄');
WriteStr(HRow+12,HCol-3+(HCols div 2),Black+LightBlackBG,'▀▀▀▀▀▀');
repeat
InKey(Ch,Key);
until Key=Return;
StoreToScr(HRow,HCol,HRows,HCols,Scr^);
FreeMem(Scr,Size);
Key := NullKey;
end;
procedure SaveVGAFile(var VGAFilename: string);
const SRow = 11;
SCol = 26;
var Scr : pointer;
Tmp : string;
Size : word;
begin
Tmp := VGAFilename;
Size := 2*5*28;
GetMem(Scr,Size);
StoreToMem(SRow,SCol,5,28,Scr^);
NewBox(SRow,SCol,4,26,White+GreenBG,' ');
AddShadow(Srow,SCol,4,26);
Fill(SRow,SCol,1,26,Green+LightWhiteBG,' ');
WriteC(SRow,SCol+13,SameAttr,'Save File');
WriteStr(SRow+2,SCol+3,SameAttr,'File :');
InputString(Tmp,SRow+2,SCol+11,12,Yellow+LightBlackBG,[Escape,Return]);
if Key=Return then
begin
VGAFilename := Tmp;
WriteDACFile(VGAFilename);
end;
Key := NullKey;
StoreToScr(SRow,SCol,5,28,Scr^);
FreeMem(Scr,Size);
end;
procedure LoadVGAFile(var VGAFilename: string);
var Tmp : string;
Dir : DirStr;
Name: NameStr;
Ext : ExtStr;
begin
GetDir(0,CurrentPath);
if Length(CurrentPath)>3 then
CurrentPath := CurrentPath+'\';
SearchPath := '*.VGA';
Tmp := VGAFilename;
OpenFile(4,20,Tmp);
if Key=Return then
if ReadDACFile(Tmp) then
begin
FSplit(Tmp,Dir,Name,Ext);
VGAFilename := Name+Ext;
end
else MessageBox('Error loading file !');
SetColorList;
with ColorList[ActiveColor] do
WriteRGBValues(R,G,B,ActiveRGB);
WriteStatus(VGAFilename);
Key := NullKey;
end;
procedure SelectColor;
begin
WriteActive(1);
with ColorList[ActiveColor] do
WriteRGBValues(R,G,B,ActiveRGB);
repeat
InKey(Ch,Key);
WriteColor(ActiveColor,' ');
case Key of
LeftArrow : if ActiveColor>0 then Dec(ActiveColor) else ActiveColor := 15;
RightArrow: if ActiveColor<15 then Inc(ActiveColor) else ActiveColor := 0;
UpArrow : if ActiveColor>3 then Dec(ActiveColor,4) else Inc(ActiveColor,12);
DownArrow : if ActiveColor<12 then Inc(ActiveColor,4) else Dec(ActiveColor,12);
F1 : Help;
F2 : SaveVGAFile(VGAFilename);
F3 : LoadVGAFile(VGAFilename);
end;
WriteColor(ActiveColor,#0);
with ColorList[ActiveColor] do
WriteRGBValues(R,G,B,ActiveRGB);
until Key in [TabKey,Escape,Return];
WriteColor(ActiveColor,#0);
end;
procedure EditColor;
var ColVal: byte;
begin
WriteActive(2);
repeat
with ColorList[ActiveColor] do
case ActiveRGB of
1: ColVal := R;
2: ColVal := G;
3: ColVal := B;
end;
InKey(Ch,Key);
case Key of
UpArrow : if ActiveRGB>1 then Dec(ActiveRGB) else ActiveRGB := 3;
DownArrow : if ActiveRGB<3 then Inc(ActiveRGB) else ActiveRGB := 1;
LeftArrow : if ColVal>0 then Dec(ColVal) else ColVal := 63;
RightArrow: if ColVal<63 then Inc(ColVal) else ColVal := 0;
F1 : Help;
F2 : SaveVGAFile(VGAFilename);
F3 : LoadVGAFile(VGAFilename);
end;
if Key in [LeftArrow,RightArrow] then
with ColorList[ActiveColor] do
case ActiveRGB of
1: R := ColVal;
2: G := ColVal;
3: B := ColVal;
end;
with ColorList[ActiveColor] do
SetDACRegister(CList[ActiveColor],R,G,B);
with ColorList[ActiveColor] do
WriteRGBValues(R,G,B,ActiveRGB);
until Key in [TabKey,Escape];
end;
procedure MainMenu;
begin
VGAFilename := 'STANDARD.VGA';
ActiveColor := 0;
ActiveRGB := 1;
Key := NullKey;
Background(VGAFilename);
WriteColor(ActiveColor,#0);
with ColorList[ActiveColor] do
WriteRGBValues(R,G,B,ActiveRGB);
repeat
if Key<>Escape then SelectColor;
if Key<>Escape then EditColor;
until Key = Escape;
if Confirm('Save before quitting',true) then
SaveVGAFile(VGAFilename);
end;
begin
GetDir(0,CurrentPath);
if Length(CurrentPath)>3 then
CurrentPath := CurrentPath+'\';
SetCursor(CursorOff);
GetColorList;
SetIntens;
NewBorder;
About;
MainMenu;
OldBorder;
SetBlink;
ClrScr;
SetCursor(CursorUnderline);
end.