PascalType.Shaper.OpenType.Processor.pas

unit PascalType.Shaper.OpenType.Processor;

////////////////////////////////////////////////////////////////////////////////
//                                                                            //
//  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

{$I PT_Compiler.inc}

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


//------------------------------------------------------------------------------
//
//      TBitSet
//
//------------------------------------------------------------------------------
type
  TBitSet = record
  private
    // TBitSet relies on FBits being a managed type which is guaranteed to be
    // initialized by the compiler even if the record isn't explicitly initialized
    // in code.
    FBits: TArray<Byte>;

    // FLastBit: Index of last bit that we *positively know* is set; It might not be
    // the actual last set bit, but we know that no bits are set after this.
    // Value is initialized the first time FBits is sized and is not used prior to this.
    FLastBit: integer;
  private
    function BitToByteIndex(Index: integer): integer;
    function BitToByteMask(Index: integer): byte;
    function GetBit(Index: integer): boolean;
    procedure SetBit(Index: integer; const Value: boolean);
  public
    procedure Initialize(Count: integer);
    function NextBit(Index: integer): integer;
    property Bit[Index: integer]: boolean read GetBit write SetBit; default;
  end;


//------------------------------------------------------------------------------
//
//              TCustomPascalTypeOpenTypeProcessor
//
//------------------------------------------------------------------------------
// Base class for GSUB and GPOS table processors
//------------------------------------------------------------------------------
type
  TCustomPascalTypeOpenTypeProcessor = class abstract
  protected type
    TLookupItem = record
      FeatureTag: TTableName;
      FeatureTable: TCustomOpenTypeFeatureTable;
    end;
    PLookupItem = ^TLookupItem;

    TLookupOrderedItem = record
      Index: integer;
      LookupItem: PLookupItem;
    end;

    TLookupItems = TArray<TLookupItem>;
    TFeatureList = TArray<Word>;

  private class var
    FOrderedLookupsComparer: IComparer<TLookupOrderedItem>;

  private
    class destructor Destroy;

  private
    FFont: TCustomPascalTypeFontFace;
    FScript: TTableType;
    FLanguage: TTableType;
    FDirection: TPascalTypeDirection;
    FIgnoreDefaultIgnorables: boolean;
    // Note: Don't use TPascalTypeFeatures for FFeatureList.
    // We need to maintain the original order of the features in it.
    FFeatureList: TFeatureList;

  protected
    FHandledLookups: TBitSet;

  protected
    procedure LoadFeatureList;
    function GetSubstitutedFeatureTable(FeatureIndex: Word): TCustomOpenTypeFeatureTable;
    function GetAvailableFeatures: TPascalTypeFeatures; virtual;
    function GetLookupsByFeatures(const AFeatures: TPascalTypeFeatures): TLookupItems;
    function DoApplyFeatures(const AFeatures: TPascalTypeFeatures; var AGlyphs: TPascalTypeGlyphString): TPascalTypeFeatures; virtual;
    function ApplyLookups(const ALookups: TLookupItems; var AGlyphs: TPascalTypeGlyphString): TPascalTypeFeatures;
    function ApplyLookup(var AGlyphIterator: TPascalTypeGlyphIterator; ALookupTable: TCustomOpenTypeLookupTable): boolean; virtual;
    function GetTable: TCustomOpenTypeCommonTable; virtual; abstract;
    property FeatureList: TFeatureList read FFeatureList; // Ordered list of features

  public
    constructor Create(AFont: TCustomPascalTypeFontFace; AScript: TTableType; ALanguage: TTableType; ADirection: TPascalTypeDirection); virtual;

    // Applies the specified features, using the lookups in the table, and
    // returns a list of features applied.
    function ApplyFeatures(const AFeatures: TPascalTypeFeatures; var AGlyphs: TPascalTypeGlyphString): TPascalTypeFeatures;

    // Applies the features in the specified plan features, using the lookups in the table, and
    // returns a list of features applied.
    function ExecutePlan(APlan: TPascalTypeShapingPlan; var AGlyphs: TPascalTypeGlyphString): TPascalTypeFeatures; virtual;

    property Font: TCustomPascalTypeFontFace read FFont;
    property Script: TTableType read FScript write FScript;
    property Language: TTableType read FLanguage write FLanguage;
    property Direction: TPascalTypeDirection read FDirection write FDirection;
    property IgnoreDefaultIgnorables: boolean read FIgnoreDefaultIgnorables write FIgnoreDefaultIgnorables;

    property Table: TCustomOpenTypeCommonTable read GetTable;
    property AvailableFeatures: TPascalTypeFeatures read GetAvailableFeatures;
  end;


//------------------------------------------------------------------------------
//------------------------------------------------------------------------------
//------------------------------------------------------------------------------

implementation

uses
{$ifdef DEBUG}
  WinApi.Windows,
{$endif DEBUG}
  System.SysUtils,
  PascalType.Tables.OpenType.Script,
  PascalType.Tables.OpenType.LanguageSystem;


//------------------------------------------------------------------------------
//
//      TBitSet
//
//------------------------------------------------------------------------------
procedure TBitSet.Initialize(Count: integer);
begin
  var OldSize := Length(FBits);
  var NewSize := (Count + 7) div 8;

  if (OldSize = 0) then
    FLastBit := -1 // First time initialization; No data
  else
  if (FLastBit >= Count) then
    FLastBit := Count-1; // Data is being shrunk

  SetLength(FBits, NewSize);

  // Clear new data
  while (OldSize < NewSize) do
  begin
    FBits[OldSize] := 0;
    Inc(OldSize);
  end;
end;

function TBitSet.BitToByteIndex(Index: integer): integer;
begin
  Result := Index div 8;
end;

function TBitSet.BitToByteMask(Index: integer): byte;
begin
  Result := 1 shl (Index and 7);
end;

function TBitSet.GetBit(Index: integer): boolean;
begin
  if (Index > FLastBit) or (FBits = nil) then
    Result := False
  else
  begin
    var ByteIndex := BitToByteIndex(Index);
    Result := (ByteIndex <= High(FBits)) and (FBits[ByteIndex] and BitToByteMask(Index) <> 0);
  end;
end;

function TBitSet.NextBit(Index: integer): integer;
begin
  if (FBits = nil) then
    Exit(-1);

  Result := Index + 1;

  var BitMask: Byte := BitToByteMask(Result);
  var ByteIndex := BitToByteIndex(Result);

  while (Result <= FLastBit) do
  begin

    var Byte := FBits[ByteIndex];

    if (Byte <> 0) then
    begin
      while (BitMask <> 0) and (Result <= FLastBit) do
      begin
        if (Byte and BitMask <> 0) then
          exit;
        BitMask := BitMask shl 1;
        Inc(Result);
      end;
    end else
      // Skip to first bit of next byte
      Result := (ByteIndex + 1) * 8;

    Inc(ByteIndex);
    BitMask := 1;
  end;

  Result := -1;
end;

procedure TBitSet.SetBit(Index: integer; const Value: boolean);
begin
  var ByteIndex: integer;
  if (Index > FLastBit) or (FBits = nil) then
  begin
    if (not Value) then
      exit;
    FLastBit := Index;
    ByteIndex := BitToByteIndex(Index);

    if (ByteIndex > High(FBits)) then
    begin
      var FirstNew := Length(FBits);
      var Size := (ByteIndex + 1) * 2; // Double size to lessen reallocation

      SetLength(FBits, Size);

      while (FirstNew < Size) do
      begin
        FBits[FirstNew] := 0;
        Inc(FirstNew);
      end;
    end;
  end else
    ByteIndex := BitToByteIndex(Index);

  if (Value) then
    FBits[ByteIndex] := FBits[ByteIndex] or BitToByteMask(Index)
  else
    FBits[ByteIndex] := FBits[ByteIndex] and (not BitToByteMask(Index));
end;


//------------------------------------------------------------------------------
//
//      TCustomPascalTypeOpenTypeProcessor
//
//------------------------------------------------------------------------------
constructor TCustomPascalTypeOpenTypeProcessor.Create(AFont: TCustomPascalTypeFontFace; AScript: TTableType; ALanguage: TTableType; ADirection: TPascalTypeDirection);
begin
  inherited Create;
  FFont := AFont;
  FScript := AScript;
  FLanguage := ALanguage;
  FDirection := ADirection;
end;

class destructor TCustomPascalTypeOpenTypeProcessor.Destroy;
begin
  FOrderedLookupsComparer := nil;
end;

function TCustomPascalTypeOpenTypeProcessor.ExecutePlan(APlan: TPascalTypeShapingPlan; var AGlyphs: TPascalTypeGlyphString): TPascalTypeFeatures;
begin
  Result := [];

  LoadFeatureList;

  FHandledLookups := Default(TBitSet);

  for var Stage in APlan do
  begin
    if (Assigned(Stage.Delegate)) then
      Stage.Delegate(Self, AGlyphs);

    if (Stage.Count > 0) then
      Result := Result + DoApplyFeatures(Stage.Features, AGlyphs);
  end;
end;

function TCustomPascalTypeOpenTypeProcessor.ApplyFeatures(const AFeatures: TPascalTypeFeatures; var AGlyphs: TPascalTypeGlyphString): TPascalTypeFeatures;
begin
  FHandledLookups := Default(TBitSet);
  Result := DoApplyFeatures(AFeatures, AGlyphs);
end;

function TCustomPascalTypeOpenTypeProcessor.DoApplyFeatures(const AFeatures: TPascalTypeFeatures; var AGlyphs: TPascalTypeGlyphString): TPascalTypeFeatures;
begin
  if (Table = nil) then
    Exit(nil);

  var LookupItems := GetLookupsByFeatures(AFeatures);

  Result := ApplyLookups(LookupItems, AGlyphs);
end;

function TCustomPascalTypeOpenTypeProcessor.ApplyLookups(const ALookups: TLookupItems; var AGlyphs: TPascalTypeGlyphString): TPascalTypeFeatures;
begin
  (*
    https://learn.microsoft.com/en-us/typography/opentype/spec/chapter2#features-and-lookups

    Features and lookups

    When designing a font, the font developer selects features according to the typographic
    capabilities the font will support. For each feature, they then implement one or more
    lookups that describe the glyph substitution or glyph positioning actions to be
    performed. Multiple lookups may be used for a given feature; in that case the lookup
    actions will be performed in sequential order. In some cases, multiple lookups applied
    in a specific order could be needed to obtain a desired effect.

    When performing layout on a run of text, a client chooses the features to be applied to
    the run and then processes the lookups referenced by these features in the order the
    lookup definitions occur in the LookupList. As a result, within the GSUB or GPOS table,
    lookups from several different features may be interleaved during text processing. It
    is up to the font developer to determine the proper order of actions performed by the
    lookups.

    A client may process GSUB features in ordered stages, with particular features
    processed in each stage. A client may also perform certain operations on glyph
    sequences, such as reordering of glyphs, before or between these stages. Such
    processing is required for correct support of many scripts. Details on such script-
    specific processing is outside the scope of this specification. Within any such
    feature-processing stage, however, lookups referenced by the features applied in that
    stage must be processed in LookupList order.
  *)

  // The Microsoft documentation above is very poorly phrased, but as I read it
  // we logically need to:
  //   1) Iterate through all features and...
  //   2) For each feature...
  //   3) Iterate through the lookups of the feature and...
  //   4) For each lookup, save them in a list.
  //   5) Once all lookups have been collected, sort the list by lookup index.
  //   6) Apply the lookups in order.
  // Note that the items in the list must be unique in order to ensure that a lookup
  // is executed only once.

  Result := nil;

  if (Length(ALookups) = 0) then
    exit;

  var GlyphIterator := AGlyphs.CreateIterator;

  GlyphIterator.IgnoreDefaultIgnorables := FIgnoreDefaultIgnorables;

  // A lookup is finished for a glyph after the client has performed the
  // substitution or positioning operation. To move to the "next" glyph, the client
  // skips all the glyphs that participated in the lookup operation: glyphs that
  // were substituted as well as any other glyphs that formed a context for the
  // operation.

  // Start by counting the lookups so we can size the array that will hold them
  var Count := 0;
  for var i := 0 to High(ALookups) do
    Inc(Count, ALookups[i].FeatureTable.LookupListCount);
  var OrderedLookups: TArray<TLookupOrderedItem>;
  Setlength(OrderedLookups, Count);

  // Populate array
  // Note that the array will contain duplicate lookup list indices, but we
  // need all the items in order to maintain the feature->lookup association.
  var n := 0;
  for var i := 0 to High(ALookups) do
  begin
    for var j := 0 to ALookups[i].FeatureTable.LookupListCount-1 do
    begin
      OrderedLookups[n].LookupItem := @ALookups[i];

      var Index := ALookups[i].FeatureTable.LookupList[j];
      OrderedLookups[n].Index := Index;

      Inc(n);
    end;
  end;

  // Sort by lookup index
  if (FOrderedLookupsComparer = nil) then
    FOrderedLookupsComparer := TComparer<TLookupOrderedItem>.Construct(
      function(const A, B: TLookupOrderedItem): integer
      begin
        Result := (A.Index - B.Index);
      end);
  TArray.Sort<TLookupOrderedItem>(OrderedLookups, FOrderedLookupsComparer);

  (*
  ** For each lookup...
  *)
  for var Lookup in OrderedLookups do
  begin

    // Skip the lookup if we already handled it - but record the associated
    // feature as handled.
    if (FHandledLookups[Lookup.Index]) then
    begin
      Result.Add(Lookup.LookupItem.FeatureTag);
      continue;
    end;


    // Create a list of features that applies this lookup.
    //
    // If a lookup is shared by Feature A and Feature B, and Feature A is applied to
    // glyphs 0-10 while Feature B is applied to 11-20, we need to apply the lookup to
    // glyphs 0-20 even though all the glyphs don't share the same features.
    //
    // If we didn't do this then the logic would execute the lookup once for Feature A
    // (processing glyphs 0-10) and then skip it for Feature B because it had already
    // been marked as handled. Consequently, glyphs 11-20 would never get processed by
    // the lookup.
    var LookupFeatures: TPascalTypeFeatures;
    for var LookupFeature in OrderedLookups do
      if (LookupFeature.Index = Lookup.Index) then
        LookupFeatures.Add(LookupFeature.LookupItem.FeatureTag);


    // Get the lookup table and setup the iterator filters based on its flags
    var LookupTable := Table.LookupListTable.LookupTables[Lookup.Index];

    if (LookupTable.LookupFlags and TCustomOpenTypeLookupTable.USE_MARK_FILTERING_SET <> 0) then
      GlyphIterator.Reset(LookupTable.LookupFlags, LookupTable.MarkFilteringSet)
    else
      GlyphIterator.Reset(LookupTable.LookupFlags);

    // This is a bit of a hack; The Reverse Chained Context Coverage substitution
    // lookup needs to process glyphs in reverse order, from the end to the start.
    var ReverseDirection := LookupTable.UseReverseDirection;

    if (ReverseDirection) then
      GlyphIterator.Index := AGlyphs.Count-1;


    (*
    ** For each glyph...
    *)
    while (not GlyphIterator.EOF) do
    begin

      var Handled := False;

      var StartIndex := GlyphIterator.Index;
      var StartCount := GlyphIterator.GlyphString.Count;

      (*
      ** Apply the lookup to the glyph
      *)
      // If the glyph is tagged with /any/ of the features that apply the current lookup...
      if (GlyphIterator.Glyph.PlanFeatures.Intersects(LookupFeatures)) then
        // For each lookup sub-table, apply the lookup until one of them succeeds
        Handled := ApplyLookup(GlyphIterator, LookupTable);


      // Flag that we handled this particular lookup, so we don't do it again.
      // Also record that the feature was handled.
      if (Handled) then
      begin
        FHandledLookups[Lookup.Index] := True;
        Result.Add(Lookup.LookupItem.FeatureTag);

{$ifdef DEBUG}
        OutputDebugString(PChar(Format('%d: Applied feature %s (%s), lookup %d: %s',
          [GlyphIterator.Index, string(Lookup.LookupItem.FeatureTag), Lookup.LookupItem.FeatureTable.DisplayName, Lookup.Index, LookupTable.ClassName])));
{$endif DEBUG}
      end;


      (*

      HarfBuzz-style glyph loop

      - Main Glyph Loop:
        In hb_ot_layout_lookup_apply, HarfBuzz iterates through every glyph
        index in the buffer one by one. It does NOT use a skipping iterator
        for this outer loop; Every glyph, including default ignorables like
        ZWJ, is given a chance to be the "trigger" (the first glyph) for a
        lookup.

      - Skipping Iterator:
        HarfBuzz uses a skipping_iterator_t only within a lookup (e.g., when
        a ligature or contextual lookup needs to match subsequent glyphs).

      - Nuanced Skipping (SKIP_MAYBE):
        The matcher in HarfBuzz returns SKIP_MAYBE for default ignorables
        (like ZWJ/ZWNJ). Crucially, in skipping_iterator_t::match, a glyph
        that is SKIP_MAYBE is not skipped if it matches the required glyph
        for the current position in the lookup. It is only skipped if it
        doesn't match and the iterator is looking for the next component.

      - Preservation:
        HarfBuzz preserves default ignorables throughout the shaping
        process. They are only "hidden" (usually replaced by the space
        glyph with zero advance) in a late stage, and only if they haven't
        been substituted (see: LayoutEngine.PostProcessPositioning and
        TPascalTypeGlyphString.HideDefaultIgnorables).

      *)

      if (not GlyphIterator.EOF) then
      begin
        // Advance if:
        // - None of the lookups succeeded
        // - Lookup succeeded but didn't advance the iterator (enough)

        if (not ReverseDirection) then
        begin
          // Adjust saved current start position for glyphs inserted or removed.
          // The scenario we're trying to handle here is primarily:
          // - The lookup "forgot" to advance (that's a bug in the software).
          // - The lookup inserted more than it advanced (e.g. expanded a
          //   liguture).
          // If we do not handle it then we can loop here forever until we run
          // out of memory.
          // Note that we cannot detect the situation where the lookup deleted
          // glyphs but didn't advance.
          var Delta := GlyphIterator.GlyphString.Count - StartCount;
          Inc(StartIndex, Delta);

          // If we haven't already skipped past the current position...
          if (GlyphIterator.Index <= StartIndex) then
          begin
            // ...Move to the expected current position...
            GlyphIterator.Index := StartIndex;
            // ...and advance to next glyph
            // Note: We do NOT skip ignorables here because we want to try
            // every single glyph as the starting position for a lookup.
            GlyphIterator.Next(1, False);
          end;

        end else
        begin
          // The Reverse Chained Context Coverage substitution lookup /moves/ backward
          // but it still perform substitution (a single glyph) forward. Therefore we
          // don't need to worry about insertions or deletions here.

          // Same as above - just in the other direction:
          // If we haven't already skipped past the current position...
          if (GlyphIterator.Index >= StartIndex) then
          begin
            // ...Move to the expected current position...
            GlyphIterator.Index := StartIndex;
            // ...and "advance" to next glyph
            // Note: We do NOT skip ignorables here because we want to try
            // every single glyph as the starting position for a lookup.
            GlyphIterator.Previous(1, False);
          end;

        end;
      end;
    end;
  end;
end;

function TCustomPascalTypeOpenTypeProcessor.ApplyLookup(var AGlyphIterator: TPascalTypeGlyphIterator; ALookupTable: TCustomOpenTypeLookupTable): boolean;
begin
  Result := ALookupTable.Apply(AGlyphIterator);
end;

function TCustomPascalTypeOpenTypeProcessor.GetSubstitutedFeatureTable(FeatureIndex: Word): TCustomOpenTypeFeatureTable;
begin
  Result := Table.FeatureListTable.Feature[FeatureIndex];

  if (Table.FeatureVariationsTable = nil) then
    Exit;

  var VariationEngine := Font.VariationEngine;
  if (VariationEngine = nil) or (not VariationEngine.Active) then
    Exit;

  var SubstitutionTable := Table.FeatureVariationsTable.GetSubstitution(VariationEngine.NormalizedCoordinates);
  if (SubstitutionTable = nil) then
    Exit;

  var SubstitutedTable := SubstitutionTable.FindSubstitution(FeatureIndex);
  if (SubstitutedTable <> nil) then
    Result := SubstitutedTable;
end;

function TCustomPascalTypeOpenTypeProcessor.GetAvailableFeatures: TPascalTypeFeatures;
var
  FeatureIndex: Word;
  FeatureTable: TCustomOpenTypeFeatureTable;
begin
  for FeatureIndex in FeatureList do
  begin
    FeatureTable := GetSubstitutedFeatureTable(FeatureIndex);
    Result.Add(FeatureTable.TableType);
  end;
end;

function TCustomPascalTypeOpenTypeProcessor.GetLookupsByFeatures(const AFeatures: TPascalTypeFeatures): TLookupItems;
var
  Count: integer;
  FeatureIndex: Word;
  FeatureTable: TCustomOpenTypeFeatureTable;
  Tag: TTableName;
begin
  SetLength(Result, Length(FeatureList));
  Count := 0;

  for FeatureIndex in FeatureList do
  begin
    FeatureTable := GetSubstitutedFeatureTable(FeatureIndex);
    Tag := FeatureTable.TableType.AsAnsiChar;

    // Intersect the requested features with the ones that are available in the font
    if (AFeatures.Contains(Tag)) then
    begin
      Result[Count].FeatureTag := Tag;
      Result[Count].FeatureTable := FeatureTable;
      Inc(Count);
    end;
  end;

  SetLength(Result, Count);
end;

procedure TCustomPascalTypeOpenTypeProcessor.LoadFeatureList;
var
  ScriptTable: TCustomOpenTypeScriptTable;
  LanguageSystem: TCustomOpenTypeLanguageSystemTable;
  i: integer;
begin
  FFeatureList := nil;

  // Get script, fallback to default
  ScriptTable := Table.ScriptListTable.FindScript(Script, True);

  if (ScriptTable = nil) then
    Exit;

  // Get language system, fallback to default
  LanguageSystem := ScriptTable.FindLanguageSystem(Language, True);

  if (LanguageSystem = nil) then
    Exit;

  // Create an ordered list of features to be applied
  SetLength(FFeatureList, LanguageSystem.FeatureIndexCount);
  for i := 0 to LanguageSystem.FeatureIndexCount-1 do
    FFeatureList[i] := LanguageSystem.FeatureIndex[i];
end;

end.