Uses SysUtils, Classes, FGL;

Type EParserError = Class(Exception);
     EXMLDocumentError = Class(Exception);

// -- tokenizer --
Const TokenNewline = #0;

      IdentifierValid = ['a'..'z', 'A'..'Z', '_', '0'..'9']; // znaki, które mogą występować *wewnątrz* identyfikatora
      NumberValid = ['0'..'9']; // znaki, które mogą występować wewnątrz liczby

Type TTokenKind = (tkBracketOpen, tkBracketClose, tkSlash, tkSpace, tkIdentifier, tkString, tkNumber, tkChar); // typ tokenów
Type PToken = ^TToken; // wskaźnik na token
     TToken = Record // pojedynczy token
               Kind      : TTokenKind;
               Line, Char: Integer;
               Value     : String;
              End;

Type TTokenList = specialize TFPGList<PToken>; // lista tokenów

Const TokenDisplay: Array[TTokenKind] of String = ('<', '>', '/', ' ', '[identifier]', '[string]', '[number]', '[char]'); // reprezentacja string-owa tokenów

Type TScanner = Class // klasa skanera
                 Private
                 Public
                  TokenList: TTokenList;

                  Constructor Create;
                  Procedure Parse(const Lines: TStringList);
                 End;

(* TScanner.Create *)
Constructor TScanner.Create;
Begin
 TokenList := nil;
End;

(* TScanner.Parse *)
Procedure TScanner.Parse(const Lines: TStringList);
Var I : Integer;
    Ch: Char;

    Text    : String;
    Position: Integer;

    Line, Char: Integer;

    { AddToken }
    // dodaje token do listy
    Procedure AddToken(const Kind: TTokenKind; const Value: String);
    Var Pnt: PToken;
    Begin
     New(Pnt);
     Pnt^.Kind  := Kind;
     Pnt^.Char  := Char;
     Pnt^.Line  := Line;
     Pnt^.Value := Value;
     TokenList.Add(Pnt);
    End;

    { read_identifier }
    // czyta identyfikator
    Function read_identifier: String;
    Begin
     Result := Ch;

     While (Text[Position] in IdentifierValid) Do
     Begin
      Result += Text[Position];
      Inc(Position);
     End;
    End;

    { read_number }
    // czyta liczbę
    Function read_number: String;
    Begin
     Result := Ch;

     While (Text[Position] in NumberValid) Do
     Begin
      Result += Text[Position];
      Inc(Position);
     End;
    End;

Begin
 Text     := '';
 Position := 1;

 Line := 1;
 Char := 0;

 if (TokenList <> nil) Then
  TokenList.Free;
 TokenList := TTokenList.Create;

 For I := 0 To Lines.Count-1 Do // przerabiamy TStringList na String, dodając co każdą linię znak `TokenNewline` (jest to ZNACZNIE wydajniejsze od operaowania na `TStringList.Lines` czy `TStringList.Text`)
  Text += Lines[I]+TokenNewline;

 While (Position < Length(Text)) Do // parsujemy tekst
 Begin
  Inc(Char);
  Ch := Text[Position]; // czytamy znak
  Inc(Position);

  Case Ch of
   '<': AddToken(tkBracketOpen, Ch);
   '>': AddToken(tkBracketClose, Ch);
   '/': AddToken(tkSlash, Ch);
   ' ': AddToken(tkSpace, Ch);
   'a'..'z', 'A'..'Z', '_': AddToken(tkIdentifier, read_identifier);
   '0'..'9': AddToken(tkNumber, read_number);

   // '"': AddToken(tkString, read_string);
   TokenNewline:
   Begin
    Inc(Line);
    Char := 0;
   End;

   else
    AddToken(tkChar, Ch); // wszelkie znaki spoza "zakresu ubsługi" dodajemy jako tokeny `tkChar`
  End;
 End;
End;

// -- XML --
Type TXMLElement = Class;
Type TXMLElementList = specialize TFPGList<TXMLElement>;

Type TXMLElement = Class
                    Private
                    Public
                     Name, Value: String; // nazwa, stringowa wartość
                     // Attributes: Array of Record Name, Value: String; Typ: (tString, tNumber); End;

                     Parent: TXMLElement;
                     Children: TXMLElementList;

                     Function FindChild(const cName: String): TXMLElement;
                    End;

Type TXMLDocument = Class
                     Private
                     Public
                      Root: TXMLElement; // węzeł główny

                      Constructor Create;
                      Procedure Parse(const Lines: TStringList);
                      Function FindElement(const Name: String): TXMLElement;
                     End;

(* TXMLElement.FindChild *)
Function TXMLElement.FindChild(const cName: String): TXMLElement;
Begin
 For Result in Children Do
  if (Result.Name = cName) Then
   Exit(Result);

 Exit(nil);
End;

(* TXMLDocument.Create *)
Constructor TXMLDocument.Create;
Begin
 Root := nil;
End;

(* TXMLDocument.Parse *)
Procedure TXMLDocument.Parse(const Lines: TStringList);
Var Scanner : TScanner;
    TokenPos: Integer = 0;

  { getLine }
  // zwraca aktualny numer linii
  Function getLine: Integer;
  Begin
   Exit(Scanner.TokenList[TokenPos]^.Line);
  End;

  { getChar }
  // zwraca aktualny numer znaku
  Function getChar: Integer;
  Begin
   Exit(Scanner.TokenList[TokenPos]^.Char);
  End;

  { read }
  // czyta jeden token i zwraca go
  Function read: TToken;
  Begin
   With Scanner do
   Begin
    if (TokenPos >= TokenList.Count) Then
     raise EParserError.CreateFmt('Unexpected end of file at %d: %d', [getLine, getChar]);

    Result := TokenList[TokenPos]^;
    Inc(TokenPos);
   End;
  End;

  { next }
  // zwraca token znajdujący się zaraz po aktualnym
  // (czyli działa identycznie jak `read`, lecz nie przesuwa wskaźnika)
  Function next(const Add: Integer=0): TToken;
  Begin
   With Scanner do
   Begin
    if (TokenPos+Add >= TokenList.Count) Then
     raise EParserError.CreateFmt('Unexpected end of file at %d: %d', [getLine, getChar]);

    Result := TokenList[TokenPos+Add]^;
   End;
  End;

  { next_t }
  // działa podobnie jak `next`, lecz zwraca jedynie sam typ tokenu
  Function next_t(const Add: Integer=0): TTokenKind;
  Begin
   Exit(next(Add).Kind);
  End;

  { eat }
  // "zjada" token; tj.jeżeli następny token nie jest tym pożądanym, wyświetla błąd
  Procedure eat(const Token: TTokenKind);
  Begin
   if (next_t <> Token) Then
    raise EParserError.CreateFmt('Unexpected token `%s` expecting `%s` at %d: %d', [TokenDisplay[next_t], TokenDisplay[Token], getLine, getChar]);

   read;
  End;

  { read_ident }
  // czyta identyfikator
  Function read_ident: String;
  Begin
   if (next_t <> tkIdentifier) Then
    raise EParserError.CreateFmt('Unexpected token `%s` expecting identifier at %d: %d', [TokenDisplay[next_t], getLine, getChar]);

   Exit(read.Value);
  End;

  { read_until_bracket_open }
  // czyta, dopóki nie napotkany zostanie znak `<`
  Function read_until_bracket_open: String;
  Var Token: TToken;
  Begin
   Result := '';

   While (true) Do
   Begin
    Token := next;
    if (Token.Kind = tkBracketOpen) Then
     Exit;

    Result += Token.Value;
    read;
   End;
  End;

  { SkipSpaces }
  // pomija spacje
  Procedure SkipSpaces;
  Begin
   While (next_t = tkSpace) Do
    read;
  End;

  { ReadNode }
  // czyta cały węzeł
  Function ReadNode(const Parent: TXMLElement): TXMLElement;
  Var ClosingNodeName: String;
  Begin
   Result          := TXMLElement.Create;
   Result.Parent   := Parent;
   Result.Children := TXMLElementList.Create;

   With Scanner do
   Begin
    eat(tkBracketOpen); // `<`
    Result.Name := read_ident; // `[identifier]`
    eat(tkBracketClose); // `>`

    SkipSpaces; // pomijamy spacje

    if (next_t = tkBracketOpen) Then // jeżeli następny token to `<`...
    Begin
     Result.Value := '';

     While (next_t = tkBracketOpen) Do // ... dopóki następny token to `<`, czytamy "dzieci"-węzły
     Begin
      if (next_t(1) = tkSlash) Then // jeżeli napotkamy na `</`, przestajemy czytać węzły dzieci
       Break;

      Result.Children.Add(ReadNode(Result)); // parsujemy węzeł-dziecko oraz dodajemy go do listy
      SkipSpaces; // pomijamy spacje
     End;
    End Else
     Result.Value := read_until_bracket_open; // ... w innym wypadku czytamy zawartość węzła

    eat(tkBracketOpen); // `<`
    eat(tkSlash); // `/`
    ClosingNodeName := read_ident; // `[identifier]`
    if (AnsiCompareStr(Result.Name, ClosingNodeName) <> 0) Then // porównujemy (węzeł zamykający musi się zgadzać z otwierającym)
     raise EXMLDocumentError.CreateFmt('Unexpected node-closing; expecting `</%s>`, got `</%s>` at %d: %d', [Result.Name, ClosingNodeName, getLine, getChar]);

    eat(tkBracketClose); // `>`
   End;
  End;

Begin
 Scanner := TScanner.Create;

 Try
  Scanner.Parse(Lines);
  Root := ReadNode(nil);
 Finally
  Scanner.Free;
 End;
End;

(* TXMLDocument.FindElement *)
Function TXMLDocument.FindElement(const Name: String): TXMLElement;
Begin
 if (Root = nil) Then
  Exit(nil);

 if (Root.Name = Name) Then
  Exit(Root) Else
  Exit(Root.FindChild(Name));
End;

// -------------------------------------------------------------------------- //
Var Src: TStringList;
    Doc: TXMLDocument;
Begin
 Src := TStringList.Create;
 Doc := TXMLDocument.Create;

 Try
  Try
   Src.Add('<root>');
   Src.Add(' <child_1>child 1 value</child_1>');
   Src.Add(' <child_2>child 2 value</child_2>');
   Src.Add(' <child_3>');
   Src.Add('  <subchild_1>subchild 1 value</subchild_1>');
   Src.Add(' </child_3>');
   Src.Add('</root>');

   Doc.Parse(Src);
   Writeln(Doc.FindElement('child_2').Value);
   Writeln(Doc.FindElement('child_3').FindChild('subchild_1').Value);
  Except
   On E: Exception Do
    Writeln(E.Message);
  End;
 Finally
  Src.Free;
  Doc.Free;
  Writeln('-- done --');
  Readln;
 End;
End.