{*************************************************************}
{           TFlame Components for Delphi 16/32                }
{ Version:  1.5                                               }
{ Authors:  Matthias Laschat - 16-bit component               }
{                                                             }
{           Aleksey Xacker   - Upgraded to Win32,             }
{                              Added transparent image,       }
{                              Added bottom range,            }
{                              Improvement                    }
{	                       (http://www.angen.net/~xacker/)}
{                                                             }
{           Emir Kurtovic    - Multicolour Flame,             }
{                              Fading of flame,               }
{                              Improvement (MIKS)             }
{                              (http://www.net.yu/~miks)      }
{*************************************************************}
{ Last modified: March, 7, 1999                               }
{*************************************************************}
{                      IMPORTANT NOTE:                        }
{  This code may be used and modified by anyone so long as    }
{ this header and copyright information remains intact. By    }
{ using this code you agree to indemnify Aleksey Xacker from  }
{ any liability that might arise from its use. You must       }
{ obtain written consent before selling or redistributing     }
{ this code.                                                  }
{                                                             }
{ If at occurrence of any questions concerning these          }
{ component, mail: xacker@phreaker.net.                       }
{ For updated versions, visit: http://www.angen.net/~xacker/  }
{*************************************************************}

unit Flame;

interface

uses
  {$IFDEF WIN32} Windows,
  {$ELSE} WinTypes, WinProcs,
  {$ENDIF} Messages, Classes, Graphics, Controls, Forms;

type
  PFlameField = ^TFlameField;
  TFlameField = Array[0..100,0..159] of Word;
  PBitmapData = ^TBitmapData;
  TBitmapData = Array[0..199,0..319] of Byte;

type
  DoSto = 0..100;    {MIKS} { До ста } 
  DoDvesta = 0..199; {MIKS} { До двухсот }
  TFireColor = (FireRed, FireGreen, FireBlue, FireDeepPurple, FireCyan, FireYellow); {MIKS Add-ON}

  TFlame = class(TGraphicControl)
  private
    FadeProcess: Byte; {MIKS}
    FFireColor: TFireColor; {MIKS}
    FFadeOut: Boolean; {MIKS}

    FEnabled: Boolean;
    FInterval: Word;
    FWindowHandle: hWnd;

    TmpImage, FImage: TBitmap;
    FPalette: HPalette;
    FBitmap: PBitmapData;
    FFlameField: PFlameField;
    FBottomRange: DoDvesta;
    FSolidFlame: Boolean;
    FOnFlame: TNotifyEvent;

    procedure UpdateTimer;
    procedure SetEnabled(Value: Boolean);
    procedure SetInterval(Value: Word);
    procedure SetOnFlame(Value: TNotifyEvent);
    procedure WndProc(var Msg: TMessage);

    procedure MakePalette; virtual;
    procedure KillPalette; virtual;
    function GetPalette: hPalette; override;
    {$IFNDEF WIN32}
    procedure DrawTransparentBitmap(ahDC: hDC; xStart, yStart, x1,y1,x2,y2: Word);
    {$ENDIF}
  protected
    procedure FlameIt; dynamic;
  public
    constructor Create(aowner: TComponent); override;
    destructor Destroy; override;
    procedure Paint; override;

    procedure DoFlame; virtual;
    procedure MakeRandomLine(y: DoSto); virtual;
    procedure MakeDarkLine(y: DoSto); virtual;
    procedure SetFlamePixel(x, y: Byte); virtual;
    procedure SetImage(aImage: TBitmap); virtual;
    procedure SetBottomRange(Value: DoDvesta); virtual;
    procedure SetFireColor(Value: TFireColor); virtual; {MIKS}
    procedure SetFadeOut(Value: Boolean); virtual; {MIKS}
  published
    property FadeOut: Boolean read FFadeOut write SetFadeOut default False; {MIKS}
    property FireColor: TFireColor read FFireColor write SetFireColor; {MIKS}

    property Align;
    property Enabled: Boolean read FEnabled write SetEnabled default True;
    property Interval: Word read FInterval write SetInterval default 50;
    property Height default 200;
    property Width default 320;
    property OnClick;
    property OnFlame: TNotifyEvent read FOnFlame write SetOnFlame;
    property Image: TBitmap read FImage write SetImage;
    property BottomRange: DoDvesta read FBottomRange write SetBottomRange;
    property SolidFlame: Boolean read FSolidFlame write FSolidFlame;
  end;

procedure Register;

implementation

constructor TFlame.Create;
begin
  inherited Create(aOwner);
  FadeProcess := $FF;
  MakePalette;
  FEnabled := True;
  FInterval := 20;
  FWindowHandle := AllocateHWnd(WndProc);
  FFadeOut := False;
  FFireColor := FireRed;
  Height := 200;
  Width := 320;

  New(FBitmap);
  New(FFlameField);
  FillChar(FBitmap^, 64000, 0);
  FillChar(FFlameField^, 32000, 0);
  FImage := TBitmap.Create;
  TmpImage := TBitmap.Create;
  UpdateTimer;
end;

destructor TFlame.Destroy;
begin
  Enabled := False;
  DeallocateHWnd(FWindowHandle);
  TmpImage.Free;
  FImage.Free;
  Dispose(FFlameField);
  Dispose(FBitmap);
  KillPalette;  
  inherited Destroy;
end;

procedure TFlame.Paint;
var
  DC, mDC: hDC;
  BitsInfo: pBitmapInfo;
  i: Integer;
  OldPal: hPalette;
  MemB, MemOld:hBitmap;
begin
  DC := Canvas.Handle;
  GetMem(bitsinfo, SizeOf(TBitmapInfoHeader) + 256 * 2);
  with BitsInfo^ do
   begin
    with bmIHeader do
     begin
      biSize := 40;
      biWidth := 320;
      biHeight := 200;
      biPlanes := 1;
      biBitCount := 8;
      biCompression := 0;
      biSizeImage := 64000;
      biXPelsPerMeter := 0;
      biYPelsPerMeter := 0;
      biClrUsed := 256;
      biClrImportant := 256;
    end;
    for i := 0 to 127 do
     begin
      bmIColors[i].RGBBlue := 2 * i;
      bmIColors[i].RGBGreen := 0;
      bmIColors[i].RGBRed := 2 * i + 1;
      bmIColors[i].RGBReserved := 0;
    end;
  end;
  mDC := TmpImage.Canvas.Handle;
  MemB := CreateCompatibleBitmap (DC, 320, 200);
  MemOld := SelectObject(mDC, MemB);
  OldPal := SelectPalette(mDC, FPalette, False);

  SetDIBitsToDevice(mDC, 0, 0, Width, Height, 0, 0, 0, 200, FBitmap, BitsInfo^, DIB_Pal_Colors);
  {$IFDEF WIN32}
  Image.Transparent := True;
  Image.TransparentColor := 0;  { black }
  TmpImage.Canvas.Draw(Width div 2 - Image.Width div 2, Height div 2 - Image.Height div 2,Image);
  {$ELSE}
  DrawTransparentBitmap(mDC, Width div 2 - Image.Width div 2, Height div 2 - Image.Height div 2,
                        0, 0, Image.Width,Image.Height);
  {$ENDIF}
  BitBlt(DC, 0, 0, Width, Height - FBottomRange, mDC, 0, 0, SrcCopy);

  DeleteObject(SelectObject(mDC, MemOld));

  FreeMem(BitsInfo, SizeOf(TBitmapInfoHeader) + 256 * 2);
  SelectPalette(DC, OldPal, False);
end;

procedure TFlame.MakePalette;
var
  Pal: PLogPalette;
  i: Integer;

  procedure SetPalettereg(c, r, g, b: Byte);
  begin
    case FFireColor of
      FireRed:Begin
        Pal^.PalPalEntry[c].PeRed:=r shl 2;
        Pal^.PalPalEntry[c].PeGreen:=g shl 2;
        Pal^.PalPalEntry[c].PeBlue:=b shl 2;
        Pal^.PalPalEntry[c].PeFlags:=0;
      end;
      FireGreen:Begin
        Pal^.PalPalEntry[c].PeRed:=g shl 2;
        Pal^.PalPalEntry[c].PeGreen:=r shl 2;
        Pal^.PalPalEntry[c].PeBlue:=b shl 2;
        Pal^.PalPalEntry[c].PeFlags:=0;
      end;
      FireBlue:Begin
        Pal^.PalPalEntry[c].PeRed:=b shl 2;
        Pal^.PalPalEntry[c].PeGreen:=g shl 2;
        Pal^.PalPalEntry[c].PeBlue:=r shl 2;
        Pal^.PalPalEntry[c].PeFlags:=0;
      end;
      FireDeepPurple:Begin
        Pal^.PalPalEntry[c].PeRed:=r shl 2;
        Pal^.PalPalEntry[c].PeGreen:=g shl 2;
        Pal^.PalPalEntry[c].PeBlue:=r shl 2;
        Pal^.PalPalEntry[c].PeFlags:=0;
      end;
      FireCyan:Begin
        Pal^.PalPalEntry[c].PeRed:=b shl 2;
        Pal^.PalPalEntry[c].PeGreen:=r shl 2;
        Pal^.PalPalEntry[c].PeBlue:=r shl 2;
        Pal^.PalPalEntry[c].PeFlags:=0;
      end;
      FireYellow:Begin
        Pal^.PalPalEntry[c].PeRed:=r shl 2;
        Pal^.PalPalEntry[c].PeGreen:=r shl 2;
        Pal^.PalPalEntry[c].PeBlue:=b shl 2;
        Pal^.PalPalEntry[c].PeFlags:=0;
      end;
    end;
  end;

begin
  GetMem(Pal, 4 + 256 * 4);
  FillChar(Pal^, 4 + 256 * 4, 0);
  Pal^.PalVersion := $300;
  Pal^.PalNumEntries := 256;
  for i:=0 to 63 do SetPaletteReg(i, i, 0, 0);
  for i:=0 to 63 do SetPaletteReg(64 + i, 63, i, 0);
  for i:=0 to 63 do SetPaletteReg(128 + i, 63, 63, i);
  for i:=0 to 63 do SetPaletteReg(192 + i, 63, 63, 63);
  FPalette:=CreatePalette(Pal^);
  FreeMem(Pal, 4 + 256 * 4);
end;

procedure TFlame.KillPalette;
begin
  DeleteObject(FPalette);
end;

function TFlame.GetPalette;
begin
  GetPalette:=FPalette;
end;

procedure TFlame.DoFlame;
type
  Giant = array[0..$FFFE] of byte;
var
  FieldPtr, BitmapPtr: Pointer;
  y, x, w, ax, fpt, bpt: Word;
  bt: Array[1..2] of Byte;
begin
  FieldPtr := FFlameField;
  BitmapPtr := FBitmap;
  for y := 0 to 97 do
{$IFDEF WIN32}
   begin
    bpt := 640 * (99 - y);
    fpt := 320 * y;
    for x := 1 to 160 do
     begin
      move(Giant(FieldPtr^)[fpt + 159 * 2], w, 2);
      ax := w;
      move(Giant(FieldPtr^)[fpt + 160 * 2], w, 2);
      ax := w + ax;
      move(Giant(FieldPtr^)[fpt + 161 * 2], w, 2);
      ax := w + ax;
      move(Giant(FieldPtr^)[fpt + 320 * 2], w, 2);
      ax := w + ax;
      ax := ax shr 2;
      if ax <> 0 then dec(ax);
      move(ax, Giant(FieldPtr^)[fpt], 2);
      inc(fpt, 2);
      bt[1] := Lo(ax);
      bt[2] := bt[1];
      Move(bt, ax, 2);
      move(ax, Giant(BitmapPtr^)[bpt - 1], 2);
      move(ax, Giant(BitmapPtr^)[bpt - 321], 2);
      dec(bpt, 2);
     end;
{$ELSE}
     asm
      push ds
      les di, BitmapPtr
      mov ax,640
      mov bx,99
      sub bx,y
      mul bx
      add di,ax

      lds si, FieldPtr
      mov ax,320
      mul y
      add si,ax

      mov cx,160
    @schleifex:

      mov ax,[si+159*2]
      add ax,[si+160*2]
      add ax,[si+161*2]
      add ax,[si+320*2]
      shr ax,2
      cmp ax,0
      je @keindec
      dec ax
    @keindec:
      mov [si],ax
      add si,2
      mov ah,al
      mov es:[di-1],ax
      mov es:[di-321],ax
      sub di,2

      loop @schleifex
      pop ds
{$ENDIF}
   end;
  Paint;
end;                      

procedure TFlame.FlameIt;
begin
  if not FFadeOut then
   if FSolidFlame then
    MakeRandomLine(98+Random(2)) {MIKS}
   else
    MakeRandomLine(98)
  else
   MakeDarkLine(98+Random(2));  {MIKS}
  DoFlame;
  if Assigned(FOnFlame) then FOnFlame(Self);
end;

procedure TFlame.MakeRandomLine;
var
  x: Word;
begin
  for x := 10 to 149 do
   FFlameField^[y, x] := Random(2) * 256;
end;

procedure TFlame.MakeDarkLine;
var
  x: Word;
begin
  for x := 10 to 149 do
   FFlameField^[y, x] := Random(2) + Random(FadeProcess);
  if FadeProcess > 0 then dec(FadeProcess)
  else
   begin
    Enabled := False;
    FadeOut := False;
    FadeProcess := 255;
    Paint;
  end;
end;

procedure TFlame.SetFlamePixel;
begin
  if (x < 0) or (x > 159) or (y < 0) or (y > 199) then Exit;
  FFlameField^[y, x] := 256;
end;

procedure TFlame.SetImage;
begin
  FImage.Assign(aImage);
  Paint;
end;

procedure TFlame.SetBottomRange;
begin
  FBottomRange := Value;
  Paint;
end;

procedure TFlame.SetFireColor(Value: TFireColor); {MIKS}
begin
  FFireColor := Value;
  MakePalette;
  Paint;
end;

procedure TFlame.SetFadeOut(Value: Boolean);
begin
  FFadeOut := Value;
  if not FFadeOut then FadeProcess := $FF; { Bypassing Fade bug (Xacker) }
  Paint;
end;

procedure TFlame.WndProc(var Msg: TMessage);
begin
  with Msg do
   if Msg = WM_TIMER then
    try
     FlameIt; {!}
    except
    end
   else
    Result := DefWindowProc(FWindowHandle, Msg, wParam, lParam);
end;

procedure TFlame.SetEnabled(Value: Boolean);
begin
  if Value <> FEnabled then
   begin
    FEnabled := Value;
    UpdateTimer;
   end;
end;

procedure TFlame.SetInterval;
begin
  if Value <> FInterval then
   begin
    FInterval := Value;
    UpdateTimer;
   end;
end;

procedure TFlame.SetOnFlame(Value: TNotifyEvent);
begin
  FOnFlame := Value;
end;

procedure TFlame.UpdateTimer;
begin
  KillTimer(FWindowHandle, 1);
  if (FInterval <> 0) and FEnabled then
    if SetTimer(FWindowHandle, 1, FInterval, nil) = 0 then
      raise EOutOfResources.Create('No timers');
end;

{$IFNDEF WIN32}
procedure TFlame.DrawTransparentBitmap(ahdc: HDC;
                                 xStart, yStart, x1,y1,x2,y2: Word);
var
  TransparentColor: TColor;
  cColor          : TColorRef;
  bmAndBack,
  bmAndObject,
  bmAndMem,
  bmSave,
  bmBackOld,
  bmObjectOld,
  bmMemOld,
  bmSaveOld       : HBitmap;
  hdcMem,
  hdcBack,
  hdcObject,
  hdcTemp,
  hdcSave         : HDC;
  ptSize          : TPoint;
begin
  { set the transparent to black }
  TransparentColor := 0;
  TransparentColor := TransparentColor or $02000000;

  hdcTemp := CreateCompatibleDC (ahdc);
  SelectObject (hdcTemp, FImage.Handle); { select the bitmap }

  { convert bitmap dimensions from device to logical points }
  ptSize.x := x2-x1;
  ptSize.y := y2-y1;
  DPToLP (hdcTemp, ptSize, 1);  { convert from device logical points }

  { create some DCs to hold temporary data }
  hdcBack   := CreateCompatibleDC(ahdc);
  hdcObject := CreateCompatibleDC(ahdc);
  hdcMem    := CreateCompatibleDC(ahdc);
  hdcSave   := CreateCompatibleDC(ahdc);

  { create a bitmap for each DC }

  { monochrome DC }
  bmAndBack   := CreateBitmap (ptSize.x, ptSize.y, 1, 1, nil);
  bmAndObject := CreateBitmap (ptSize.x, ptSize.y, 1, 1, nil);

  bmAndMem    := CreateCompatibleBitmap (ahdc, ptSize.x, ptSize.y);
  bmSave      := CreateCompatibleBitmap (ahdc, ptSize.x, ptSize.y);

  { each DC must select a bitmap object to store pixel data }
  bmBackOld   := SelectObject (hdcBack, bmAndBack);
  bmObjectOld := SelectObject (hdcObject, bmAndObject);
  bmMemOld    := SelectObject (hdcMem, bmAndMem);
  bmSaveOld   := SelectObject (hdcSave, bmSave);

  { set proper mapping mode }
  SetMapMode (hdcTemp, GetMapMode (ahdc));

  { save the bitmap sent here, because it will be overwritten }
  BitBlt (hdcSave, 0, 0, ptSize.x, ptSize.y, hdcTemp, x1, y1, SRCCOPY);

  { set the background color of the source DC to the color.
    contained in the parts of the bitmap that should be transparent }
  cColor := SetBkColor (hdcTemp, TransparentColor);

  { create the object mask for the bitmap by performing a BitBlt()
    from the source bitmap to a monochrome bitmap }
  BitBlt (hdcObject, 0, 0, ptSize.x, ptSize.y, hdcTemp, x1, y1, SRCCOPY);

  { set the background color of the source DC back to the original color }
  SetBkColor (hdcTemp, cColor);

  { create the inverse of the object mask }
  BitBlt (hdcBack, 0, 0, ptSize.x, ptSize.y, hdcObject, 0, 0, NOTSRCCOPY);

  { copy the background of the main DC to the destination }
  BitBlt (hdcMem, 0, 0, ptSize.x, ptSize.y, ahdc, xStart, yStart, SRCCOPY);

  { mask out the places where the bitmap will be placed }
  BitBlt (hdcMem, 0, 0, ptSize.x, ptSize.y, hdcObject, 0, 0, SRCAND);

  { mask out the transparent colored pixels on the bitmap }
  BitBlt (hdcTemp, x1, y1, ptSize.x, ptSize.y, hdcBack, 0, 0, SRCAND);

  { XOR the bitmap with the background on the destination DC }
  BitBlt (hdcMem, 0, 0, ptSize.x, ptSize.y, hdcTemp, x1, y1, SRCPAINT);

  { copy the destination to the screen }
  BitBlt (ahdc, xStart, yStart, ptSize.x, ptSize.y, hdcMem, 0, 0, SRCCOPY);

  { place the original bitmap back into the bitmap sent here }
  BitBlt (hdcTemp, x1, y1, ptSize.x, ptSize.y, hdcSave, 0, 0, SRCCOPY);

  { delete the memory bitmaps }
  DeleteObject (SelectObject (hdcBack, bmBackOld));
  DeleteObject (SelectObject (hdcObject, bmObjectOld));
  DeleteObject (SelectObject (hdcMem, bmMemOld));
  DeleteObject (SelectObject (hdcSave, bmSaveOld));

  { delete the memory DCs }
  DeleteDC (hdcMem);
  DeleteDC (hdcBack);
  DeleteDC (hdcObject);
  DeleteDC (hdcSave);
  DeleteDC (hdcTemp);
end;
{$ENDIF}

procedure Register;
begin
  RegisterComponents('Xacker', [TFlame]);
end;

end.
