Program vytvorí prechod medzi dvoma farbami

Delphi & Pascal (česká wiki)
Přejít na: navigace, hledání
Kategória: KMP (Klub mladých programátorov)

Autor: Aleš Kucik
web: www.webpark.cz/prog-pascal

Program: Makepal.pas,  Graphx.pas,  Textscr.pas
Súbor exe: Makepal.exe

MAKEPAL - návod
  • tento program slouží k vytvoření různých VGA palet. Zajímavou možností je vytvoření plynulého přechodu mezi dvěma barvami.
  • program je nutné spouštět z příkazového řádku (jako parametr je vyžadován název souboru, kam bude paleta uložena) Např.: makepal.exe paleta1
  • pokud tento soubor již existuje bude přepsán!!!
  • vzniklý soubor je typový soubor. Typu array [0..255,0..2] of byte.
OVLÁDÁNÍ -
Mezi paložkami se pohybujete stiskem klávesy se znakem počátečního písmene zvolené položky (pro položku 1BARVA to je "1" atd.)
šipka nahoru - zvětšuje hodnotu položky
šipka dolů - zmenšuje hodnotu položky
položky:
  • 1BARVA - výběr 1. barvy (klávesa "1")
  • 2BARVA - vžběr 2. barvy (klávesa "2")
  • R - hodnota červené složky dané barvy (klávesa "R")
  • G - hodnota zelené složky dané barvy (klávesa "G")
  • B - hodnota modré složky dané barvy (klávesa "B")
  • "DANÁ BARVA" je ta, která byla vybrána naposled (pokud jste naposled stiskli "1" budete měnit složky 1. barvy)
  • TEXT - možnost nastavení barvy textu (může se stát, že na text na obrazovce vyjde černá barva a text se tak stane nečitelný - touto položkou lze barvu měnit)
  • "P...Process" - vytvoří plynulý přechod mezi 1. a 2. barvou
  • program se ukončí stiskem klávesy "ESC"
{ 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);
 
  assign(soubor,name+'.pal');
  rewrite(soubor);
  close(soubor);
  getmem(virtScreen,sizeof(virtScreen));
  virt:=seg(virtScreen^);
  setVGA;
  font:=BIOSfont;
end;
 
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);
 
  if choiceC then getpal(b1H,r,g,b)
   else getpal(b2H,r,g,b);
  str(r:2,s);
  xytextB(font, rX, rY, textCol,'R:'+s+#0,virt);
  str(g:2,s);
  xytextB(font, gX, gY, textCol,'G:'+s+#0,virt);
  str(b:2,s);
  xytextB(font, bX, bY, textCol,'B:'+s+#0,virt);
 
  str(textCol:3,s);
  xytextB(font, tX, tY, textCol,'TEXT:'+s+#0,virt);
  xytextB(font, pX, pY, textCol,'P..PREPOCITEJ!'+#0,virt);
  xytextB(font, uX, uY, textCol,'U..ULOZ'+#0,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;
 
  until konec;
  setVGApal(pal);
  finish;
end.