{ 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.