unit DXInput;

interface

{$INCLUDE DelphiXcfg.inc}

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

type

  {  EDXInputError  }

  EDXInputError = class(Exception);

  {  EForceFeedbackEffectError  }

  EForceFeedbackEffectError = class(Exception);


  {  TForceFeedbackEffect  }

  TForceFeedbackEffectType = (etNone, etConstantForce, etPeriodic, etCondition);

  TForceFeedbackEffect = class;
  TForceFeedbackEffects = class;

  TForceFeedbackEffectObject = class
  private
    FAxes: array[0..1] of DWORD;
    FAxesCount: Integer;
    Feff: TDIEffect;
    FDirections: array[0..1] of DWORD;
    FEnvelope: TDIEnvelope;
    FConstantForce: TDIConstantForce;
    FCondition: TDICondition;
    FPeriodic: TDIPeriodic;
    FEffect: IDirectInputEffect;
    procedure Clear;
    procedure Init(Effect: TForceFeedbackEffect);
    procedure Release;
  public
    destructor Destroy; override;
  end;

  TForceFeedbackEffect = class(TPersistent)
  private
    FRoot: TForceFeedbackEffects;                 
    FParent: TForceFeedbackEffect;
    FList: TList;
    FAttackLevel: Integer;
    FAttackTime: Integer;
    FCondition: TPoint;
    FConstant: TPoint;
    FEffectType: TForceFeedbackEffectType;
    FFadeLevel: Integer;
    FFadeTime: Integer;
    FName: string;
    FPeriod: Integer;
    FPlaying: Boolean;
    FPower: Integer;
    FTime: Integer;
    FStartDelayTime: Integer;
    FObject: TForceFeedbackEffectObject;
    FObject2: TForceFeedbackEffectObject;
    FFindEffectFlag: Boolean;
    FFindEffectGUID: TGUID;
    procedure Acquire;
    procedure Finalize;
    procedure Initialize;
    procedure ChangeEffect;
    procedure MakeEff;
    procedure CreateEffect;
    function GetCount: Integer;
    function GetEffect(Index: Integer): TForceFeedbackEffect;
    function GetIndex: Integer;
    function GetPlaying: Boolean;
    procedure SetAttackLevel(Value: Integer);
    procedure SetAttackTime(Value: Integer);
    procedure SetCondition(Value: TPoint);
    procedure SetConstant(Value: TPoint);
    procedure SetEffectType(Value: TForceFeedbackEffectType);
    procedure SetFadeLevel(Value: Integer);
    procedure SetFadeTime(Value: Integer);
    procedure SetIndex(Value: Integer);
    procedure SetPeriod(Value: Integer);
    procedure SetParent(Value: TForceFeedbackEffect);
    procedure SetPower(Value: Integer);
    procedure SetTime(Value: Integer);
    procedure SetStartDelayTime(Value: Integer);
    function HasInterface: Boolean;
  protected
    function GetOwner: TPersistent; override;
    property StartDelayTime: Integer read FStartDelayTime write SetStartDelayTime;
  public
    constructor Create(AParent: TForceFeedbackEffect);
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    procedure Clear;
    function Find(const Name: string): TForceFeedbackEffect;
    function IndexOf(const Name: string): Integer;
    procedure LoadFromFile(const FileName: string);
    procedure LoadFromStream(Stream: TStream);
    procedure SaveToFile(const FileName: string);
    procedure SaveToStream(Stream: TStream);
    procedure Start;
    procedure Stop;
    procedure Unload(Recurse: Boolean);
    property Count: Integer read GetCount;
    property Effects[Index: Integer]: TForceFeedbackEffect read GetEffect; default;
    property Index: Integer read GetIndex write SetIndex;
    property Playing: Boolean read GetPlaying;
    property Parent: TForceFeedbackEffect read FParent write SetParent;
    property Name: string read FName write FName;
    property EffectType: TForceFeedbackEffectType read FEffectType write SetEffectType;
    property AttackLevel: Integer read FAttackLevel write SetAttackLevel;
    property AttackTime: Integer read FAttackTime write SetAttackTime;
    property Condition: TPoint read FCondition write SetCondition;
    property Constant: TPoint read FConstant write SetConstant;
    property FadeLevel: Integer read FFadeLevel write SetFadeLevel;
    property FadeTime: Integer read FFadeTime write SetFadeTime;
    property Period: Integer read FPeriod write SetPeriod;
    property Power: Integer read FPower write SetPower;
    property Time: Integer read FTime write SetTime;
  end;

  {  TForceFeedbackEffects  }

  TCustomInput = class;

  TForceFeedbackEffects = class(TForceFeedbackEffect)
  private
    FComponent: TComponent;
    FInput: TCustomInput;
  protected
    procedure DefineProperties(Filer: TFiler); override;
  public
    constructor Create(Input: TCustomInput);
    destructor Destroy; override;
    property Input: TCustomInput read FInput;
  end;

  {  TCustomInput  }

  TDXInputState = (isUp, isDown, isLeft, isRight, isButton1, isButton2, isButton3,
    isButton4, isButton5, isButton6, isButton7, isButton8, isButton9, isButton10, isButton11,
    isButton12, isButton13, isButton14, isButton15, isButton16, isButton17, isButton18,
    isButton19, isButton20, isButton21, isButton22, isButton23, isButton24, isButton25,
    isButton26, isButton27, isButton28, isButton29, isButton30, isButton31, isButton32);

  TDXInputStates = set of TDXInputState;

  TCustomDXInput = class;

  TCustomInput = class(TPersistent)
  private          
    FBindInputStates: Boolean;
    FButtonCount: Integer;
    FDataFormat: TDIDataFormat;
    FDataFormatObjects: array[0..255] of TDIObjectDataFormat;
    FDataFormatGUIDs: array[0..255] of TGUID;
    FDevice: IDirectInputDevice;
    FDevice2: IDirectInputDevice2;
    FDXInput: TCustomDXInput;
    FEffects: TForceFeedbackEffects;
    FEnabled: Boolean;
    FForceFeedback: Boolean;
    FForceFeedbackDevice: Boolean;
    FInitialized: Boolean;
    FStates: TDXInputStates;
    procedure Acquire;
    procedure Finalize; virtual;
    procedure Initialize; virtual;
    function GetButton(Index: Integer): Boolean;
    function GetCooperativeLevel: Integer; virtual;
    function GetDeviceState(dwSize: Integer; var Data): Boolean;
    function SetDataFormat: Boolean;
    procedure SetEffects(Value: TForceFeedbackEffects);
    procedure SetEnabled(Value: Boolean);
    procedure SetForceFeedback(Value: Boolean);
    procedure SetWindowHandle(Value: Integer);
  public
    constructor Create(DXInput: TCustomDXInput); virtual;
    destructor Destroy; override;
    procedure Update; virtual; abstract;
    property ButtonCount: Integer read FButtonCount;
    property Buttons[Index: Integer]: Boolean read GetButton;
    property States: TDXInputStates read FStates;
  published
    property BindInputStates: Boolean read FBindInputStates write FBindInputStates;
    property Effects: TForceFeedbackEffects read FEffects write SetEffects;
    property Enabled: Boolean read FEnabled write SetEnabled;
    property ForceFeedback: Boolean read FForceFeedback write SetForceFeedback;
  end;

  {  TKeyboard  }

  PKeyAssign = ^TKeyAssign;
  TKeyAssign = array[0..2] of Integer;

  TKeyAssignList = array[TDXInputState] of TKeyAssign;

  TKeyboard = class(TCustomInput)
  private
    FKeyStates: TKeyboardState;
    procedure Finalize; override;
    procedure Initialize; override;
    function GetKey(Key: Integer): Boolean;
    procedure ReadAssigns(Stream: TStream);
    procedure WriteAssigns(Stream: TStream);
  protected
    procedure DefineProperties(Filer: TFiler); override;
  public
    KeyAssigns: TKeyAssignList;
    constructor Create(DXInput: TCustomDXInput); override;
    procedure Update; override;
    property Keys[Key: Integer]: Boolean read GetKey;
  end;

  {  TMouse  }

  TMouse = class(TCustomInput)
  private  
    Fdims: TDIMouseState;
    procedure Finalize; override;
    procedure Initialize; override;
    function GetX: Integer;
    function GetY: Integer;
    function GetZ: Integer;
  public
    constructor Create(DXInput: TCustomDXInput); override;
    procedure Update; override;
    property X: Integer read GetX;
    property Y: Integer read GetY;
    property Z: Integer read GetZ;
  end;

  {  TJoystick  }

  TJoystick = class(TCustomInput)
  private
    Fdijs: TDIJoyState2;
    FAutoCenter: Boolean;
    FDeviceGUID: TGUID;
    FEnumFlag: Boolean;
    FEnumIndex: Integer;
    FID: Integer;
    FID2: Integer;
    FJoyCaps: TJoyCaps;
    FDeadZone: array[0..SizeOf(TDIJoyState2)-1] of Integer;
    FRange: array[0..SizeOf(TDIJoyState2)-1] of Integer;
    procedure Finalize; override;
    procedure Initialize; override;
    function GetCooperativeLevel: Integer; override;
    function GetDeadZone(Obj: Integer): Integer;
    function GetRange(Obj: Integer): Integer;
    function GetX: Integer;
    function GetY: Integer;
    function GetZ: Integer;
    procedure SetDeadZone(Obj: Integer; Value: Integer);
    procedure SetRange(Obj: Integer; Value: Integer);
    procedure SetAutoCenter(Value: Boolean);
    procedure SetID(Value: Integer);
  public
    constructor Create(DXInput: TCustomDXInput); override;
    procedure Update; override;
    property DeadZone[Obj: Integer]: Integer read GetDeadZone write SetDeadZone;
    property Range[Obj: Integer]: Integer read GetRange write SetRange;
    property Joystate: TDIJoyState2 read Fdijs;
    property X: Integer read GetX;
    property Y: Integer read GetY;
    property Z: Integer read GetZ;
  published
    property AutoCenter: Boolean read FAutoCenter write SetAutoCenter;
    property DeadZoneX: Integer index DIJOFS_X read GetDeadZone write SetDeadZone;
    property DeadZoneY: Integer index DIJOFS_Y read GetDeadZone write SetDeadZone;
    property DeadZoneZ: Integer index DIJOFS_Z read GetDeadZone write SetDeadZone;
    property ID: Integer read FID write SetID;
    property RangeX: Integer index DIJOFS_X read GetRange write SetRange;
    property RangeY: Integer index DIJOFS_Y read GetRange write SetRange;
    property RangeZ: Integer index DIJOFS_Z read GetRange write SetRange;
  end;

  {  TCustomDXInput  }

  TCustomDXInput = class(TComponent)
  private
    FActiveOnly: Boolean;
    FDevice: TList;
    FDInput: IDirectInput;
    FForm: TCustomForm;
    FJoystick: TJoystick;
    FKeyboard: TKeyboard;
    FMouse: TMouse;
    FOldStates: TDXInputStates;
    FStates: TDXInputStates;
    FSubClass: TControlSubClass;
    FUseDirectInput: Boolean;
    procedure Finalize;
    procedure Initialize;
    procedure FormWndProc(var Message: TMessage; DefWindowProc: TWndMethod);
    procedure SetActiveOnly(Value: Boolean);
    procedure SetJoystick(Value: TJoystick);
    procedure SetKeyboard(Value: TKeyboard);
    procedure SetMouse(Value: TMouse);
    procedure SetWindowHandle;
    procedure SetUseDirectInput(Value: Boolean);
  protected
    procedure Loaded; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Update;
    property ActiveOnly: Boolean read FActiveOnly write SetActiveOnly;
    property Joystick: TJoystick read FJoystick write SetJoystick;
    property Keyboard: TKeyboard read FKeyboard write SetKeyboard;
    property Mouse: TMouse read FMouse write SetMouse;
    property States: TDXInputStates read FStates write FStates;
    property UseDirectInput: Boolean read FUseDirectInput write SetUseDirectInput;
  end;

  {  TDXInput  }

  TDXInput = class(TCustomDXInput)
  published
    property ActiveOnly;
    property Joystick;
    property Keyboard;
    property Mouse;
    property UseDirectInput;
  end;

function DefKeyAssign: TKeyAssignList;
function DefKeyAssign2_1: TKeyAssignList;
function DefKeyAssign2_2: TKeyAssignList;

implementation

uses DXConsts;

procedure AssignKey(var KeyAssignList: TKeyAssignList; State: TDXInputState;
  const Keys: array of Integer);
var
  i, i2: Integer;
  KeyAssign: PKeyAssign;
begin
  KeyAssign := @KeyAssignList[State];
  FillChar(KeyAssign^, SizeOf(TKeyAssign), 0);

  i2 := 0;
  for i:=LOW(Keys) to HIGH(Keys) do
  begin
    if i2<3 then
      KeyAssign^[i2] := Keys[i]
    else
      Exit;
    Inc(i2);
  end;
end;

function DefKeyAssign: TKeyAssignList;
begin
  FillChar(Result, SizeOf(Result), 0);

  AssignKey(Result, isUp,      [Ord('K'), VK_UP, VK_NUMPAD8]);
  AssignKey(Result, isDown,    [Ord('J'), VK_DOWN, VK_NUMPAD2]);
  AssignKey(Result, isLeft,    [Ord('H'), VK_LEFT, VK_NUMPAD4]);
  AssignKey(Result, isRight,   [Ord('L'), VK_RIGHT, VK_NUMPAD6]);
  AssignKey(Result, isButton1, [Ord('Z'), VK_SPACE]);
  AssignKey(Result, isButton2, [Ord('X'), VK_RETURN]);
  AssignKey(Result, isButton9, [VK_F2]);
end;

function DefKeyAssign2_1: TKeyAssignList;
begin
  FillChar(Result, SizeOf(Result), 0);

  AssignKey(Result, isUp,      [Ord('K'), VK_UP, VK_NUMPAD8]);
  AssignKey(Result, isDown,    [Ord('J'), VK_DOWN, VK_NUMPAD2]);
  AssignKey(Result, isLeft,    [Ord('H'), VK_LEFT, VK_NUMPAD4]);
  AssignKey(Result, isRight,   [Ord('L'), VK_RIGHT, VK_NUMPAD6]);
  AssignKey(Result, isButton1, [VK_SPACE , VK_NUMPAD0]);
  AssignKey(Result, isButton2, [VK_RETURN, VK_NUMPAD5]);
  AssignKey(Result, isButton9, [VK_F2]);
end;

function DefKeyAssign2_2: TKeyAssignList;
begin
  FillChar(Result, SizeOf(Result), 0);

  AssignKey(Result, isUp,      [Ord('E')]);
  AssignKey(Result, isDown,    [Ord('C')]);
  AssignKey(Result, isLeft,    [Ord('S')]);
  AssignKey(Result, isRight,   [Ord('F')]);
  AssignKey(Result, isButton1, [Ord('Z')]);
  AssignKey(Result, isButton2, [Ord('X')]);
  AssignKey(Result, isButton9, [VK_F2]);
end;

{  TForceFeedbackEffectObject  }

destructor TForceFeedbackEffectObject.Destroy;
begin
  Release;                      
  inherited Destroy;
end;

function ConvertTime(i: Integer): DWORD;
begin
  if i=-1 then Result := INFINITE else Result := i*1000;
end;

procedure TForceFeedbackEffectObject.Clear;
begin
  FillChar(Feff, SizeOf(Feff), 0);
end;

procedure TForceFeedbackEffectObject.Init(Effect: TForceFeedbackEffect);
begin
  with FEnvelope do
  begin
    dwSize := SizeOf(FEnvelope);

    dwAttackLevel := Effect.FAttackLevel;
    if Effect.FTime<0 then
      dwAttackTime := Effect.FAttackTime*1000
    else
      dwAttackTime := Min(Effect.FAttackTime, Effect.FTime)*1000;
                                              
    if Effect.FTime<0 then
    begin
      dwFadeLevel := 0;
      dwFadeTime := 0;
    end else
    begin
      dwFadeLevel := Effect.FFadeLevel;
      dwFadeTime := Min(Effect.FFadeTime, Effect.FTime)*1000;
    end;
  end;

  FillChar(Feff, SizeOf(Feff), 0);
  with Feff do
  begin
    dwSize := SizeOf(Feff);
    dwFlags := DIEFF_CARTESIAN or DIEFF_OBJECTOFFSETS;
    dwDuration := ConvertTime(Effect.FTime);
    dwSamplePeriod := 0;
    dwGain := Effect.FPower;
    dwTriggerButton := DIEB_NOTRIGGER;
    dwTriggerRepeatInterval := 0;
    cAxes := FAxesCount;
    rgdwAxes := @FAxes;
    rglDirection := @FDirections;
    lpEnvelope := @FEnvelope;
    //dwStartDelay := Effect.FStartDelayTime;
  end;
end;

procedure TForceFeedbackEffectObject.Release;
begin
  FEffect := nil;
end;

{  TForceFeedbackEffect  }