Rux.pas

unit Rux;

interface

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

type
  TUxTheme = record
  public
    constructor Create(AActiveCaptionColor, AInactiveCaptionColor: TColor); overload;
    constructor Create(ATintColor: TColor); overload;
    class function SameWB(AColor: TColor): TColor; static;
    class function OtherWB(AColor: TColor): TColor; static;
    function ActiveCaptionTextColor: TColor;
    function InactiveCaptionTextColor: TColor;
    function DownCaptionColor: TColor;
    function DownCaptionTextColor: TColor;
    function InactiveTextColor: TColor;
    function InsertionPointColor1: TColor;
    function InsertionPointColor2: TColor;
    class function ColorIsDark(AColor: TColor): Boolean; static;
    class function Contrast(AColor1, AColor2: TColor): Boolean; static;
    class function Readable(AColor1, AColor2: TColor): Boolean; static;
  public
    case Boolean of
      True: (
        TintColor,
        ActiveCaptionColor,
        InactiveCaptionColor,
        WindowedColor: TColor;
        BlackenedColor: TColor;
        CaptionMidColor: TColor;
      );
      False: (
        Accent0,
        Accent1,
        Accent2,
        Accent3,
        Accent4,
        Accent5: TColor;
      )
  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;

var
  ColorSettingChanging: Boolean;
  ColorChanging: Boolean;

implementation

uses
  ASColors;

{ TUxTheme }

constructor TUxTheme.Create(AActiveCaptionColor, AInactiveCaptionColor: TColor);
begin
  ActiveCaptionColor := AActiveCaptionColor;
  InactiveCaptionColor := AInactiveCaptionColor;
  WindowedColor := 0.2 * TRGB(AActiveCaptionColor) + 0.8 * TRGB(clWhite);
  BlackenedColor := 0.6 * TRGB(AActiveCaptionColor) + 0.4 * TRGB(clBlack);
end;

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

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

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

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

constructor TUxTheme.Create(ATintColor: TColor);
begin
  var LBaseColor := THSV(ATintColor);
  if (LBaseColor.Saturation < 0.05) and (LBaseColor.Value > 0.95) then
  begin
    if LBaseColor.Saturation <= 1 - LBaseColor.Value then
      LBaseColor.Value := 0.95
    else
      LBaseColor.Saturation := 0.05;
  end;
  Accent0 := ATintColor;
  Accent1 := 0.7 * TRGB(LBaseColor) + 0.3 * TRGB(clWhite);
  Accent2 := 0.4 * TRGB(LBaseColor) + 0.6 * TRGB(clWhite);
  Accent3 := 0.2 * TRGB(LBaseColor) + 0.8 * TRGB(clWhite);
  Accent4 := 0.6 * TRGB(LBaseColor) + 0.4 * TRGB(clBlack);
  CaptionMidColor := 0.5 * TRGB(ActiveCaptionColor) + 0.5 * TRGB(InactiveCaptionColor);
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.InsertionPointColor1: TColor;
begin
  Result := BlackenedColor
end;

function TUxTheme.InsertionPointColor2: TColor;
begin
  Result := ActiveCaptionColor
end;

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

class 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.