Subversion Repositories spacemission

unit DXClass;

interface

{$INCLUDE DelphiXcfg.inc}

uses

  Windows, Messages, SysUtils, Classes, Controls, Forms, MMSystem, DirectX;

type

  {  EDirectDrawError  }

  EDirectXError = class(Exception);

  {  TDirectX  }

  TDirectX = class(TPersistent)

  private

    procedure SetDXResult(Value: HRESULT);

  protected

    FDXResult: HRESULT;

    procedure Check; virtual;

  public

    property DXResult: HRESULT read FDXResult write SetDXResult;

  end;

  {  TDirectXDriver  }

  TDirectXDriver = class(TCollectionItem)

  private

    FGUID: PGUID;

    FGUID2: TGUID;

    FDescription: string;

    FDriverName: string;

    procedure SetGUID(Value: PGUID);

  public

    property GUID: PGUID read FGUID write SetGUID;

    property Description: string read FDescription write FDescription;

    property DriverName: string read FDriverName write FDriverName;

  end;

  {  TDirectXDrivers  }

  TDirectXDrivers = class(TCollection)

  private

    function GetDriver(Index: Integer): TDirectXDriver;

  public

    constructor Create;

    property Drivers[Index: Integer]: TDirectXDriver read GetDriver; default;

  end;

  {  TDXForm  }

  TDXForm = class(TForm)

  private

    FStoreWindow: Boolean;

    FWindowPlacement: TWindowPlacement;

    procedure WMSYSCommand(var Msg: TWMSYSCommand); message WM_SYSCOMMAND;

  protected

    procedure CreateParams(var Params: TCreateParams); override;

  public

    constructor Create(AOnwer: TComponent); override;

    destructor Destroy; override;

    procedure RestoreWindow;

    procedure StoreWindow;

  end;

  {  TCustomDXTimer  }

  TDXTimerEvent = procedure(Sender: TObject; LagCount: Integer) of object;

  TCustomDXTimer = class(TComponent)

  private

    FActiveOnly: Boolean;

    FEnabled: Boolean;

    FFrameRate: Integer;

    FInitialized: Boolean;

    FInterval: Cardinal;

    FInterval2: Cardinal;

    FNowFrameRate: Integer;

    FOldTime: DWORD;

    FOldTime2: DWORD;

    FOnActivate: TNotifyEvent;

    FOnDeactivate: TNotifyEvent;

    FOnTimer: TDXTimerEvent;

    procedure AppIdle(Sender: TObject; var Done: Boolean);

    function AppProc(var Message: TMessage): Boolean;

    procedure Finalize;

    procedure Initialize;

    procedure Resume;

    procedure SetActiveOnly(Value: Boolean);

    procedure SetEnabled(Value: Boolean);

    procedure SetInterval(Value: Cardinal);

    procedure Suspend;

  protected

    procedure DoActivate; virtual;

    procedure DoDeactivate; virtual;

    procedure DoTimer(LagCount: Integer); virtual;

    procedure Loaded; override;

  public

    constructor Create(AOwner: TComponent); override;

    destructor Destroy; override;

    property ActiveOnly: Boolean read FActiveOnly write SetActiveOnly;

    property Enabled: Boolean read FEnabled write SetEnabled;

    property FrameRate: Integer read FFrameRate;

    property Interval: Cardinal read FInterval write SetInterval;

    property OnActivate: TNotifyEvent read FOnActivate write FOnActivate;

    property OnDeactivate: TNotifyEvent read FOnDeactivate write FOnDeactivate;

    property OnTimer: TDXTimerEvent read FOnTimer write FOnTimer;

  end;

  {  TDXTimer  }

  TDXTimer = class(TCustomDXTimer)

  published

    property ActiveOnly;

    property Enabled;

    property Interval;

    property OnActivate;

    property OnDeactivate;

    property OnTimer;

  end;

  {  TControlSubClass  }

  TControlSubClassProc = procedure(var Message: TMessage; DefWindowProc: TWndMethod) of object;

  TControlSubClass = class

  private

    FControl: TControl;

    FDefWindowProc: TWndMethod;

    FWindowProc: TControlSubClassProc;

    procedure WndProc(var Message: TMessage);

  public

    constructor Create(Control: TControl; WindowProc: TControlSubClassProc);

    destructor Destroy; override;

  end;

  {  THashCollectionItem  }

  THashCollectionItem = class(TCollectionItem)

  private

    FHashCode: Integer;

    FIndex: Integer;

    FName: string;

    FLeft: THashCollectionItem;

    FRight: THashCollectionItem;

    procedure SetName(const Value: string);

    procedure AddHash;

    procedure DeleteHash;

  protected

    function GetDisplayName: string; override;

    procedure SetIndex(Value: Integer); override;

  public

    constructor Create(Collection: TCollection); override;

    destructor Destroy; override;

    procedure Assign(Source: TPersistent); override;

    property Index: Integer read FIndex write SetIndex;

  published

    property Name: string read FName write SetName;

  end;

  {  THashCollection  }

  THashCollection = class(TCollection)

  private

    FHash: array[0..255] of THashCollectionItem;

  public

    function IndexOf(const Name: string): Integer;

  end;

function Max(Val1, Val2: Integer): Integer;

function Min(Val1, Val2: Integer): Integer;

function Cos256(i: Integer): Double;

function Sin256(i: Integer): Double;

function PointInRect(const Point: TPoint; const Rect: TRect): Boolean;

function RectInRect(const Rect1, Rect2: TRect): Boolean;

function OverlapRect(const Rect1, Rect2: TRect): Boolean;

function WideRect(ALeft, ATop, AWidth, AHeight: Integer): TRect;

procedure ReleaseCom(out Com);

function DXLoadLibrary(const FileName, FuncName: string): TFarProc;

implementation

uses DXConsts;

function Max(Val1, Val2: Integer): Integer;

begin

  if Val1>=Val2 then Result := Val1 else Result := Val2;

end;

function Min(Val1, Val2: Integer): Integer;

begin

  if Val1<=Val2 then Result := Val1 else Result := Val2;

end;

function PointInRect(const Point: TPoint; const Rect: TRect): Boolean;

begin

  Result := (Point.X >= Rect.Left) and

            (Point.X <= Rect.Right) and

            (Point.Y >= Rect.Top) and

            (Point.Y <= Rect.Bottom);

end;

function RectInRect(const Rect1, Rect2: TRect): Boolean;

begin

  Result := (Rect1.Left >= Rect2.Left) and

            (Rect1.Right <= Rect2.Right) and

            (Rect1.Top >= Rect2.Top) and

            (Rect1.Bottom <= Rect2.Bottom);

end;

function OverlapRect(const Rect1, Rect2: TRect): Boolean;

begin

  Result := (Rect1.Left < Rect2.Right) and

            (Rect1.Right > Rect2.Left) and

            (Rect1.Top < Rect2.Bottom) and

            (Rect1.Bottom > Rect2.Top);

end;

function WideRect(ALeft, ATop, AWidth, AHeight: Integer): TRect;

begin

  with Result do

  begin

    Left := ALeft;

    Top := ATop;

    Right := ALeft+AWidth;

    Bottom := ATop+AHeight;

  end;

end;

var

  CosinTable: array[0..255] of Double;

procedure InitCosinTable;

var

  i: Integer;

begin

  for i:=0 to 255 do

    CosinTable[i] := Cos((i/256)*2*PI);

end;

function Cos256(i: Integer): Double;

begin

  Result := CosinTable[i and 255];

end;

function Sin256(i: Integer): Double;

begin

  Result := CosinTable[(i+192) and 255];

end;

procedure ReleaseCom(out Com);

begin

end;

var

  LibList: TStringList;

function DXLoadLibrary(const FileName, FuncName: string): Pointer;

var

  i: Integer;

  h: THandle;

begin

  if LibList=nil then

    LibList := TStringList.Create;

  i := LibList.IndexOf(AnsiLowerCase(FileName));

  if i=-1 then

  begin

    {  DLL is loaded.  }

    h := LoadLibrary(PChar(FileName));

    if h=0 then

      raise Exception.CreateFmt(SDLLNotLoaded, [FileName]);

    LibList.AddObject(AnsiLowerCase(FileName), Pointer(h));

  end else

  begin

    {  DLL has already been loaded.  }

    h := THandle(LibList.Objects[i]);

  end;

  Result := GetProcAddress(h, PChar(FuncName));

  if Result=nil then

    raise Exception.CreateFmt(SDLLNotLoaded, [FileName]);

end;

procedure FreeLibList;

var

  i: Integer;

begin

  if LibList<>nil then

  begin

    for i:=0 to LibList.Count-1 do

      FreeLibrary(THandle(LibList.Objects[i]));

    LibList.Free;

  end;

end;

{  TDirectX  }

procedure TDirectX.Check;

begin

end;

procedure TDirectX.SetDXResult(Value: HRESULT);

begin

  FDXResult := Value;

  if FDXResult<>0 then Check;

end;

{  TDirectXDriver  }

procedure TDirectXDriver.SetGUID(Value: PGUID);

begin

  if not IsBadHugeReadPtr(Value, SizeOf(TGUID)) then

  begin

    FGUID2 := Value^;

    FGUID := @FGUID2;

  end else

    FGUID := Value;

end;

{  TDirectXDrivers  }

constructor TDirectXDrivers.Create;

begin

  inherited Create(TDirectXDriver);

end;

function TDirectXDrivers.GetDriver(Index: Integer): TDirectXDriver;

begin

  Result := (inherited Items[Index]) as TDirectXDriver;

end;

{  TDXForm  }

var

  SetAppExStyleCount: Integer;

constructor TDXForm.Create(AOnwer: TComponent);

var

  ExStyle: Integer;

begin

  inherited Create(AOnwer);

  Inc(SetAppExStyleCount);

  ExStyle := GetWindowLong(Application.Handle, GWL_EXSTYLE);

  ExStyle := ExStyle or WS_EX_TOOLWINDOW;

  SetWindowLong(Application.Handle, GWL_EXSTYLE, ExStyle);

end;

destructor TDXForm.Destroy;

var

  ExStyle: Integer;

begin

  Dec(SetAppExStyleCount);

  if SetAppExStyleCount=0 then

  begin

    ExStyle := GetWindowLong(Application.Handle, GWL_EXSTYLE);

    ExStyle := ExStyle and (not WS_EX_TOOLWINDOW);

    SetWindowLong(Application.Handle, GWL_EXSTYLE, ExStyle);

  end;

  inherited Destroy;

end;

procedure TDXForm.CreateParams(var Params: TCreateParams);

begin

  inherited CreateParams(Params);

  Params.ExStyle := Params.ExStyle or WS_EX_APPWINDOW;

end;

procedure TDXForm.RestoreWindow;

begin

  if FStoreWindow then

  begin

    SetWindowPlacement(Handle, @FWindowPlacement);

    FStoreWindow := False;

  end;

end;

procedure TDXForm.StoreWindow;

begin

  FWindowPlacement.Length := SizeOf(FWindowPlacement);

  FStoreWindow := GetWindowPlacement(Handle, @FWindowPlacement);

end;

procedure TDXForm.WMSYSCommand(var Msg: TWMSYSCommand);

begin

  if Msg.CmdType = SC_MINIMIZE then

  begin

    DefaultHandler(Msg);

    WindowState := wsMinimized;

  end else

    inherited;

end;

{  TCustomDXTimer  }

constructor TCustomDXTimer.Create(AOwner: TComponent);

begin

  inherited Create(AOwner);

  FActiveOnly := True;

  FEnabled := True;

  Interval := 1000;

  Application.HookMainWindow(AppProc);

end;

destructor TCustomDXTimer.Destroy;

begin

  Finalize;

  Application.UnHookMainWindow(AppProc);

  inherited Destroy;

end;

procedure TCustomDXTimer.AppIdle(Sender: TObject; var Done: Boolean);

var

  t, t2: DWORD;

  LagCount, i: Integer;

begin

  Done := False;

  t := TimeGetTime;

  t2 := t-FOldTime;

  if t2>=FInterval then

  begin

    FOldTime := t;

    LagCount := t2 div FInterval2;

    if LagCount<1 then LagCount := 1;

    Inc(FNowFrameRate);

    i := Max(t-FOldTime2, 1);

    if i>=1000 then

    begin

      FFrameRate := Round(FNowFrameRate*1000/i);

      FNowFrameRate := 0;

      FOldTime2 := t;

    end;

    DoTimer(LagCount);

  end;

end;

function TCustomDXTimer.AppProc(var Message: TMessage): Boolean;

begin

  Result := False;

  case Message.Msg of

    CM_ACTIVATE:

        begin

          DoActivate;

          if FInitialized and FActiveOnly then Resume;

        end;

    CM_DEACTIVATE:

        begin

          DoDeactivate;

          if FInitialized and FActiveOnly then Suspend;

        end;

  end;

end;

procedure TCustomDXTimer.DoActivate;

begin

  if Assigned(FOnActivate) then FOnActivate(Self);

end;

procedure TCustomDXTimer.DoDeactivate;

begin

  if Assigned(FOnDeactivate) then FOnDeactivate(Self);

end;

procedure TCustomDXTimer.DoTimer(LagCount: Integer);

begin

  if Assigned(FOnTimer) then FOnTimer(Self, LagCount);

end;

procedure TCustomDXTimer.Finalize;

begin

  if FInitialized then

  begin

    Suspend;

    FInitialized := False;

  end;

end;

procedure TCustomDXTimer.Initialize;

begin

  Finalize;

  if ActiveOnly then

  begin

    if Application.Active then

      Resume;

  end else

    Resume;

  FInitialized := True;

end;

procedure TCustomDXTimer.Loaded;

begin

  inherited Loaded;

  if (not (csDesigning in ComponentState)) and FEnabled then

    Initialize;

end;

procedure TCustomDXTimer.Resume;

begin

  FOldTime := TimeGetTime;

  FOldTime2 := TimeGetTime;

  Application.OnIdle := AppIdle;

end;

procedure TCustomDXTimer.SetActiveOnly(Value: Boolean);

begin

  if FActiveOnly<>Value then

  begin

    FActiveOnly := Value;

    if Application.Active and FActiveOnly then

      if FInitialized and FActiveOnly then Suspend;

  end;

end;

procedure TCustomDXTimer.SetEnabled(Value: Boolean);

begin

  if FEnabled<>Value then

  begin

    FEnabled := Value;

    if ComponentState*[csReading, csLoading]=[] then

      if FEnabled then Initialize else Finalize;

  end;

end;

procedure TCustomDXTimer.SetInterval(Value: Cardinal);

begin

  if FInterval<>Value then

  begin

    FInterval := Max(Value, 0);

    FInterval2 := Max(Value, 1);

  end;

end;

procedure TCustomDXTimer.Suspend;

begin

  Application.OnIdle := nil;

end;

{  TControlSubClass  }

constructor TControlSubClass.Create(Control: TControl;

  WindowProc: TControlSubClassProc);

begin

  inherited Create;

  FControl := Control;

  FDefWindowProc := FControl.WindowProc;

  FControl.WindowProc := WndProc;

  FWindowProc := WindowProc;

end;

destructor TControlSubClass.Destroy;

begin

  FControl.WindowProc := FDefWindowProc;

  inherited Destroy;

end;

procedure TControlSubClass.WndProc(var Message: TMessage);

begin

  FWindowProc(Message, FDefWindowProc);

end;

{  THashCollectionItem  }

function MakeHashCode(const Str: string): Integer;

var

  s: string;

begin

  s := AnsiLowerCase(Str);

  Result := Length(s)*16;

  if Length(s)>=2 then

    Result := Result + (Ord(s[1]) + Ord(s[Length(s)-1]));

  Result := Result and 255;

end;

constructor THashCollectionItem.Create(Collection: TCollection);

begin

  inherited Create(Collection);

  FIndex := inherited Index;

  AddHash;

end;

destructor THashCollectionItem.Destroy;

var

  i: Integer;

begin

  for i:=FIndex+1 to Collection.Count-1 do

    Dec(THashCollectionItem(Collection.Items[i]).FIndex);

  DeleteHash;

  inherited Destroy;

end;

procedure THashCollectionItem.Assign(Source: TPersistent);

begin

  if Source is THashCollectionItem then

  begin

    Name := THashCollectionItem(Source).Name;

  end else

    inherited Assign(Source);

end;

procedure THashCollectionItem.AddHash;

var

  Item: THashCollectionItem;

begin

  FHashCode := MakeHashCode(FName);

  Item := THashCollection(Collection).FHash[FHashCode];

  if Item<>nil then

  begin

    Item.FLeft := Self;

    Self.FRight := Item;

  end;

  THashCollection(Collection).FHash[FHashCode] := Self;

end;

procedure THashCollectionItem.DeleteHash;

begin

  if FLeft<>nil then

  begin

    FLeft.FRight := FRight;

    if FRight<>nil then

      FRight.FLeft := FLeft;

  end else

  begin

    if FHashCode<>-1 then

    begin

      THashCollection(Collection).FHash[FHashCode] := FRight;

      if FRight<>nil then

        FRight.FLeft := nil;

    end;

  end;

  FLeft := nil;

  FRight := nil;

end;

function THashCollectionItem.GetDisplayName: string;

begin

  Result := Name;

  if Result='' then Result := inherited GetDisplayName;

end;

procedure THashCollectionItem.SetIndex(Value: Integer);

begin

  if FIndex<>Value then

  begin

    FIndex := Value;

    inherited SetIndex(Value);

  end;

end;

procedure THashCollectionItem.SetName(const Value: string);

begin

  if FName<>Value then

  begin

    FName := Value;

    DeleteHash;

    AddHash;

  end;

end;

{  THashCollection  }

function THashCollection.IndexOf(const Name: string): Integer;

var

  Item: THashCollectionItem;

begin

  Item := FHash[MakeHashCode(Name)];

  while Item<>nil do

  begin

    if AnsiCompareText(Item.Name, Name)=0 then

    begin

      Result := Item.FIndex;

      Exit;

    end;

    Item := Item.FRight;

  end;

  Result := -1;

end;

initialization

  InitCosinTable;

finalization

  FreeLibList;

end.