Dze je subor www.TrSek.com/cover/ales/makepal.pas{ MAKEPAL.PAS Copyright (c) Ales Kucik }
{ Program slouzi k vytvoreni ruznych VGA palet. }
{ Zajimavou moznosti je vytvoreni plynuleho prechodu mezi dvema }
{ barvami. }
{ }
{ Datum:29.11.2002 http://www.trsek.com }
program super_paleta;
{$G+}
uses crt,graphX,textscr;
const
choiceC:boolean =true; {menim b1 nebo b2 (barvu cislo 1 nebo 2)}
lastPressed:byte = 1;
b1X= 10; {souradnice textu}
b1Y= 10;
b1H:byte= 1; {prednastaveni hodnoty pro polozku 1Barva}
b2X= 10;
b2Y= 20;
b2H:byte= 1; {prednastaveni hodnoty b2H}
rX = 10;
rY = 30;
gX = 10;
gY = 40;
bX = 10;
bY = 50;
tX = 180;
tY = 10;
pX = 180;
pY = 40;
uX = 180;
uY = 50;
palX = 32;
palY = 180;
palV = 10;
textCol:byte = 15;
konec:boolean = false;
var
font:pointer;
pal:tpal;
r,g,b:byte;
virtScreen:^tVirtual;
virt:word;
name:string[8];
soubor:file of tpal;
procedure init;
begin
if paramCount = 0 then
begin
writeln('Prosim uvedte nazev souboru ve kterem bude ulozena nova');
writeln('paleta. Nazev by mel obsahovat pouze pripustne znaky.');
writeln('POZOR!! Pri pokusu otevrit jiz existujici soubor, bude');
writeln('prepsan!!!');
writeln('Tvar : makepal.exe xxxxxxxx');
writeln('Napr.: makepal.exe pokus');
writeln;writeln;
writeln('Vase paleta bude ulozena v souboru xxxxxxxx.pal');
writeln;
writeln('Bol vybran default pokus.pal');
name:='pokus';
end
else
name:=paramStr(1);
procedure finish;
begin
setText;
freemem(virtScreen,sizeof(virtScreen));
end;
procedure drawPal(x,y,h:integer; where:word);
var
i:byte;
begin
for i:=0 to 255 do
lineV(x+i,y,h,i,where);
end;
procedure process(c1,c2:byte);
var
r1,g1,b1,
r2,g2,b2: byte;
stepR,
stepG,
stepB: shortint;
step,
i: byte;
begin
getpal(c1,r1,g1,b1);
getpal(c2,r2,g2,b2);
stepR:=r2-r1;
stepG:=g2-g1;
stepB:=b2-b1;
step:=c2-c1;
for i:=1 to step-1 do
setpal(c1+i,r1+stepR*i div step,g1+stepG*i div step,b1+stepB*i div step);
end;
procedure uloz;
var
temp:tpal;
begin
rewrite(soubor);
getVGApal(temp);
write(soubor, temp);
close(soubor);
end;
procedure drawMenu;
var
s:string;
i:byte;
begin
str(b1H:3,s);
xytextB(font, b1X, b1Y, textCol,'1BARVA:'+s+#0,virt);
for i:=0 to 7 do
lineH(b1X+100,b1Y+i,20,b1H,virt);
str(b2h:3,s);
xytextB(font, b1X, b2Y, textCol,'2BARVA:'+s+#0,virt);
for i:=0 to 7 do
lineH(b2X+100,b2Y+i,20,b2H,virt);
{ramecek kolem palety}
lineH(palX-1,palY-1,257,textCol,virt);
lineH(palX-1,palY+palV+1,257,textCol,virt);
lineV(palX-1,palY-1,palV+2,textCol,virt);
lineV(palX+256,palY-1,palV+2,textCol,virt);
drawpal(palX,palY,palV,virt);
end;
begin
init;
getVGApal(pal);
repeat
cls(0,virt);
drawMenu;
waitretrace;
flip(virt,VGA);
case getkey of
49: begin {stisknuta 1}
lastpressed:=1;
choiceC:=true;
end;
50: begin {stisknuta 2}
lastpressed:=2;
choiceC:=false;
end;
114,82: lastpressed:=3; {stisknuto r}
103,71: lastpressed:=4; {stisknuto g}
98, 66: lastpressed:=5; {stisknuto b}
328:case lastpressed of {sipka nahoru}
1: if b1H < 255 then inc(b1H);
2: if b2H < 255 then inc(b2H);
3: if choiceC then
begin
getpal(b1H,r,g,b);
if r<63 then
begin
inc(r);
setpal(b1H,r,g,b);
end;
end
else
begin
getpal(b2H,r,g,b);
if r<63 then
begin
inc(r);
setpal(b2H,r,g,b);
end;
end;
4: if choiceC then
begin
getpal(b1H,r,g,b);
if g<63 then
begin
inc(g);
setpal(b1H,r,g,b);
end;
end
else
begin
getpal(b2H,r,g,b);
if g<63 then
begin
inc(g);
setpal(b2H,r,g,b);
end;
end;
5: if choiceC then
begin
getpal(b1H,r,g,b);
if b<63 then
begin
inc(b);
setpal(b1H,r,g,b);
end;
end
else
begin
getpal(b2H,r,g,b);
if b<63 then
begin
inc(b);
setpal(b2H,r,g,b);
end;
end;
6: if textCol<255 then inc(textCol);
end; {konec sipka nahoru}
336:case lastpressed of {sipka dolu}
1: if b1H > 0 then dec(b1H);
2: if b2H > 0 then dec(b2H);
3: if choiceC then
begin
getpal(b1H,r,g,b);
if r>0 then
begin
dec(r);
setpal(b1H,r,g,b);
end;
end
else
begin
getpal(b2H,r,g,b);
if r>0 then
begin
dec(r);
setpal(b2H,r,g,b);
end;
end;
4: if choiceC then
begin
getpal(b1H,r,g,b);
if g>0 then
begin
dec(g);
setpal(b1H,r,g,b);
end;
end
else
begin
getpal(b2H,r,g,b);
if g>0 then
begin
dec(g);
setpal(b2H,r,g,b);
end;
end;
5: if choiceC then
begin
getpal(b1H,r,g,b);
if b>0 then
begin
dec(b);
setpal(b1H,r,g,b);
end;
end
else
begin
getpal(b2H,r,g,b);
if b>0 then
begin
dec(b);
setpal(b2H,r,g,b);
end;
end;
6: if textCol>0 then dec(textCol);
end; {konec sipka dolu}
116,84: lastpressed:=6;
112,80: if b1H < b2H then process(b1H, b2H)
else if b2H < b1H then process(b2H, b1H);
117,85:uloz;
27:konec:=true;
end;