lazarus.fresnel/src/base/fresnel.controls.pas

{
    This file is part of the Fresnel Library.
    Copyright (c) 2024 by the FPC & Lazarus teams.

    Basic Fresnel control classes

    See the file COPYING.modifiedLGPL.txt, included in this distribution,
    for details about the copyright.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

 **********************************************************************}

unit Fresnel.Controls;

{$mode ObjFPC}{$H+}
{$IF FPC_FULLVERSION>30300}
{$WARN 6060 off} // Case statement does not handle all possible cases
{$ENDIF}

interface

uses
  Classes, SysUtils, Math, fpCSSTree, fpCSSResParser,
  fpImage, fresnel.images,
  Fresnel.Classes, Fresnel.Dom;

type

  { TDiv - div element }

  TDiv = class(TFresnelElement)
  private
    class var FFresnelDivTypeID: TCSSNumericalID;
    class constructor InitFresnelDivClass;
  public
    class function CSSTypeID: TCSSNumericalID; override;
    class function CSSTypeName: TCSSString; override;
    class function GetCSSTypeStyle: TCSSString; override;
  end;

  { TSpan - span element }

  TSpan = class(TFresnelElement)
  private
    class var FFresnelSpanTypeID: TCSSNumericalID;
    class constructor InitFresnelSpanClass;
  public
    class function CSSTypeID: TCSSNumericalID; override;
    class function CSSTypeName: TCSSString; override;
    class function GetCSSTypeStyle: TCSSString; override;
  end;

  TFresnelLabelState = (
    flsMinCaptionValid,
    flsMaxWidthValid,
    flsMinWidthValid,
    flsLastSizeValid
    );
  TFresnelLabelStates = set of TFresnelLabelState;

  { TCustomLabel }

  TCustomLabel = class(TReplacedElement)
  private
    FCaption: TFresnelCaption;
  protected
    FLabelStates: TFresnelLabelStates;
    FMinCaption: String; // Caption with linebreak after each word
    FMaxWidthSize: TFresnelPoint; // size for biggest width, no extra line breaks
    FMinWidthSize: TFresnelPoint; // size for width of longest word
    FOldFont: IFresnelFont;
    FLastMax: TFresnelPoint;
    FLastSize: TFresnelPoint; // result for last call with fixed max width or height
    procedure ComputeMinCaption; virtual;
    function GetFont: IFresnelFont; override;
    procedure SetCaption(const AValue: TFresnelCaption); virtual;
    procedure SetName(const NewName: TComponentName); override;
    procedure DoRender(aRenderer: IFresnelRenderer); override;
  public
    function GetIntrinsicContentSize(aMode: TFresnelLayoutMode; aMaxWidth: TFresnelLength=NaN;
      aMaxHeight: TFresnelLength=NaN): TFresnelPoint; override;
    property Caption: TFresnelCaption read FCaption write SetCaption;
  end;

  { TLabel - label element }

  TLabel = class(TCustomLabel)
  private
    class var FFresnelLabelTypeID: TCSSNumericalID;
    class constructor InitFresnelLabelClass;
  public
    class function CSSTypeID: TCSSNumericalID; override;
    class function CSSTypeName: TCSSString; override;
    class function GetCSSTypeStyle: TCSSString; override;
  published
    property Caption;
  end;

  { TBody - body element }

  TBody = class(TFresnelElement)
  private
    class var FFresnelBodyTypeID: TCSSNumericalID;
    class constructor InitFresnelBodyClass;
  public
    class function CSSTypeID: TCSSNumericalID; override;
    class function CSSTypeName: TCSSString; override;
    class function GetCSSTypeStyle: TCSSString; override;
  end;


  { TCustomButton }

  TIconPosition = (ipTop,ipBottom,ipLeft,ipRight);

  TCustomButton = class(TFresnelElement)
  private
    FCaption: string;
    FIconMargin: Single;
    FIConPosition: TIconPosition;
    FImage: TImageData;
    function ImageHasData: Boolean;
    procedure SetCaption(AValue: string);
    procedure SetIconMargin(AValue: Single);
    procedure SetIconPosition(AValue: TIconPosition);
    procedure SetImage(AValue: TImageData);
  Protected
    procedure AllocateImage;
    procedure FPOObservedChanged(ASender: TObject; Operation: TFPObservedOperation; Data: Pointer); override;
  Public
    Property HaveImage : Boolean read ImageHasData;
    Property Caption : string Read FCaption Write SetCaption;
    Property Icon : TImageData Read FImage Write SetImage Stored ImageHasData;
    Property IconPosition : TIconPosition Read FIConPosition Write SetIconPosition;
    Property IconMargin : Single Read FIconMargin Write SetIconMargin;
  end;

  { TButton - button element }

  TButton = class(TCustomButton)
  private
    class var FFresnelButtonTypeID: TCSSNumericalID;
    class constructor InitFresnelButtonClass;
  public
    class function CSSTypeID: TCSSNumericalID; override;
    class function CSSTypeName: TCSSString; override;
    class function GetCSSTypeStyle: TCSSString; override;
  Published
    Property Caption;
    Property Icon;
    Property IconPosition;
    Property IconMargin;
  end;

  { TCustomImage }

  TCustomImage = class(TReplacedElement)
  private
    FImage: TImageData;
    procedure SetImage(AValue: TImageData);
  Protected
    procedure DoRender(aRenderer: IFresnelRenderer); override;
  Public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function GetIntrinsicContentSize(aMode: TFresnelLayoutMode; aMaxWidth: TFresnelLength=NaN;
      aMaxHeight: TFresnelLength=NaN): TFresnelPoint; override;
    Property Image : TImageData Read FImage Write SetImage;
  end;

  { TImage - img element }

  TImage = class(TCustomImage)
  private
    class var FFresnelImageTypeID: TCSSNumericalID;
    class constructor InitFresnelImageClass;
  public
    class function CSSTypeID: TCSSNumericalID; override;
    class function CSSTypeName: TCSSString; override;
    class function GetCSSTypeStyle: TCSSString; override;
  Published
    Property Image;
  end;

implementation

{ TSpan }

class constructor TSpan.InitFresnelSpanClass;
begin
  FFresnelSpanTypeID:=CSSRegistry.AddType(CSSTypeName).Index;
end;

class function TSpan.CSSTypeID: TCSSNumericalID;
begin
  Result:=FFresnelSpanTypeID;
end;

class function TSpan.CSSTypeName: TCSSString;
begin
  Result:='span';
end;

class function TSpan.GetCSSTypeStyle: TCSSString;
begin
  Result:='span { display: inline flow; }';
end;

{ TDiv }

class constructor TDiv.InitFresnelDivClass;
begin
  FFresnelDivTypeID:=CSSRegistry.AddType(CSSTypeName).Index;
end;

class function TDiv.CSSTypeID: TCSSNumericalID;
begin
  Result:=FFresnelDivTypeID;
end;

class function TDiv.CSSTypeName: TCSSString;
begin
  Result:='div';
end;

class function TDiv.GetCSSTypeStyle: TCSSString;
begin
  Result:='div { display: block; }';
end;

{ TBody }

class constructor TBody.InitFresnelBodyClass;
begin
  FFresnelBodyTypeID:=CSSRegistry.AddType(CSSTypeName).Index;
end;

class function TBody.CSSTypeID: TCSSNumericalID;
begin
  Result:=FFresnelBodyTypeID;
end;

class function TBody.CSSTypeName: TCSSString;
begin
  Result:='body';
end;

class function TBody.GetCSSTypeStyle: TCSSString;
begin
  Result:='body { background-color: white; color: black; display: block; position: static; margin: 8px; }';
end;


{ TCustomButton }

procedure TCustomButton.SetCaption(AValue: string);
begin
  if FCaption=AValue then Exit;
  FCaption:=AValue;
  DomChanged;
end;

function TCustomButton.ImageHasData: Boolean;
begin
  Result:=Assigned(Fimage) and FImage.HasData;
end;

procedure TCustomButton.SetIconMargin(AValue: Single);
begin
  if FIconMargin=AValue then Exit;
  FIconMargin:=AValue;
  DomChanged;
end;

procedure TCustomButton.SetIconPosition(AValue: TIconPosition);
begin
  if FIConPosition=AValue then Exit;
  FIConPosition:=AValue;
  DomChanged;
end;

procedure TCustomButton.SetImage(AValue: TImageData);
begin
  if FImage=AValue then Exit;
  if not Assigned(FImage) then
    AllocateImage;
  FImage.Assign(AValue);
  DomChanged;
end;

procedure TCustomButton.AllocateImage;
begin
  if Assigned(FImage) then
    Fimage.FPODetachObserver(Self);
  FreeAndNil(Fimage);
  FImage:=DefaultImageDataClass.Create(Self);
  Fimage.FPOAttachObserver(Self);
end;

procedure TCustomButton.FPOObservedChanged(ASender: TObject; Operation: TFPObservedOperation; Data: Pointer);
begin
  inherited FPOObservedChanged(ASender, Operation, Data);
  if aSender=FImage then
    begin
    If Operation=ooFree then
      FImage:=Nil;
    DomChanged;
    end;
end;

{ TButton }

class constructor TButton.InitFresnelButtonClass;
begin
  FFresnelButtonTypeID:=CSSRegistry.AddType(CSSTypeName).Index;
end;

class function TButton.CSSTypeID: TCSSNumericalID;
begin
  Result:=FFresnelButtonTypeID;
end;

class function TButton.CSSTypeName: TCSSString;
begin
  Result:='button';
end;

class function TButton.GetCSSTypeStyle: TCSSString;
begin
  Result:='';
end;

{ TCustomImage }

procedure TCustomImage.SetImage(AValue: TImageData);
begin
  if FImage=AValue then Exit;
  FImage.Assign(AValue);
  DomChanged;
end;

procedure TCustomImage.DoRender(aRenderer: IFresnelRenderer);
begin
  inherited DoRender(aRenderer);
  if Assigned(FImage.Data) then
    aRenderer.DrawImage(UsedClientBox.Left,UsedClientBox.Top,UsedClientBox.Width,UsedClientBox.Height,
                        FImage.Data);
end;

constructor TCustomImage.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FImage:=DefaultImageDataClass.Create(Self);
end;

destructor TCustomImage.Destroy;
begin
  FreeAndNil(FImage);
  inherited Destroy;
end;

function TCustomImage.GetIntrinsicContentSize(aMode: TFresnelLayoutMode; aMaxWidth: TFresnelLength;
  aMaxHeight: TFresnelLength): TFresnelPoint;
begin
  if FImage=nil then
    exit(Default(TFresnelPoint));
  case aMode of
  flmMinWidth,flmMinHeight:
    exit(Default(TFresnelPoint));
  flmMax:
    begin
      Result.X:=FImage.Width;
      Result.Y:=FImage.Height;
      if (Result.X=0) or (Result.Y=0) then exit;
      if (not IsNan(aMaxWidth)) and (Result.X>aMaxWidth) and (aMaxWidth>=0) then
        Result.Y:=Result.Y*(aMaxWidth/Result.X);
      if (not IsNan(aMaxHeight)) and (Result.Y>aMaxHeight) and (aMaxHeight>=0) then
        Result.X:=Result.X*(aMaxHeight/Result.Y);
    end;
  end;
end;

{ TImage }

class constructor TImage.InitFresnelImageClass;
begin
  FFresnelImageTypeID:=CSSRegistry.AddType(CSSTypeName).Index;
end;

class function TImage.CSSTypeID: TCSSNumericalID;
begin
  Result:=FFresnelImageTypeID;
end;

class function TImage.CSSTypeName: TCSSString;
begin
  Result:='img';
end;

class function TImage.GetCSSTypeStyle: TCSSString;
begin
  Result:='image { display: block; }';
end;

{ TCustomLabel }

procedure TCustomLabel.ComputeMinCaption;
// create FMinCaption from FCaption by putting every word on a line of its own
var
  LineBreakLen, SrcP, l, StartP, WordLen, TargetP: Integer;
  MyLineBreak: string;
begin
  GetFont;
  if flsMinCaptionValid in FLabelStates then exit;
  Include(FLabelStates,flsMinCaptionValid);
  if FCaption='' then
  begin
    FMinCaption:='';
    exit;
  end;
  MyLineBreak:=sLineBreak;
  LineBreakLen:=length(MyLineBreak);
  SrcP:=1;
  l:=length(FCaption);
  SetLength(FMinCaption,l);
  TargetP:=1;
  while (SrcP<=l) and (FCaption[SrcP] in [' ',#9]) do inc(SrcP);
  if SrcP>l then
  begin
    // only spaces
    FMinCaption:=' ';
    exit;
  end;
  while SrcP<=l do begin
    StartP:=SrcP;
    while (SrcP<=l) and not (FCaption[SrcP] in [' ',#9]) do inc(SrcP);
    WordLen:=SrcP-StartP;
    if TargetP+WordLen+LineBreakLen>length(FMinCaption) then
      SetLength(FMinCaption,Max(TargetP+WordLen+LineBreakLen,length(FMinCaption)*5 div 4));
    System.Move(FCaption[StartP],FMinCaption[TargetP],WordLen);
    inc(TargetP,WordLen);
    if SrcP<=l then
    begin
      System.Move(MyLineBreak[1],FMinCaption[TargetP],LineBreakLen);
      inc(TargetP,LineBreakLen);
    end;
    while (SrcP<=l) and (FCaption[SrcP] in [' ',#9]) do inc(SrcP);
  end;
  SetLength(FMinCaption,TargetP-1);
end;

function TCustomLabel.GetFont: IFresnelFont;
begin
  Result:=inherited GetFont;
  if Result<>FOldFont then
  begin
    FLabelStates:=FLabelStates-[flsMinCaptionValid,flsMinWidthValid,flsMaxWidthValid,flsLastSizeValid];
    FOldFont:=Result;
  end;
end;

procedure TCustomLabel.SetCaption(const AValue: TFresnelCaption);
begin
  if FCaption=AValue then Exit;
  FCaption:=AValue;
  FMinCaption:='';
  FLabelStates:=FLabelStates-[flsMinCaptionValid,flsMinWidthValid,flsMaxWidthValid,flsLastSizeValid];
  DomChanged;
end;

procedure TCustomLabel.SetName(const NewName: TComponentName);
var
  ChangeCaption: Boolean;
begin
  if Name=NewName then exit;
  ChangeCaption :=
    not (csLoading in ComponentState)
    and (Name = Caption)
    and ((Owner = nil) or not (csLoading in Owner.ComponentState));
  inherited SetName(NewName);
  if ChangeCaption then Caption := NewName;
end;

procedure TCustomLabel.DoRender(aRenderer: IFresnelRenderer);
var
  aCaption : string;
  aColorFP, ShadowColor: TFPColor;
  aOffsetX, aOffsetY, aRadius: TFresnelLength;
  HaveShadow : Boolean;
begin
  aCaption:=Caption;
  if aCaption='' then
    exit;
  aColorFP:=GetComputedColor(fcaColor,colTransparent);
  if aColorFP.Alpha=alphaTransparent then
    exit;

  // Change to loop, later
  HaveShadow:=GetComputedTextShadow(aOffsetX, aOffsetY, aRadius, ShadowColor);
  if HaveShadow then
    aRenderer.AddTextShadow(aOffsetX,aOffsetY,ShadowColor,aRadius);

  aRenderer.TextOut(UsedClientBox.Left,UsedClientBox.Top,Font,aColorFP,aCaption);
  if HaveShadow then
    aRenderer.ClearTextShadows;
end;

function TCustomLabel.GetIntrinsicContentSize(aMode: TFresnelLayoutMode; aMaxWidth: TFresnelLength;
  aMaxHeight: TFresnelLength): TFresnelPoint;
begin
  GetFont;

  // todo writing-mode
  if IsNan(aMaxHeight) then ;

  case aMode of
  flmMinWidth:
    begin
      // size when using the width of the longest word
      if not (flsMinWidthValid in FLabelStates) then
      begin
        if not (flsMinCaptionValid in FLabelStates) then
          ComputeMinCaption;
        FMinWidthSize:=Font.TextSize(FMinCaption);
        if FMinCaption<>FCaption then
          FMinWidthSize:=Font.TextSizeMaxWidth(FCaption,FMinWidthSize.X);
        Include(FLabelStates,flsMinWidthValid);
      end;
      Result:=FMinWidthSize;
    end;
  flmMax,flmMinHeight:
    begin
      if not (flsMaxWidthValid in FLabelStates) then
      begin
        FMaxWidthSize:=Font.TextSize(FCaption);
        Include(FLabelStates,flsMaxWidthValid);
      end;

      if IsNan(aMaxWidth) or (aMaxWidth<0) or (FMaxWidthSize.X<aMaxWidth) then
        Result:=FMaxWidthSize
      else begin
        if (not (flsLastSizeValid in FLabelStates)) or IsNan(FLastMax.X) then
        begin
          FLastMax.X:=aMaxWidth;
          FLastMax.Y:=NaN;
          FLastSize:=Font.TextSizeMaxWidth(FCaption,aMaxWidth);
        end;
        Result:=FLastSize;
      end;
    end;
  end;
end;

{ TLabel }

class constructor TLabel.InitFresnelLabelClass;
begin
  FFresnelLabelTypeID:=CSSRegistry.AddType(CSSTypeName).Index;
end;

class function TLabel.CSSTypeID: TCSSNumericalID;
begin
  Result:=FFresnelLabelTypeID;
end;

class function TLabel.CSSTypeName: TCSSString;
begin
  Result:='label';
end;

class function TLabel.GetCSSTypeStyle: TCSSString;
begin
  Result:='label { display: inline flow; }';
end;

end.