Einzelnen Beitrag anzeigen

Dax
(Gast)

n/a Beiträge
 
#7

Da ist nix negativ!!

  Alt 28. Mär 2003, 07:19
Ich zeig euch mal den Code(bei dem der Stack auch überläuft, aber erst nach laaaaaaanger Zeit):
Delphi-Quellcode:
unit AckerCalc;

interface

uses
  Windows, Messages, SysUtils, Classes;

type
  TAckerCalcEvent = procedure(X, Y, Result, NumberOfResult: integer; Calls: int64) of object;
  TAckerMethod = procedure of object;
  TAckerCalc = class;
  TCalcThread = class(tthread)
  private
    Owner: TAckerCalc;
    x, y, x1, y1: integer;
    function run(x, y: integer): integer;
  protected
    procedure execute; override;
  end;
  TAckerCalc = class(tcomponent)
  private
    FCalc: TCalcThread;
    FPriority: TThreadPriority;
    FDone, FCancel, FPause, FResume, FStart: TAckerMethod;
    FDoneOne: TAckerCalcEvent;
    FX, FY, FX1, FY1: integer;
    procedure Done; dynamic;
    procedure DoneOne; dynamic;
    function FCaretX: integer;
    function FCaretY: integer;
    function FCaretCalls: int64;
  protected
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    procedure Start;
    procedure Pause;
    procedure Resume;
    procedure Cancel;
    procedure ChangePriority(Priority: TTHreadPriority);
    property CaretX: integer read FCaretX;
    property CaretY: integer read FCaretY;
    property CaretCalls: int64 read FCaretCalls;
    property ThreadPriority: TThreadPriority read FPriority write FPriority;
    property OnDone: TAckerMethod read FDone write FDone;
    property OnDoneOne: TAckerCalcEvent read FDoneOne write FDoneOne;
    property OnCancel: TAckerMethod read FCancel write FCancel;
    property OnPause: TAckerMethod read FPause write FPause;
    property OnResume: TAckerMethod read FResume write FResume;
    property OnStart: TAckerMethod read FStart write FStart;
    property BeginAtX: integer read FX write FX;
    property BeginAtY: integer read FY write FY;
    property EndAtX: integer read FX1 write FX1;
    property EndAtY: integer read FY1 write FY1;
  end;

procedure Register;

implementation

var
  c: int64;
  cx, cy, result, d: integer;

procedure Register;
begin
  RegisterComponents('Gecko', [TAckerCalc]);
end;

constructor TAckerCalc.Create(AOwner: TComponent);
begin
  inherited create(AOwner);
end;

destructor TAckerCalc.Destroy;
begin
  inherited destroy;
end;

procedure TAckerCalc.Done;
begin
  if not FCalc.Terminated then
  begin
    if assigned(OnDone) then FDone;
  end;
end;

procedure TACkerCalc.Start;
begin
  d := 0;
  FCalc := TCalcThread.Create(true);
  FCalc.Priority := FPriority;
  FCalc.Owner := self;
  FCalc.x := FX;
  FCalc.y := FY;
  FCalc.x1 := FX1;
  FCalc.y1 := FY1;
  if assigned(OnStart) then FStart;
  FCalc.Resume;
end;

procedure TAckerCalc.DoneOne;
begin
  inc(d);
  if assigned(OnDoneOne) then FDoneOne(cx, cy, result, d, c)
end;

procedure TAckerCalc.Cancel;
begin
  FCalc.Terminate;
  if assigned(OnCancel) then FCancel;
end;

procedure TAckerCalc.Pause;
begin
  FCalc.Suspend;
  if assigned(OnPause) then FPause;
end;

procedure TAckerCalc.Resume;
begin
  FCalc.Resume;
  if assigned(OnResume) then FResume;
end;

function TAckerCalc.FCaretX: integer;
begin
  result := cx;
end;

function TAckerCalc.FCaretY: integer;
begin
  result := cy;
end;


function TAckerCalc.FCaretCalls: int64;
begin
  result := c;
end;

procedure TAckerCalc.ChangePriority(Priority: TTHreadPriority);
begin
  FCalc.Suspend;
  FCalc.Priority := Priority;
  FCalc.Resume;
end;

{*****************************************************************************}

procedure TCalcThread.execute;
var a, b: integer;
begin
  for a := x to x1 do
  for b := y to y1 do
  begin
    c := 0;
    if terminated then break;
    result := run(a, b);
    cx := a;
    cy := b;
    if not terminated then synchronize(Owner.DoneOne);
  end;

  if not terminated then
  synchronize(Owner.Done);
  terminate;
end;

function TCalcThread.run(x, y: integer): integer;
begin
  while suspended do{nix};
  inc(c);
  cx := x;
  cy := y;
  if terminated then exit;
  if x = 0 then result := y + 1 else
  if (x <> 0) and (y = 0) then result := run(x - 1, 1) else
      result := run(x - 1, run(x, y-1));
end;

end.
Übrigens: das hier ist meine Kompo dazu
  Mit Zitat antworten Zitat