Dze je subor www.TrSek.com/cover/ales/fire.pasprogram fire;
uses graphx,crt;
const
zhaseni1 = 1;
type
tvirt= array [1..65280] of byte;
{jestli se divite proc pole neni dlouhe 64000 (320x200) tak vezte
ze zde mame k dobru 4 radky proto 320x204 = 65280}
var
pvirt:^tvirt;
vaddr:word;
save:tpal;
soub:file of tpal;
mezi:byte;
font:pointer;
procedure fire1;
var
i,j:integer;
temp:tpal;
hlp:word;
begin
read(soub, temp);
close(soub);
fillchar(mem[vaddr:0],sizeof(pvirt^),0); {vycisteni pomocneho pole}
setVGApal(temp);
repeat
hlp:=203*320; {takto se dostaneme na posledni radek pole}
for i:=0 to 319 do {umistime nejake "zarodecne" pixely}
begin {proto se plamen mihota}
mem[vaddr:i+hlp]:=random(2)*255;
mem[vaddr:i+hlp-320]:=random(2)*255;
mem[vaddr:i+hlp-640]:=random(2)*255;
end;
for j:=1 to 201 do
for i:=0 to 319 do
begin
mezi:=(mem[vaddr:i+(j+2)*320-1]+
mem[vaddr:i+(j+1)*320-1]+
mem[vaddr:i+(j+2)*320+1]+
mem[vaddr:i+(j+1)*320+1]+
mem[vaddr:i+(j+2)*320] )div 5;
if mezi < zhaseni1 then mezi:=0
else mezi:= mezi-zhaseni1;
mem[vaddr:(j-1)*320+i]:=mezi;
end;
waitretrace;
flip(vaddr,VGA);
until keypressed;
readkey;
end;
procedure fire2;
var
i,j:integer;
temp:tpal;
hlp:word;
begin
read(soub, temp);
close(soub);
fillchar(mem[vaddr:0],sizeof(pvirt^),0); {vycisteni pomocneho pole}
setVGApal(temp);
repeat
hlp:=203*320; {takto se dostaneme na posledni radek pole}
for i:=0 to 319 do {umistime nejake "zarodecne" pixely}
begin {proto se plamen mihota}
mem[vaddr:i+hlp]:=random(2)*255;
mem[vaddr:i+hlp-320]:=random(2)*255;
mem[vaddr:i+hlp-640]:=random(2)*255;
end;
for j:=1 to 201 do
for i:=0 to 319 do
begin
mezi:=(mem[vaddr:i+(j+2)*320-1]+
mem[vaddr:i+(j+1)*320-1]+
mem[vaddr:i+(j+2)*320+1]+
mem[vaddr:i+(j+1)*320+1]+
mem[vaddr:i+(j+2)*320] )div 5;
if mezi < zhaseni1 then mezi:=0
else mezi:= mezi-zhaseni1;
mem[vaddr:(j-1)*320+i]:=mezi;
end;
waitretrace;
flip(vaddr,VGA);
until keypressed;
readkey;
end;
procedure fire3;
var
i,j:integer;
temp:tpal;
hlp:word;
begin
read(soub, temp);
close(soub);
fillchar(mem[vaddr:0],sizeof(pvirt^),0); {vycisteni pomocneho pole}
setVGApal(temp);
repeat
hlp:=203*320; {takto se dostaneme na posledni radek pole}
for i:=0 to 319 do {umistime nejake "zarodecne" pixely}
begin
mem[vaddr:i+hlp]:=random(2)*255;
mem[vaddr:i+hlp-320]:=random(2)*255;
end;
for j:=1 to 201 do {vlastni vypocet}
for i:=0 to 319 do
begin
mezi:=(mem[vaddr:i+(j+1)*320]+
mem[vaddr:i+(j+2)*320] )div 2;
if mezi < zhaseni1 then mezi:=0
else mezi:= mezi-zhaseni1;
mem[vaddr:(j-1)*320+i]:=mezi;
end;
waitretrace;
flip(vaddr,VGA);
until keypressed;
readkey;
end;
procedure efekt1;
var
i,j:integer;
temp:tpal;
hlp:word;
begin
read(soub, temp);
close(soub);
fillchar(mem[vaddr:0],sizeof(pvirt^),0); {vycisteni pomocneho pole}
setVGApal(temp);
repeat
for j:=1 to 201 do {vlastni vypocet}
for i:=0 to 319 do
begin
mezi:=(mem[vaddr:i+(j+1)*320]+
mem[vaddr:i+(j+2)*320] )div 2;
if mezi < zhaseni1 then mezi:=0
else mezi:= mezi-zhaseni1;
mem[vaddr:j*320+i]:=mezi;
mem[vaddr:(j-1)*320+i]:=mezi;
end;
xytextB(font,random(250),180,255,chr(random(100)+40)+#0,vaddr);
waitretrace;
flip(vaddr,VGA);
until keypressed;
readkey;
end;
procedure efekt2;
var
i,j:integer;
temp:tpal;
hlp:word;
begin
read(soub, temp);
close(soub);
fillchar(mem[vaddr:0],sizeof(pvirt^),0); {vycisteni pomocneho pole}
setVGApal(temp);
repeat
for j:=0 to 201 do
for i:=0 to 319 do
begin
mezi:=(mem[vaddr:i+(j+2)*320-1]+
mem[vaddr:i+(j+1)*320-1]+
mem[vaddr:i+(j+2)*320+1]+
mem[vaddr:i+(j+1)*320+1]+
mem[vaddr:i+(j+2)*320] )div 5;
mem[vaddr:(j)*320+i]:=mezi;
end;
xytextB(font,random(250)+10,random(180),255,'BUM!'+#0,vaddr);
waitretrace;
flip(vaddr,VGA);
until keypressed;
readkey;
end;
begin
clrscr;
writeln('DEMONSTRACNI PROGRAM PRO EFEKT OHNE');
writeln('Domovska stranka: www.webpark.cz/prog-pascal/');
writeln;
writeln('Tento program by mel slouzit jenom jako ukazka. Tvorivosti');
writeln('se meze nekladou. Muzete menit paletu, pixely ze ketrych se');
writeln('pocita prumerna hodnota, zhaseci konstantu atd.');
writeln('Pokud nevite jak vytvorit svou paletu kouknete se na mou');
writeln('homepage, jiste tam naleznete neco s cim ji vytvorite');
writeln('Uvidite nekolik efektu, pracujicich na stejnem primcipu');
writeln;writeln;writeln;
writeln('Stiskni ENTR...');
readkey;
randomize; {zapneme si nahodny cisla}
getmem(pvirt,sizeof(tvirt)); {zabereme kus pameti pro virtualni obrazovku}
vaddr:=seg(pvirt^); {zjistime si segment a ulozime ve vaddr}
font:=BIOSfont; {ukazatel na font BIOSU - z unity GRAPHIX}
setVGA; {inicializace modu 13h}
getVGApal(save); {ulozeni puvodni palety}
cls(0,VGA);
setVGApal(save);
xytextB(font,0,0,15,'Efekt OHNE cislo 1'+#0,VGA);
delay(1000);
assign(soub,'f1.pal');
{$I-}
reset(soub);
{$I+}
if IOresult = 0 then fire1
else
begin
xytextB(font,0,100,15,'!!NENASEL JSEM SOUBOR F1.PAL!!'+#0,VGA);
delay(3000);
end;
cls(0,VGA);
setVGApal(save);
xytextB(font,0,0,15,'Efekt OHNE cislo 2 -'+#0,VGA);
xytextB(font,0,10,15,'pouze jina paleta'+#0,VGA);
delay(2000);
assign(soub,'f2.pal');
{$I-}
reset(soub);
{$I+}
if IOresult = 0 then fire2
else
begin
xytextB(font,0,100,15,'!!NENASEL JSEM SOUBOR F2.PAL!!'+#0,VGA);
delay(3000);
end;
cls(0,VGA);
setVGApal(save);
xytextB(font,0,0,15,'Efekt OHNE cislo 3'+#0,VGA);
delay(1000);
assign(soub,'f1.pal');
{$I-}
reset(soub);
{$I+}
if IOresult = 0 then fire3
else
begin
xytextB(font,0,100,15,'!!NENASEL JSEM SOUBOR F1.PAL!!'+#0,VGA);
delay(3000);
end;
cls(0,VGA);
setVGApal(save);
xytextB(font,0,0,15,'JINY EFEKT'+#0,VGA);
delay(1000);
assign(soub,'f1.pal');
{$I-}
reset(soub);
{$I+}
if IOresult = 0 then efekt1
else
begin
xytextB(font,0,100,15,'!!NENASEL JSEM SOUBOR F1.PAL!!'+#0,VGA);
delay(3000);
end;
cls(0,VGA);
setVGApal(save);
xytextB(font,0,0,15,'''VYBUCH'''+#0,VGA);
delay(1000);
assign(soub,'f1.pal');
{$I-}
reset(soub);
{$I+}
if IOresult = 0 then efekt2
else
begin
xytextB(font,0,100,15,'!!NENASEL JSEM SOUBOR F1.PAL!!'+#0,VGA);
delay(3000);
end;