从字符串中提取字符串标记对象？

Question

Delphi (10.4) 是否有一个字符串标记器，它以类似于下面的方式从字符串中提取字符串标记对象？

MyPhrase := 'I have a simple word and a complex Word: A lot of WORDS.';

MyTokens := MyTokenize(MyPhrase, 'word');

for i := 0 to MyTokens.Count - 1 do
  Memo1.Lines.Add(IntToStr(MyTokens[i].Pos) + ': ' + MyTokens[i].String);

在 Memo1 中给出这个结果：

16: word  
35: Word  
50: WORD

在 Delphi 文档中搜索“tokenize string”没有得到任何有用的结果。

当然，写这样一个function是小菜一碟，但不知现有庞大的Delphi代码宝中是否已经有这个程序。

编辑：我正在试验一个应该具有所需功能的单词表：

program MyTokenize;

{$APPTYPE CONSOLE}

{$R *.res}

uses
  CodeSiteLogging,
  System.RegularExpressions,
  System.Types,
  System.Classes,
  System.StrUtils,
  System.SysUtils;

type
  PWordRec = ^TWordRec;

  TWordRec = record
    WordStr: string;
    WordPos: Integer;
  end;

  TWordList = class(TList)
  private
    function Get(Index: Integer): PWordRec;
  public
    destructor Destroy; override;
    function Add(Value: PWordRec): Integer;
    property Items[Index: Integer]: PWordRec read Get; default;
  end;

function TWordList.Add(Value: PWordRec): Integer;
begin
  Result := inherited Add(Value);
end;

destructor TWordList.Destroy;
var
  i: Integer;
begin
  for i := 0 to Count - 1 do
    FreeMem(Items[i]);
  inherited;
end;

function TWordList.Get(Index: Integer): PWordRec;
begin
  Result := PWordRec(inherited Get(Index));
end;

var
  WordList: TWordList;
  WordRec: PWordRec;
  i: Integer;

begin
  try
    //MyPhrase := 'A crossword contains words but not WORD';

    WordList := TWordList.Create;
    try
      // AV only at the THIRD loop!!!
      for i := 0 to 2 do
      begin
        GetMem(WordRec, SizeOf(TWordRec));
        WordRec.WordPos := i;
        WordRec.WordStr := IntToStr(i);
        WordList.Add(WordRec);
      end;

      for i := 0 to WordList.Count - 1 do
        Writeln('WordPos: ', WordList[i].WordPos, ' WordStr: ', WordList[i].WordStr);

      WriteLn('  Press Enter to free the list');
      ReadLn;
    finally
      WordList.Free;
    end;

  except
    on E: Exception do
    begin
      Writeln(E.ClassName, ': ', E.Message);
      ReadLn;
    end;
  end;
end.

不幸的是，它有一个奇怪的错误：它恰好在第三个 for 循环中获得了一个 AV！

EDIT2：似乎只有当项目的 Build Configuration 设置为Debug时才会发生 AV。 当项目的 Build Configuration 设置为Release时，就没有 AV。 这与 MemoryManager 有关系吗？

Answer 1

根据要求，这是我自己的做法：

首先，我想创建一个执行此操作的 function，因此每次我们需要执行此操作时都可以重用它。

I could have this function return or populate a TList<TWordRec> , but then it would be tiresome to work with it, because the user of the function would then need to add try..finally blocks every time the function is used. 相反，我让它返回一个TArray<TWordRec> 。 根据定义，这只是array of TWordRec的数组，即TWordRec的动态数组。

但是如何有效地填充这样的数组呢？ 我们都知道你不应该一次增加一个动态数组的长度； 此外，这需要大量代码。 相反，我填充了一个本地TList<TWordRec> ，然后，作为最后一步，从中创建一个数组：

type
  TPhraseMatch = record
    Position: Integer;
    Text: string;
  end;

function GetPhraseMatches(const AText, APhrase: string): TArray<TPhraseMatch>;
begin

  var TextLower := AText.ToLower;
  var PhraseLower := APhrase.ToLower;

  var List := TList<TPhraseMatch>.Create;
  try

    var p := 0;
    repeat
      p := Pos(PhraseLower, TextLower, p + 1);
      if p <> 0 then
      begin
        var Match: TPhraseMatch;
        Match.Position := p - 1 {since the OP wants 0-based string indexing};
        Match.Text := Copy(AText, p, APhrase.Length);
        List.Add(Match);
      end;
    until p = 0;

    Result := List.ToArray;

  finally
    List.Free;
  end;

end;

请注意，出于教育原因，我选择了正则表达式方法的替代方法。 我也相信这种方法更快。 还要注意使用TList<TWordRec>是多么容易：它就像一个TStringList但使用单词记录而不是字符串！

现在，让我们使用这个 function：

procedure TWordFinderForm.ePhraseChange(Sender: TObject);
begin

  lbMatches.Items.BeginUpdate;
  try
    lbMatches.Items.Clear;
    for var Match in GetPhraseMatches(mText.Text, ePhrase.Text) do
      lbMatches.Items.Add(Match.Position.ToString + ':'#32 + Match.Text)
  finally
    lbMatches.Items.EndUpdate;
  end;

end;

如果我没有选择使用 function，而是将所有代码放在一个块中，我可以以完全相同的方式迭代TList<TWordRec> ：

for var Match in List do

Answer 2

主要是为了我自己的乐趣，我决定写一个答案，以与 Delphi 的编译器相同的方式标记输入。 这如下所示。

当然，OP 要求代码应与 'WORDS' 中的 'WORD' 匹配，这排除了目标字符串和 Parser.TokenString 之间的直接比较，并且需要按照所写的方式派生 Fragment。

顺便说一句，它表明不需要使用诸如 PWordRec 之类的构造以及手动分配和取消分配“令牌”。

    program StringTokens;

    {$APPTYPE CONSOLE}

    {$R *.res}

    uses
      System.SysUtils, System.Classes;

    var
      Parser : TParser;
      MyPhrase : String;
      Target : String;
      Fragment : String;
      SS : TStringStream;
      List : TStringList;
      i : Integer;
    begin

      MyPhrase := 'I have a simple word and a complex Word: A lot of WORDS. A partial wor';
      Target := 'word';
      SS := TStringStream.Create(MyPhrase);
      List := TStringlist.Create;
      Parser := TParser.Create(SS);

      try
        while Parser.Token <> #0 do begin
          Fragment := Copy(Parser.TokenString, 1, Length(Target));
          if SameText(Fragment, Target) then
            List.Add(Fragment);
          Parser.NextToken;
        end;

        for i := 0 to List.Count - 1 do
          writeln(i, List[i]);
        readln;
      finally
        List.Free;
        Parser.Free;
        SS.Free;
      end;
    end.

更新：

如果不明显，获取源字符串中令牌片段出现的位置是微不足道的，如下

    [...]
    if SameText(Fragment, Target) then
      List.AddObject(Fragment, TObject(Parser.SourcePos));

    [...]
    for i := 0 to List.Count - 1 do
      writeln(i, List[i], integer(List.Objects[i]));

Answer 3

这给出了问题中要求的结果：

编辑：我现在使用WordRec.WordPos:= MatchResult.Index;简化了代码

EDIT2：清理了uses列表

program MyTokenize;

{$APPTYPE CONSOLE}

{$R *.res}

uses
  System.RegularExpressions,
  System.Classes,
  System.SysUtils;

type
  PWordRec = ^TWordRec;

  TWordRec = record
    WordStr: string;
    WordPos: Integer;
  end;

  TWordList = class(TList)
  private
    function Get(Index: Integer): PWordRec;
  public
    destructor Destroy; override;
    function Add(Value: PWordRec): Integer;
    property Items[Index: Integer]: PWordRec read Get; default;
  end;

function TWordList.Add(Value: PWordRec): Integer;
begin
  Result := inherited Add(Value);
end;

destructor TWordList.Destroy;
var
  i: Integer;
begin
  for i := 0 to Count - 1 do
  begin
    System.Dispose(Items[i]);
  end;
  inherited;
end;

function TWordList.Get(Index: Integer): PWordRec;
begin
  Result := PWordRec(inherited Get(Index));
end;

var
  WordList: TWordList;
  WordRec: PWordRec;
  i: Integer;
  RegexObj: TRegEx;
  MatchResult: TMatch;
  MyPhrase, MyWord: string;

begin
  try
    MyPhrase := 'A crossword contains words but not WORD';
    MyWord := 'word';

    WordList := TWordList.Create;
    try
      RegexObj := TRegEx.Create(MyWord, [roIgnoreCase]);
      MatchResult := RegexObj.Match(MyPhrase);
      while MatchResult.Success do
      begin
        WordRec := System.New(PWordRec);
        WordRec.WordPos := MatchResult.Index;
        WordRec.WordStr := MatchResult.Value;
        WordList.Add(WordRec);
        MatchResult := MatchResult.NextMatch;
      end;

      // Output:
      for i := 0 to WordList.Count - 1 do
        Writeln('WordPos: ', WordList[i].WordPos, ' WordStr: ', WordList[i].WordStr);

      WriteLn('  Press Enter to free the list');
      ReadLn;
    finally
      WordList.Free;
    end;

  except
    on E: Exception do
    begin
      Writeln(E.ClassName, ': ', E.Message);
      ReadLn;
    end;
  end;
end.