[Back to GRAPHICS SWAG index] [Back to Main SWAG index] [Original]
{$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.
[Back to GRAPHICS SWAG index] [Back to Main SWAG index] [Original]