Sordie.co.uk

libsassy/libSassy.Windows.pas

Raw

{(
 )) libSassy.Windows
((    Windowing and window hooking library
 ))
((  Copyright  Sordie Aranka Solomon-Smith 2015-2016
 ))
((  This work is made available under the terms of the Creative Commons
 )) Attribution-NonCommercial-ShareAlike 3.0 Unported license
((  http://creativecommons.org/licenses/by-nc-sa/3.0/
 )}

unit libSassy.Windows;

interface

uses
  Winapi.Windows,
  Winapi.Messages,

  libSassy.Interfaces,
  libSassy.Errors,
  libSassy.DateTime;

type
  TWindowError = class(TException);

{$REGION 'TWindow'}
  TWindow = class(TInterface)
  private
    fHandle: HWND;

    function  GetWindowValue(Index: Integer): Integer; inline;
    procedure SetWindowValue(Index, Value: Integer);   inline;

    function  GetClassValue (Index: Integer): Integer; inline;
    procedure SetClassValue (Index, Value: Integer);   inline;

    function  GetPosSize(Index: Integer): Integer;
    procedure SetPosSize(Index, Value: Integer);

    function  GetClientSize(Index: Integer): Integer;
    procedure SetClientSize(Index, Value: Integer);

    function  GetCaption: String;
    procedure SetCaption(Value: String);
  public
    class function ProcessMessages(const Wait: Boolean = True): Cardinal;

    constructor Create(const AHandle: HWND);

    function Perform(const Msg: Integer; const wParam: WPARAM; const lParam: LPARAM): LRESULT; inline;

    procedure Show(const ShowCmd: Integer = SW_SHOW);

    function Rect:       TRect; inline;
    function ClientRect: TRect; inline;

    property Handle: HWND read fHandle;

    property WindowLong[Index: Integer]: Integer read GetWindowValue write SetWindowValue;
    property ClassLong [Index: Integer]: Integer read GetClassValue  write SetClassValue;

    property StyleEx:   Integer index GWL_EXSTYLE   read GetWindowValue write SetWindowValue;
    property Style:     Integer index GWL_STYLE     read GetWindowValue write SetWindowValue;
    property Instance:  Integer index GWL_HINSTANCE read GetWindowValue write SetWindowValue;
    property ID:        Integer index GWL_ID        read GetWindowValue write SetWindowValue;
    property DlgProc:   Integer index DWL_DLGPROC   read GetWindowValue write SetWindowValue;
    property DlgResult: Integer index DWL_MSGRESULT read GetWindowValue write SetWindowValue;
    property DlgUser:   Integer index DWL_USER      read GetWindowValue write SetWindowValue;

    property ClassAtom:       Integer index GCW_ATOM          read GetClassValue write SetClassValue;
    property ClassBackground: Integer index GCL_HBRBACKGROUND read GetClassValue write SetClassValue;
    property ClassCursor:     Integer index GCL_HCURSOR       read GetClassValue write SetClassValue;
    property ClassIcon:       Integer index GCL_HICON         read GetClassValue write SetClassValue;
    property ClassSmallIcon:  Integer index GCL_HICONSM       read GetClassValue write SetClassValue;
    property ClassModule:     Integer index GCL_HMODULE       read GetClassValue write SetClassValue;
    property ClassMenuName:   Integer index GCL_MENUNAME      read GetClassValue write SetClassValue;
    property ClassStyle:      Integer index GCL_STYLE         read GetClassValue write SetClassValue;

    property Left:   Integer index 0 read GetPosSize write SetPosSize;
    property Top:    Integer index 1 read GetPosSize write SetPosSize;
    property Width:  Integer index 2 read GetPosSize write SetPosSize;
    property Height: Integer index 3 read GetPosSize write SetPosSize;

    property ClientWidth:  Integer index 0 read GetClientSize write SetClientSize;
    property ClientHeight: Integer index 1 read GetClientSize write SetClientSize;

    property Caption: String read GetCaption write SetCaption;
  end;
{$ENDREGION}

{$REGION 'TWindowSubClass'}
  PWndMsg = ^TWndMsg;
  TWndMsg = packed record
    Msg:     Cardinal;
    Wnd:     HWND;
    wParam:  WPARAM;
    lParam:  LPARAM;
    lResult: LRESULT;
  end;

  PWndProc = ^TWndProc;
  TWndProc = function(Wnd: HWND; Msg: Integer; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;

  TWindowSubClass = class(TWindow)
  private
    fOldWndProc: PWndProc;
  protected
    //class function WndProc(Wnd: HWND; Msg: Integer; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
  public
    constructor Create(const AHandle: HWND);
    destructor  Destroy; override;

    function StartSubClass: Boolean;
    function EndSubClass:   Boolean;

    procedure DefaultHandler(var Msg);             override;
    procedure WindowMethod  (var WndMsg: TWndMsg); virtual;

    property OldWndProc: PWndProc read fOldWndProc;
  end;
{$ENDREGION}

{$REGION 'TWindowClass'}
  TWindowParams = record
    ExStyle:    Cardinal;
    WindowName: String;
    Style:      Cardinal;
    X, Y, W, H: Integer;
    Parent:     HWND;
    Menu:       HMENU;
    HInstance:  HINST;
    Param:      Pointer;
  end;

  TWindowClass = class(TWindowSubclass)
  public
    class var Atom: ATOM;

    class constructor Create;
    class destructor  Destroy;

    class procedure InitWindowClass(var WndClass: WNDCLASSEX); virtual;

    class function  RegisterClass:   Boolean;
    class function  UnregisterClass: Boolean;

    constructor Create;
    destructor  Destroy; override;

    procedure InitWindowParams(var Params: TWindowParams); virtual;

    procedure CreateWindow;           virtual;
    function  DestroyWindow: Boolean; virtual;
  end;
{$ENDREGION}

{$REGION 'TEngineWindow'}
  TEngineWindow = class(TWindowClass)
  private
    fDisplayWidth:      Integer;
    fDisplayHeight:     Integer;
    fDisplayAspect:     Single;
    fDisplayFullScreen: Boolean;

    fWindowWidth:  Integer;
    fWindowHeight: Integer;

    fTargetFramesPerSecond: Integer;
    fFramesPerSecond:       Integer;

    fTimeScale: Extended;

    fRunning: Boolean;
  protected
    procedure WMDestroy    (var Msg: TWndMsg); message WM_DESTROY;
    procedure WMEraseBkgnd (var Msg: TWndMsg); message WM_ERASEBKGND;
    procedure WMKeyDown    (var Msg: TWndMsg); message WM_KEYDOWN;
    procedure WMKeyUp      (var Msg: TWndMsg); message WM_KEYUP;
    procedure WMLButtonDown(var Msg: TWndMsg); message WM_LBUTTONDOWN;
    procedure WMLButtonUp  (var Msg: TWndMsg); message WM_LBUTTONUP;
    procedure WMRButtonDown(var Msg: TWndMsg); message WM_RBUTTONDOWN;
    procedure WMRButtonUp  (var Msg: TWndMsg); message WM_RBUTTONUP;
    procedure WMMButtonDown(var Msg: TWndMsg); message WM_MBUTTONDOWN;
    procedure WMMButtonUp  (var Msg: TWndMsg); message WM_MBUTTONUP;
    procedure WMXButtonDown(var Msg: TWndMsg); message WM_XBUTTONDOWN;
    procedure WMXButtonUp  (var Msg: TWndMsg); message WM_XBUTTONUP;
    procedure WMMouseMove  (var Msg: TWndMsg); message WM_MOUSEMOVE;
  public
    KeyStates: array[Word] of Boolean;
    MouseX:    Integer;
    MouseY:    Integer;

    constructor Create(const AWidth, AHeight: Integer; const AFullScreen: Boolean = False);

    class procedure InitWindowClass(var WndClass: WNDCLASSEX); override;

    procedure InitWindowParams(var Params: TWindowParams); override;

    procedure CreateWindow;           override;
    function  DestroyWindow: Boolean; override;

    procedure SetDisplaySize(const AWidth, AHeight: Integer; const AFullScreen: Boolean = False); virtual;

    procedure Run;

    function  InitializeAssets: Boolean; virtual;
    procedure DestroyAssets;             virtual;

    function  Cycle (const Delta: Extended): Boolean; virtual;
    function  Render(const Delta: Extended): Boolean; virtual;

    procedure Present; virtual;

    property DisplayWidth:      Integer read fDisplayWidth;
    property DisplayHeight:     Integer read fDisplayHeight;
    property DisplayAspect:     Single  read fDisplayAspect;
    property DisplayFullScreen: Boolean read fDisplayFullScreen;

    property Running: Boolean read fRunning;

    property TargetFramesPerSecond: Integer read fTargetFramesPerSecond write fTargetFramesPerSecond;
    property FramesPerSecond:       Integer read fFramesPerSecond;

    property TimeScale: Extended read fTimeScale write fTimeScale;
  end;
{$ENDREGION}

implementation

{$REGION 'TWindow'}
function TWindow.GetWindowValue(Index: Integer): Integer;
begin
  Result := GetWindowLong(fHandle, Index);
end;

procedure TWindow.SetWindowValue(Index, Value: Integer);
begin
  SetWindowLong(fHandle, Index, Value);
end;

function TWindow.GetClassValue(Index: Integer): Integer;
begin
  Result := GetClassLong(fHandle, Index);
end;

procedure TWindow.SetClassValue(Index, Value: Integer);
begin
  SetClassLong(fHandle, Index, Value);
end;

function TWindow.GetPosSize;
begin
  with Rect do
    case Index of
      0: Result := Left;
      1: Result := Top;
      2: Result := Right - Left;
      3: Result := Bottom - Top;
    else
      Result := 0;
    end;
end;

procedure TWindow.SetPosSize;
begin
  with Rect do
    case Index of
      0: MoveWindow(fHandle, Value, Top,   Right - Left, Bottom - Top, True);
      1: MoveWindow(fHandle, Left,  Value, Right - Left, Bottom - Top, True);
      2: MoveWindow(fHandle, Left,  Top,   Value,        Bottom - Top, True);
      3: MoveWindow(fHandle, Left,  Top,   Right - Left, Value,        True);
    end;
end;

function TWindow.GetClientSize;
begin
  with ClientRect do
    case Index of
      0: Result := Right  - Left;
      1: Result := Bottom - Top;
    else
      Result := 0;
    end;
end;

procedure TWindow.SetClientSize;
begin
  case Index of
    0: Width  := Value + (Width  - ClientWidth);
    1: Height := Value + (Height - ClientHeight);
  end;
end;

function TWindow.GetCaption;
begin
  SetLength(Result, GetWindowTextLength(fHandle) + 1);
  SetLength(Result, GetWindowText(fHandle, PChar(Result), Length(Result)));
end;

procedure TWindow.SetCaption;
begin
  SetWindowText(fHandle, Value);
end;

class function TWindow.ProcessMessages;
var
  Msg: TMsg;
begin
  if Wait then WaitMessage;

  while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do
  begin
    if Msg.message = WM_QUIT then break;

    TranslateMessage(Msg);
    DispatchMessage(Msg);
  end;

  Result := Msg.message;
end;

constructor TWindow.Create;
begin
  inherited Create;

  fHandle := AHandle;
end;

function TWindow.Perform;
begin
  Result := SendMessage(fHandle, Msg, wParam, lParam);
end;

procedure TWindow.Show;
begin
  ShowWindow(fHandle, ShowCmd);
end;

function TWindow.Rect;
begin
  GetWindowRect(fHandle, Result);
end;

function TWindow.ClientRect;
begin
  GetClientRect(fHandle, Result);
end;
{$ENDREGION}

{$REGION 'TWindowSubClass'}
function TWindowSubClassWndProc(Wnd: HWND; Msg: Integer; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
var
  Subclass: TWindowSubclass;
  WndMsg:   TWndMsg;
begin
  Subclass := TWindowSubclass(GetWindowLong(Wnd, GWL_USERDATA));

  WndMsg.Msg     := Msg;
  WndMsg.Wnd     := Wnd;
  WndMsg.wParam  := wParam;
  WndMsg.lParam  := lParam;
  WndMsg.lResult := 0;

  try
    Subclass.WindowMethod(WndMsg);
    Result := WndMsg.lResult;
  except
    Result := DefWindowProc(Wnd, Msg, wParam, lParam);
  end;
end;

constructor TWindowSubClass.Create;
begin
  inherited Create(AHandle);

  fOldWndProc := nil;
  StartSubClass;
end;

destructor TWindowSubClass.Destroy;
begin
  EndSubClass;

  inherited;
end;

function TWindowSubClass.StartSubClass;
begin
  if not EndSubClass then exit(False);
  if Handle = 0 then exit(False);

  fOldWndProc := Pointer(GetWindowLong(Handle, GWL_WNDPROC));

  SetWindowLong(Handle, GWL_USERDATA, NativeInt(Self));
  SetWindowLong(Handle, GWL_WNDPROC,  NativeInt(@TWindowSubClassWndProc));

  Result := True;
end;

function TWindowSubClass.EndSubClass;
begin
  if fOldWndProc = nil then exit(True);

  SetWindowLong(Handle, GWL_WNDPROC, NativeInt(fOldWndProc));
  fOldWndProc := nil;

  Result := True;
end;

procedure TWindowSubClass.DefaultHandler;
begin
  with TWndMsg(Msg) do
    lResult := CallWindowProc(fOldWndProc, Wnd, Msg, wParam, lParam);
end;

procedure TWindowSubClass.WindowMethod;
begin
  Dispatch(WndMsg);
end;
{$ENDREGION}

{$REGION 'TWindowClass'}
class constructor TWindowClass.Create;
begin
  Atom := 0;
end;

class destructor TWindowClass.Destroy;
begin
  UnregisterClass;
end;

class procedure TWindowClass.InitWindowClass;
begin
  with WndClass do
  begin
    lpfnWndProc   := @DefWindowProc;
    hInstance     := SysInit.HInstance;
    hIcon         := LoadIcon(0, IDI_APPLICATION);
    hCursor       := LoadCursor(0, IDC_ARROW);
    hbrBackground := COLOR_BTNFACE + 1;
    lpszClassName := PChar(ClassName);
  end;
end;

class function TWindowClass.RegisterClass;
var
  WndClass: WNDCLASSEX;
begin
  if Atom <> 0 then exit(True);

  FillChar(WndClass, sizeof(WndClass), 0);
  WndClass.cbSize := sizeof(WndClass);

  InitWindowClass(WndClass);

  Atom := RegisterClassEx(WndClass);
  Result := Atom <> 0;
end;

class function TWindowClass.UnregisterClass;
begin
  if Atom = 0 then exit(True);

  Result :=  WinApi.Windows.UnregisterClass(PChar(Atom), HInstance);
  if Result then Atom := 0;
end;

constructor TWindowClass.Create;
begin
  inherited Create(0);

  //CreateWindow;
end;

destructor TWindowClass.Destroy;
begin
  DestroyWindow;

  inherited;
end;

procedure TWindowClass.InitWindowParams;
begin
  with Params do
  begin
    ExStyle    := 0;
    WindowName := ClassName;
    Style      := WS_VISIBLE or WS_OVERLAPPEDWINDOW;
    X          := Integer(CW_USEDEFAULT);
    Y          := Integer(CW_USEDEFAULT);
    W          := Integer(CW_USEDEFAULT);
    H          := Integer(CW_USEDEFAULT);
    Parent     := 0;
    Menu       := 0;
    HInstance  := SysInit.HInstance;
    Param      := nil;
  end;
end;

procedure TWindowClass.CreateWindow;
var
  Params: TWindowParams;
begin
  EndSubClass;

  if not RegisterClass then TWindowError.RaiseException('Failed to register window class "' + ClassName + '"');
  if not DestroyWindow then TWindowError.RaiseException('Failed to destroy old window "' + ClassName + '"');

  InitWindowParams(Params);

  with Params do
    fHandle := CreateWindowEx(ExStyle, PChar(Atom), PChar(WindowName), Style, X, Y, W, H, Parent, Menu, HInstance, Param);

  if Handle = 0 then
    TWindowError.RaiseException('Failed to create window "' + ClassName + '"');

  if not StartSubClass then
    TWindowError.RaiseException('Failed to subclass window "' + ClassName + '"');
end;

function TWindowClass.DestroyWindow;
begin
  if Handle = 0 then exit(True);

  WinApi.Windows.DestroyWindow(Handle);
  Result := EndSubClass;

  fHandle := 0;
end;
{$ENDREGION}

{$REGION 'TEngineWindow'}
procedure TEngineWindow.WMDestroy;
begin
  if fRunning then PostQuitMessage(0);
end;

procedure TEngineWindow.WMEraseBkgnd;
begin
  Msg.lResult := 0;
end;

procedure TEngineWindow.WMKeyDown;
begin
  KeyStates[Msg.wParam] := True;

  case Msg.wParam of
    VK_F11:
      if fDisplayFullScreen then
        SetDisplaySize(fWindowWidth, fWindowHeight, False)
      else
        SetDisplaySize(fWindowWidth{GetSystemMetrics(SM_CXSCREEN)}, fWindowHeight{GetSystemMetrics(SM_CYSCREEN)}, True);
  end;
end;

procedure TEngineWindow.WMKeyUp;
begin
  KeyStates[Msg.wParam] := False;
end;

procedure TEngineWindow.WMLButtonDown;
begin
  KeyStates[VK_LBUTTON] := True;
end;

procedure TEngineWindow.WMLButtonUp;
begin
  KeyStates[VK_LBUTTON] := False;
end;

procedure TEngineWindow.WMRButtonDown;
begin
  KeyStates[VK_RBUTTON] := True;
end;

procedure TEngineWindow.WMRButtonUp;
begin
  KeyStates[VK_RBUTTON] := False;
end;

procedure TEngineWindow.WMMButtonDown;
begin
  KeyStates[VK_MBUTTON] := True;
end;

procedure TEngineWindow.WMMButtonUp;
begin
  KeyStates[VK_MBUTTON] := False;
end;

procedure TEngineWindow.WMXButtonDown;
begin
  KeyStates[VK_XBUTTON1] := True;
end;

procedure TEngineWindow.WMXButtonUp;
begin
  KeyStates[VK_XBUTTON1] := False;
end;

procedure TEngineWindow.WMMouseMove;
begin
  MouseX :=  Msg.lParam         and $FFFF;
  MouseY := (Msg.lParam shr 16) and $FFFF;
end;

constructor TEngineWindow.Create;
begin
  if (AWidth = 0) and (AHeight = 0) and AFullScreen then
  begin
    fDisplayWidth  := GetSystemMetrics(SM_CXSCREEN);
    fDisplayHeight := GetSystemMetrics(SM_CYSCREEN);
  end
  else
  begin
    fDisplayWidth  := AWidth;
    fDisplayHeight := AHeight;
  end;

  fWindowWidth  := fDisplayWidth;
  fWindowHeight := fDisplayHeight;

  fDisplayFullScreen := AFullScreen;

  fRunning := False;

  fTargetFramesPerSecond := 60;
  fFramesPerSecond       := 0;

  fTimeScale := 60;

  inherited Create;
end;

class procedure TEngineWindow.InitWindowClass;
begin
  inherited;

  WndClass.hbrBackground := 0;
end;

procedure TEngineWindow.InitWindowParams;
begin
  inherited;

  Params.W := fDisplayWidth;
  Params.H := fDisplayHeight;

  Params.Style := WS_CAPTION or WS_SYSMENU or WS_MINIMIZEBOX;
end;

procedure TEngineWindow.CreateWindow;
begin
  inherited;
end;

function TEngineWindow.DestroyWindow;
begin
  if fDisplayFullScreen then
    ChangeDisplaySettings(TDevMode(nil^), 0);

  Result := inherited;
end;

procedure TEngineWindow.SetDisplaySize;
var
  DevMode: TDevMode;
begin
  fDisplayWidth  := AWidth;
  fDisplayHeight := AHeight;

  if AFullScreen then
  begin
    FillChar(DevMode, sizeof(DevMode), 0);

    with DevMode do
    begin
      dmSize := sizeof(DevMode);

      dmPelsWidth  := fDisplayWidth;
      dmPelsHeight := fDisplayHeight;
      dmBitsPerPel := 32;

      dmFields := DM_BITSPERPEL or DM_PELSWIDTH or DM_PELSHEIGHT;
    end;

    fDisplayFullScreen := ChangeDisplaySettings(DevMode, CDS_FULLSCREEN) = DISP_CHANGE_SUCCESSFUL;
  end
  else
  begin
    if fDisplayFullScreen then
      ChangeDisplaySettings(TDevMode(nil^), 0);

    fDisplayFullScreen := False;
  end;

  if fDisplayFullScreen then
    SetWindowLong(Handle, GWL_STYLE, Integer(WS_POPUP or WS_EX_TOPMOST))
  else
    SetWindowLong(Handle, GWL_STYLE, WS_CAPTION or WS_SYSMENU or WS_MINIMIZEBOX);

  if fDisplayFullScreen then
    ShowWindow(Handle, SW_MAXIMIZE)
  else
  begin
    ShowWindow(Handle, SW_RESTORE);

    ClientWidth  := fDisplayWidth;
    ClientHeight := fDisplayHeight;

    Left := (GetSystemMetrics(SM_CXSCREEN) div 2) - (Width  div 2);
    Top  := (GetSystemMetrics(SM_CYSCREEN) div 2) - (Height div 2);
  end;

  if fDisplayHeight > 0 then
    fDisplayAspect := fDisplayWidth / fDisplayHeight
  else
    fDisplayAspect := 1;
end;

procedure TEngineWindow.Run;
var
  Target: Extended;
  Scale:  Extended;
  Timer:  TStopwatch;

  FrameCount: Cardinal;
  FrameTimer: TStopwatch;
begin
  CreateWindow;

  if not InitializeAssets then
  begin
    DestroyWindow;
    exit;
  end;

  Target := 1 / fTargetFramesPerSecond;
  Scale  := fTimeScale * Target;

  Timer.Reset;

  FrameCount := 0;
  FrameTimer.Reset;

  SetDisplaySize(fDisplayWidth, fDisplayHeight, fDisplayFullScreen);

  fRunning := True;

  try
    while ProcessMessages(False) <> WM_QUIT do
    begin
      if not Cycle(Scale * Timer.WaitFor(Target, False, True)) then break;

      inc(FrameCount);
      if FrameTimer.Elapsed >= 1 then
      begin
        fFramesPerSecond := round(FrameCount / FrameTimer.Split);
        FrameCount := 0;
      end;

      TickService.TimeSlice;
    end;
  finally
    fFramesPerSecond := 0;

    fRunning := False;

    DestroyAssets;
    DestroyWindow;
  end;
end;

function TEngineWindow.InitializeAssets;
begin
  Result := True;
end;

procedure TEngineWindow.DestroyAssets;
begin
  {}
end;

function TEngineWindow.Cycle;
begin
  Result := Render(Delta);

  if Result then Present;
end;

function TEngineWindow.Render;
begin
  Result := True;
end;

procedure TEngineWindow.Present;
begin
  {}
end;
{$ENDREGION}

end.