mainunit.pas

delphi 最好的3D控件GLScene_Demos

{:
  A demo for using Alex Denissov's Graphics32 library (http://www.g32.org)
  to generate 2D texture for use with GLScene.<p>

  By Nelson Chu<p>

  Try lighting the white line near the bottom of the window with your mouse
  pointer and see the fire spreads. Press ESC to quit.<p>

  To use Graphics32 with GLScene:<p>

  1. Make sure GLS_Graphics32_SUPPORT is defined in GLSCene.inc. Recompile if
     needed.<br>
  2. In your program, use code like:<br>

       GLTexture.Image.GetBitmap32(0).assign(Bitmap32);<br>
       GLTexture.Image.NotifyChange(self);<br>

     to assign the Bitmap32 to your GLScene texture and notify GLScene.<p>

  To get fast assignment, remember to make the dimensions of your Bitmap32 equal
  to a power of two, so that GLScene doesn't need to do conversion internally.<p>

  In this sample program, a 256 x 256 Graphics32 TByteMap is used to generate a
  "fire" image. At each frame, the fire image is first "visualized" in a
  Graphics32 Bitmap32. Then, the TBitmap32 is copied to the texture of a Cube.
}

unit MainUnit;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  ExtCtrls, StdCtrls, ComCtrls, GR32, GR32_ByteMaps, AsyncTimer, GLScene,
  GLObjects, GLHUDObjects, GLWin32Viewer, GLMisc, GR32_Image, GLCadencer;

type
  TForm1 = class(TForm)
    AsyncTimer1: TAsyncTimer;
    GLScene1: TGLScene;
    GLSceneViewer1: TGLSceneViewer;
    GLCamera1: TGLCamera;
    Timer1: TTimer;
    PaintBox32: TPaintBox32;
    Cube1: TGLCube;
    GLCadencer1: TGLCadencer;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure AsyncTimer1Timer(Sender: TObject);
    procedure GLSceneViewer1MouseMove(Sender: TObject; Shift: TShiftState;
      X, Y: Integer);
    procedure GLSceneViewer1MouseDown(Sender: TObject;
      Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    procedure GLSceneViewer1MouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure Timer1Timer(Sender: TObject);
    procedure GLCadencer1Progress(Sender: TObject; const deltaTime,
      newTime: Double);
  private
    SourceLit : array of boolean;
    BlobX, BlobY : integer;
    BlobSize : integer;

    procedure LitSource(i : integer);
    procedure DrawBlob(x, y : integer; BlobSize : integer);
    procedure SetUpColorTableYellow;
    procedure SetColorInt(i, r, g, b : integer);

  public
    HeatMap: TByteMap;
    pal: TPalette32;
    OldMousePos: TPoint;
    MouseDragging: Boolean;

    SourceLineHeight : integer;

    procedure PaintData;

    procedure ProcessHeatMap(HeatMap: TByteMap);
  end;

var
  Form1: TForm1;

const
  HeatMapWidth = 256;
  HeatMapHeight = 256;

implementation

{$R *.DFM}

uses OpenGL1x;

{ TForm1 }

{$i GLScene.inc}

{$ifndef GLS_Graphics32_SUPPORT}
   Please rebuild this demo with Graphics32 support (see GLScene.inc)
{$endif}

procedure TForm1.AsyncTimer1Timer(Sender: TObject);
begin
   // Update and animate the 2D Fire, this part is Graphics32 stuff only
   DrawBlob(BlobX, BlobY, BlobSize);
   ProcessHeatMap(HeatMap);
   PaintData;
   // Assign our TBitmap32 to the texture, this is done in two steps
   with Cube1.Material.Texture.Image do begin
      // Update the internal TGLBitmap32 with the TBitmap32
      GetBitmap32(GL_TEXTURE_2D).Assign(PaintBox32.Buffer);
      // And notify a change occured (you could perform other operations on the
      // TGLBitmap32 before this notification, f.i. adjusting the Alpha channel)
      NotifyChange(self);
   end;
   // Specifying the target (GL_TEXTURE_2D) isn't really usefull for 2D textures,
   // since you only have one, but for cube maps, you can use the OpenGL
   // texture target constant to specify which 2D component of the cube map
   // will be obtained and altered.
   // The Alpha channel of TBitmap32 is transfered "as is" to the TGLBitmap32,
   // which may or may not be a wanted effect. You can use the SetAlphaXxxx
   // function to alter the TGLBitmap32 alpha channel without altering the
   // TBitmap32.
end;

//
// All that follows takes care of animating the texture and cube
//

procedure TForm1.FormCreate(Sender: TObject);
var i : integer;
begin
  SetUpColorTableYellow;
  HeatMap := TByteMap.Create;
  HeatMap.SetSize(HeatMapWidth, HeatMapHeight);
  setlength(SourceLit, 256);
  for i:=0 to length(SourceLit)-1 do
   SourceLit[i]:=false;

  HeatMap.Clear(0);

  BlobSize:=3;
  AsyncTimer1.Enabled:=true;

  SourceLineHeight:=HeatMapHeight - 36;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  HeatMap.Free;
end;

procedure TForm1.PaintData;
begin
  HeatMap.WriteTo(PaintBox32.Buffer, Pal);
  PaintBox32.Buffer.HorzLine(0, SourceLineHeight-1, PaintBox32.Buffer.Width-1, clWhite32);
  PaintBox32.Buffer.HorzLine(0, SourceLineHeight, PaintBox32.Buffer.Width-1, clWhite32);

  PaintBox32.Buffer.RenderText(5, 256-24, 'Texture generated with Graphics32', 0, clWhite32);
  PaintBox32.Invalidate;
end;

procedure TForm1.ProcessHeatMap(HeatMap: TByteMap);
const hotvalue = 255;
      nbHotSpots = 200;
// nbHotSpots is the no. of hot spots added at a time
// it also determines the rate the fire spreads on the white line
var x, y : integer;
begin
  for y:=1 to nbHotSpots-1 do
  begin
    x:=10 + random(HeatMap.Width-20);
    if SourceLit[x] then // add hot spots, checking if the pixel can be lit
    begin
      HeatMap[x, SourceLineHeight]:=hotvalue - 16 + random(16);
      if random(3)=0 then
        HeatMap[x, SourceLineHeight+1]:=hotvalue;
      case random(3) of
        0 : LitSource(x+1);
        1 : LitSource(x-1);
      end;
    end;
  end;

  for y:=HeatMap.Height-2 downto 2 do // do some kind of averaging
    for x:=2 to HeatMap.Width-2 do
    case random(6) of
     0 : HeatMap[x, y] := ( HeatMap[x-1, y+1] + HeatMap[x+1, y+1] +
                            HeatMap[x-2, y+2] + HeatMap[x+1, y+2] ) div 4;

     1 : HeatMap[x, y] := ( HeatMap[x-1, y+1] + HeatMap[x-2, y+1] +
                                   HeatMap[x+1, y-1] ) div 3;

     2 : HeatMap[x, y] := ( HeatMap[x-1, y+1] + HeatMap[x-2, y+1] +
                                   HeatMap[x+1, y-1] ) div 4;
    else
         HeatMap[x, y] := ( HeatMap[x, y] +
			           HeatMap[x-1, y+1] + HeatMap[x+1, y+1] +
                                   HeatMap[x-2, y+2] + HeatMap[x+2, y+2] ) div 5;
    end;

end;

procedure TForm1.DrawBlob(x, y : integer; BlobSize : integer);
var bx, by, c : integer;
const hotvalue = 240;
      MaxColorIndex = 255;
begin
  for bx:=-BlobSize to BlobSize do
   for by:=-BlobSize to BlobSize do
   begin
     if ( (bx+x>1) and (bx+x<HeatMap.Width-1) and  // within the heat map
          (by+y>1) and (by+y<HeatMap.Height-1) ) then
       begin
         c := hotvalue - 30 + (BlobSize - bx + 1) * (BlobSize - by + 1);
         if (c > MaxColorIndex) then c := MaxColorIndex;
         HeatMap[bx+x, by+y] := c;
         if (by+y=SourceLineHeight) then LitSource(bx+x);
       end;
   end;
end;

procedure TForm1.LitSource(i: integer);
begin
  SourceLit[i]:=true;
end;

procedure TForm1.GLSceneViewer1MouseMove(Sender: TObject;
  Shift: TShiftState; X, Y: Integer);
begin
   if ssLeft in Shift then
      blobSize:=6
   else blobSize:=3;
   BlobX := x;
   BlobY := y;
end;

procedure TForm1.GLSceneViewer1MouseDown(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
 blobSize:=6;
end;

procedure TForm1.GLSceneViewer1MouseUp(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
 blobSize:=3;
end;

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin