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”没有得到任何有用的结果。

当然，写这样一个函数是微不足道的，但是我想知道在现有的庞大的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： 似乎只有在项目的构建配置设置为 Debug 时才会发生 AV。当项目的构建配置设置为 Release 时，则没有 AV。这与 MemoryManager 有关系吗？

Answer 1

根据要求，我自己会这样做：

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

我可以让这个函数返回或填充一个 TList<TWordRec>，但是使用它会很烦人，因为函数的用户每次都需要添加 try..finally 块用来。相反，我让它返回一个 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，但使用单词记录而不是字符串！

现在，让我们使用这个函数：

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;

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

for var Match in List do

Answer 2

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

当然，OP 的要求是代码应该与 'WORD' 匹配在 'WORDS' 中排除了 Target 字符串之间的直接比较和 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.

从字符串中提取字符串令牌对象？

3 个答案: