Пламя

ИСПОЛЬЗОВАНЫ ВСТАВКИ АСССЕМБЛЕР

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

http://ishodniki.ru/