home *** CD-ROM | disk | FTP | other *** search
- 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.