unit UResponsiveGUI;

///////////////////////////////////////////////////////////////////////////////
/// TResponsiveGUI re-routes calls to Application.ProcessMessages to only
///  handle the part of the Windows message queue that does not come from user
///  input.
///
/// TResponsiveGUI.Enabled: if True, calls are rerouted. If False they are not.
/// TResponsiveGUI.Sleep: if True, calls are rerouted. If False they are not.
/// Parameter AAllowUserInput: if available on a method, this allows for
///  bypassing the reroute. I.e. revert back to a regular
///  Application.ProcessMessages.
///
/// IMPORTANT: When changing caption of a component suct as a TButton or a
///  TLabel, TResponsiveGUI message handling will not correctly update those
///  changes. This is because a message gets posted that is interpreted by
///  Windows as a user message.
/// The solution is to call "Update" on that component (I.e. TButton.Update),
///  which forces immediate redrawing. In fact, if a redraw is why an
///  Application.ProcessMessages is called, maybe that entire call can be
///  replaced with a TForm.Update, or TPanel.Update, instead of a
///  TResposiveGUI.ProcessMessages.
///////////////////////////////////////////////////////////////////////////////
interface

uses
  Winapi.Windows;

type
  TResponsiveGUI = class(TObject)
  strict private
    class var FEnabled: Boolean;
  strict protected
    const
      PM_QS_ALL = 0;
      PM_QS_INPUT = QS_INPUT shl 16;
      PM_QS_PAINT = QS_PAINT shl 16;
      PM_QS_POSTMESSAGE = (QS_POSTMESSAGE or QS_HOTKEY or QS_TIMER) shl 16;
      PM_QS_SENDMESSAGE = QS_SENDMESSAGE shl 16;
      PM_QS_NOT_INPUT = PM_QS_PAINT or PM_QS_POSTMESSAGE or PM_QS_SENDMESSAGE;
    type
      TStopRefFunc = reference to function: Boolean;
      TStopObjFunc = function: Boolean of object;
      TStopFuncRec = record
        StopFunc: TStopRefFunc;
        LastCalled: TDateTime;
        LastResult: Boolean;
        Stop: TDateTime;
        class operator Initialize(out Dest: TStopFuncRec);
      end;
  strict protected
    class function HasStop(AStopFuncRec: TStopFuncRec): Boolean;
    class function DoStop(var AStopFuncRec: TStopFuncRec): Boolean;
    class procedure DoProcessMessages(var AStopFuncRec: TStopFuncRec; AFilter: Cardinal; AProcessRelease: Boolean); overload;
    class procedure DoProcessMessages(AStop: TDateTime; AStopFunc: TStopRefFunc; AFilter: Cardinal; AProcessRelease: Boolean); overload;
    class procedure DoSleep(AMilliseconds: Cardinal; AStopFunc: TStopRefFunc);
  public
    class procedure ProcessMessages(AAllowUserInput: Boolean = False; AProcessRelease: Boolean = False); overload;
    class procedure ProcessMessages(AStop: TDateTime; AAllowUserInput: Boolean = False; AProcessRelease: Boolean = False); overload;
    class procedure ProcessMessages(AStopFunc: TStopRefFunc; AAllowUserInput: Boolean = False; AProcessRelease: Boolean = False); overload;
    class procedure ProcessMessages(AStopFunc: TStopObjFunc; AAllowUserInput: Boolean = False; AProcessRelease: Boolean = False); overload;
    class procedure ProcessMessages(AStop: TDateTime; AStopFunc: TStopRefFunc; AAllowUserInput: Boolean = False; AProcessRelease: Boolean = False); overload;
    class procedure ProcessMessages(AStop: TDateTime; AStopFunc: TStopObjFunc; AAllowUserInput: Boolean = False; AProcessRelease: Boolean = False); overload;

    class procedure Sleep(AMilliseconds: Cardinal); overload;
    class procedure Sleep(AMilliseconds: Cardinal; AStopFunc: TStopRefFunc); overload;
    class procedure Sleep(AMilliseconds: Cardinal; AStopFunc: TStopObjFunc); overload;

    class property Enabled: Boolean read FEnabled write FEnabled;
  end;

implementation

uses
  Vcl.Forms,
  Vcl.Controls,
  Winapi.Messages,
  System.SysUtils,
  System.DateUtils,
  System.Generics.Collections;

class operator TResponsiveGUI.TStopFuncRec.Initialize (out Dest: TStopFuncRec);
begin
  inherited;
  Dest.StopFunc := nil;
  Dest.LastCalled := 0;
  Dest.LastResult := False;
  Dest.Stop := 0;
end;

class function TResponsiveGUI.HasStop(AStopFuncRec: TStopFuncRec): Boolean;
// Is a stop assigned?
begin
  Result := (AStopFuncRec.Stop > 0) or Assigned(AStopFuncRec.StopFunc);
end;

class function TResponsiveGUI.DoStop(var AStopFuncRec: TStopFuncRec): Boolean;
// Used internally to determine if a stop is triggered.
// Record data is used to make sure not too many calls to
// AStopFunc are made. They are spaced at least 200 ms apart. Once a stop's been
// called for (func returned True) that flag does not get reset.
const
  MinMillisecondsBetweenCalls = 200;
var
  AStopFunc: TStopRefFunc;
begin
  if not HasStop(AStopFuncRec) then Exit(False);
  if (AStopFuncRec.Stop > 0) and (AStopFuncRec.Stop < Now) then Exit(True);
  if not Assigned(AStopFuncRec.StopFunc) then Exit(False);
  AStopFunc := AStopFuncRec.StopFunc;
  if (not AStopFuncRec.LastResult) and (
    (AStopFuncRec.LastCalled <= 0) or
    (MilliSecondsBetween(Now, AStopFuncRec.LastCalled) >=
    MinMillisecondsBetweenCalls)
    ) then
  begin
    // A new call (refresh) is needed
    AStopFuncRec.LastResult := AStopFunc;
    AStopFuncRec.LastCalled := Now;
  end;
  Result := AStopFuncRec.LastResult;
end;

class procedure TResponsiveGUI.ProcessMessages(AAllowUserInput: Boolean = False;
  AProcessRelease: Boolean = False);
begin
  TResponsiveGUI.ProcessMessages(0, AAllowUserInput, AProcessRelease);
end;

class procedure TResponsiveGUI.ProcessMessages(AStop: TDateTime;
  AAllowUserInput: Boolean = False; AProcessRelease: Boolean = False);
begin
  if AAllowUserInput then
    TResponsiveGUI.DoProcessMessages(AStop, nil, PM_QS_ALL, AProcessRelease)
  else
    TResponsiveGUI.DoProcessMessages(AStop, nil, PM_QS_NOT_INPUT,
      AProcessRelease);
end;

class procedure TResponsiveGUI.ProcessMessages(AStopFunc: TStopRefFunc;
  AAllowUserInput: Boolean = False; AProcessRelease: Boolean = False);
begin
  TResponsiveGUI.ProcessMessages(0, AStopFunc, AAllowUserInput,
    AProcessRelease);
end;

class procedure TResponsiveGUI.ProcessMessages(AStopFunc: TStopObjFunc;
  AAllowUserInput: Boolean = False; AProcessRelease: Boolean = False);
begin
  TResponsiveGUI.ProcessMessages(0, AStopFunc, AAllowUserInput,
    AProcessRelease);
end;

class procedure TResponsiveGUI.ProcessMessages(AStop: TDateTime;
  AStopFunc: TStopRefFunc; AAllowUserInput: Boolean = False;
  AProcessRelease: Boolean = False);
begin
  if AAllowUserInput then
    TResponsiveGUI.DoProcessMessages(AStop, AStopFunc, PM_QS_ALL,
      AProcessRelease)
  else
    TResponsiveGUI.DoProcessMessages(AStop, AStopFunc, PM_QS_NOT_INPUT,
      AProcessRelease);
end;

class procedure TResponsiveGUI.ProcessMessages(AStop: TDateTime;
  AStopFunc: TStopObjFunc; AAllowUserInput: Boolean = False;
  AProcessRelease: Boolean = False);
begin
  TResponsiveGUI.ProcessMessages(AStop,
    function: Boolean
    begin
      Result := AStopFunc;
    end,
    AAllowUserInput, AProcessRelease);
end;

class procedure TResponsiveGUI.DoProcessMessages(AStop: TDateTime;
  AStopFunc: TStopRefFunc; AFilter: Cardinal; AProcessRelease: Boolean);
var
  AStopFuncRec: TStopFuncRec;
begin
  AStopFuncRec.StopFunc := AStopFunc;
  AStopFuncRec.Stop := AStop;
  TResponsiveGUI.DoProcessMessages(AStopFuncRec, AFilter, AProcessRelease);
end;

type
  TApplicationHack = class(TApplication);

class procedure TResponsiveGUI.DoProcessMessages(var AStopFuncRec: TStopFuncRec;
  AFilter: Cardinal; AProcessRelease: Boolean);
// Processes just the paint messages on the message queue.
// AStopFuncRec: function that, if it returns true, will also stop
//   processmessages immediately, plus some data to make sure that that function
//   doesn't get called too often
// AStopFuncRec.Stop: the system time after which this procedure is no longer
//   allowed to run. 0 means no stop time
// AFilter: pass in one or more (or together) of the PM_QS constants defined
//   above. See PeekMessage documentation for meaning

  function PeekMsg(var AMsg: TMsg; AFilterMin, AFilterMax,
    ARemoveMsg: Cardinal): Boolean;
  begin
    Result :=
      Winapi.Windows.PeekMessage(AMsg, 0, AFilterMin, AFilterMax, ARemoveMsg);
  end;

  procedure DispatchMsg(AMsg: TMsg; AFilterMin, AFilterMax,
    ARemoveMsg: Cardinal);
  var
    AHandled: Boolean;
    AIsUnicode, AMsgExists: Boolean;
  begin
    AIsUnicode := (AMsg.hwnd = 0) or IsWindowUnicode(AMsg.hwnd);
    if AIsUnicode then
      AMsgExists := Winapi.Windows.PeekMessageW(AMsg, 0, 0, 0, ARemoveMsg)
    else
      AMsgExists := Winapi.Windows.PeekMessageA(AMsg, 0, 0, 0, ARemoveMsg);
    if not AMsgExists then
      Exit;
    AHandled := False;
    if Assigned(Application.OnMessage) then
      Application.OnMessage(AMsg, AHandled);
    if not(AMsg.message = WM_HOTKEY) and
      not TApplicationHack(Application).IsPreProcessMessage(AMsg) and
      not TApplicationHack(Application).IsHintMsg(AMsg) and
      not AHandled and
      not TApplicationHack(Application).IsMDIMsg(AMsg) and
      not TApplicationHack(Application).IsKeyMsg(AMsg) and
      not TApplicationHack(Application).IsDlgMsg(AMsg) then
    begin
      Winapi.Windows.TranslateMessage(AMsg);
      if AIsUnicode then
        Winapi.Windows.DispatchMessageW(AMsg)
      else
        Winapi.Windows.DispatchMessageA(AMsg);
    end;
  end;

var
  AMsg: TMsg;
  AHasDispatchedMsg: Boolean;
  AMsgs: System.Generics.Collections.TList<Winapi.Windows.TMsg>;
begin
  if not FEnabled then
  begin
    Application.ProcessMessages;
    Exit;
  end;

  if (AFilter = PM_QS_ALL) and AProcessRelease and (not HasStop(AStopFuncRec))
  then
  begin
    // Bypass option. Just call TResponsiveGUI.ProcessMessages(True, True);
    Application.ProcessMessages;
    Exit;
  end;

  AHasDispatchedMsg := False;
  AMsgs := System.Generics.Collections.TList<Winapi.Windows.TMsg>.Create;
  try
    while Winapi.Windows.PeekMessage(AMsg, 0, 0, 0, PM_NOREMOVE or AFilter) do
    begin
      if AMsg.message = WM_QUIT then
      begin
        // A WM_QUIT message triggers regular processmessages
        Application.ProcessMessages;
        Break;
      end else begin
        if (AMsg.message = CM_RELEASE) and (not AProcessRelease) then
        begin
          // A CM_RELEASE message is taken out of the queue, but remembered
          // on the AMsgs list
          AMsgs.Add(AMsg);
          Winapi.Windows.PeekMessage(AMsg, 0, 0, 0, PM_REMOVE or AFilter);
        end else begin
          DispatchMsg(AMsg, 0, 0, PM_REMOVE or AFilter);
        end;
      end;
      AHasDispatchedMsg := True;
    if TResponsiveGUI.DoStop(AStopFuncRec) then Break;
    end;

  if AHasDispatchedMsg and TResponsiveGUI.DoStop(AStopFuncRec) then Exit;
    while PeekMsg(AMsg, WM_TIMER, WM_TIMER, PM_NOREMOVE) do
    begin
      // Handle all WM_TIMER messages in the queue
      DispatchMsg(AMsg, WM_TIMER, WM_TIMER, PM_REMOVE);
      AHasDispatchedMsg := True;
    if TResponsiveGUI.DoStop(AStopFuncRec) then Break;
    end;

  if AHasDispatchedMsg and TResponsiveGUI.DoStop(AStopFuncRec) then Exit;
    while PeekMsg(AMsg, WM_PAINT, WM_PAINT, PM_NOREMOVE) do
    begin
      // Handle all WM_PAINT messages in the queue
      DispatchMsg(AMsg, WM_PAINT, WM_PAINT, PM_REMOVE);
      // AHasDispatchedMsg := True;
    if TResponsiveGUI.DoStop(AStopFuncRec) then Break;
    end;
    for AMsg in AMsgs do begin
      // Go through the saved messages and put them back on the queue, but don't
      // process them. A real application.ProcessMessages (not a
      // TResponsiveGUI.ProcessMessages) will process these.
      // Right now, this happens to CM_RELEASE messages
      PostMessage(AMsg.hwnd, AMsg.message, AMsg.wParam, AMsg.lParam);
    end;
  finally
    FreeAndNil(AMsgs);
  end;
end;

class procedure TResponsiveGUI.DoSleep(AMilliseconds: Cardinal;
AStopFunc: TStopRefFunc);
// AMilliseconds: = How long to sleep
// AStopFunc: gets called a lot, and when it returns True the sleep is over
const
  ASleepInterval = 30;
var
  AStopFuncRec: TStopFuncRec;
begin
  AStopFuncRec.StopFunc := AStopFunc;
  AStopFuncRec.Stop := IncMilliSecond(Now, AMilliseconds);
  if TResponsiveGUI.DoStop(AStopFuncRec) then Exit;
  if not FEnabled then
  begin
    System.SysUtils.Sleep(AMilliSeconds);
  end else begin
    while (not TResponsiveGUI.DoStop(AStopFuncRec)) and
      (MillisecondsBetween(AStopFuncRec.Stop, Now) > ASleepInterval) do
    begin
      System.SysUtils.Sleep(ASleepInterval);
      TResponsiveGUI.DoProcessMessages(AStopFuncRec, PM_QS_PAINT, False);
      if TResponsiveGUI.DoStop(AStopFuncRec) then Exit;
    end;
    if (AStopFuncRec.Stop > Now) then
      AMilliseconds := MillisecondsBetween(AStopFuncRec.Stop, Now)
    else
      AMilliseconds := 0;
    System.SysUtils.Sleep(AMilliseconds);
  end;
end;

class procedure TResponsiveGUI.Sleep(AMilliseconds: Cardinal);
begin
  if not FEnabled then
  begin
    System.SysUtils.Sleep(AMilliSeconds);
  end else begin
    TResponsiveGUI.DoSleep(AMilliseconds, nil);
  end;
end;

class procedure TResponsiveGUI.Sleep(AMilliseconds: Cardinal;
AStopFunc: TStopObjFunc);
begin
  TResponsiveGUI.DoSleep(AMilliseconds,
    function: Boolean
    begin
      Result := AStopFunc;
    end);
end;

class procedure TResponsiveGUI.Sleep(AMilliseconds: Cardinal;
AStopFunc: TStopRefFunc);
begin
  TResponsiveGUI.DoSleep(AMilliseconds, AStopFunc);
end;

end.
