lazarus.fresnel/tests/base/TCFresnelCSS.pas

{
 *****************************************************************************
  This file is part of Fresnel.

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

 Examples:
    ./testfresnelbase --suite=TTestFresnelCSS.TestEmptyViewport
}
unit TCFresnelCSS;

{$mode ObjFPC}{$H+}

interface

uses
  Classes, SysUtils, Math, fpcunit, testregistry, FpImage, Fresnel.DOM,
  Fresnel.Renderer, Fresnel.Layouter, Fresnel.Classes, Fresnel.Controls,
  Avl_Tree, UTF8Utils;

type

  { TTestFont }

  TTestFont = class(TInterfacedObject,IFresnelFont)
  public
    Desc: TFresnelFontDesc;
    function GetDescription: String;
    function GetFamily: string;
    function GetKerning: string;
    function GetSize: double;
    function GetStyle: string;
    function GetVariant: string;
    function GetWeight: double;
    function TextSize(const aText: string): TFresnelPoint;
    function TextSizeMaxWidth(const aText: string; MaxWidth: TFresnelLength): TFresnelPoint;
    function GetTool: TObject;
  end;

  { TTestFontEngine }

  TTestFontEngine = class(TFresnelFontEngine)
  private
    FFonts: TAVLTree; // tree of TTestFont sorted with CompareTestFont
  protected
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function FindFont(const Desc: TFresnelFontDesc): TTestFont; virtual;
    function Allocate(const Desc: TFresnelFontDesc): IFresnelFont; override;
  end;

  { TTestRenderer }

  TTestRenderer = class(TFresnelRenderer)
  public
    procedure Arc(const aColor: TFPColor; const aCenter, aRadii: TFresnelPoint;
      aStartAngle: TFresnelLength=0; aStopAngle: TFresnelLength=DoublePi); override;
    procedure FillRect(const aColor: TFPColor; const aRect: TFresnelRect); override;
    procedure Line(const aColor: TFPColor; const x1, y1, x2, y2: TFresnelLength); override;
    procedure RoundRect(const aColor: TFPColor; const aRect: TFresnelRoundRect; Fill: Boolean);
      override;
    procedure TextOut(const aLeft, aTop: TFresnelLength;
      const aFont: IFresnelFont; const aColor: TFPColor;
      const aText: string); override;
    procedure DrawImage(const aLeft, aTop, aWidth, aHeight: TFresnelLength; const aImage: TFPCustomImage); override;
    constructor Create(AOwner: TComponent); override;
  end;

  { TTestViewport }

  TTestViewport = class(TFresnelViewport)
  private
    FLayoutQueued: boolean;
    FRenderer: TFresnelRenderer;
  protected
    procedure SetWidth(AValue: TFresnelLength); override;
    procedure SetHeight(AValue: TFresnelLength); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure DomChanged; override;
    procedure Draw; virtual;
    property LayoutQueued: boolean read FLayoutQueued write FLayoutQueued;
    property Renderer: TFresnelRenderer read FRenderer write FRenderer;
  end;

  { TCustomTestFresnelCSS }

  TCustomTestFresnelCSS = Class(TTestCase)
  protected
    procedure SetUp; override;
    procedure TearDown; override;
  public
    Viewport: TTestViewport;
  end;

  { TTestFresnelCSS }

  TTestFresnelCSS = class(TCustomTestFresnelCSS)
  published
    procedure TestEmptyViewport;
    procedure TestBody;

    procedure TestGetStyleAttr_OneValue;
    procedure TestGetStyleAttr_TwoValues;
    procedure TestGetStyleAttr_OneFunction;
    procedure TestGetStyleAttr_TwoFunctions;
    procedure TestGetStyleAttr_NestedFunctions;
    procedure TestSetStyleAttr_NewValueEmpty;
    procedure TestSetStyleAttr_NewValueFirst;
    procedure TestSetStyleAttr_NewValueAppend;
    procedure TestSetStyleAttr_NewValueAppendSemicolon;
    procedure TestSetStyleAttr_DeleteOnlyValue;
    procedure TestSetStyleAttr_DeleteFirstValue;
    procedure TestSetStyleAttr_DeleteLastValue;
    procedure TestSetStyleAttr_DeleteMiddleValue;
    procedure TestSetStyleAttr_ReplaceOnlyValue;
    procedure TestSetStyleAttr_ReplaceFirstValue;
    procedure TestSetStyleAttr_ReplaceLastValue;
    procedure TestSetStyleAttr_ReplaceMiddleValue;

    procedure TestVar_NoDefault;
  end;

function LinesToStr(const Args: array of const): string;

implementation

const
  // char sizes for a font size of 100
  CharHeight = 115;
  CharWidths: array[32..126] of word = (
    278, // space
    278, // !
    355, // "
    556, // #
    556, // $
    889, // %
    667, // &
    191, // '
    333, // (
    333, // )
    389, // *
    584, // +
    278, // ,
    333, // -
    278, // .
    278, // /
    556, // 0
    489, // 1
    556, // 2
    556, // 3
    556, // 4
    556, // 5
    556, // 6
    556, // 7
    556, // 8
    556, // 9
    278, // :
    278, // ;
    584, // <
    584, // =
    584, // >
    556, // ?
    1015, // @
    667, // A
    667, // B
    722, // C
    722, // D
    667, // E
    611, // F
    778, // G
    722, // H
    278, // I
    500, // J
    667, // K
    556, // L
    833, // M
    722, // N
    778, // O
    667, // P
    778, // Q
    722, // R
    667, // S
    611, // T
    722, // U
    667, // V
    944, // W
    667, // X
    667, // Y
    611, // Z
    278, // [
    278, // \
    278, // ]
    469, // ^
    556, // _
    333, // `
    556, // a
    556, // b
    500, // c
    556, // d
    556, // e
    262, // f
    556, // g
    556, // h
    222, // i
    222, // j
    500, // k
    222, // l
    833, // m
    556, // n
    556, // o
    556, // p
    556, // q
    333, // r
    500, // s
    278, // t
    556, // u
    500, // v
    722, // w
    500, // x
    500, // y
    500, // z
    334, // {
    260, // |
    334, // }
    584  // ~
    );

function CompareTestFont(Desc1, Desc2: Pointer): integer;
var
  A: PFresnelFontDesc absolute Desc1;
  B: PFresnelFontDesc absolute Desc2;
begin
  Result:=A^.Compare(B^);
end;

function CompareFontDescTestFont(aDesc, aFont: Pointer): integer;
var
  Desc: PFresnelFontDesc absolute aDesc;
  Font: TTestFont absolute aFont;
begin
  Result:=Desc^.Compare(Font.Desc);
end;

function LinesToStr(const Args: array of const): string;
var
  s: String;
  i: Integer;
begin
  s:='';
  for i:=Low(Args) to High(Args) do
  begin
    case Args[i].VType of
      vtChar:         s += Args[i].VChar+LineEnding;
      vtString:       s += Args[i].VString^+LineEnding;
      vtPChar:        s += Args[i].VPChar+LineEnding;
      vtWideChar:     s += String(Args[i].VWideChar)+LineEnding;
      vtPWideChar:    s += String(Args[i].VPWideChar)+LineEnding;
      vtAnsiString:   s += AnsiString(Args[i].VAnsiString)+LineEnding; // FPC uses encoding CP_UTF8 for TVarRec.VAnsiString
      vtWidestring:   s += String(WideString(Args[i].VWideString))+LineEnding;
      vtUnicodeString:s += String(UnicodeString(Args[i].VUnicodeString))+LineEnding;
    end;
  end;
  Result:=s;
end;

{ TTestFont }

function TTestFont.GetFamily: string;
begin
  Result:=Desc.Family;
end;

function TTestFont.GetDescription: String;
begin
  Result:=Desc.Family;
end;

function TTestFont.GetKerning: string;
begin
  Result:=Desc.Kerning;
end;

function TTestFont.GetSize: Double;
begin
  Result:=Desc.Size;
end;

function TTestFont.GetStyle: string;
begin
  Result:=Desc.Style;
end;

function TTestFont.GetVariant: string;
begin
  Result:=Desc.Variant_;
end;

function TTestFont.GetWeight: double;
begin
  Result:=Desc.Weight;
end;

function TTestFont.TextSize(const aText: string): TFresnelPoint;
begin
  Result:=TextSizeMaxWidth(aText,1000000);
end;

function TTestFont.TextSizeMaxWidth(const aText: string;
  MaxWidth: TFresnelLength): TFresnelPoint;
var
  aSize, CurLineWidth, CurLineHeight: TFresnelLength;
  CodepointLen: Integer;
  p: PChar;
  CodePoint: Cardinal;

  procedure AddLineBreak;
  begin
    if CurLineWidth>Result.X then
      Result.X:=CurLineWidth;
    CurLineWidth:=0;
    Result.Y:=Result.Y+CurLineHeight;
  end;

  procedure AddChar(CharWidth: TFresnelLength);
  begin
    if (CurLineWidth>0) and (CurLineWidth+CharWidth>MaxWidth) then
      AddLineBreak;
    CurLineWidth:=CurLineWidth+CharWidth;
  end;

begin
  aSize:=Desc.Size;
  if aSize<0 then
    raise EFresnelFont.CreateFmt('font size negative "%g"',[Desc.Size]);
  Result.X:=0;
  Result.Y:=0;
  if (aText='') or (SameValue(aSize,0)) then
    exit;
  CurLineHeight:=aSize*CharHeight/100;
  Result.Y:=CurLineHeight;
  p:=PChar(aText);
  CurLineWidth:=0;
  CodepointLen:=0;
  while p^<>#0 do
  begin
    CodePoint:=ord(p^);
    case CodePoint of
    0: break;
    10,13:
      begin
        AddLineBreak;
        if (p[1] in [#10,#13]) and (CodePoint<>ord(p[1])) then
          inc(p,2)
        else
          inc(p);
      end;
    32..126:
      begin
        AddChar(aSize*CharWidths[CodePoint]/100);
        inc(p);
      end
    else
      {$IFNDEF CPUWASM}
      CodePoint:=UTF8CodepointToUnicode(p,CodepointLen);
      {$ELSE}
      CodePoint:=0;
      {$ENDIF}
      AddChar(aSize*CharWidths[65]/100);
      inc(p,CodepointLen);
    end;
  end;
  if CurLineWidth>Result.X then
    Result.X:=CurLineWidth;
end;

function TTestFont.GetTool: TObject;
begin
  Result:=Self;
end;

{ TTestFontEngine }

constructor TTestFontEngine.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FFonts:=TAVLTree.Create(@CompareTestFont);
end;

destructor TTestFontEngine.Destroy;
begin
  FFonts.FreeAndClear;
  FreeAndNil(FFonts);

  inherited Destroy;
end;

function TTestFontEngine.FindFont(const Desc: TFresnelFontDesc): TTestFont;
var
  Node: TAVLTreeNode;
begin
  Node:=FFonts.FindKey(@Desc,@CompareFontDescTestFont);
  if Node=nil then
    Result:=nil
  else
    Result:=TTestFont(Node.Data);
end;

function TTestFontEngine.Allocate(const Desc: TFresnelFontDesc): IFresnelFont;
var
  aFont: TTestFont;
begin
  aFont:=FindFont(Desc);
  if aFont=nil then
  begin
    aFont:=TTestFont.Create;
    aFont.Desc:=Desc;
    FFonts.Add(aFont);
  end;
  Result:=aFont;
end;

{ TTestRenderer }

procedure TTestRenderer.Arc(const aColor: TFPColor; const aCenter, aRadii: TFresnelPoint;
  aStartAngle: TFresnelLength; aStopAngle: TFresnelLength);
begin
  if aColor=colBlack then;
  if aCenter.X=0 then ;
  if aRadii.X=0 then;
  if aStartAngle=0 then;
  if aStopAngle=0 then;
end;

procedure TTestRenderer.FillRect(const aColor: TFPColor;
  const aRect: TFresnelRect);
begin
  if aColor=colBlack then ;
  if aRect.IsEmpty then ;
end;

procedure TTestRenderer.Line(const aColor: TFPColor; const x1, y1, x2,
  y2: TFresnelLength);
begin
  if aColor=colBlack then ;
  if x1+y1+x2+y2=0 then ;
end;

procedure TTestRenderer.RoundRect(const aColor: TFPColor; const aRect: TFresnelRoundRect;
  Fill: Boolean);
begin
  if aColor=colBlack then;
  if aRect.Box.Left=0 then;
  if Fill then;
end;

procedure TTestRenderer.TextOut(const aLeft, aTop: TFresnelLength;
  const aFont: IFresnelFont; const aColor: TFPColor; const aText: string);
begin
  if aLeft=aTop then ;
  if aFont=nil then ;
  if aColor=colBlack then  ;
  if aText='' then ;
end;

procedure TTestRenderer.DrawImage(const aLeft, aTop, aWidth, aHeight: TFresnelLength; const aImage: TFPCustomImage);
begin
  if (aLeft=aTop) then ;
  if (aWidth=aHeight) then ;
  if (aImage=nil) then ;
end;

constructor TTestRenderer.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
end;

{ TTestViewport }

procedure TTestViewport.SetWidth(AValue: TFresnelLength);
begin
  inherited SetWidth(AValue);
  LayoutQueued:=true;
end;

procedure TTestViewport.SetHeight(AValue: TFresnelLength);
begin
  inherited SetHeight(AValue);
  LayoutQueued:=true;
end;

constructor TTestViewport.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Layouter:=TViewportLayouter.Create(nil);
  TViewportLayouter(Layouter).Viewport:=Self;
  Renderer:=TTestRenderer.Create(Self);
end;

destructor TTestViewport.Destroy;
begin
  FreeAndNil(FRenderer);
  Layouter.Free;
  Layouter:=nil;
  inherited Destroy;
end;

procedure TTestViewport.DomChanged;
begin
  LayoutQueued:=true;
  inherited DomChanged;
end;

procedure TTestViewport.Draw;
begin
  //debugln(['TTestViewport.WSDraw ',DbgSName(Self),' ',DbgSName(Renderer)]);
  if LayoutQueued then
  begin
    LayoutQueued:=false;
    ApplyCSS;
    //Layouter.WriteLayoutTree;
    Layouter.Apply(Self);
  end;
  Renderer.Draw(Self);
end;

{ TCustomTestFresnelCSS }

procedure TCustomTestFresnelCSS.SetUp;
begin
  inherited SetUp;
  Viewport:=TTestViewport.Create(nil);
end;

procedure TCustomTestFresnelCSS.TearDown;
begin
  FreeAndNil(Viewport);
  inherited TearDown;
end;

{ TTestFresnelCSS }

procedure TTestFresnelCSS.TestEmptyViewport;
begin
  Viewport.Draw;
end;

procedure TTestFresnelCSS.TestBody;
var
  Body: TBody;
begin
  Body:=TBody.Create(Viewport);
  Body.Name:='Body';
  Body.Parent:=Viewport;
  Viewport.Draw;
  Body.WriteComputedAttributes('Body');
end;

procedure TTestFresnelCSS.TestGetStyleAttr_OneValue;
begin
  if Viewport.Style<>'' then
    Fail('20240820190117');
  Viewport.Style:='padding:3px';
  AssertEquals('padding:3px',Viewport.Style);
  AssertEquals('3px',Viewport.GetStyleAttr('padding'));
end;

procedure TTestFresnelCSS.TestGetStyleAttr_TwoValues;
begin
  Viewport.Style:='padding-left:3px; padding-top: 4px';
  AssertEquals('3px',Viewport.GetStyleAttr('padding-left'));
  AssertEquals('4px',Viewport.GetStyleAttr('padding-top'));
end;

procedure TTestFresnelCSS.TestGetStyleAttr_OneFunction;
begin
  Viewport.Style:='padding-left:var(--bird)';
  AssertEquals('var(--bird)',Viewport.GetStyleAttr('padding-left'));
end;

procedure TTestFresnelCSS.TestGetStyleAttr_TwoFunctions;
begin
  Viewport.Style:='padding-left:var(--bird); padding-right: min(10px, 20%) ';
  AssertEquals('var(--bird)',Viewport.GetStyleAttr('padding-left'));
  AssertEquals('min(10px, 20%)',Viewport.GetStyleAttr('padding-right'));
end;

procedure TTestFresnelCSS.TestGetStyleAttr_NestedFunctions;
begin
  Viewport.Style:='padding-left: calc(var(--bird)*10%) ; padding-right: min(max(10%,3em), 20%) min(3px,5ch)';
  AssertEquals('calc(var(--bird)*10%)',Viewport.GetStyleAttr('padding-left'));
  AssertEquals('min(max(10%,3em), 20%) min(3px,5ch)',Viewport.GetStyleAttr('padding-right'));
end;

procedure TTestFresnelCSS.TestSetStyleAttr_NewValueEmpty;
begin
  if not Viewport.SetStyleAttr('padding-left','') then
    Fail('20240820193346');
  AssertEquals('',Viewport.Style);
end;

procedure TTestFresnelCSS.TestSetStyleAttr_NewValueFirst;
begin
  if not Viewport.SetStyleAttr('padding-left','3px') then
    Fail('20240820193354');
  AssertEquals('padding-left:3px',Viewport.Style);
end;

procedure TTestFresnelCSS.TestSetStyleAttr_NewValueAppend;
begin
  Viewport.Style:='padding-left:4px';
  if not Viewport.SetStyleAttr('padding-right','7px') then
    Fail('20240820193401');
  AssertEquals('padding-left:4px; padding-right:7px',Viewport.Style);
end;

procedure TTestFresnelCSS.TestSetStyleAttr_NewValueAppendSemicolon;
begin
  Viewport.Style:='padding-left:4px ;';
  if not Viewport.SetStyleAttr('padding-right','7px') then
    Fail('20240820194710');
  AssertEquals('padding-left:4px ; padding-right:7px',Viewport.Style);
end;

procedure TTestFresnelCSS.TestSetStyleAttr_DeleteOnlyValue;
begin
  Viewport.Style:='padding-left:4px';
  if not Viewport.SetStyleAttr('padding-left','') then
    Fail('20240820193844');
  AssertEquals('',Viewport.Style);
end;

procedure TTestFresnelCSS.TestSetStyleAttr_DeleteFirstValue;
begin
  Viewport.Style:='padding-left:4px; padding-top:3px';
  if not Viewport.SetStyleAttr('padding-left','') then
    Fail('20240820193847');
  AssertEquals('padding-top:3px',Viewport.Style);
end;

procedure TTestFresnelCSS.TestSetStyleAttr_DeleteLastValue;
begin
  Viewport.Style:='padding-left:4px ; padding-top:3px';
  if not Viewport.SetStyleAttr('padding-top','') then
    Fail('20240820194509');
  AssertEquals('padding-left:4px ;',Viewport.Style);
end;

procedure TTestFresnelCSS.TestSetStyleAttr_DeleteMiddleValue;
begin
  Viewport.Style:='padding-left:4px ; padding-top:3px; padding-right: 2px';
  if not Viewport.SetStyleAttr('padding-top','') then
    Fail('20240820195100');
  AssertEquals('padding-left:4px ;padding-right: 2px',Viewport.Style);
end;

procedure TTestFresnelCSS.TestSetStyleAttr_ReplaceOnlyValue;
begin
  Viewport.Style:='padding-left: 4px;';
  if not Viewport.SetStyleAttr('padding-left','5em') then
    Fail('20240820195245');
  AssertEquals('padding-left:5em;',Viewport.Style);
end;

procedure TTestFresnelCSS.TestSetStyleAttr_ReplaceFirstValue;
begin
  Viewport.Style:='padding-left: 4px ; padding-top:3px';
  if not Viewport.SetStyleAttr('padding-left','7em') then
    Fail('20240820195924');
  AssertEquals('padding-left:7em; padding-top:3px',Viewport.Style);
end;

procedure TTestFresnelCSS.TestSetStyleAttr_ReplaceLastValue;
begin
  Viewport.Style:='padding-left: 4px ; padding-top: 3px ';
  if not Viewport.SetStyleAttr('padding-top','7em') then
    Fail('20240820200021');
  AssertEquals('padding-left: 4px ; padding-top:7em',Viewport.Style);
end;

procedure TTestFresnelCSS.TestSetStyleAttr_ReplaceMiddleValue;
begin
  Viewport.Style:='padding-left:4px ; padding-top: 3px ; padding-right: 2px';
  if not Viewport.SetStyleAttr('padding-top','7em') then
    Fail('20240820200135');
  AssertEquals('padding-left:4px ; padding-top:7em; padding-right: 2px',Viewport.Style);
end;

procedure TTestFresnelCSS.TestVar_NoDefault;
var
  Body: TBody;
begin
  Viewport.Stylesheet.Text:=LinesToStr([
    ':root {',
    '--bird-color:red;',
    '}',
    'body {',
    'color:var(--bird-color);',
    '}']);
  Body:=TBody.Create(Viewport);
  Body.Name:='Body';
  Body.Parent:=Viewport;
  Viewport.ApplyCSS;
  AssertEquals('red',Viewport.GetComputedCSSString('--bird-color'));
  AssertEquals('red',Body.GetComputedCSSString('--bird-color'));
  AssertEquals('red',Body.GetComputedCSSString('color'));
end;

Initialization
  RegisterTests([TTestFresnelCSS]);
end.