Предметный указатель

////////////////////////////////////////////////
//   Algorithms and Data Structures; lab #2   //
//           made by nblknn, 351005           //
////////////////////////////////////////////////
Program Lab2;

{$APPTYPE CONSOLE}
{$R *.res}

Uses
    System.SysUtils;

Type
    PPage = ^TPage;

    TPage = Record
        Number: Integer;
        Next: PPage;
    End;

    PTerm = ^TTerm;

    TTerm = Record
        ParentTerm, Subterm: PTerm;
        Name: String;
        Page: PPage;
        Next: PTerm;
    End;

Var
    TermHead: PTerm = Nil;

Procedure InsertTerm(Var Term, TermHead: PTerm);
Var
    Temp1, Temp2: PTerm;
Begin
    If TermHead = Nil Then
    Begin
        TermHead := Term;
        Term.Next := Nil;
    End
    Else
    Begin
        Temp1 := TermHead;
        If (Term.Name > Temp1.Name) Then
        Begin
            While (Temp1.Next <> Nil) And (Temp1.Next.Name < Term.Name) Do
                Temp1 := Temp1.Next;
            Temp2 := Temp1.Next;
            Term.Next := Temp2;
            Temp1.Next := Term;
        End
        Else
        Begin
            Temp2 := TermHead;
            Term.Next := Temp2;
            TermHead := Term;
        End;
    End;
End;

Function CreateTerm(Name: String; ParentTerm: PTerm): PTerm;
Var
    NewTerm, Temp: PTerm;
Begin
    NewTerm := New(PTerm);
    NewTerm.Name := Name;
    NewTerm.ParentTerm := ParentTerm;
    NewTerm.Page := Nil;
    NewTerm.Subterm := Nil;
    If ParentTerm = Nil Then
        InsertTerm(NewTerm, TermHead)
    Else
        InsertTerm(NewTerm, ParentTerm.Subterm);
    Result := NewTerm;
End;

Procedure InsertPage(NewPage: PPage; Term: PTerm);
Var
    Temp, Temp2: PPage;
Begin
    Temp := Term.Page;
    If (NewPage.Number > Temp.Number) Then
    Begin
        While (Temp.Next <> Nil) And (Temp.Next.Number < NewPage.Number) Do
            Temp := Temp.Next;
        Temp2 := Temp.Next;
        NewPage.Next := Temp2;
        Temp.Next := NewPage;
    End
    Else
    Begin
        Temp2 := Term.Page;
        NewPage.Next := Temp2;
        Term.Page := NewPage;
    End;
End;

Procedure CreatePage(Number: Integer; Term: PTerm);
Var
    NewPage: PPage;
Begin
    NewPage := New(PPage);
    NewPage.Number := Number;
    NewPage.Next := Nil;
    If Term.Page = Nil Then
        Term.Page := NewPage
    Else
        InsertPage(NewPage, Term);
End;

Procedure EnterTerm(IsSubterm: Boolean; InsertLevel: Integer;
  ParentTerm: PTerm);
Var
    Name, PageStr: String;
    Number, TermHash: Integer;
    Term: PTerm;
Begin
    If Not IsSubterm Then
    Begin
        Write(#13#10'Введите название термина: ');
    End
    Else
        Write(#13#10'Введите название подтермина для "', ParentTerm.Name,
          '", или нажмите Enter для окончания ввода: ');
    Readln(Name);
    While Name <> '' Do
    Begin
        Term := CreateTerm(Name, ParentTerm);
        Repeat
            Write('Введите страницу, или нажмите Enter для окончания ввода: ');
            Readln(PageStr);
            If PageStr <> '' Then
            Begin
                Number := StrToInt(PageStr);
                CreatePage(Number, Term);
            End;
        Until PageStr = '';
        { If InsertLevel < 3 Then
          EnterTerm(True, InsertLevel + 1, Term);
          If Not IsSubterm Then
          Exit
          // Write('Введите название термина, или нажмите Enter для окончания ввода: ')
          Else
          Write(#13#10'Введите название подтермина для "', ParentTerm.Name,
          '", или нажмите Enter для окончания ввода: ');
          Readln(Name); }
        Exit;
    End;
End;

Procedure ShowList(Term: PTerm; InsertLevel: Integer; Offset: String);
Var
    TempPage: PPage;
    TempTerm: PTerm;
Begin
    TempTerm := Term;
    If (InsertLevel = 4) Or (Term = Nil) Then
        Exit
    Else
        While TempTerm <> Nil Do
        Begin
            Write(Offset, TempTerm.Name);
            TempPage := TempTerm.Page;
            While TempPage <> Nil Do
            Begin
                Write(', ', TempPage.Number);
                TempPage := TempPage.Next;
            End;
            Writeln;
            If TempTerm.Subterm <> Nil Then
                ShowList(TempTerm.Subterm, InsertLevel + 1, Offset + '   ');
            TempTerm := TempTerm.Next;
        End;
End;

Procedure ShowTerm(Term: PTerm; InsertLevel: Integer; Offset: String);
Var
    TempPage: PPage;
    TempTerm: PTerm;
Begin
    TempTerm := Term;
    If (InsertLevel = 4) Or (Term = Nil) Then
        Exit
    Else
        While TempTerm <> Nil Do
        Begin
            Write(Offset, TempTerm.Name);
            TempPage := TempTerm.Page;
            While TempPage <> Nil Do
            Begin
                Write(', ', TempPage.Number);
                TempPage := TempPage.Next;
            End;
            Writeln;
            If TempTerm.Subterm <> Nil Then
                ShowList(TempTerm.Subterm, InsertLevel + 1, Offset + '   ');
            TempTerm := TempTerm.Next;
            If InsertLevel = 1 Then
                Exit;
        End;
End;

Function GetTerm(Parent: PTerm): PTerm;
Var
    Name: String;
    Temp: PTerm;
    IsFound: Boolean;
Begin
    Write('Введите требующийся (под)термин: ');
    Readln(Name);
    IsFound := False;
    If Parent = Nil Then
        Temp := TermHead
    Else
        Temp := Parent.Subterm;
    While Not IsFound And (Temp <> Nil) Do
    Begin
        If (Name = Temp.Name) Then
            IsFound := True
        Else
            Temp := Temp.Next;
    End;
    If IsFound Then
        Result := Temp
    Else
    Begin
        Writeln('Такого (под)термина не было найдено...');
        Result := Nil;
    End;
End;

Procedure DeletePage(Page: PPage; Var Term: PTerm);
Var
    Temp, Temp2: PPage;
Begin
    Temp := Term.Page;
    If Temp.Number = Page.Number Then
        Temp := Nil
    Else If Temp.Next <> Nil Then
    Begin
        While (Temp.Next <> Nil) And (Temp.Next.Number <> Page.Number) Do
            Temp := Temp.Next;
        If Temp.Next = Nil Then
        Begin
            Temp := Nil;
        End
        Else
        Begin
            Temp.Next := Temp.Next.Next;
        End;
    End
    Else
    Begin
        Term.Page := Nil;
    End;
    Dispose(Page);
End;

Procedure DeleteTerm(Term: PTerm);
Var
    Temp, Temp2: PTerm;
Begin
    If Term.ParentTerm <> Nil Then
        Temp := Term.ParentTerm.Subterm
    Else
        Temp := TermHead;
    If Temp.Name = Term.Name Then
    Begin
        If Temp.Next <> Nil Then
        Begin
            If Term.ParentTerm <> Nil Then
                Term.ParentTerm.Subterm := Term.ParentTerm.Subterm.Next
            Else
                TermHead := TermHead.Next;
        End;
        Temp := Nil;
    End
    Else If Temp.Next <> Nil Then
    Begin
        While (Temp.Next <> Nil) And (Temp.Next.Name <> Term.Name) Do
            Temp := Temp.Next;
        If Temp.Next = Nil Then
        Begin
            Temp := Nil;
        End
        Else
        Begin
            Temp.Next := Temp.Next.Next;
        End;
    End
    Else
    Begin
        Temp := Nil;
    End;
    Dispose(Term);
End;

Function ChangeName(Term: PTerm): PTerm;
Var
    Name: String;
    Temp: PTerm;
Begin
    Write('Введите новое название: ');
    Readln(Name);
    Temp := CreateTerm(Name, Term.ParentTerm);
    Temp.Page := Term.Page;
    Temp.Subterm := Term.Subterm;
    DeleteTerm(Term);
    Result := Temp;
End;

Function GetPage(Term: PTerm): PPage;
Var
    Number: Integer;
    Temp: PPage;
    IsFound: Boolean;
Begin
    Write('Введите требующуюся страницу: ');
    Readln(Number);
    IsFound := False;
    Temp := Term.Page;
    While Not IsFound And (Temp <> Nil) Do
    Begin
        If (Number = Temp.Number) Then
            IsFound := True
        Else
            Temp := Temp.Next;
    End;
    If IsFound Then
        Result := Temp
    Else
    Begin
        Writeln('Такой страницы не было найдено...');
        Result := Nil;
    End;
End;

Procedure ChangePages(Term: PTerm);
Var
    Choice, PageNumber: Integer;
    EditPage: PPage;
Begin
    // ShowTerm(Term, 1, '');
    While True Do
    Begin
        Write(#13#10'Опции:'#13#10'1. Добавить страницу'#13#10'2. Изменить значение страницы'
          + #13#10'3. Удалить страницу'#13#10'4. Выход' +
          #13#10'Введите номер пункта, который нужно выполнить: ');
        Readln(Choice);
        If Choice In [2, 3] Then
        Begin
            EditPage := GetPage(Term);
            If EditPage = Nil Then
                Continue;
        End;
        Case Choice Of
            1:
                Begin
                    Write('Введите значение страницы: ');
                    Readln(PageNumber);
                    CreatePage(PageNumber, Term);
                End;
            2:
                Begin
                    Write('Введите новое значение страницы: ');
                    Readln(PageNumber);
                    CreatePage(PageNumber, Term);
                    DeletePage(EditPage, Term);
                End;
            3:
                Begin
                    DeletePage(EditPage, Term);
                End;
            4:
                Exit;
        End;
    End;
End;

Procedure ChangeSubterm(Subterm: PTerm; InsertLevel: Integer);
Var
    Choice: Integer;
    EditSubterm: PTerm;
Begin
    While True Do
    Begin
        Writeln;
        ShowTerm(SubTerm, 2, '');
        Write(#13#10'Опции:'#13#10'1. Изменить название подтермина'#13#10'2. Изменить страницы'
          + #13#10'3. Изменить подтермины'#13#10'4. Удалить подтермин'#13#10'5. Добавить подтермин'#13#10'6. Выход'
          + #13#10'Введите номер пункта, который нужно выполнить: ');
        Readln(Choice);
        Case Choice Of
            1:
                Subterm := ChangeName(Subterm);
            2:
                ChangePages(Subterm);
            3:
                Begin
                    If InsertLevel = 2 Then
                    Begin
                        EditSubterm := GetTerm(Nil);
                        If EditSubterm <> Nil Then
                            ChangeSubterm(EditSubterm, 3);
                    End
                    Else
                        Writeln('Достигнута максимальная вложенность!');
                End;
            4:
                Begin
                    DeleteTerm(Subterm);
                    Exit;
                End;
            5:
                If InsertLevel = 2 Then
                    EnterTerm(True, InsertLevel + 1, SubTerm)
                Else
                    Writeln('Достигнута максимальная вложенность!');
            6:
                Exit;
        End;
    End;
End;

Procedure ChangeTerm(Term: PTerm);
Var
    Choice: Integer;
    EditSubterm: PTerm;
Begin
    While True Do
    Begin
        Writeln;
        ShowTerm(Term, 1, '');
        Write(#13#10'Опции:'#13#10'1. Изменить название термина'#13#10'2. Изменить страницы'
          + #13#10'3. Изменить подтермин'#13#10'4. Удалить термин'#13#10'5. Добавить подтермин'#13#10'6. Выход'
          + #13#10'Введите номер пункта, который нужно выполнить: ');
        Readln(Choice);
        Case Choice Of
            1:
                Begin
                    Term := ChangeName(Term);
                End;
            2:
                ChangePages(Term);
            3:
                Begin
                    EditSubterm := GetTerm(Term);
                    If EditSubterm <> Nil Then
                        ChangeSubterm(EditSubterm, 2);
                End;
            4:
                Begin
                    DeleteTerm(Term);
                    Exit;
                End;
            5:
                EnterTerm(True, 2, Term);
            6:
                Exit;
        End;
    End;
End;

Procedure FindTerms(TermName: String);
Var
    FindArr: Array Of PTerm;
    Temp: PTerm;
Begin
    Temp := TermHead;
    While Temp <> Nil Do
    Begin
        If Temp.Name = TermName Then
        Begin
            SetLength(FindArr, Length(FindArr) + 1);
            FindArr[High(FindArr)] := Temp;
        End;
        Temp := Temp.Next;
    End;
    Writeln(#13#10'Найденные термины (с подтерминами):');
    For Var I := 0 To High(FindArr) Do
        ShowTerm(FindArr[I], 1, '');
End;

Procedure SearchBySubterm(Name: String);
Var
    Temp, Temp2: PTerm;
    FindArr: Array Of PTerm;
Begin
    Temp := TermHead;
    While Temp <> Nil Do
    Begin
        If (Temp.Subterm <> Nil) And (Temp.Subterm.Name = Name) Then
        Begin
            SetLength(FindArr, Length(FindArr) + 1);
            FindArr[High(FindArr)] := Temp;
        End;
        Temp2 := Temp.Subterm;
        While Temp2 <> Nil Do
        Begin
            If (Temp2.Subterm <> Nil) And (Temp2.Subterm.Name = Name) Then
            Begin
                SetLength(FindArr, Length(FindArr) + 1);
                FindArr[High(FindArr)] := Temp2;
            End;
            Temp2 := Temp2.Next;
        End;
        Temp := Temp.Next;
    End;
    Writeln(#13#10'Найденные термины:');
    For Var I := 0 To High(FindArr) Do
        Writeln(FindArr[I].Name);
End;

Procedure Search();
Var
    Choice: Integer;
    SearchTerm: PTerm;
    Name: String;
Begin
    Write(#13#10'Поиск:'#13#10'1. По термину'#13#10'2. По подтермину'#13#10'3. Выход'
      + #13#10'Введите номер пункта, который нужно выполнить: ');
    Readln(Choice);
    Case Choice Of
        1:
            Begin
                SearchTerm := GetTerm(Nil);
                If SearchTerm <> Nil Then
                    FindTerms(SearchTerm.Name);
            End;
        2:
            Begin
                Write('Введите требующийся подтермин: ');
                Readln(Name);
                SearchBySubterm(Name);
            End;
        3:
            Exit;
    End;
End;

Var
    Choice: Integer;
    EditTerm: PTerm = Nil;

Begin
    Writeln('Добро пожаловать в программу для работы с предметным указателем!');
    While True Do
    Begin
        Write('Меню:'#13#10'1. Добавить термин'#13#10'2. Изменить термин' +
          #13#10'3. Просмотр предметного указателя'#13#10'4. Поиск'#13#10'5. Выход'
          + #13#10'Введите номер пункта, который нужно выполнить: ');
        Readln(Choice);
        Case Choice Of
            1:
                EnterTerm(False, 1, Nil);
            2:
                Begin
                    EditTerm := GetTerm(Nil);
                    If EditTerm <> Nil Then
                        ChangeTerm(EditTerm);
                End;
            3:
                Begin
                    Writeln(#13#10'ПРЕДМЕТНЫЙ УКАЗАТЕЛЬ:');
                    Try
                        ShowList(TermHead, 1, '');
                    Except
                        Writeln;
                    End;
                End;
            4:
                Search;
            5:
                Break;
        End;
        Writeln('Нажмите Enter для возвращения в меню...');
        Readln;
    End;

End.