home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
C!T ROM 2
/
ctrom_ii_b.zip
/
ctrom_ii_b
/
PROGRAM
/
PASCAL
/
SVGADC30
/
EDIT256.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1993-03-03
|
9KB
|
321 lines
program Edit_256_Palette;
{ This program lets you edit a 256 colour palette }
{ The keys to use are as follows : }
{ Use arrow keys to move around. }
{ }
{ Increase color F G H }
{ Decrease color V B N }
{ Red Grn Blu }
{ }
{ Press 'p' to get into "Pan" mode }
{ Press 'p' again to mark first color }
{ Move to second color and press 'p' to mark }
{ The colors between these two markers will be }
{ "panned". If you don't understand then just }
{ try it! }
{ Press 'c' to get into "Copy" mode }
{ Press 'c' again to mark first color }
{ Move to target palette and press press 'c' }
{ again to copy color }
{ Press 'q' to quit }
{ Press 's' to save a pallette }
{ The program is not very user friendly but it }
{ does the job! }
uses SVGA, Dos, crt;
const x1 = 30; x2 = 90;
y1 = 260; y2 = 290;
Red = 252;
Green = 253;
Blue = 254;
White = 255;
var i, j, Rx, Ry : integer;
register : registers;
Colors : RGB;
XPos, YPos, OldXPos, OldYPos : byte;
Ch : char;
PaletteName : string;
procedure ShowCol( Col : RGB );
begin
Line( 51, 150, 51, 20, 0 );
Line( 52, 150, 52, 20, 0 );
Line( 58, 150, 58, 20, 0 );
Line( 59, 150, 59, 20, 0 );
Line( 65, 150, 65, 20, 0 );
Line( 66, 150, 66, 20, 0 );
Line( 51, 150, 51, 150-Col.Red*2, red );
Line( 52, 150, 52, 150-Col.Red*2, red );
Line( 58, 150, 58, 150-Col.Grn*2, Green );
Line( 59, 150, 59, 150-Col.Grn*2, Green );
Line( 65, 150, 65, 150-Col.Blu*2, Blue );
Line( 66, 150, 66, 150-Col.Blu*2, Blue );
RectFill( x1, y1, x2, y2, XPos+YPos );
end;
procedure ReadPal( PalNum : byte; var Col : RGB );
begin
Col.Grn := Color[PalNum].Grn;
Col.Blu := Color[PalNum].Blu;
Col.Red := Color[PalNum].Red;
end;
{procedure ChangeColor( PalNum: byte; Hue : RGB );
begin
with register do
begin
AX := $1010;
BX := PalNum;
CH := Hue.Grn;
CL := Hue.Blu;
DH := Hue.Red;
end;
intr( $10, register );
end;}
procedure PutCursor( X, Y, OldX, OldY : byte );
begin
Rx := trunc(OldX/32)*50+150;
Ry := OldY*15;
Rectangle( Rx, Ry, Rx+49, Ry+14, OldX+OldY );
Rectangle( Rx+1, Ry+1, Rx+48, Ry+13, OldX+OldY );
Rx := trunc(X/32)*50+150;
Ry := Y*15;
Rectangle( Rx, Ry, Rx+49, Ry+14, Red );
Rectangle( Rx+1, Ry+1, Rx+48, Ry+13, White );
OldXPos := XPos; OldYPos := YPos;
end;
procedure GetKey;
begin
Case Ch of
'K' : XPos := XPos - 32;
'M' : XPos := XPos + 32;
'H' : if (YPos-1) >= 0 then YPos := YPos - 1
else YPos := 31;
'P' : if (YPos+1) <= 31 then YPos := YPos + 1
else YPos := 0;
end;
end;
procedure Swap2( var A , B : byte );
var swapper : byte;
begin
swapper := A;
A := B;
B := swapper;
end;
procedure Pan;
var Markers, Count, Start, Finish, Fx, Sx, Fy, Sy : byte;
R, G, B : real;
swap : boolean;
begin
Markers := 0;
Count := 0;
repeat
Ch := ReadKey;
if Ch = 'p' then
begin
Markers := Markers + 1;
if Markers = 1 then
begin
Start := XPos + YPos;
Sx := XPos; Sy := YPos;
end
else
begin
Finish := XPos + YPos;
Fx := XPos; Fy := YPos;
end;
Rx := trunc(XPos/32)*50+170;
Ry := YPos*15+3;
RectFill( Rx, Ry, Rx+9, Ry+8, Red );
RectFill( Rx+2, Ry+1, Rx+7, Ry+7, White );
end;
if (Ch = #0) then
begin
Ch := ReadKey;
GetKey;
PutCursor( XPos, YPos, OldXPos, OldYPos );
ReadPal( XPos+YPos, Colors );
ShowCol( Colors );
end;
until Markers = 2;
if Start <> Finish then
begin
if Start > Finish then
begin
Swap2( Start, Finish );
Swap2( Sx, Fx );
Swap2( Sy, Fy );
end;
Markers := Start;
R := (Color[Finish].Red - Color[Start].Red) / abs(Finish - Start);
G := (Color[Finish].Grn - Color[Start].Grn) / abs(Finish - Start);
B := (Color[Finish].Blu - Color[Start].Blu) / abs(Finish - Start);
repeat
Colors := Color[Markers];
if (Color[Start].Red + Count*R) <= 63 then
Colors.Red := round(Color[Start].Red + Count*R)
else Colors.Red := 63;
if (Color[Start].Grn + Count*G) <= 63 then
Colors.Grn := round(Color[Start].Grn + Count*G)
else Colors.Grn := 63;
if (Color[Start].Blu + Count*B) <= 63 then
Colors.Blu := round(Color[Start].Blu + Count*B)
else Colors.Blu := 63;
SetColor( Markers, Colors );
Color[Markers] := Colors;
Count := Count + 1;
Markers := Markers + 1;
until Markers = Finish;
Rx := round((Start-Sy)/32)*50+170;
Ry := (Start-Sx)*15+3;
RectFill( Rx, Ry, Rx+9, Ry+8, Start );
Rx := round((Finish-Fy)/32)*50+170;
Ry := (Finish-Fx)*15+3;
RectFill( Rx, Ry, Rx+9, Ry+8, Finish );
end;
end;
procedure CopyPal;
var Markers, Start, Finish, Sx, Sy, Fx, Fy: byte;
begin
Markers := 0;
repeat
Ch := ReadKey;
if Ch = 'c' then
begin
Markers := Markers + 1;
if Markers = 1 then
begin
Start := XPos + YPos;
Sx := XPos; Sy := YPos;
end
else
begin
Finish := XPos + YPos;
Fx := XPos; Fy := YPos;
end;
Rx := trunc(XPos/32)*50+170;
Ry := YPos*15+3;
RectFill( Rx, Ry, Rx+9, Ry+8, Red );
RectFill( Rx+2, Ry+1, Rx+7, Ry+7, White );
end;
if (Ch = #0) then
begin
Ch := ReadKey;
GetKey;
PutCursor( XPos, YPos, OldXPos, OldYPos );
ReadPal( XPos+YPos, Colors );
ShowCol( Colors );
end;
until Markers = 2;
SetColor( Finish, Color[ Start ] );
Rx := round((Start-Sy)/32)*50+170;
Ry := (Start-Sx)*15+3;
RectFill( Rx, Ry, Rx+9, Ry+8, Start );
Rx := round((Finish-Fy)/32)*50+170;
Ry := (Finish-Fx)*15+3;
RectFill( Rx, Ry, Rx+9, Ry+8, Finish );
end;
procedure SavePal;
var Fil : File of RGB;
t : byte;
begin
assign( fil, PaletteName );
{$I-} rewrite( fil ); {$I+}
i := IOResult;
if i = 0 then
begin
for t := 0 to 255 do
write( fil, Color[t] );
Close( fil );
end;
end;
procedure SetUp;
var ch : char;
begin
write( 'Start New Palette ? ');
Ch := ReadKey;
if (Ch = 'n') OR (Ch = 'N') then
begin
clrscr;
write( 'Name of Existing Palette to work with : ' );
read( PaletteName );
end
else
begin
clrscr;
write( 'Name of New Palette : ');
read( PaletteName );
end;
SetMode( SVGA6448 );
if (Ch='n') OR (Ch='N') then LoadPalette( PaletteName )
else LoadPalette( 'pal256.002' );
for i := 0 to 7 do
for j := 0 to 31 do
RectFill( i*50+150, j*15, i*50+199, j*15+14, i*32+j );
OldXPos := 0; OldYPos :=20;
XPos := 0; YPos := 20;
PutCursor( XPos, YPos, 0, 0 );
ReadPal( XPos+YPos, Colors );
ShowCol( Colors );
RectFill( x1, y1, x2, y2, XPos+YPos );
Ch := 't';
end;
begin
SetUp;
repeat
Ch := ReadKey;
if Ch in ['p','P'] then Pan;
if Ch in ['s','S'] then SavePal;
if Ch in ['c','C'] then CopyPal;
if (Ch <> #0) then
begin
Colors := Color[XPos+YPos];
Case Ch of
'f','F' : if (Colors.Red + 1) <= 63 then Colors.Red := Colors.Red + 1;
'v','V' : if (Colors.Red - 1) >= 0 then Colors.Red := Colors.Red - 1;
'g','G' : if (Colors.Grn + 1) <= 63 then Colors.Grn := Colors.Grn + 1;
'b','B' : if (Colors.Grn - 1) >= 0 then Colors.Grn := Colors.Grn - 1;
'h','H' : if (Colors.Blu + 1) <= 63 then Colors.Blu := Colors.Blu + 1;
'n','N' : if (Colors.Blu - 1) >= 0 then Colors.Blu := Colors.Blu - 1;
end;
SetColor( XPos+YPos, Colors );
ShowCol( Colors );
Color[XPos+YPos] := Colors;
end;
if (Ch = #0) then
begin
Ch := ReadKey;
GetKey;
PutCursor( XPos, YPos, OldXPos, OldYPos );
ReadPal( XPos+YPos, Colors );
ShowCol( Colors );
end;
until Ch in ['q','Q'];
ExitGraphics;
end.