program 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; setVGApal(save); {obnoveni puvodni palety} setText; {nastaveni textoveho modu} freemem(pvirt,sizeof(tvirt)); {uvolneni palety} end.