Rux.pas

unit Rux;

interface

uses SysUtils, Types, UITypes, Classes, Graphics, Generics.Defaults,
  Generics.Collections;

type
  TUxTheme = record
    ActiveCaptionColor,
    InactiveCaptionColor: TColor;
    constructor Create(AActiveCaptionColor, AInactiveCaptionColor: TColor); overload;
    constructor Create(ABaseColor: TColor); overload;
    function SameWB(AColor: TColor): TColor;
    function OtherWB(AColor: TColor): TColor;
    function ActiveCaptionTextColor: TColor;
    function InactiveCaptionTextColor: TColor;
    function DownCaptionColor: TColor;
    function DownCaptionTextColor: TColor;
    function InactiveTextColor: TColor;
    function ColorIsDark(AColor: TColor): Boolean;
    function Contrast(AColor1, AColor2: TColor): Boolean;
    function Readable(AColor1, AColor2: TColor): Boolean;
  end;

  TUx = class(TComponent)
  private
    class var FInstance: TUx;
    FThemeData: TUxTheme;
    FCallbacks: TDictionary<TComponent, TProc>;
    FSimpleCallbacks: TList<TProc>;
    procedure CallCallbacks;
  protected
    procedure Notification(AComponent: TComponent; Operation: TOperation);
      override;
  public
    class constructor ClassCreate;
    class destructor ClassDestroy;
    class procedure ThemeUpdate(AUxThemeData: TUxTheme); static;
    class property ThemeData: TUxTheme read FThemeData;
    class procedure RegisterCallback(AComponent: TComponent;
      ACallback: TProc); overload; static;
    class procedure RegisterCallback(ACallback: TProc); overload; static;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  end;

implementation

uses
  ASColors;

{ TUxTheme }

constructor TUxTheme.Create(AActiveCaptionColor, AInactiveCaptionColor: TColor);
begin
  ActiveCaptionColor := AActiveCaptionColor;
  InactiveCaptionColor := AInactiveCaptionColor;
end;

function TUxTheme.ActiveCaptionTextColor: TColor;
begin
  Result := OtherWB(ActiveCaptionColor);
end;

function TUxTheme.ColorIsDark(AColor: TColor): Boolean;
begin
  Result := ASColors.ColorIsDark(AColor);
end;

function TUxTheme.Contrast(AColor1, AColor2: TColor): Boolean;
begin
  Result := Abs(THSL(AColor1).Lightness - THSL(AColor2).Lightness) > 0.5;
end;

function TUxTheme.Readable(AColor1, AColor2: TColor): Boolean;
begin
  Result := Abs(THSL(AColor1).Lightness - THSL(AColor2).Lightness) > 0.1;
end;

constructor TUxTheme.Create(ABaseColor: TColor);
var
  hsv: THSV;
begin
  ActiveCaptionColor := ABaseColor;
  hsv := ABaseColor;
  hsv.Saturation := hsv.Saturation / 2;
  hsv.Value := hsv.Value + (1 - hsv.Value) / 2;
  InactiveCaptionColor := hsv;
end;

function TUxTheme.DownCaptionColor: TColor;
begin
  Result := SameWB(ActiveCaptionColor);
end;

function TUxTheme.DownCaptionTextColor: TColor;
begin
  Result := OtherWB(ActiveCaptionColor);
end;

function TUxTheme.InactiveCaptionTextColor: TColor;
begin
  Result := OtherWB(InactiveCaptionColor);
end;

function TUxTheme.InactiveTextColor: TColor;
begin
  Result := 0.75*TRGB(InactiveCaptionColor) + 0.25*TRGB(InactiveCaptionTextColor());
end;

function TUxTheme.OtherWB(AColor: TColor): TColor;
begin
  if ASColors.ColorIsDark(AColor) then
    Result := clWhite
  else
    Result := clBlack;
end;

function TUxTheme.SameWB(AColor: TColor): TColor;
begin
  if ASColors.ColorIsDark(AColor) then
    Result := clBlack
  else
    Result := clWhite;
end;

{ TUx }

procedure TUx.CallCallbacks;
begin
  if Assigned(FCallbacks) then
    for var p in FCallbacks do
      if Assigned(p.Value) then
        p.Value();
  if Assigned(FSimpleCallbacks) then
    for var p in FSimpleCallbacks do
      if Assigned(p) then
        p();
end;

class constructor TUx.ClassCreate;
begin
  FInstance := TUx.Create(nil);
end;

class destructor TUx.ClassDestroy;
begin
  FreeAndNil(FInstance);
end;

constructor TUx.Create(AOwner: TComponent);
begin
  inherited;
  FThemeData := TUxTheme.Create($B4855E);
  FCallbacks := TDictionary<TComponent, TProc>.Create;
  FSimpleCallbacks := TList<TProc>.Create;
end;

destructor TUx.Destroy;
begin
  FreeAndNil(FSimpleCallbacks);
  FreeAndNil(FCallbacks);
  inherited;
end;

procedure TUx.Notification(AComponent: TComponent; Operation: TOperation);
begin
  inherited;
  if Operation = opRemove then
    if Assigned(FCallbacks) then
      FCallbacks.Remove(AComponent);
end;

class procedure TUx.RegisterCallback(ACallback: TProc);
begin
  if Assigned(FInstance) and Assigned(FInstance.FSimpleCallbacks) and Assigned(ACallback) then
  begin
    FInstance.FSimpleCallbacks.Add(ACallback);
    ACallback();
  end;
end;

class procedure TUx.RegisterCallback(AComponent: TComponent; ACallback: TProc);
begin
  if Assigned(FInstance) and Assigned(FInstance.FCallbacks) and Assigned(AComponent) and Assigned(ACallback) then
  begin
    AComponent.FreeNotification(FInstance);
    FInstance.FCallbacks.Add(AComponent, ACallback);
    ACallback();
  end;
end;

class procedure TUx.ThemeUpdate(AUxThemeData: TUxTheme);
begin
  if Assigned(FInstance) then
  begin
    FInstance.FThemeData := AUxThemeData;
    FInstance.CallCallbacks;
  end;
end;

end.