PascalType.Shaper.Layout.Fallback.pas

unit PascalType.Shaper.Layout.Fallback;

////////////////////////////////////////////////////////////////////////////////
//                                                                            //
//  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 Anders Melander.                    //
//                                                                            //
//  Portions created by Anders Melander are Copyright (C) 2024                //
//  by Anders Melander. All Rights Reserved.                                  //
//                                                                            //
////////////////////////////////////////////////////////////////////////////////

interface

uses
  PascalType.Types,
  PascalType.Unicode,
  PascalType.FontFace.SFNT,
  PascalType.GlyphString,
  PascalType.Shaper.Plan;

type
  TPascalTypeFallbackLayoutEngine = class
  private type
    TGlyphExtents = record
      XBearing: integer;
      YBearing: integer;
      Width: integer;
      Height: integer;
    end;

  private
    // IsMark returns true if the glyph should be treated as a mark for fallback positioning.
    // It prioritizes Unicode categorization over font-provided glyph classes.
    class function IsMark(AGlyph: TPascalTypeGlyph): boolean; static;

    // ZeroMarkAdvances zeroes the advances of mark glyphs and optionally adjusts their offsets
    // to maintain their relative position when their advances are removed.
    class procedure ZeroMarkAdvances(var AGlyphs: TPascalTypeGlyphString; AStart, AEnd: integer; AAdjustOffsets: boolean); static;

    // PositionMark calculates the offsets for a single mark glyph to position it correctly
    // relative to its base glyph based on its Canonical Combining Class (CCC).
    class procedure PositionMark(APlan: TPascalTypeShapingPlan; AFont: TCustomPascalTypeFontFace; var AGlyphs: TPascalTypeGlyphString; var ABaseExtents: TGlyphExtents; AGlyphIndex: integer; ACombiningClass: Cardinal); static;

    // PositionAroundBase positions a sequence of marks around a specific base glyph.
    class procedure PositionAroundBase(APlan: TPascalTypeShapingPlan; AFont: TCustomPascalTypeFontFace; var AGlyphs: TPascalTypeGlyphString; ABaseIndex, AEndIndex: integer; AAdjustOffsets: boolean); static;

    // PositionCluster iterates through the glyph string and identifies clusters
    // (a base glyph followed by one or more marks) to apply fallback positioning.
    class procedure PositionCluster(APlan: TPascalTypeShapingPlan; AFont: TCustomPascalTypeFontFace; var AGlyphs: TPascalTypeGlyphString; AStartIndex, AEndIndex: integer; AAdjustOffsets: boolean); static;
  public
    // Apply performs fallback mark positioning for the entire glyph string.
    class procedure Apply(APlan: TPascalTypeShapingPlan; AFont: TCustomPascalTypeFontFace; var AGlyphs: TPascalTypeGlyphString; AAdjustOffsets: boolean); static;
  end;

implementation

uses
  System.Math;

class procedure TPascalTypeFallbackLayoutEngine.Apply(APlan: TPascalTypeShapingPlan; AFont: TCustomPascalTypeFontFace; var AGlyphs: TPascalTypeGlyphString; AAdjustOffsets: boolean);
begin
  if (AGlyphs.Count = 0) then
    exit;

  // Position clusters.
  // A cluster consists of a base glyph followed by zero or more mark glyphs.
  var StartIndex := 0;
  var i := 1;
  while (i < AGlyphs.Count) do
  begin
    // If the current glyph is not a mark, it starts a new cluster.
    // We process the previous cluster.
    if (not IsMark(AGlyphs[i])) then
    begin
      PositionCluster(APlan, AFont, AGlyphs, StartIndex, i, AAdjustOffsets);
      StartIndex := i;
    end;

    Inc(i);
  end;

  // Process the last cluster.
  PositionCluster(APlan, AFont, AGlyphs, StartIndex, AGlyphs.Count, AAdjustOffsets);
end;

class function TPascalTypeFallbackLayoutEngine.IsMark(AGlyph: TPascalTypeGlyph): boolean;
begin
  if (Length(AGlyph.CodePoints) > 0) then
  begin
    Result := PascalTypeUnicode.IsMark(AGlyph.CodePoints[0]);
    if (not Result) then
      Result := (PascalTypeUnicode.CanonicalCombiningClass(AGlyph.CodePoints[0]) <> PascalTypeUnicode.cccNotReordered);
  end else
    Result := AGlyph.IsMark;
end;

class procedure TPascalTypeFallbackLayoutEngine.ZeroMarkAdvances(var AGlyphs: TPascalTypeGlyphString; AStart, AEnd: integer; AAdjustOffsets: boolean);
begin
  for var i := AStart to AEnd - 1 do
  begin
    var Glyph := AGlyphs[i];

    if (IsMark(Glyph)) then
    begin
      if (AAdjustOffsets) then
      begin
        Glyph.XOffset := Glyph.XOffset - Glyph.XAdvance;
        Glyph.YOffset := Glyph.YOffset - Glyph.YAdvance;
      end;

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

class procedure TPascalTypeFallbackLayoutEngine.PositionMark(APlan: TPascalTypeShapingPlan; AFont: TCustomPascalTypeFontFace; var AGlyphs: TPascalTypeGlyphString; var ABaseExtents: TGlyphExtents; AGlyphIndex: integer; ACombiningClass: Cardinal);
var
  XMin, YMin, XMax, YMax: SmallInt;
  MarkExtents: TGlyphExtents;
  YGap: integer;
  Glyph: TPascalTypeGlyph;
begin
  Glyph := AGlyphs[AGlyphIndex];

  if (not AFont.GetGlyphExtents(Glyph.GlyphID, XMin, YMin, XMax, YMax)) then
    exit;

  MarkExtents.XBearing := XMin;
  MarkExtents.YBearing := YMax;
  MarkExtents.Width := XMax - XMin;
  MarkExtents.Height := YMin - YMax;

  YGap := AFont.HeaderTable.UnitsPerEm div 16;

  Glyph.XOffset := 0;
  Glyph.YOffset := 0;

  // X positioning
  case ACombiningClass of

    PascalTypeUnicode.cccDoubleBelow, PascalTypeUnicode.cccDoubleAbove:
      case AGlyphs.Direction of
        dirLeftToRight:
          Glyph.XOffset := Glyph.XOffset + ABaseExtents.XBearing + ABaseExtents.Width - MarkExtents.Width div 2 - MarkExtents.XBearing;

        dirRightToLeft:
          Glyph.XOffset := Glyph.XOffset + ABaseExtents.XBearing - MarkExtents.Width div 2 - MarkExtents.XBearing;
      end;

    PascalTypeUnicode.cccAttachedBelowLeft, PascalTypeUnicode.cccBelowLeft, PascalTypeUnicode.cccAboveLeft:
      // Left align
      Glyph.XOffset := Glyph.XOffset + ABaseExtents.XBearing - MarkExtents.XBearing;

    PascalTypeUnicode.cccAttachedAboveRight, PascalTypeUnicode.cccBelowRight, PascalTypeUnicode.cccAboveRight:
      // Right align
      Glyph.XOffset := Glyph.XOffset + ABaseExtents.XBearing + ABaseExtents.Width - MarkExtents.Width - MarkExtents.XBearing;

  else

    // Default: Center align
    Glyph.XOffset := Glyph.XOffset + ABaseExtents.XBearing + (ABaseExtents.Width - MarkExtents.Width) div 2 - MarkExtents.XBearing;

  end;

  // Y positioning
  case ACombiningClass of

    PascalTypeUnicode.cccDoubleBelow, PascalTypeUnicode.cccBelowLeft, PascalTypeUnicode.cccBelow, PascalTypeUnicode.cccBelowRight:
      begin
        ABaseExtents.Height := ABaseExtents.Height - YGap;
        Glyph.YOffset := ABaseExtents.YBearing + ABaseExtents.Height - MarkExtents.YBearing;

        if (YGap > 0) = (Glyph.YOffset > 0) then
        begin
          ABaseExtents.Height := ABaseExtents.Height - Glyph.YOffset;
          Glyph.YOffset := 0;
        end;

        ABaseExtents.Height := ABaseExtents.Height + MarkExtents.Height;
      end;

    PascalTypeUnicode.cccDoubleAbove, PascalTypeUnicode.cccAboveLeft, PascalTypeUnicode.cccAbove, PascalTypeUnicode.cccAboveRight:
      begin
        ABaseExtents.YBearing := ABaseExtents.YBearing + YGap;
        ABaseExtents.Height := ABaseExtents.Height - YGap;
        Glyph.YOffset := ABaseExtents.YBearing - (MarkExtents.YBearing + MarkExtents.Height);

        // HarfBuzz correction logic:
        // If the mark's YOffset has the opposite sign of YGap (meaning it moved in the "wrong" direction
        // and would overlap the base glyph), distribute the correction between the mark and the base.
        if (YGap > 0) <> (Glyph.YOffset > 0) then
        begin
          var Correction := -Glyph.YOffset div 2;
          ABaseExtents.YBearing := ABaseExtents.YBearing + Correction;
          ABaseExtents.Height := ABaseExtents.Height - Correction;
          Glyph.YOffset := Glyph.YOffset + Correction;
        end;

        ABaseExtents.YBearing := ABaseExtents.YBearing - MarkExtents.Height;
        ABaseExtents.Height := ABaseExtents.Height + MarkExtents.Height;
      end;

    PascalTypeUnicode.cccAttachedBelowLeft, PascalTypeUnicode.cccAttachedBelow:
      begin
        Glyph.YOffset := ABaseExtents.YBearing + ABaseExtents.Height - MarkExtents.YBearing;

        if (YGap > 0) = (Glyph.YOffset > 0) then
        begin
          ABaseExtents.Height := ABaseExtents.Height - Glyph.YOffset;
          Glyph.YOffset := 0;
        end;

        ABaseExtents.Height := ABaseExtents.Height + MarkExtents.Height;
      end;

    PascalTypeUnicode.cccAttachedAbove, PascalTypeUnicode.cccAttachedAboveRight:
      begin
        Glyph.YOffset := ABaseExtents.YBearing - (MarkExtents.YBearing + MarkExtents.Height);

        // HarfBuzz correction logic:
        // If the mark's YOffset has the opposite sign of YGap (meaning it moved in the "wrong" direction
        // and would overlap the base glyph), distribute the correction between the mark and the base.
        if (YGap > 0) <> (Glyph.YOffset > 0) then
        begin
          var Correction := -Glyph.YOffset div 2;
          ABaseExtents.YBearing := ABaseExtents.YBearing + Correction;
          ABaseExtents.Height := ABaseExtents.Height - Correction;
          Glyph.YOffset := Glyph.YOffset + Correction;
        end;

        ABaseExtents.YBearing := ABaseExtents.YBearing - MarkExtents.Height;
        ABaseExtents.Height := ABaseExtents.Height + MarkExtents.Height;
      end;

  end;
end;

class procedure TPascalTypeFallbackLayoutEngine.PositionAroundBase(APlan: TPascalTypeShapingPlan; AFont: TCustomPascalTypeFontFace; var AGlyphs: TPascalTypeGlyphString; ABaseIndex, AEndIndex: integer; AAdjustOffsets: boolean);
var
  XMin, YMin, XMax, YMax: SmallInt;
  BaseGlyph: TPascalTypeGlyph;
  BaseExtents: TGlyphExtents;
  XOffset, YOffset: integer;
begin
  BaseGlyph := AGlyphs[ABaseIndex];

  // Attempt to retrieve the bounding box of the base glyph.
  // If extents cannot be found, we simply zero the advances of any subsequent marks.
  if (not AFont.GetGlyphExtents(BaseGlyph.GlyphID, XMin, YMin, XMax, YMax)) then
  begin
    ZeroMarkAdvances(AGlyphs, ABaseIndex + 1, AEndIndex, AAdjustOffsets);
    exit;
  end;

  // Use horizontal advance for horizontal positioning.
  // Generally a better idea as it accounts for side bearings and works for zero-ink glyphs.
  // See: https://github.com/harfbuzz/harfbuzz/issues/1532
  BaseExtents.XBearing := 0;
  BaseExtents.YBearing := YMax + BaseGlyph.YOffset;
  BaseExtents.Width := AFont.GetAdvanceWidth(BaseGlyph.GlyphID);
  BaseExtents.Height := YMin - YMax;

  (*

  TODO : Mark-to-Ligature Fallback

  In standard OpenType positioning, the GDEF table defines attachment points for each
  component of a ligature. When we fall back to manual positioning, we should try to
  distribute marks across these components. For example, if we have an 'fi' ligature
  followed by a combining mark that belongs to the 'i', we should ideally center it
  over the second half of the glyph.

  To do this accurately, the engine needs to know two things:

  - How many components the ligature has (retrievable from the GDEF table's
    LigatureCaretList or by checking Unicode properties for known ligatures).

  - Which component a specific mark belongs to (usually tracked during the GSUB
    phase via "ligature properties").

  *)
{$if defined(MarkToLigatureFallback)}
  var LigatureComponents := 1;
  // TODO: Get ligature component count from GDEF if available, or Unicode
  // For now we assume 1.
{$ifend}

  XOffset := 0;
  YOffset := 0;

  // In forward directions (LTR, TopDown), we track the relative displacement from the base.
  if (AGlyphs.Direction in [dirLeftToRight, dirTopDown]) then
  begin
    XOffset := XOffset - BaseGlyph.XAdvance;
    YOffset := YOffset - BaseGlyph.YAdvance;
  end;

  var ComponentExtents := BaseExtents;
{$if defined(MarkToLigatureFallback)}
  var LastLigatureComponent := -1;
{$ifend}
  var LastCombiningClass: Cardinal := PascalTypeUnicode.cccInvalid;
  var ClusterExtents: TGlyphExtents := BaseExtents;

  // Iterate through the marks following the base glyph and position them relative to the cluster's accumulated extents.
  for var i := ABaseIndex + 1 to AEndIndex - 1 do
  begin
    var Glyph := AGlyphs[i];

{$if defined(MarkToLigatureFallback)}
    if (LigatureComponents > 1) then
    begin
       // TODO: Implement ligature component handling
    end;
{$ifend}

    var CombiningClass: Cardinal := 0;
    if (Length(Glyph.CodePoints) > 0) then
      CombiningClass := PascalTypeUnicode.RecategorizedCombiningClass(Glyph.CodePoints[0]);

    if (CombiningClass <> 0) then
    begin
      // If the combining class changes, we reset the positioning reference (ClusterExtents)
      // to the current cluster extents (ComponentExtents).
      if (LastCombiningClass <> CombiningClass) then
      begin
        LastCombiningClass := CombiningClass;
        ClusterExtents := ComponentExtents;
      end;

      PositionMark(APlan, AFont, AGlyphs, ClusterExtents, i, CombiningClass);

      // Marks have their advances zeroed during fallback positioning.
      Glyph.XAdvance := 0;
      Glyph.YAdvance := 0;
      // Adjust mark offset to be relative to the cluster's start point.
      Glyph.XOffset := Glyph.XOffset + XOffset;
      Glyph.YOffset := Glyph.YOffset + YOffset;
    end else
    begin
      // If we encounter a glyph that isn't a combining mark (which shouldn't happen within PositionAroundBase calls
      // under normal cluster logic, but we handle it for robustness), update the displacement tracking.
      if (AGlyphs.Direction in [dirLeftToRight, dirTopDown]) then
      begin
        XOffset := XOffset - Glyph.XAdvance;
        YOffset := YOffset - Glyph.YAdvance;
      end else
      begin
        XOffset := XOffset + Glyph.XAdvance;
        YOffset := YOffset + Glyph.YAdvance;
      end;
    end;
  end;
end;

class procedure TPascalTypeFallbackLayoutEngine.PositionCluster(APlan: TPascalTypeShapingPlan; AFont: TCustomPascalTypeFontFace; var AGlyphs: TPascalTypeGlyphString; AStartIndex, AEndIndex: integer; AAdjustOffsets: boolean);
begin
  if (AEndIndex - AStartIndex < 2) then
    exit;

  var i := AStartIndex;
  while (i < AEndIndex) do
  begin
    // Locate the start of a base+marks sequence within the cluster.
    if (not IsMark(AGlyphs[i])) then
    begin
      var j := i + 1;
      while (j < AEndIndex) and (IsMark(AGlyphs[j])) do
        Inc(j);

      PositionAroundBase(APlan, AFont, AGlyphs, i, j, AAdjustOffsets);
      i := j;
    end else
      Inc(i);
  end;
end;

end.