source: branches/Analyzátor gramatiky/UGrammer.pas

unit UGrammer;

{$MODE Delphi}

interface

uses
  Classes, ComCtrls, SysUtils, fgl, UParser;

type
  TGrammerRule = class;

  TPathItem = class
  public
    Rule: TGrammerRule;
    ItemIndex: Integer;
    Affected: Boolean;
    CharIndex: Integer;
    procedure Assign(Source: TPathItem);
  end;

  TPathItemList = specialize TFPGObjectList<TPathItem>;

  TGrammerPath = class
    Items: TPathItemList;
    procedure Assign(Source: TGrammerPath);
    procedure Next;
    constructor Create;
    destructor Destroy; override;
  end;

  TPossibleCharacter = class
    Character: Char;
    RulePath: TGrammerPath;
    procedure Assign(Source: TPossibleCharacter);
    constructor Create;
    destructor Destroy; override;
  end;

  TPossibleCharacterList = specialize TFPGObjectList<TPossibleCharacter>;

  TPossibleCharacters = class
    Items: TPossibleCharacterList;
    procedure Assign(Source: TPossibleCharacters);
    constructor Create;
    destructor Destroy; override;
  end;

  TRuleType = (rtSequence, rtAlternative);
  TRuleItemType = (itTerminal, itNonterminal);

  TGrammerItem = class
  private
    Processed: Boolean;
    Parent: TGrammerRule;
  public
    ItemType: TRuleItemType;
    Text: string;
    Rule: TGrammerRule;
    RuleName: string;
    Optional: Boolean;
    Repetition: Boolean;
//    procedure GetPossibleCharacters(Path: TGrammerPath; var Characters: TPossibleCharacters);
    constructor Create;
  end;

  TGrammerItemList = specialize TFPGObjectList<TGrammerItem>;

  { TGrammerRule }

  TGrammerRule = class
  private
  public
    Token: Boolean;
    Parent: TGrammerRule;
    Name: string;
    RuleType: TRuleType;
    Items: TGrammerItemList;
    procedure ClearProcessed;
    function Add: TGrammerItem;
    procedure AddTerminal(AText: string; AOptional, ARepetition: Boolean);
    procedure AddTerminalText(Text: string);
    procedure AddRule(ARule: TGrammerRule; AOptional, ARepetition: Boolean);
    procedure ProcessCharacter(Character: Char);
//    procedure GetPossibleCharacters(Path: TGrammerPath;
//      var Characters: TPossibleCharacters; UseIndex: Integer = 0; UseCharIndex: Integer = -1);
    function Check(Path: TGrammerPath; Token: string;
      UseIndex: Integer = 0; UseCharIndex: Integer = -1): Boolean;
    constructor Create;
    destructor Destroy; override;
  end;

  TGrammerRuleList = specialize TFPGObjectList<TGrammerRule>;

  TGrammer = class
  public
    Rules: TGrammerRuleList;
    TopRule: TGrammerRule;
    constructor Create;
    procedure ClearProcessed;
    procedure CorrectRuleLinks;
    destructor Destroy; override;
  end;


implementation

{ TGrammerRule }

function TGrammerRule.Add: TGrammerItem;
begin
  Result := TGrammerItem.Create;
  Items.Add(Result);
  Result.Parent := Self;
end;

procedure TGrammerRule.AddRule(ARule: TGrammerRule; AOptional,
  ARepetition: Boolean);
begin
  with Add do begin
    ItemType := itNonterminal;
    Rule := ARule;
    Optional := AOptional;
    Repetition := ARepetition;
    Parent := Self;
  end;
end;

procedure TGrammerRule.AddTerminal(AText: string; AOptional, ARepetition: Boolean);
begin
  with Add do begin
    ItemType := itTerminal;
    Text := AText;
    Optional := AOptional;
    Repetition := ARepetition;
    Parent := Self;
  end;
end;

procedure TGrammerRule.AddTerminalText(Text: string);
var
  I: Integer;
begin
  for I := 1 to Length(Text) do
    AddTerminal(Text[I], False, False);
end;

procedure TGrammerRule.ClearProcessed;
var
  I: Integer;
begin
  for I := 0 to Items.Count - 1 do
    Items[I].Processed := False;
end;

constructor TGrammerRule.Create;
begin
  Parent := nil;
  Items := TGrammerItemList.Create;
end;

destructor TGrammerRule.Destroy;
begin
  Items.Destroy;
  inherited;
end;

(*
procedure TGrammerRule.GetPossibleCharacters(Path: TGrammerPath;
  var Characters: TPossibleCharacters; UseIndex: Integer = 0; UseCharIndex: Integer = -1);
var
  I: Integer;
  NextItemIndex, NextCharIndex: Integer;
  NextRule: TGrammerRule;
  TempPath: TGrammerPath;
begin
  TempPath := TGrammerPath.Create;
  with Path.Items[Path.Items.Add(TPathItem.Create)] do begin
    Rule := Self;
    ItemIndex := UseIndex;
    CharIndex := UseCharIndex;
    Affected := True;
  end;

  case RuleType of
    rtAlternative: begin
      if UseIndex > 0 then begin
        // Forward generation to upper item
        Path.Items.Delete(Path.Items.Count - 1);
        with Path.Items[Path.Items.Count - 1] do begin
          NextItemIndex := ItemIndex;
          NextCharIndex := CharIndex;
          NextRule := Rule;
        end;
        Path.Items.Delete(Path.Items.Count - 1);
        NextRule.GetPossibleCharacters(Path, Characters, NextItemIndex + 1, NextCharIndex);
      end else begin
        // Generate alternatives
        for I := 0 to Items.Count - 1 do begin
          Path.Items[Path.Items.Count - 1].ItemIndex := I;
          //Inc(Path.Items[High(Path.Items)].CharIndex);
          Items[I].GetPossibleCharacters(Path, Characters);
        end;
      end;
    end;
    rtSequence: begin
      TempPath.Assign(Path);
      if UseIndex >= Items.Count then begin
        // Forward generation to upper item
        Path.Items.Delete(Path.Items.Count - 1);
        with Path.Items[Path.Items.Count - 1] do begin
          NextItemIndex := ItemIndex;
          NextCharIndex := CharIndex;
          NextRule := Rule;
        end;
        Path.Items.Delete(Path.Items.Count - 1);
        NextRule.GetPossibleCharacters(Path, Characters, NextItemIndex + 1, NextCharIndex);
      end else begin
        Path.Items[Path.Items.Count - 1].ItemIndex := UseIndex;
        Items[UseIndex].GetPossibleCharacters(Path, Characters);
      end;
      // Check repetition
      if (UseIndex > 0) and not Items[UseIndex - 1].Processed then
        if Items[UseIndex - 1].Repetition then begin
          TempPath.Items[TempPath.Items.Count - 1].ItemIndex := UseIndex - 1;
          Items[UseIndex - 1].GetPossibleCharacters(TempPath, Characters);
        end;
    end;
  end;
  TempPath.Destroy;
end;
*)

procedure TGrammerRule.ProcessCharacter(Character: Char);
begin
end;

function TGrammerRule.Check(Path: TGrammerPath; Token: string;
  UseIndex: Integer; UseCharIndex: Integer): Boolean;
begin

end;

{ TGrammer }

procedure TGrammer.ClearProcessed;
var
  I: Integer;
begin
  for I := 0 to Rules.Count - 1 do
    Rules[I].ClearProcessed;
end;

procedure TGrammer.CorrectRuleLinks;
var
  I: Integer;
  II: Integer;
  J: Integer;
begin
  for I := 0 to Rules.Count - 1 do with Rules[I] do begin
    for II := 0 to Items.Count - 1 do with Items[II] do begin
      if (ItemType = itNonterminal) and (not Assigned(Rule)) then begin
        J := 0;
        while (J < Rules.Count) and (Rules[J].Name <> RuleName) do Inc(J);
        if J < Rules.Count then Rule := Rules[J] else
          raise Exception.Create('Rule link correction failed on rule ' +
            IntToStr(I) + ' item ' + IntToStr(II));
      end;
    end;
  end;
end;

constructor TGrammer.Create;
begin
  Rules := TGrammerRuleList.Create;
end;

destructor TGrammer.Destroy;
begin
  Rules.Destroy;
  inherited;
end;

{ TGrammerItem }

constructor TGrammerItem.Create;
begin
  Rule := nil;
end;

(*
procedure TGrammerItem.GetPossibleCharacters(Path: TGrammerPath;
  var Characters: TPossibleCharacters);
var
  Found: Boolean;
  NextItemIndex, NextCharIndex: Integer;
  NextRule: TGrammerRule;
begin
  Processed := True;
  case ItemType of
    itTerminal: begin
      Characters.Items.Add(TPossibleCharacter.Create);
      Characters.Items[Characters.Items.Count - 1].Character := Character;
      Characters.Items[Characters.Items.Count - 1].RulePath.Assign(Path);
      with Characters.Items[Characters.Items.Count - 1].RulePath do begin
        Inc(Items[Items.Count - 1].ItemIndex);
      end;
    end;
    itNonterminal: begin
      Rule.GetPossibleCharacters(Path, Characters);
    end;
  end;
  if Optional then begin
        // Forward generation to upper item
        //SetLength(Path.Items, Length(Path.Items) - 1);
        with Path.Items[Path.Items.Count - 1] do begin
          NextItemIndex := ItemIndex;
          NextCharIndex := CharIndex;
          NextRule := Rule;
        end;
        Path.Items.Delete(Path.Items.Count - 1);
        NextRule.GetPossibleCharacters(Path, Characters, NextItemIndex + 1, NextCharIndex);
  end;
end;
*)

{ TGrammerPath }

procedure TGrammerPath.Assign(Source: TGrammerPath);
var
  I: Integer;
begin
  for I := 0 to Items.Count - 1 do
    Items[I].Destroy;
  Items.Count := Source.Items.Count;
  for I := 0 to Items.Count - 1 do begin
    Items[I] := TPathItem.Create;
    Items[I].Assign(Source.Items[I]);
  end;
end;

procedure TGrammerPath.Next;
var
  Index: Integer;
  Success: Boolean;
begin
  Success := False;
  Index := Items.Count - 1;
  while not Success and (Index >= 0) do begin
    with Items[Index] do if Rule.Items[ItemIndex].Repetition then begin
      Success := True;
      //Inc(CharIndex);
    end else begin
      if ((ItemIndex + 1) < Rule.Items.Count) and (Rule.RuleType = rtSequence) then begin
        Inc(ItemIndex);
        //Inc(CharIndex);
        Success := True;
      end else Dec(Index);
    end;
  end;
  Items.Count := Index + 1;
end;

constructor TGrammerPath.Create;
begin
  Items := TPathItemList.Create;
end;

destructor TGrammerPath.Destroy;
begin
  Items.Destroy;
  inherited Destroy;
end;

{ TPathItem }

procedure TPathItem.Assign(Source: TPathItem);
begin
  Rule := Source.Rule;
  ItemIndex := Source.ItemIndex;
  CharIndex := Source.CharIndex;
  Affected := Source.Affected;
end;

{ TPossibleCharacter }

procedure TPossibleCharacter.Assign(Source: TPossibleCharacter);
begin
  Character := Source.Character;
  RulePath.Assign(Source.RulePath);
end;

constructor TPossibleCharacter.Create;
begin
  RulePath := TGrammerPath.Create;
end;

destructor TPossibleCharacter.Destroy;
begin
  RulePath.Destroy;
  inherited Destroy;
end;

{ TPossibleCharacters }

procedure TPossibleCharacters.Assign(Source: TPossibleCharacters);
var
  I: Integer;
begin
  Items.Count := Source.Items.Count;
  for I := 0 to Items.Count - 1 do
    Items[I].Assign(Source.Items[I]);
end;

constructor TPossibleCharacters.Create;
begin
  Items := TPossibleCharacterList.Create;
end;

destructor TPossibleCharacters.Destroy;
begin
  Items.Destroy;
  inherited Destroy;
end;

end.