Пламя 3

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

{$A+,B-,D+,E+,F-,G+,I-,L+,N+,O-,P+,Q-,R-,S-,T-,V-,X+,Y+}
{$M 16384,0,655360}

{

Hi guys, try this, use it in your code, but please credit

Frank Jan Sorensen Alias:Frank Patxi (fjs@lab.jt.dk) for the
fireroutine.

}

{

Hi again, guys!

If you use this code, please also credit me, Joachim Fenkes, 'cause I added
the following speedups:

  -Replaced one tiny loop with a faster Move(...) (not much speedup)
  -Wrote the main display loop in 100% assembler, including a faster random
   number generator (the RNG is only a more or less optimized version of
   Borland's generator (see MEGARAND.ASM), but with the advantage of the
   ultimate crash if you call it normally :-)
  -Changed version number into 1.10 (this isn't a speedup, but necessary :-)

}

{
 Bcoz of the knowledge that reading from videocards is much slower than
 writing to them, I changed some things to write and read from/to a pointer
 and put the result with 32-Bit moves to the screen

 Also I added now a much more faster randommer.

 The result of this change is more than 3 times fast than before
  Stefan Goehler
 Please credit me!
 ...
 to JF: your bug is fixed!
}
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.

http://ishodniki.ru