Информационный сервер для программистов: Исходники со всего света. Паскальные исходники со всего света
  Powered by Поисковый сервер Яndex: Найдется ВСЁ!
На Главную Pascal Форум Информер Страны мира
   Demo Making    >>    fire2
   
 
 Burn 2.0 - Improved Fire Routine [320x200x256]  Gerhard Piran 15.11.97

Улучшенная версия программы BURN с возможностью регулирования параметров пламени с помощью графических ползунков.
Fire code with alot of options.



3k 
 

  {> Cut here. FileName= FIRE2.PAS } {$A+,B+,D-,E-,F-,G+,I-,L-,N-,O-,P-,Q-,R-,S-,T-,V-,X+,Y-} {$M 20000,0,0} {Burn V1.0: the original fireroutine was made by Frank Jan Sorensen alias Frank Patxi (fjs@lab.jt.dk)} {Burn V2.0: interaction, speedup and sparks added by Gerhard Piran} Program Burn2; {12.12.95} uses Dos, Crt; var regs: Registers; pic: integer; {drawn pictures} {********************************************************} procedure SetVideoMode (vMode: byte); begin regs.ax := vMode; {Bit 7 = 1: RAM nicht l"schen} Intr ($10,regs); end; {--------------------------------------------------------} function GetVideoMode: byte; begin regs.ah := $0F; intr ($10, regs); GetVideoMode := regs.al; end; {*********************************************************} type ColorValue = record R,G,B: byte; end; VGAPaletteType = array[0..255] of ColorValue; procedure ReadPal (var pal: VGAPaletteType); begin regs.AX := $1017; regs.BX := 0; regs.CX := 256; regs.ES := Seg(pal); regs.DX := Ofs(pal); repeat until Port[$03DA] And $08 = $08; {Wait for rescan} Intr ($10,regs); end; {--------------------------------------------------------} procedure WritePal (var pal: VGAPaletteType); begin regs.AX := $1012; regs.BX := 0; regs.CX := 256; regs.ES := Seg(pal); regs.DX := Ofs(pal); repeat until Port[$03DA] and $08 = $08; {Wait for rescan} Intr($10,regs); end; {*********************************************************} { Convert HSI (Hue, Saturation, Intensity) -> RGB } {---------------------------------------------------------} procedure Hsi2Rgb (H, S, I: Real; var C: ColorValue); var T, Rv, Gv, Bv: Real; begin T := H; Rv := 1 + S * Sin(T - 2 * Pi / 3); Gv := 1 + S * Sin(T); Bv := 1 + S * Sin(T + 2 * Pi / 3); T := 63.999 * I / 2; c.R := trunc(Rv * T); c.G := trunc(Gv * T); c.B := trunc(Bv * T); end; {*********************************************************} { fast pixel drawing for graphic mode 320x200x256 {---------------------------------------------------------} procedure PutPixel (x,y: integer; c: byte); assembler; asm mov ax,y mov bx,ax shl ax,8 shl bx,6 add bx,ax add bx,x mov ax,0a000h mov es,ax mov al,c mov es:[bx],al end; {--------------------------------------------------------} function GetPixel (x,y: integer): byte; begin asm mov ax,y mov bx,ax shl ax,8 shl bx,6 add bx,ax add bx,x mov ax,0a000h mov es,ax mov al,es:[bx] mov @result,al end; end; {********************************************************} procedure Info; begin ClrScr; WriteLn('Burn V 2.0, a hot burning stuff'#13#10); WriteLn('commands: '#13#10 +' ? this help'#13#10 +' + - change width'#13#10 +' C clear base fire'#13#10 +' W give water into fire'#13#10 +' P draw palette'#13#10 +' A animate values on/off'); WriteLn(' space random values'#13#10 +' cursor edit values'#13#10 +' ESC exit demo'#13#10); WriteLn('values 1: decrease root of flame'#13#10 +' 2: how far flames go up'#13#10 +' 3: more or less fire'#13#10 +' 4: smooth root of flame'#13#10 +' 5: limit of start burning'#13#10 +' 6: burnability (wood..gaz)'#13#10 +' 7: sparks'#13#10 +' 8: new flames'#13#10 +' 9: put water into fire'#13#10); end; {********************************************************} const maxPar = 9; actPar: integer = 1; procedure StartBurning (xl,yl: integer); type tPar = record min, max, value: integer end; const par: array [1..maxPar] of tPar =((min: 0; max: 50; value: 10) {0: rootRand} ,(min: 0; max: 50; value: 15) {1: decay} ,(min: -2; max: 10; value: 10) {2: moreFire} ,(min: 0; max: 9; value: 10) {3: smooth} ,(min: 0; max:100; value: 10) {4: minFire} ,(min: 3; max: 90; value: 10) {5: fireInc} ,(min: 0; max: 10; value: 10) {6: sparks} ,(min: 0; max: 20; value: 10) {7: new fire} ,(min: 0; max: 20; value: 10)); {8: put water} const maxX = 319; maxY = 199; bkColor = 16; var vga256: array[0..maxY,0..maxX] of byte absolute $A000:0; cb: char; rootRand, {Max/Min decrease of the root of the flames} moreFire, {change fire intensity} decay, {How far should the flames go up on the screen ?} smooth, {How descrete can the flames be?} minFire, {limit between the "starting to burn" and the "is burning" routines } fireIncrease {3 = Wood, 90 = Gazolin} sparks, {new sparks per picture} newFlame, {create new flame} putWater: integer;{put water to fire} x1,x2,y1,y2: integer; {drawing rectangle} {********************************************************} procedure MakePal; const maxColor = 110; var ni: integer; pal: VGAPaletteType; begin FillChar (pal, SizeOf (pal), 0); for ni := 1 to MaxColor do HSI2RGB (4.6-1.5*ni/MaxColor, ni/MaxColor, ni/MaxColor, pal[ni]); for ni := MaxColor to 255 do begin pal[ni] := pal[ni-1]; With pal[ni] do begin if R < 63 then Inc(R); if R < 63 then Inc(R); if (ni Mod 2=0) And (G<53) then Inc(G); if (ni Mod 2=0) And (B<63) then Inc(B); end; end; WritePal (pal); end; procedure DrawPaletteScreen; var xi, yi: integer; begin MakePal; for yi := 0 to maxY do for xi := 0 to maxX do PutPixel (xi,yi,yi); end; procedure DrawValues; var ni, yi: integer; begin for ni := 1 to maxPar do begin yi := succ(ni) * 3; FillChar (vga256[yi,100], 120, 0); with par[ni] do if actPar = ni then FillChar (vga256[yi,100], 1 + longint(value)*119 div 20, 100) else FillChar (vga256[yi,100], 1 + longint(value)*119 div 20, 50); end; end; procedure CalcValues; begin with par[1] do rootRand := min + value * (max - min) div 20; with par[2] do decay := max - value * (max - min) div 20; with par[3] do moreFire := min + value * (max - min) div 20; with par[4] do smooth := min + value * (max - min) div 20; with par[5] do minFire := min + value * (max - min) div 20; with par[6] do fireIncrease := min + sqr (value); with par[7] do sparks := min + value * (max - min) div 20; with par[8] do newFlame := max - value * (max - min) div 20; with par[9] do putWater := max - value * (max - min) div 20; end; procedure ChangeValue; begin cb := ReadKey; if cb = 'P' {down} then actPar := (actPar mod maxPar) + 1; if cb = 'H' {up} then actPar := (actPar+maxPar-2) mod maxPar + 1; with par[actPar] do begin if cb = 'K' {left} then if value > 0 then dec (value); if cb = 'M' {right} then if value < 20 then inc (value); end; CalcValues; DrawValues; cb := #1; end; procedure RandomValues; var ni: integer; begin for ni := 1 to maxPar do par[ni].value := random(21); CalcValues; DrawValues; end; procedure AnimateValues; var ni: integer; begin ni := 1 + random (maxPar); with par[ni] do if random (2) = 0 then if value < 20 then inc (value) else else if value > 0 then dec (value); CalcValues; DrawValues; end; procedure ChangeSize (dx: integer); var yi: integer; begin if (dx > 0) and (x1 - dx > 2) then repeat dec (x1); inc (x2); dec (dx); for yi := y1 to y2 do begin PutPixel (x1,yi,0); PutPixel (x2,yi,0); end; until dx = 0; if (dx < 0) and (x1 - dx < 140) then repeat for yi := y1 to y2 do begin PutPixel (x1, yi, bkColor); PutPixel (x2, yi, bkColor); end; inc (x1); dec (x2); inc (dx); until dx = 0; xl := x2 - x1 - 1; end; procedure Help; begin SetVideoMode (3); {TextMode} ClrScr; Info; Write ('Hit any key to start '); cb := ReadKey; SetVideoMode ($13); MakePal; end; const animValues: boolean = false; var flameArray: array[0..319] of byte; x,xi,y,c,v: integer; begin x1 := (320 - xl) div 2; x2 := x1 + xl - 1; y1 := (200 - yl) div 2; y2 := y1 + yl - 1; Help; Randomize; FillChar (vga256, SizeOf(vga256), bkColor); FillChar (flameArray, SizeOf(flameArray), 0); for x := x1 to x2 do for y := y1 to y2 do PutPixel (x,y,0); CalcValues; pic := 0; repeat inc (pic); if KeyPressed then cb := upcase(ReadKey) else cb := #1; if cb = #0 then ChangeValue; while KeyPressed do ReadKey; {empty keyboard buffer} {Put the values from flameArray on the bottom line of the screen} for x := x1 to x2 do PutPixel (x, y2, flameArray[x]); {This loop makes the actual flames} for xi := x1 to x2 do begin if xi = x1 then x := xi else if xi < x2 then x := xi - 1 else x := xi - 2; for y := y1 + 1 to y2 do begin v := GetPixel (xi,y); if (v = 0) or (v < decay) { then PutPixel (x,pred(y),0) else PutPixel (x-pred(Random(3)),Pred(y),v-Random(decay)); } then vga256[pred(y),xi] := 0 else vga256[pred(y),x+Random(3)] := v-Random(decay); end; end; for xi := 1 to sparks do begin x := x1 + random (xl); y := y2 - random (yl - 10); PutPixel (x,y, GetPixel (x,y)+y); end; if Random(newFlame) = 0 {new fire ?} then FillChar (flameArray[x1+Random(xl-5)],5,199); if Random(putWater)= 0 {put water ?} then FillChar (flameArray[x1+Random(xl-5)],3,0); if cb <> #1 {check input ?} then begin if cb = '+' then ChangeSize (+5) else if cb = '-' then ChangeSize (-5) else if cb = 'R' then RandomValues else if cb = ' ' then RandomValues else if cb = 'A' then animValues := not animValues else if cb = 'C' then FillChar (flameArray, SizeOf(flameArray),0) else if cb = 'W' then for x := 1 to xl div 10 do flameArray[x1+Random(xl)] := 0 else if cb = '?' then Help else if cb = 'P' then DrawPaletteScreen; end; if animValues then AnimateValues; {This loop controls the "root" of the flames (values in flameArray)} for x := x1 to x2 do begin c := flameArray[x]; if c < MinFire then {Increase by the "burnability"} begin {Starting to burn:} if c > 10 then Inc (c, Random (fireIncrease)); end else {Otherwise randomize and increase by intensity (is burning)} Inc (c, Random (rootRand * 2 + 1) - rootRand + moreFire); if c > 200 then c := 200; {c too large ?} flameArray[x] := c; end; {Pour a little water on both sides of the fire to make it look nice on the sides} for x := 1 to xl div 8 do begin c := Trunc(Sqr(Random)*xl/8); flameArray[x1+c] := 0; flameArray[x2-c] := 0; end; {Smoothen the values of FrameArray to avoid "descrete" flames} for x := x1+Smooth to x2-Smooth do begin c := 0; for y := -Smooth to Smooth do Inc (c,flameArray[x+y]); flameArray[x] := c div (2*Smooth+1); end; until (cb = #27); end; {********************************************************} var lastMode: byte; Begin lastMode := GetVideoMode; {save video mode} StartBurning (120, 100); {fire simulation} SetVideoMode (lastMode); {Restore video mode} Info; End.