PascalType.Shaper.Layout.pas

unit PascalType.Shaper.Layout;

////////////////////////////////////////////////////////////////////////////////
//                                                                            //
//  Version: MPL 1.1 or LGPL 2.1 with linking exception                       //
//                                                                            //
//  The contents of this file are subject to the Mozilla Public License       //
//  Version 1.1 (the "License"); you may not use this file except in          //
//  compliance with the License. You may obtain a copy of the License at      //
//  http://www.mozilla.org/MPL/                                               //
//                                                                            //
//  Software distributed under the License is distributed on an "AS IS"       //
//  basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the   //
//  License for the specific language governing rights and limitations under  //
//  the License.                                                              //
//                                                                            //
//  Alternatively, the contents of this file may be used under the terms of   //
//  the Free Pascal modified version of the GNU Lesser General Public         //
//  License Version 2.1 (the "FPC modified LGPL License"), in which case the  //
//  provisions of this license are applicable instead of those above.         //
//  Please see the file LICENSE.txt for additional information concerning     //
//  this license.                                                             //
//                                                                            //
//  The code is part of the PascalType Project                                //
//                                                                            //
//  The initial developer of this code is Christian-W. Budde                  //
//                                                                            //
//  Portions created by Christian-W. Budde are Copyright (C) 2010-2017        //
//  by Christian-W. Budde. All Rights Reserved.                               //
//                                                                            //
////////////////////////////////////////////////////////////////////////////////

interface

uses
  System.Classes,
  Generics.Collections,
  PascalType.Types,
  PascalType.Classes,
  PascalType.Unicode,
  PascalType.GlyphString,
  PascalType.FontFace.SFNT,
  PascalType.Tables.OpenType.Common,
  PascalType.Tables.OpenType.GSUB,
  PascalType.Tables.OpenType.GPOS,
  PascalType.Tables.OpenType.Feature,
  PascalType.Tables.OpenType.Lookup,
  PascalType.Shaper.Plan;


type
  TZeroMarkWidths = (zmwNever, zmwBeforePositioning, zmwAfterPositioning);

//------------------------------------------------------------------------------
//
//              TCustomPascalTypeLayoutEngine
//
//------------------------------------------------------------------------------
// The layout engine represent the font technology specific layer.
// Each font technology (OpenType, CFF, etc.) will have its own concrete
// layout engine class.
// Due to the unit and class dependencies we cannot have the font create the
// engine, so instead it is created by hardcoded rules in the shaper (for now).
//------------------------------------------------------------------------------
type
  TCustomPascalTypeLayoutEngine = class abstract
  private
    FFont: TCustomPascalTypeFontFace;
    FZeroMarkWidths: TZeroMarkWidths;

  protected
    function GetAvailableFeatures: TPascalTypeFeatures; virtual;
    procedure Setup(APlan: TPascalTypeShapingPlan; var AGlyphs: TPascalTypeGlyphString); virtual;
    procedure Reset; virtual;
    procedure ExecuteSubstitution(APlan: TPascalTypeShapingPlan; var AGlyphs: TPascalTypeGlyphString; var AAppliedFeatures: TPascalTypeFeatures);
    procedure ExecutePositioning(APlan: TPascalTypeShapingPlan; var AGlyphs: TPascalTypeGlyphString; var AAppliedFeatures: TPascalTypeFeatures);
    function ApplySubstitution(APlan: TPascalTypeShapingPlan; var AGlyphs: TPascalTypeGlyphString): TPascalTypeFeatures; virtual; abstract;
    function ApplyPositioning(APlan: TPascalTypeShapingPlan; var AGlyphs: TPascalTypeGlyphString): TPascalTypeFeatures; virtual; abstract;
    procedure PreProcessPositioning(APlan: TPascalTypeShapingPlan; var AGlyphs: TPascalTypeGlyphString); virtual;
    procedure PostProcessPositioning(APlan: TPascalTypeShapingPlan; var AGlyphs: TPascalTypeGlyphString; var AAppliedFeatures: TPascalTypeFeatures); virtual;
    procedure ClearMarkAdvance(var AGlyphs: TPascalTypeGlyphString; AAdjustOffsets: boolean = False);
    procedure ApplyKerning(var AGlyphs: TPascalTypeGlyphString);
    procedure ApplyRightToLeft(var AGlyphs: TPascalTypeGlyphString);

  public
    constructor Create(AFont: TCustomPascalTypeFontFace); virtual;
    destructor Destroy; override;

    procedure Layout(APlan: TPascalTypeShapingPlan; var AGlyphs: TPascalTypeGlyphString; var AAppliedFeatures: TPascalTypeFeatures); virtual;

    property Font: TCustomPascalTypeFontFace read FFont;
    property ZeroMarkWidths: TZeroMarkWidths read FZeroMarkWidths write FZeroMarkWidths;

    property AvailableFeatures: TPascalTypeFeatures read GetAvailableFeatures;
  end;


implementation

uses
  System.Math,
  System.SysUtils,
{$ifdef DEBUG}
  WinApi.Windows,
{$endif DEBUG}
  PascalType.Shaper.Layout.Fallback,
  PascalType.Tables.OpenType.Script,
  PascalType.Tables.OpenType.LanguageSystem,
  PascalType.Tables.TrueType.kern; // TPascalTypeKerningTable


//------------------------------------------------------------------------------
//
//              TCustomPascalTypeLayoutEngine
//
//------------------------------------------------------------------------------
constructor TCustomPascalTypeLayoutEngine.Create(AFont: TCustomPascalTypeFontFace);
begin
  inherited Create;

  FFont := AFont;
end;

destructor TCustomPascalTypeLayoutEngine.Destroy;
begin

  inherited;
end;

procedure TCustomPascalTypeLayoutEngine.Reset;
begin
end;

procedure TCustomPascalTypeLayoutEngine.ApplyKerning(var AGlyphs: TPascalTypeGlyphString);
var
  KerningTable: TPascalTypeKerningTable;
  KerningSubTable: TPascalTypeKerningSubTable;
  i, j: integer;
  Delta: integer;
{$ifdef DEBUG}
  AnyApplied: boolean;
{$endif DEBUG}
begin
  // TODO : Move this to another unit
{$ifdef DEBUG}
  AnyApplied := False;
{$endif DEBUG}

  KerningTable := Font.GetTableByTableType('kern') as TPascalTypeKerningTable;

  for i := 0 to AGlyphs.Count-2 do
  begin
    for j := 0 to KerningTable.KerningSubtableCount-1 do
    begin
      KerningSubTable := KerningTable.KerningSubtable[j];

      // Ignore vertical kerning
      if (KerningSubTable.IsCrossStream) then
        continue;

      if (not KerningSubTable.IsHorizontal) then
        continue;

      if (KerningSubTable.IsVertical) or (KerningSubTable.IsVariation) then
        continue;

      // TODO : GetKerningValue should return a boolean indicating match/no-match
      Delta := KerningSubTable.FormatTable.GetKerningValue(AGlyphs[i].GlyphID, AGlyphs[i+1].GlyphID);

      if (Delta <> 0) then
      begin
{$ifdef DEBUG}
        AnyApplied := True;
{$endif DEBUG}

        if (KerningSubTable.IsMinimum) then
          AGlyphs[i].XAdvance := Max(Delta, AGlyphs[i].XAdvance)
        else
        if (KerningSubTable.IsReplace) then
          AGlyphs[i].XAdvance := Delta
        else
        begin
{$define CenteredKerning}
{$if defined(CenteredKerning)}

          // Centered kerning (HarfBuzz style)
          var v2 := Delta div 2;
          var v1 := Delta - v2;

          AGlyphs[i].XAdvance := AGlyphs[i].XAdvance + v1;
          AGlyphs[i+1].XOffset := AGlyphs[i+1].XOffset + v2;
          AGlyphs[i+1].XAdvance := AGlyphs[i+1].XAdvance + v2;
{$else}

          AGlyphs[i].XAdvance := AGlyphs[i].XAdvance + Delta;

{$ifend}

        end;
      end;
    end;
  end;
{$ifdef DEBUG}
  if (AnyApplied) then
    OutputDebugString('Applied kern table');
{$endif DEBUG}
end;

procedure TCustomPascalTypeLayoutEngine.ApplyRightToLeft(var AGlyphs: TPascalTypeGlyphString);
begin
  if (AGlyphs.Direction = dirRightToLeft) then
    AGlyphs.Reverse;
end;

procedure TCustomPascalTypeLayoutEngine.ClearMarkAdvance(var AGlyphs: TPascalTypeGlyphString; AAdjustOffsets: boolean);
begin
  for var Glyph in AGlyphs do
    if (Glyph.IsMark) then
    begin
      if (AAdjustOffsets) then
      begin
        // If the font has no GPOS and direction is forward, then when zeroing mark
        // widths, we shift the mark with it, such that the mark is positioned
        // hanging over the previous glyph.
        Glyph.XOffset := Glyph.XOffset - Glyph.XAdvance;
        Glyph.YOffset := Glyph.YOffset - Glyph.YAdvance;
      end;

      Glyph.XAdvance := 0;
      Glyph.YAdvance := 0;
    end;
end;

procedure TCustomPascalTypeLayoutEngine.Layout(APlan: TPascalTypeShapingPlan; var AGlyphs: TPascalTypeGlyphString; var AAppliedFeatures: TPascalTypeFeatures);
begin
  if (AGlyphs.Count = 0) then
    exit;

  Setup(APlan, AGlyphs);

  AAppliedFeatures := Default(TPascalTypeFeatures);

  (*
  ** Substitute glyphs
  *)
  ExecuteSubstitution(APlan, AGlyphs, AAppliedFeatures);

  (*
  ** Position glyphs
  *)
  ExecutePositioning(APlan, AGlyphs, AAppliedFeatures);

end;

procedure TCustomPascalTypeLayoutEngine.Setup(APlan: TPascalTypeShapingPlan; var AGlyphs: TPascalTypeGlyphString);
begin
  AGlyphs.PlanFeatures.Assign(APlan.GlobalFeatures);
end;

procedure TCustomPascalTypeLayoutEngine.ExecuteSubstitution(APlan: TPascalTypeShapingPlan; var AGlyphs: TPascalTypeGlyphString; var AAppliedFeatures: TPascalTypeFeatures);
begin
  AAppliedFeatures := AAppliedFeatures + ApplySubstitution(APlan, AGlyphs);
end;

function TCustomPascalTypeLayoutEngine.GetAvailableFeatures: TPascalTypeFeatures;
begin
  Result := nil;
end;

procedure TCustomPascalTypeLayoutEngine.ExecutePositioning(APlan: TPascalTypeShapingPlan; var AGlyphs: TPascalTypeGlyphString; var AAppliedFeatures: TPascalTypeFeatures);
begin
  PreProcessPositioning(APlan, AGlyphs);

  var AppliedFeatures := ApplyPositioning(APlan, AGlyphs);

  PostProcessPositioning(APlan, AGlyphs, AppliedFeatures);

  AAppliedFeatures := AAppliedFeatures + AppliedFeatures;
end;

procedure TCustomPascalTypeLayoutEngine.PreProcessPositioning(APlan: TPascalTypeShapingPlan; var AGlyphs: TPascalTypeGlyphString);
begin
  // Get default positions
  for var Glyph in AGlyphs do
  begin
    if (Glyph.IsMark) then
    begin
      Glyph.XAdvance := 0;
      Glyph.YAdvance := 0;
    end else
    if (AGlyphs.Direction <> dirTopDown) then
      Glyph.XAdvance := Font.GetAdvanceWidth(Glyph.GlyphID)
    else
      Glyph.YAdvance := -Font.GetAdvanceHeight(Glyph.GlyphID);
  end;
end;

procedure TCustomPascalTypeLayoutEngine.PostProcessPositioning(APlan: TPascalTypeShapingPlan; var AGlyphs: TPascalTypeGlyphString; var AAppliedFeatures: TPascalTypeFeatures);
begin
  (*
  ** Hide do-nothing characters
  *)
  AGlyphs.HideDefaultIgnorables;

  // Use unicode properties to position marks if no features were applied (i.e. no GPOS table)
  if (APlan.FallbackMarkPositioning) and (not AAppliedFeatures.Contains('mark')) then
    TPascalTypeFallbackLayoutEngine.Apply(APlan, Font, AGlyphs, APlan.AdjustMarkOffsetsWhenZeroing);

  // In order to avoid drift between a base and its marks in vertical layout,
  // we apply the vertical origin shift to the roots of attachment chains
  // before propagating the shifts via fixups.
  if (AGlyphs.Direction = dirTopDown) then
  begin
    for var Glyph in AGlyphs do
    begin
      // Roots are glyphs that are not attached to anything else.
      if (Glyph.MarkAttachment = -1) and (Glyph.CursiveAttachment = -1) then
      begin
        var VOrigin := Font.GetVerticalOrigin(Glyph.GlyphID);
        Glyph.XOffset := Glyph.XOffset - VOrigin.X;
        Glyph.YOffset := Glyph.YOffset - VOrigin.Y;
      end;
    end;
  end;


  // Apply attachment fixups.
  // This propagates the root's origin shift down the chain and handles relative positioning.
  // Since we are using a pen-based advancement model, marks must be "reached back"
  // to their base glyph's origin.
  AGlyphs.FixupCursiveAttachments;
  AGlyphs.FixupMarkAttachments;


  // Apply old-style TrueType/AAT kerning table if kerning is enabled in features but GPOS didn't have a kern lookup.
  if (AGlyphs.PlanFeatures.Contains('kern')) and (not AAppliedFeatures.Contains('kern')) and (Font.GetTableByTableName('kern') <> nil) then
  begin
    ApplyKerning(AGlyphs);
    AAppliedFeatures.Add('kern');
  end;
end;

end.