Скачать Burn 2.0 - Modified Fire Routine

Program Burn;
uses
  Dos,Crt;
 
Const
  RootRand = 20;  { Max/Min decrease of the root of the flames }
  Decay    =  5;  { How far should the flames go up on the screen? }
                  { This MUST be positive - JF }
  MinY     = 50;  { Startingline of the flame routine.
                    (should be adjusted along with MinY above) }
  Smooth   =  1;  { How descrete can the flames be?}
  MinFire  = 50;  { limit between the "starting to burn" and
                    the "is burning" routines }
  XStart   = 90;  { Startingpos on the screen, should be divideable
                    by 4 without remain!}
  XEnd     = 210; { Guess! }
  Width    = XEnd-XStart; {Well- }
  MaxColor = 110;   { Constant for the MakePal procedure }
  FireIncrease : Byte =   3;  {3 = Wood, 90 = Gazolin}
 
{Var
  Scr : Array[0..199,0..319] Of Byte Absolute $A000:$0000;}
 
Type
  ColorValue     = record
                     R, G, B : byte;
                   end;
  VGAPaletteType = array[0..255] of ColorValue;
 
function fastrand : word;assembler;
const
  factor : longint = $8088405;
asm
  db  66h,81h,0E3h,0FFh,0FFh,00h,00h{and ebx,$FFFF}
  db  66h;mov  ax,word ptr randseed
  db  66h;mul  word ptr factor
  db  66h;inc  ax
  db  66h;mov  word ptr randseed,ax
 
  db  66h;shr  ax,16
  db  66h;mul  bx
  db  66h;shr  ax,16
end;
 
procedure ReadPal(var Pal);
var
  K    : VGAPaletteType Absolute Pal;
  Regs : Registers;
begin
  with Regs do
  begin
    AX := $1017;
    BX := 0;
    CX := 256;
    ES := Seg(K);
    DX := Ofs(K);
    Repeat Until Port[$03DA] And $08 = $08; {Wait for rescan}
    Intr($10,Regs);
  end;
end;
 
procedure move(var input,output;size : word);assembler;
{
implemented by me -SG
-you can use this routine instead of the one implemented in Pascal...
 it's much more faster (nearly 4 times depending on your pc)!
}
asm
mov dx,ds
lds si,input
les di,output
mov cx,size
mov ax,cx
shr cx,2
jz @not4
db 0F3h,66h,0A5h{rep movsd}
@not4:
 mov cx,ax
 and cx,11b
 jz @end
rep movsb
@end:
mov ds,dx
end;
 
 
procedure WritePal(var Pal);
Var
  K : VGAPaletteType Absolute Pal;
  Regs : Registers;
begin
  with Regs do
  begin
    AX := $1012;
    BX := 0;
    CX := 256;
    ES := Seg(K);
    DX := Ofs(K);
    Repeat Until Port[$03DA] And $08 = $08; {Wait for rescan}
    Intr($10,Regs);
  end;
end;
 
Procedure Hsi2Rgb(H, S, I : Real; var C : ColorValue);
{Convert (Hue, Saturation, Intensity) -> (RGB)}
var
  T : Real;
  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;
  with C do
  begin
    R := trunc(Rv * T);
    G := trunc(Gv * T);
    B := trunc(Bv * T);
  end;
end; { Hsi2Rgb }
 
{ Faster put'n get pixel routines!  }
(*
procedure put(x,y : integer; c : byte); assembler;
{ Written by Matt Sottile }
 asm
  mov ax,y
  shl ax,6
  mov di,ax
  shl di,2
  add di,ax
  add di,x
  mov ax,0a000h
  mov es,ax
  mov al,c
  mov es:[di],al
 end;
 
Function get(x,y : integer):byte; assembler;
{ Put Modified by me }
asm
  mov ax,y
  shl ax,6
  mov di,ax
  shl di,2
  add di,ax
  add di,x
  mov ax,0a000h
  mov es,ax
  mov al,es:[bx]
end;
*)
Procedure MakePal;
Var
  I : Byte;
  Pal   : VGAPaletteType;
 
begin
  FillChar(Pal,SizeOf(Pal),0);
  For I:=1 To MaxColor Do
    HSI2RGB(4.6-1.5*I/MaxColor,I/MaxColor,I/MaxColor,Pal[I]);
  For I:=MaxColor To 255 Do
  begin
    Pal[I]:=Pal[I-1];
    With Pal[I] Do
    begin
      If R<63 Then Inc(R);
      If R<63 Then Inc(R);
      If (I Mod 2=0) And (G<53)  Then Inc(G);
      If (I Mod 2=0) And (B<63) Then Inc(B);
    end;
  end;
 
  WritePal(Pal);
 
end;
 
 
Function Rand(R:Integer):Integer;
{ Return a random number between -R And R}
begin
  Rand:=Random(R*2+1)-R;
end;
 
 
Procedure Help;
Var
  Mode : Byte;
  R    : Registers;
begin
  R.Ax:=$0F00;
  Intr($10,R);
  Mode:=R.Al;
  R.Ax:=$0003;  {TextMode}
  Intr($10,R);
 
  ClrScr;
  WriteLn('Burn version 1.15');
  WriteLn;
  WriteLn('Light''n''play');
  WriteLn;
  WriteLn('Keys : ');
  WriteLn('<space> : Throw in a match');
  WriteLn('<W>     : Water');
  WriteLn('<+>     : Increase intensity');
  WriteLn('<->     : Decrease intensity');
  WriteLn('<C>     : Initialize fire');
  WriteLn('<1>..<9>: Burnability (1=Wood, 9=Gaz)');
  WriteLn('<?>     : This help');
  WriteLn;
  Write('Hit any key kid >');
  ReadKey;
  R.Ax:=$0000+Mode;
  Intr($10,R);
  If Mode = $13 Then MakePal;
end;
 
Var
  FlameArray : Array[XStart..XEnd] Of Byte;
  LastMode : Byte;
  I,J : Integer;
  X,P : Integer;
  MoreFire,
  V   : Integer;
  R   : Registers;
  Ch  : Char;
  pt   : pointer;
begin
  getmem(pt,64000);
  Help;
  RandomIze;
  R.Ax:=$0F00;
  Intr($10,R);
  LastMode:=R.Al;
  R.Ax:=$0013;
  Intr($10,R);
 
  MoreFire:=1;
  MakePal;
 
  (* Use this if you want to view the palette *)
{  For I:=0 To 255 Do
  For J:=0 To 20 Do
    Put(I,J,I);
  ReadKey;}
 
  { Initialize FlameArray }
  For I:=XStart To XEnd Do
    FlameArray[I]:=0;
 
{  FillChar(Scr,SizeOf(Scr),0); { Clear Screen }
  fillchar(pt^,64000,0);
 
  repeat
    If KeyPressed Then Ch:=ReadKey Else Ch:='.';
                                  {'.' = Nothing (Dummy)}
 
    While KeyPressed Do ReadKey;  { Empty Keyboard buffer }
 
   { Put the values from FlameArray on the bottom line of the screen }
    Move(FlameArray,
         ptr(seg(pt^),ofs(pt^)+199*320+pred(XStart))^,
         Width+1);
 
    { This loop makes the actual flames }
 
    { Here comes my assembler code - JF }
 
    { There's still a little bug in the code: When you have started
      the fire, some pixels near the upper left corner of the screen
      dance around. }
 
    asm
       les DI, PT
       mov SI, DI
       mov AX, MinY*320+XStart
       add SI, MinY*320+XStart
       add DI, MinY*320+XStart-320
       mov CX, 200-MinY
@@1:
         push CX
         mov CX, Width+1
@@2:
           mov AL,ES:[SI]
           inc SI
           cmp AL, Decay
           jb  @@3
           cmp CX, 2
           jb  @@3
           cmp CX, Width-1
           ja  @@3
           push CX
           push AX
           mov BX, 3
           call FastRand
           dec AX
           push AX
           mov BX, Decay
           call FastRand
           pop DX
           pop CX
           sub CL, AL
           mov AL, CL
           sub DI, DX
           mov ES:[DI],AL{a little bit faster than stosb}
           inc DI
           add DI, DX
           pop CX
           dec CX
           jnz @@2
 
         add SI, 319-Width
         mov DI, SI
         sub DI, 320
         pop CX
         dec CX
         jnz @@1
 
       jmp @@4
 
@@3:       xor AL, AL
           mov ES:[DI],AL
           inc DI
           dec CX
           jnz @@2
 
         add SI, 319-Width
         mov DI, SI
         sub DI, 320
         pop CX
         dec CX
         jnz @@1
 
@@4:
    end;
 
{
  (* This was the original code I translated to assembler - JF *)
 
    For I:=XStart To XEnd Do
    For J:=MinY To 199 Do
    begin
      V:=VMem[J, I];
      If (V=0) Or
         (V<Decay) Or
         (I<=XStart) Or
         (I>=XEnd) Then
        Put(I, Pred(J), 0);
      else
        Put(I-Pred(Random(3)), Pred(J), V-Random(Decay));
    end;
}
 
    {Match?}
    If (Random(150)=0) Or (Ch=' ') Then
      FillChar(FlameArray[XStart+Random(XEnd-XStart-5)],5,255);
 
    {In-/Decrease?}
    If (Ch='-') Then If MoreFire >-2 Then Dec(MoreFire);
    If (Ch='+') Then If MoreFire < 4 Then Inc(MoreFire);
 
    {!!}
    If UpCase(Ch) = 'C' Then
      FillChar(FlameArray,SizeOf(FlameArray),0);
    If UpCase(Ch) = 'W' Then
      for I:=1 To 10 Do FlameArray[XStart+Random(Width)]:=0;
 
    If Ch = '?' Then Help;
 
    if Ch in ['1'..'9'] Then FireIncrease:=3+Sqr(Ord(Ch)-Ord('1'));
 
    {This loop controls the "root" of the
     flames ie. the values in FlameArray.}
    For I:=XStart To XEnd Do
    begin
      X:=FlameArray[I];
 
      If X<MinFire Then { Increase by the "burnability"}
      begin
        {Starting to burn:}
        If X>10 Then Inc(X,Random(FireIncrease));
      end
      else
      { Otherwise randomize and increase by intensity (is burning)}
        Inc(X,Rand(RootRand)+MoreFire);
      If X>255 Then X:=255; { X Too large ?}
      FlameArray[I]:=X;
    end;
 
 
    { Pour a little water on both sides of
      the fire to make it look nice on the sides}
    For I:=1 To Width Div 8 Do
    begin
      X:=Trunc(Sqr(Random)*Width/8);
      FlameArray[XStart+X]:=0;
      FlameArray[XEnd-X]:=0;
    end;
 
    {Smoothen the values of FrameArray to avoid "descrete" flames}
    P:=0;
    For I:=XStart+Smooth To XEnd-Smooth Do
    begin
      X:=0;
      For J:=-Smooth To Smooth Do Inc(X,FlameArray[I+J]);
      FlameArray[I]:=X Div succ(Smooth shl 1);
    end;
 
  for i := miny to 199 do
  move(ptr(seg(pt^),ofs(pt^)+i*320+xstart)^,
       ptr(segA000,i*320+xstart)^,
       width+1);
  Until Ch=#27;
  {Restore video mode}
  textmode(lastmode);
  {Good bye}
freemem(pt,64000);
end.