home *** CD-ROM | disk | FTP | other *** search
/ Rat's Nest 1 / ratsnest1.iso / incoming / pas_sors.arj / BURN.PAS < prev    next >
Pascal/Delphi Source File  |  1994-05-25  |  7KB  |  309 lines
  1. {$A+,B-,D+,E+,F-,G+,I-,L+,N+,O-,P+,Q-,R-,S-,T-,V-,X+,Y+}
  2. {$M 16384,0,655360}
  3.  
  4. {
  5.  
  6. Hi guys, try this, use it in your code, but please credit
  7.  
  8. Frank Jan Sorensen Alias:Frank Patxi (fjs@lab.jt.dk) for the
  9. fireroutine.
  10.  
  11. }
  12.  
  13.  
  14. Program Burn;
  15. uses
  16.   Dos,Crt;
  17.  
  18. Const
  19.   RootRand     =  20;   { Max/Min decrease of the root of the flames }
  20.   Decay        =  10;   { How far should the flames go up on the screen? }
  21.   MinY         = 100;   { Startingline of the flame routine.
  22.                           (should be adjusted along with MinY above) }
  23.   Smooth       =   1;   { How descrete can the flames be?}
  24.   MinFire      =  50;   { limit between the "starting to burn" and
  25.                           the "is burning" routines }
  26.   XStart       =  90;   { Startingpos on the screen }
  27.   XEnd         = 210;   { Guess! }
  28.   Width        = XEnd-XStart; {Well- }
  29.   MaxColor     = 110;   { Constant for the MakePal procedure }
  30.   FireIncrease : Byte =   3;  {3 = Wood, 90 = Gazolin}
  31.  
  32. Var
  33.   Scr : Array[0..199,0..319] Of Byte Absolute $A000:$0000;
  34.  
  35. Type
  36.   ColorValue     = record
  37.                      R, G, B : byte;
  38.                    end;
  39.   VGAPaletteType = array[0..255] of ColorValue;
  40.  
  41.  
  42. procedure ReadPal(var Pal);
  43. var
  44.   K    : VGAPaletteType Absolute Pal;
  45.   Regs : Registers;
  46. begin
  47.   with Regs do
  48.   begin
  49.     AX := $1017;
  50.     BX := 0;
  51.     CX := 256;
  52.     ES := Seg(K);
  53.     DX := Ofs(K);
  54.     Repeat Until Port[$03DA] And $08 = $08; {Wait for rescan}
  55.     Intr($10,Regs);
  56.   end;
  57. end;
  58.  
  59. procedure WritePal(var Pal);
  60. Var
  61.   K : VGAPaletteType Absolute Pal;
  62.   Regs : Registers;
  63. begin
  64.   with Regs do
  65.   begin
  66.     AX := $1012;
  67.     BX := 0;
  68.     CX := 256;
  69.     ES := Seg(K);
  70.     DX := Ofs(K);
  71.     Repeat Until Port[$03DA] And $08 = $08; {Wait for rescan}
  72.     Intr($10,Regs);
  73.   end;
  74. end;
  75.  
  76. Procedure Hsi2Rgb(H, S, I : Real; var C : ColorValue);
  77. {Convert (Hue, Saturation, Intensity) -> (RGB)}
  78. var
  79.   T : Real;
  80.   Rv, Gv, Bv : Real;
  81. begin
  82.   T := H;
  83.   Rv := 1 + S * Sin(T - 2 * Pi / 3);
  84.   Gv := 1 + S * Sin(T);
  85.   Bv := 1 + S * Sin(T + 2 * Pi / 3);
  86.   T := 63.999 * I / 2;
  87.   with C do
  88.   begin
  89.     R := trunc(Rv * T);
  90.     G := trunc(Gv * T);
  91.     B := trunc(Bv * T);
  92.   end;
  93. end; { Hsi2Rgb }
  94.  
  95. { Faster put'n get pixel routines!  }
  96.  
  97. procedure put(x,y : integer; c : byte); assembler;
  98. { Written by Matt Sottile }
  99.  asm
  100.   mov ax,y
  101.   mov bx,ax
  102.   shl ax,8
  103.   shl bx,6
  104.   add bx,ax
  105.   add bx,x
  106.   mov ax,0a000h
  107.   mov es,ax
  108.   mov al,c
  109.   mov es:[bx],al
  110.  end;
  111.  
  112. Function get(x,y : integer):byte;
  113. { Put Modified by me }
  114. begin
  115.  asm
  116.   mov ax,y
  117.   mov bx,ax
  118.   shl ax,8
  119.   shl bx,6
  120.   add bx,ax
  121.   add bx,x
  122.   mov ax,0a000h
  123.   mov es,ax
  124.   mov al,es:[bx]
  125.   mov @result,al
  126.  end;
  127. end;
  128.  
  129. Procedure MakePal;
  130. Var
  131.   I : Byte;
  132.   Pal   : VGAPaletteType;
  133.  
  134. begin
  135.   FillChar(Pal,SizeOf(Pal),0);
  136.   For I:=1 To MaxColor Do
  137.     HSI2RGB(4.6-1.5*I/MaxColor,I/MaxColor,I/MaxColor,Pal[I]);
  138.   For I:=MaxColor To 255 Do
  139.   begin
  140.     Pal[I]:=Pal[I-1];
  141.     With Pal[I] Do
  142.     begin
  143.       If R<63 Then Inc(R);
  144.       If R<63 Then Inc(R);
  145.       If (I Mod 2=0) And (G<53)  Then Inc(G);
  146.       If (I Mod 2=0) And (B<63) Then Inc(B);
  147.     end;
  148.   end;
  149.  
  150.   WritePal(Pal);
  151.  
  152. end;
  153.  
  154.  
  155. Function Rand(R:Integer):Integer;{ Return a random number between -R And R}
  156. begin
  157.   Rand:=Random(R*2+1)-R;
  158. end;
  159.  
  160. Procedure Help;
  161. Var
  162.   Mode : Byte;
  163.   R    : Registers;
  164. begin
  165.   R.Ax:=$0F00;
  166.   Intr($10,R);
  167.   Mode:=R.Al;
  168.   R.Ax:=$0003;  {TextMode}
  169.   Intr($10,R);
  170.  
  171.   ClrScr;
  172.   WriteLn('Burn version 1.00');
  173.   WriteLn;
  174.   WriteLn('Light''n''play');
  175.   WriteLn;
  176.   WriteLn('Keys : ');
  177.   WriteLn('<space> : Throw in a match');
  178.   WriteLn('<W>     : Water');
  179.   WriteLn('<+>     : Increase intensity');
  180.   WriteLn('<->     : Decrease intensity');
  181.   WriteLn('<C>     : Initialize fire');
  182.   WriteLn('<1>..<9>: Burnability (1=Wood, 9=Gaz)');
  183.   WriteLn('<?>     : This help');
  184.   WriteLn;
  185.   Write('Hit any key kid >');
  186.   ReadKey;
  187.   R.Ax:=$0000+Mode;
  188.   Intr($10,R);
  189.   If Mode = $13 Then MakePal;
  190. end;
  191.  
  192. Var
  193.   FlameArray : Array[XStart..XEnd] Of Byte;
  194.   LastMode : Byte;
  195.   I,J : Integer;
  196.   X,P : Integer;
  197.   MoreFire,
  198.   V   : Integer;
  199.   R   : Registers;
  200.   Ch  : Char;
  201. begin
  202.  
  203.   Help;
  204.   RandomIze;
  205.   R.Ax:=$0F00;
  206.   Intr($10,R);
  207.   LastMode:=R.Al;
  208.   R.Ax:=$0013;
  209.   Intr($10,R);
  210.  
  211.   MoreFire:=1;
  212.   MakePal;
  213.  
  214. {
  215.   (* Use this if you want to view the palette *)
  216.   For I:=0 To 255 Do
  217.   For J:=0 To 20 Do
  218.     Put(I,J,I);
  219.   ReadKey;
  220. {}
  221.   { Initialize FlameArray }
  222.   For I:=XStart To XEnd Do
  223.     FlameArray[I]:=0;
  224.  
  225.   FillChar(Scr,SizeOf(Scr),0); { Clear Screen }
  226.  
  227.   repeat
  228.     If KeyPressed Then Ch:=ReadKey Else Ch:='.'; {'.' = Nothing (Dummy)}
  229.  
  230.     While KeyPressed Do ReadKey;  { Empty Keyboard buffer }
  231.  
  232.     { Put the values from FlameArray on the bottom line of the screen }
  233.     For I:=XStart To XEnd Do
  234.       Put(I,199,FlameArray[I]);
  235.  
  236.     { This loop makes the actual flames }
  237.  
  238.     For I:=XStart To XEnd Do
  239.     For J:=MinY To 199 Do
  240.     begin
  241.       V:=Get(I,J);
  242.       If (V=0) Or
  243.          (V<Decay) Or
  244.          (I<=XStart) Or
  245.          (I>=XEnd) Then
  246.         Put(I,Pred(J),0)
  247.       else
  248.         Put(I-Pred(Random(3)),Pred(J),V-Random(Decay));
  249.     end;
  250.  
  251.     {Match?}
  252.     If (Random(150)=0) Or (Ch=' ') Then
  253.       FillChar(FlameArray[XStart+Random(XEnd-XStart-5)],5,255);
  254.  
  255.     {In-/Decrease?}
  256.     If (Ch='-') Then If MoreFire >-2 Then Dec(MoreFire);
  257.     If (Ch='+') Then If MoreFire < 4 Then Inc(MoreFire);
  258.  
  259.     {!!}
  260.     If UpCase(Ch) = 'C' Then FillChar(FlameArray,SizeOf(FlameArray),0);
  261.     If UpCase(Ch) = 'W' Then
  262.       for I:=1 To 10 Do FlameArray[XStart+Random(Width)]:=0;
  263.  
  264.     If Ch = '?' Then Help;
  265.  
  266.     if Ch in ['1'..'9'] Then FireIncrease:=3+Sqr(Ord(Ch)-Ord('1'));
  267.  
  268.     {This loop controls the "root" of the
  269.      flames ie. the values in FlameArray.}
  270.     For I:=XStart To XEnd Do
  271.     begin
  272.       X:=FlameArray[I];
  273.  
  274.       If X<MinFire Then { Increase by the "burnability"}
  275.       begin
  276.         {Starting to burn:}
  277.         If X>10 Then Inc(X,Random(FireIncrease));
  278.       end
  279.       else
  280.       { Otherwise randomize and increase by intensity (is burning)}
  281.         Inc(X,Rand(RootRand)+MoreFire);
  282.       If X>255 Then X:=255; { X Too large ?}
  283.       FlameArray[I]:=X;
  284.     end;
  285.  
  286.  
  287.     { Pour a little water on both sides of
  288.       the fire to make it look nice on the sides}
  289.     For I:=1 To Width Div 8 Do
  290.     begin
  291.       X:=Trunc(Sqr(Random)*Width/8);
  292.       FlameArray[XStart+X]:=0;
  293.       FlameArray[XEnd-X]:=0;
  294.     end;
  295.  
  296.     {Smoothen the values of FrameArray to avoid "descrete" flames}
  297.     P:=0;
  298.     For I:=XStart+Smooth To XEnd-Smooth Do
  299.     begin
  300.       X:=0;
  301.       For J:=-Smooth To Smooth Do Inc(X,FlameArray[I+J]);
  302.       FlameArray[I]:=X Div (2*Smooth+1);
  303.     end;
  304.   Until Ch=#27;
  305.   {Restore video mode}
  306.   R.Ax:=$0000+LastMode;
  307.   Intr($10,R);
  308.   {Good bye}
  309. end.