beginthreaddemo.pas

《Delphi技术手册源码》原书佩戴的光盘

unit BeginThreadDemo;

// Simple demonstration of using a background thread to compute
// a Mandelbrot set. For some good information on the Mandelbrot set
// and ways to make this simple program better, see
// http://home.earthlink.net/~mrob/muency.html

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, ComCtrls, StdCtrls;

procedure Foo; forward;

const
  // Background thread sends this message to the main thread.
  Wm_Finished = Wm_User;

type
  TThreadInfo = class;
  TWmFinished = packed record
    Msg: Cardinal;
    Aborted: LongBool;
    Info: TThreadInfo;
    Result: LongInt;
  end;

  // Pass a ThreadInfo object to each thread. The record
  // contains the bitmap where the thread draws the Mandelbrot set
  // and a flag that the thread checks periodically to see if it
  // should terminate early.
  TThreadInfo = class
  private
    fBitmap: TBitmap;
    fAborted: Boolean;
  public
    constructor Create(Width, Height: Integer);
    destructor Destroy; override;
    procedure Abort;

    property Bitmap: TBitmap read fBitmap;
    property Aborted: Boolean read fAborted;
  end;

  TForm1 = class(TForm)
    StatusBar1: TStatusBar;
    Panel1: TPanel;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    EditXOffset: TEdit;
    EditYOffset: TEdit;
    EditZoom: TEdit;
    Splitter1: TSplitter;
    Panel2: TPanel;
    Image1: TImage;
    procedure Form1Create(Sender: TObject);
    procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure EditZoomExit(Sender: TObject);
    procedure EditZoomKeyPress(Sender: TObject; var Key: Char);
    procedure EditXOffsetExit(Sender: TObject);
    procedure EditXOffsetKeyPress(Sender: TObject; var Key: Char);
    procedure EditYOffsetExit(Sender: TObject);
    procedure EditYOffsetKeyPress(Sender: TObject; var Key: Char);
    procedure Form1Resize(Sender: TObject);
    procedure Splitter1Moved(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private declarations }
    ThreadInfo: TThreadInfo;
    Thread: THandle;
    procedure WmFinished(var Msg: TWmFinished); message Wm_Finished;
    procedure StartThread;
    procedure StopThread;
    procedure ShowStatus;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

{ TThreadInfo }
constructor TThreadInfo.Create(Width, Height: Integer);
begin
  inherited Create;
  fBitmap := TBitmap.Create;
  Bitmap.Width := Width;
  Bitmap.Height := Height;
  Bitmap.PixelFormat := pf24bit;
end;

destructor TThreadInfo.Destroy;
begin
  FreeAndNil(fBitmap);
  inherited;
end;

procedure TThreadInfo.Abort;
begin
  fAborted := True;
end;


// Use up to 360 iterations so it is easy to map iterations to a Hue
// in an HSV color scheme.
const
  MaxIterations = 360;

// Compute the number of iterations at the point (X, Y).
// Stop at MaxIterations, which is a crude approximation of infinity.
function ComputeIterations(X, Y: Double): Integer;
const
  Threshold = 4.0;
var
  XNew, YNew: Double;
  XC, YC: Double;
begin
  XC := X;
  YC := Y;
  for Result := 0 to MaxIterations-1 do
  begin
    XNew := X * X - Y * Y + XC;
    YNew := 2 * X * Y + YC;
    if (XNew * XNew + YNew * YNew) > Threshold then
      Exit;
    X := XNew;
    Y := YNew;
  end;
  Result := MaxIterations;
end;

// Map Hue, Saturation, and Value to a TColor, that is, RGB color.
function HSV(Hue: Integer; Saturation, Value: Byte): TColor;
var
  P, Q, R, S: Byte;
begin
  if Saturation = 0 then
    Result := RGB(Value, Value, Value)
  else
  begin
    Hue := Hue mod 360;
    S := Round(Saturation * Frac(Hue / 60));
    P := MulDiv(Value, 255 - Saturation, 255);
    Q := MulDiv(Value, 255 - S, 255);
    R := MulDiv(Value, 255 - (Saturation-S), 255);
    case Hue div 60 of
    0: Result := RGB(Value, R, P);
    1: Result := RGB(Q, Value, P);
    2: Result := RGB(P, Value, R);
    3: Result := RGB(P, Q, Value);
    4: Result := RGB(R, P, Value);
    5: Result := RGB(Value, P, Q);
    else
      raise Exception.CreateFmt('Cannot happen: Invalid Hue = %d', [Hue]);
    end;
  end;
end;

// These starting points look nice. Feel free to change them
// to something different if you wish.
var
  XOffset: Double = -0.03;
  YOffset: Double = 0.78;
  Zoom: Double = 450000.0;
const
  Background = clBlack;

// The bitmap uses a 24-bit pixel format, so each pixel
// occupies three bytes. The TRgb array makes it easier to access
// the red, green, and blue components of a color in a scanline.
type
  TRgb = array[0..2] of Byte;
  PRgb = ^TRgb;

function MandelbrotThread(Param: Pointer): Integer;
var
  R, C: Integer;                  // position on the bitmap
  Color: TColor;                  // color to paint a pixel
  Count: Integer;                 // number of iterations
  X, Y: Double;                   // Position in the imaginary plane
  XIncrement, YIncrement: Double; // Increment X, Y for each pixel
  Scanline: PRgb;                 // access the bitmap one scanline at a time
begin
  Result := 0;

  XIncrement := TThreadInfo(Param).Bitmap.Width / Zoom;
  YIncrement := TThreadInfo(Param).Bitmap.Height / Zoom;

  Y := YOffset;
  for R := 0 to TThreadInfo(Param).Bitmap.Height-1 do
  begin
    X := XOffset;
    Scanline := TThreadInfo(Param).Bitmap.ScanLine[R];
    for C := 0 to TThreadInfo(Param).Bitmap.Width-1 do
    begin
      Count := ComputeIterations(X, Y);
      X := X + XIncrement;
      // Map the maximum number of iterations to a background color,
      // and turn the other iterations into a variety of colors
      // by using the count as the hue in a saturated color scheme.
      if Count = MaxIterations then
        Color := Background
      else

        Color := HSV(Count, 255, 255);
      Scanline[0] := GetBValue(Color);
      Scanline[1] := GetGValue(Color);
      Scanline[2] := GetRValue(Color);
      Inc(Scanline);
    end;
    Y := Y + YIncrement;
    // If the user changes a parameter, a new thread is started
    // and the old thread is terminated. When a thread is terminated,
    // it does not notify the main thread because the main thread
    // cares only about the most recent background thread.
    if TThreadInfo(Param).Aborted then
    begin
      PostMessage(Form1.Handle, Wm_Finished, 1, LParam(Param));
      Exit;
    end;
  end;
  // Tell the main thread that the background thread is finished.
  // Pass the bitmap object as a message parameter.
  PostMessage(Form1.Handle, Wm_Finished, 0, LParam(Param));
end;

resourcestring
  sWorking = 'Working...';
  sAborted = 'Interrupted';

// When the background thread finishes, draw the bitmap and free
// the thread info object. If the thread was aborted, of course,
// don't draw the bitmap.
procedure TForm1.WmFinished(var Msg: TWmFinished);
begin
  if Msg.Info = ThreadInfo then
    ThreadInfo := nil;
  if not Msg.Aborted then
  begin
    Image1.Picture.Bitmap := Msg.Info.Bitmap;
    StatusBar1.Panels[1].Text := '';
  end
  else if ThreadInfo = nil then
    StatusBar1.Panels[1].Text := sAborted
  else
    StatusBar1.Panels[1].Text := sWorking;

  FreeAndNil(Msg.Info);
  CloseHandle(Thread);
  Thread := 0;
  ShowStatus;
end;

// Start a new thread to compute and draw a Mandelbrot set.
procedure TForm1.StartThread;
var
  ThreadId: Cardinal;
begin
  StopThread;
  ThreadInfo := TThreadInfo.Create(Image1.Width, Image1.Height);
  Thread := BeginThread(nil, 0, @MandelbrotThread, ThreadInfo, 0, ThreadId);
  StatusBar1.Panels[1].Text := sWorking;
end;

// When the form first opens, start off the initial thread.
procedure TForm1.Form1Create(Sender: TObject);
begin
  StartThread;
  ShowStatus;
end;

// When the user clicks on the form, recenter the image where the user
// clicked, and if the user clicks with the left button, zoom in.
// Click with the right means zoom out. The user might have resized
// the form, so map the position to the position on the original bitmap.
procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  XCenter, YCenter: Double;
begin
  if ThreadInfo = nil then
  begin
    XCenter := X / Zoom + XOffset;
    YCenter := Y / Zoom + YOffset;
    if Button = mbLeft then
      Zoom := Zoom * 1.5
    else if Button = mbRight then
      Zoom := Zoom / 1.5;
    XOffset := XCenter - Image1.Picture.Bitmap.Width  / Zoom / 2.0;
    YOffset := YCenter - Image1.Picture.Bitmap.Height / Zoom / 2.0;
    StartThread;
    ShowStatus;
  end;
end;

// Display the offset and scale.
procedure TForm1.ShowStatus;
begin
  EditXOffset.Text := FloatToStr(XOffset);
  EditYOffset.Text := FloatToStr(YOffset);
  EditZoom.Text    := FloatToStr(Zoom);
end;

// Show the imaginary coordinates of the position under the cursor.
procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
var
  XPos, YPos: Double;
begin
  XPos := X / Zoom + XOffset;
  YPos := Y / Zoom + YOffset;
  StatusBar1.Panels[0].Text := Format('(%.4g, %.4g)', [XPos, YPos]);
end;

// When the user changes any parameter or resizes the form,
// start up a new thread to redraw the bitmap.
procedure TForm1.EditZoomExit(Sender: TObject);
begin
  Zoom := StrToFloat(EditZoom.Text);
  StartThread;
end;

procedure TForm1.EditZoomKeyPress(Sender: TObject; var Key: Char);
begin
  if Key = ^M then
  begin
    Zoom := StrToFloat(EditZoom.Text);
    StartThread;
    Key := #0;
  end;
end;

procedure TForm1.EditXOffsetExit(Sender: TObject);
begin
  XOffset := StrToFloat(EditXOffset.Text);
  StartThread;
end;

procedure TForm1.EditXOffsetKeyPress(Sender: TObject; var Key: Char);
begin
  if Key = ^M then
  begin
    XOffset := StrToFloat(EditXOffset.Text);
    StartThread;
    Key := #0;
  end;
end;

procedure TForm1.EditYOffsetExit(Sender: TObject);
begin
  YOffset := StrToFloat(EditYOffset.Text);
  StartThread;
end;

procedure TForm1.EditYOffsetKeyPress(Sender: TObject; var Key: Char);
begin
  if Key = ^M then
  begin
    YOffset := StrToFloat(EditYOffset.Text);
    StartThread;
    Key := #0;
  end;
end;

procedure TForm1.Form1Resize(Sender: TObject);
begin
  StartThread;
end;

// Stop the current thread, in preparation for starting a new one.
procedure TForm1.StopThread;
begin
  if ThreadInfo <> nil then
    ThreadInfo.Abort;
end;

procedure TForm1.Splitter1Moved(Sender: TObject);
begin
  StartThread;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  StopThread;
end;

procedure Foo;
label
  X, Y;
var
  I, J: Integer;
begin
  goto Y;
  try
    X: I := 0;
  except
    Y: J := 10;
  end;
  Halt(I + J);
end;

end.