scheduler.pas

3D GameStudio 的Delphi开发包

//////////////////////////////////////////////////////////////////////
//
// Delphi Function Scheduler for the A6_5x Engine (acknex.dll) done by
// Michal Messerschmidt aka LazyDog of Lazy Dog Software
// (www.LazyDogSoftware.com)
// (c) Lazy Dog Software / Michael Messerschmidt 2006
//
// SDK Version 6.50.6
//
// tested on Delphi 5,6,7,2005 & 2006
//
// how to use:
// 
// put a call in your main loop to ExecScheduler;
//////////////////////////////////////////////////////////////////////

unit scheduler;

interface
uses A6Engine;

procedure Wait(I : Single = 1);
procedure ExecScheduler;
procedure Proc_Add_Sch(entity,event : Pointer);
procedure Proc_Remove_Sch(p : PEntity);
procedure Proc_Kill_Sch(mode : Integer);
procedure Proc_Late_Sch;
procedure Proc_Early_Sch;
function  Proc_Status_Sch(event : Pointer) : Integer;

implementation
uses Classes, Windows, SysUtils {$IFNDEF VER130}, DateUtils {$ENDIF};  //Delphi 5

type
  TScheduleThread = class(TThread)
  private
    { Private declarations }
  protected
    procedure Execute; override;
  end;

PEntAction = ^TEntAction;
TEntAction = Record
               ent   : PEntity;   // pointer to the entity
               func  : PEvent;    // pointer to it's action function
               Del   : Boolean;   // function needs deleted
               Up    : Boolean;   // function needs moved earlier in the list
               Down  : Boolean;   // function needs moved later in the list
               Pause : Integer;   // amount of pause
               Time  : TDateTime; // time when wait began
             end;

var Schedule  : TList;
    FuncList  : Array of Pointer;
    CurrFunc  : Integer;
    EntAction : PEntAction;
    ScheduleThread : TScheduleThread;

    NeedToClean    : Boolean = False;
    NeedToMoveUp   : Boolean = False;
    NeedToMoveDown : Boolean = False;
    RunFunctions   : Boolean = False;

{$IFDEF VER130} //Delphi 5
const MinsPerDay = 24 * 60;      

function IncMinute(const OrigDate : TDateTime; const AddMinutes: LongInt) : TDateTime;
begin
  Result := ((OrigDate * MinsPerDay) + AddMinutes) / MinsPerDay;
end;

function IncSecond(const OrigDate : TDateTime; const AddSeconds: LongInt): TDateTime;
begin
  Result := ((OrigDate * SysUtils.SecsPerDay) + AddSeconds) / SysUtils.SecsPerDay;
end;

function IncMilliSecond(const OrigDate : TDateTime; const AddMsSeconds: LongInt): TDateTime;
begin
  Result := ((OrigDate * SysUtils.MSecsPerDay) + AddMsSeconds) / SysUtils.MSecsPerDay;
end;

function TimePassed(const A, B: TDateTime): Boolean;
begin
  Result := Frac(A) >= Frac(B);
end;
{$ENDIF}

function FuncDelayOver(I : Integer) : Boolean;
begin
  Result := True;

  if PEntAction(Schedule.Items[I]).Pause = 1 then Exit; // default 1 frame so just exit

  if PEntAction(Schedule.Items[I]).Pause > 1 then       // positive value represents # of frames to wait
  begin                                                 // so just decrease count by 1 and exit
    Dec(PEntAction(Schedule.Items[I]).Pause);           // when this value becomes 1 function is called
    Result := False;
    Exit;
  end;                                                  // negative value represents # of seconds
                                                        // below call determines if enough time has passed
  {$IFDEF VER130} //Delphi 5
  Result := TimePassed(Now,PEntAction(Schedule.Items[I]).Time);
  {$ELSE}
  Result := CompareTime(Now,PEntAction(Schedule.Items[I]).Time) >= 0;
  {$ENDIF}
end;

procedure Proc_Add_Sch(entity,event : Pointer);
begin
  New(EntAction);              // create a new function record
  EntAction^.ent   := entity;  // save the entity
  EntAction^.func  := event;   // save the function to call
  EntAction^.Del   := False;   // function doesn't need deleted
  EntAction^.Up    := False;   // function doesn't need moved earlier
  EntAction^.Down  := False;   // function doesn't need moved later
  EntAction^.Pause := 1;       // default of execute every 1 frame
  Schedule.Add(EntAction);     // add the record to the list

  SetLength(FuncList,Schedule.Count); // increase size of our function list

                               // the function event becomes a fiber, stored in FuncList
  FuncList[Schedule.Count-1] := Pointer(CreateFiber(0,event,entity));
end;

procedure Wait(I : Single = 1);

var M,S,ms : Word;
    Temp : TDateTime;
begin
  if not RunFunctions then Exit;        // can only be called from within a function in the scheduler

  if I < 0 then  // negative value represents # of seconds of delay
  begin
    PEntAction(Schedule.Items[CurrFunc]).Pause := -1;

    I := I * -1;

    Temp := Now;                        // get current time, we'll add delay amounts to create future time

    if I >= 60 then                     // at least 1 minute
    begin
      M := Trunc(I) Div 60;             // determine # of minutes
      Temp := IncMinute(Temp,M);        // increase our future time by # of minutes

      I := I - (M * 60);                // remove the minutes from the total delay
    end;

    if I >= 1 then                      // at least 1 second
    begin
      S := Trunc(I);                    // determine # of seconds
      Temp := IncSecond(Temp,S);        // increase our future time by # of seconds

      I := I - S;                       // remove the seconds from the total delay
    end;

    if I > 0 then                       // at least 1 ms
    begin
      ms := Trunc(Frac(I) * 1000);      // determine # of ms
      Temp := IncMilliSecond(Temp,ms);  // increase our future time by # of ms
    end;

    PEntAction(Schedule.Items[CurrFunc]).Time := Temp; // save this future time
  end
  else PEntAction(Schedule.Items[CurrFunc]).Pause := Trunc(I); // store the # of frames to wait

  SwitchToFiber(FuncList[0]);  // jump back to SchedulerFunction, to execute next function in the list
end;

procedure InitScheduler;
begin
  ScheduleThread := TScheduleThread.Create(True);  //Starts Suspended

  ExecScheduler;           // makes sure TScheduleThread.Execute is
                           // called before the user tries to add procedures
                           // to the function list  
end;

procedure ExecScheduler;
begin
  RunFunctions := True;
  ScheduleThread.Resume;    // restart the function thread to execute each function in the list
  while RunFunctions do ;   // have the main thread wait until the function thread finishes
end;

procedure Proc_Remove_Sch(p : PEntity);

var I : Integer;
begin
  for I := 0 to Schedule.Count - 1 do
  begin
    EntAction := Schedule.Items[I];

    if EntAction^.ent = p then
    begin
      EntAction^.Del := True;       // flag this function as needing to be deleted
      NeedToClean    := True;       // let the SchedulerFunction know to call CleanScheduler
    end;
  end;
end;

procedure CleanScheduler;

var I : Integer;
begin
  for I := Schedule.Count - 1 downto 1 do  //don't need to check first func which is our main driver
  if PEntAction(Schedule.Items[I]).Del then
  begin
    EntAction := Schedule.Items[I];
    Dispose(EntAction);                 // remove memory allocated
    Schedule.Delete(I);                 // remove from the list
    DeleteFiber(FuncList[I]);           // remove the fiber function
    SetLength(FuncList,Schedule.Count); // reduce the length of the function list
  end;

  NeedToClean := False;                 // clear this so this function isn't called when it isn't needed
end;

procedure MoveFuncsUp;

var Save : Pointer;
    I,J : Integer;
begin
  for I := 2 to Schedule.Count-1 do     // start at the second function
  if PEntAction(Schedule.Items[I]).Up then
  begin
    PEntAction(Schedule.Items[I]).Up := False;

    Schedule.Move(I,1);                 // Move the Function Record to the beginning of the list

    Save := FuncList[I];                // Save the Current Function Pointer

    for J := I-1 downto 1 do            // Move all the pointers from the previous position through
      FuncList[J+1] := FuncList[J];     // the beginning of the list down 1 position

    FuncList[1] := Save;                // Move the saved function pointer to the first position
  end;

  NeedToMoveUp := False;                // clear this so this function isn't called when it isn't needed
end;

procedure MoveFuncsDown;

var Save : Pointer;
    I,J : Integer;
begin
  I := 1;                                 // don't need to check first func which is our main driver

  while I < Schedule.Count-1 do           // don't need to check last func
  begin
    if PEntAction(Schedule.Items[I]).Down then
    begin
      PEntAction(Schedule.Items[I]).Down := False;

      Schedule.Move(I,Schedule.Count-1);  // Move the Function Record to the end of the list

      Save := FuncList[I];                // Save the Current Function Pointer

      for J := I+1 to Schedule.Count-1 do // Move all the pointers from the next position through
        FuncList[J-1] := FuncList[J];     // the end of the list up 1 position

      FuncList[Schedule.Count-1] := Save; // Move the saved function pointer to the last position
    end
    else Inc(I);
  end;

  NeedToMoveDown := False;                // clear this so this function isn't called when it isn't needed
end;

procedure SchedulerFunction(Param : Pointer); //stdcall;

var I : Integer;
begin
  I := 0;

  while True do
  if RunFunctions then
  begin
    Inc(I);

    if I > Schedule.Count-1 then   // we are done for this time through
    begin
      if NeedToClean then          // Remove Functions flagged for delete
        CleanScheduler;

      if NeedToMoveUp then         // Move Functions flagged to be moved earlier
        MoveFuncsUp;

      if NeedToMoveDown then       // Move Functions flagged to be moved later
        MOveFuncsDown;

      I := 0;                      // reset so that next time through we're at beginning of list
      RunFunctions := False;       // allow the main thread to continue
      CurrFunc := 0;               // don't point to any functions
      ScheduleThread.Suspend;      // suspend the scheduler for now.
    end
    else
    begin
      if _INT(ev.freeze_mode^) > 1 then Exit;        // all functions suspened

      if not PEntAction(Schedule.Items[I]).Del then  // if not marked as deleted
        if FuncDelayOver(I) then                     // the delay is over, function can be called
        begin
          CurrFunc := I;                             // save the index to the current function
          EntAction := Schedule.Items[CurrFunc];
          ev.me := EntAction^.ent;                   // point the engine variable me = the entity
          SwitchToFiber(FuncList[CurrFunc]);         // jump to a function
        end;
    end;
  end;
end;

procedure TScheduleThread.Execute;
begin
  SetLength(FuncList,1);
  FuncList[0] := Pointer(ConvertThreadToFiber(Pointer(1))); // turn the thread into a fiber
  New(EntAction);
  Schedule := TList.Create;
  Schedule.Add(EntAction);
  SchedulerFunction(Pointer(1));
end;

procedure CloseDownScheduler;

var I : Integer;
begin
  if Schedule = Nil then Exit;      // in case of failure before scheduler init

  for I := Schedule.Count - 1 downto 0 do
  begin
    EntAction := Schedule.Items[I];
    Dispose(EntAction);             // remove memory allocated
    Schedule.Delete(I);             // remove from the list

    DeleteFiber(FuncList[I]);
  end;

  Schedule.Free;
  SetLength(FuncList,0);
end;

procedure Proc_Kill_Sch(mode : Integer);

const KillMe    = 1;   // terminates all functions created by the me entity
      KillYou   = 2;   // terminates all functions created by the you entity
      KillOther = 4;   // terminates all other instances of the current function
      KillAll   = 16;  // terminates all functions

var I : Integer;
    KillIt : Boolean;
begin
  if (mode = KillOther) and not RunFunctions then Exit;   // for this mode can only be called from within
                                                          // a function running in the scheduler

  for I := 1 to Schedule.Count - 1 do  // don't need to check first func which is our main driver
  begin
    case mode of
      KillMe    : KillIt := PEntAction(Schedule.Items[I]).ent = ev.me;
      KillYou   : KillIt := PEntAction(Schedule.Items[I]).ent = ev.you;
      KillOther : KillIt := (CurrFunc <> I) and (PEntAction(Schedule.Items[I]).func = PEntAction(Schedule.Items[CurrFunc]).func);
      KillAll   : KillIt := True;
             else KillIt := False;
    end;

    if KillIt then
    begin
      PEntAction(Schedule.Items[I]).Del := True;  // mark the function to be deleted
      NeedToClean := True;                        // let the SchedulerFunction know to call CleanScheduler
    end;
  end;
end;

procedure Proc_Late_Sch;
begin
  if not RunFunctions then Exit;                     // can only be called from within a function in the scheduler

  if CurrFunc = 0 then Exit;                         // Not pointing to a valid current function

  if CurrFunc >= Schedule.Count-1 then Exit;         // Current Function is already at the end of the list

  PEntAction(Schedule.Items[CurrFunc]).Down := True; // mark the function to be moved later
  NeedToMoveDown := True;                            // let the SchedulerFunction know to call MoveFuncsDown
end;

procedure Proc_Early_Sch;
begin
  if not RunFunctions then Exit;                   // can only be called from within a function in the scheduler

  if CurrFunc <= 1 then Exit;                      // Current Function is already at the beginning of the list

  PEntAction(Schedule.Items[CurrFunc]).Up := True; // mark the function to be moved earlier
  NeedToMoveUp := True;                            // let the SchedulerFunction know to call MoveFuncsUp
end;

function Proc_Status_Sch(event : Pointer) : Integer;

var I : Integer;
begin
  Result := 0;                                         // 1 = function running, 0 = not running

  for I := 1 to Schedule.Count-1 do                    // don't need to check first func which is our main driver
    if PEntAction(Schedule.Items[I]).ent = event then  // found a match for the event
      if not PEntAction(Schedule.Items[I]).Del then    // not marked to be deleted
      begin
        Result := 1;
        Exit;
      end;
end;

initialization
InitScheduler;

finalization
CloseDownScheduler;

end.