Ссылочные типы в языке Ада. Решение тематических задач

Для решения в этот раз я предлагаю всего 2 задачи (Я больше не успел. Планировал ещё рассмотреть хэш, но, видимо, позже). Задачи довольно большие и полностью охватывают рассмотренный материал, но если этого мало, то для этого раздела подойдут задачи из темы "Цикл For и массивы в языке Ада. Решение тематических задач". Нужно просто вместо классических массивов использовать списки ссылок. Вторая задача иллюстрирует, что такое двоичные деревья, и сама по себе является своего рода подтемой.

  • Есть обувной магазин. С помощью ссылок разработать пример поступления обуви в магазин и её продажи. Для простоты считать, что имеется только один вид обуви. Необходимо предусмотреть следующие операции:

    1. Положить обувь на полку.
    2. Взять обувь с полки.
    3. Посмотреть, какие размеры имеются в наличии и их цену.

    P.S.: Основная цель данной задачи - научиться создавать связанные списки.

  • 1. Положить обувь на полку
    2. Продать обувь с полки
    3. Показать, какие размеры есть в наличии и их цену
    4. Выход из программы
    Ваш выбор: 1

    Размер: 41
    Цена: 500

    1. Положить обувь на полку
    2. Продать обувь с полки
    3. Показать, какие размеры есть в наличии и их цену
    4. Выход из программы
    Ваш выбор: 1

    Размер: 39
    Цена: 450

    1. Положить обувь на полку
    2. Продать обувь с полки
    3. Показать, какие размеры есть в наличии и их цену
    4. Выход из программы
    Ваш выбор: 3

    -----------------------------------------------
    41 Стоимость: 500.00 руб.
    -----------------------------------------------
    39 Стоимость: 450.00 руб.
    -----------------------------------------------

    1. Положить обувь на полку
    2. Продать обувь с полки
    3. Показать, какие размеры есть в наличии и их цену
    4. Выход из программы
    Ваш выбор:

  • with Ada.Text_IO; use Ada.Text_IO;
    with Ada.Integer_Text_IO; use Ada.Integer_Text_IO;
    with Ada.Float_Text_IO; use Ada.Float_Text_IO;
    with Ada.Unchecked_Deallocation;
     
    procedure main is
    -------------------Переменные-------------------------------------------
        ans : Integer := 0;
     
        type Shoes_Type;
        type Ref_Shoes_Type is access Shoes_Type;
        type Shoes_Type is
            Record
                Size : Integer; --Размер обуви
                --Чтобы не перегружать задачу новыми типами буду использовать
                --для выражения стоимости встроенный тип Float:
                Cost : Float; --Стоимость
                Next : Ref_Shoes_Type; --Ссылка на следующую пару
            end Record;
     
        Root : Ref_Shoes_Type := NULL;
     
        procedure Free is new Ada.Unchecked_Deallocation(Shoes_Type, Ref_Shoes_Type);
     
    --------------Подпрограммы----------------------------------------------
     
        function Find_Shoes(Root : Ref_Shoes_Type; sz : Integer) return Ref_Shoes_Type is
        --Проверяет наличие размера и возвращает ссылку на него или NULL
            Current : Ref_Shoes_Type := Root;
        begin
            while Current /= NULL loop
                if Current.Size = sz then
                    return Current;
                end if;
                Current := Current.Next;
            end loop;
            return NULL;
        end Find_Shoes;
        --------------------------------------------------------------------
     
        function Menu return Integer is
        --Показывает меню и обрабатывает выбор пользователя
            ans : Integer := 0;
            --В объявлении следующих строк можно обойтись и без ключевого слова constant,
            --но так будет правильнее:
            Str_1 : aliased constant String := "1. Положить обувь на полку";
            Str_2 : aliased constant String := "2. Продать обувь с полки";
            Str_3 : aliased constant String := "3. Показать, какие размеры есть в наличии и их цену";
            Str_4 : aliased constant String := "4. Выход из программы";
     
            type Full_Menu_Type is array(Integer range <>) of access constant String;
            --Создаём массив ссылок на статические переменные (в динамической памяти ничего не создаётся)
            Full_Menu : constant Full_Menu_Type := (1 => Str_1'Access,
                                                    2 => Str_2'Access,
                                                    3 => Str_3'Access,
                                                    4 => Str_4'Access
                                                   );
        begin
            loop
                for i in Full_Menu'Range loop
                    Put_Line(Full_Menu(i).all);
                end loop;
                Put("Ваш выбор: ");
                Get(ans);
                exit when ans > 0 and ans < 9;
            end loop;
        return ans;
        end Menu;
     
        --------------------------------------------------------------------
        procedure Put_Shoes(Root : in out Ref_Shoes_Type) is
        --Положить новую пару обуви на полку
            Tail : Ref_Shoes_Type;
        begin
            if Root /= NULL then --Если в магазине уже есть обувь
                Tail := Root; --Переходим в конец списка обуви
                while Tail.Next /= NULL loop --**ЧАСТАЯ ОШИБКА WHILE TAIL /= NULL
                    Tail := Tail.Next;
                end loop;
                --Выделяем место под новую пару
                Tail.Next := new Shoes_Type;
                Tail := Tail.Next;
            else --Если в магазине обуви нет, это первое поступление
                Root := new Shoes_Type;
                Tail := Root;
            end if;
            --Считываем нужные данные
            Put("Размер: ");
            Get(Tail.Size);
            Put("Цена: ");
            Get(Tail.Cost);
            Tail.Next := NULL; --Необязательная строка
        end Put_Shoes;
     
        --------------------------------------------------------------------
        procedure Sell_Shoes(Root : in out Ref_Shoes_Type) is
            Current, Tmp : Ref_Shoes_Type;
            sz : Integer;
            ch : Character;
        begin
            Put("Какой размер обуви Вам нужен? -> ");
            Get(sz);
            if Root.Size = sz then
                Current := Root.Next;
                Free(Root);
                Root := Current;
            else
                if NULL /= Find_Shoes(Root, sz) then
                    Current := Root;
                    while Current.Next.Size /= sz loop
                        Current := Current.Next;
                    end loop;
                    Tmp := Current.Next;
                    Current.Next := Tmp.Next;
                    Free(Tmp);
                else
                    Put_Line("Извините, Вашего размера нет");
                    Put_Line("Для продолжения нажмите любую клавишу");
                    Get_Immediate(ch);
                end if;
            end if;
        end Sell_Shoes;
        --------------------------------------------------------------------
     
        procedure Show_Shoes(Root : in ref_Shoes_Type) is
        --Показать весь ассортимент
            Current : Ref_Shoes_Type := Root;
        begin
            while Current /= NULL loop
                Put_Line("-----------------------------------------------");
                Put(Item => Current.Size, Width => 0);
                Put(" Стоимость: ");
                Put(Item => Current.Cost, Fore => 4, Aft => 2, Exp => 0);
                Put(" руб.");
                New_Line;
                Current := Current.Next;
            end loop;
            Put_Line("-----------------------------------------------");
        end Show_Shoes;
        --------------------------------------------------------------------
     
        procedure Clear_All(Root : in out Ref_Shoes_Type) is
        --Удаление объектов из динамической памяти
            Current : Ref_Shoes_Type := Root;
        begin
            while Current /= NULL loop
                Root := Root.Next;
                Free(Current);
                Current := Root;
            end loop;
        end Clear_All;
     
    ------------------------------------------------------------------------
    begin
        loop
            ans := Menu;
            case ans is
                when 1 => Put_Shoes(Root);
                when 2 => Sell_Shoes(Root);
                when 3 => Show_Shoes(Root);
                when 4 => Clear_All(Root);
                when others => Put_Line("Ошибка ввода! Попробуйте ещё!");
            end case;
            exit when ans = 4;
        end loop;
    end main;

  • Реализовать двоичное дерево. Нужно предусмотреть добавление элемента в дерево, удаление элемента, просмотр всего дерева.


  • Двоичное дерево представляет собой структурированный набор узлов, причём:

    • У каждого узла не более двух подузлов.
    • Любое значение меньше значения узла становится левым подузлом.
    • Любое значение больше или равное значению узла становится правым подузлом.

              

    Соответственно, одинаковых значений дерево не содержит. Основное назначение двоичных деревьев заключается в повышении эффективности поиска.


  • Для простоты я вывожу дерево на экран горизонтально:

                     ->40
                ->30
                       ->26
                   ->25
                       ->23
           ->20
      ->10
                  ->9
               ->8
                  ->7
                     ->6
            ->5
                  ->4
               ->3
                       ->2
                  ->1
    

  • В приведённом ниже примере я постарался максимально всё упростить (даже в ущерб краткости. Можно было сократить/объединить некоторые проверки, но тогда возросла бы сложность восприятия). Все узлы имеют двухсторонние связи, т.е. каждый элемент связан с предыдущим элементом и с одним либо двумя следующими элементами. Задача разбита на 2 пакета: первый отвечает за меню, второй - за само дерево.

    my_menu.ads

    with Ada.Unchecked_Deallocation;
     
    --Для примера создадим меню в динамической памяти
     
    package My_Menu is
     
        --Объявим типы как ограниченные приватные.
        --Их описание см. в приватной части пакета ниже
        type Ref_String is limited private;
        type Main_Menu is limited private;
        type Ref_Main_Menu is limited private;
     
        procedure Show_Menu; --Показать меню
        procedure Delete_Menu; --Удалить динамически созданное меню
        function Get_Choice return Integer; --Получить выбор пользователя
     
     
    private
        type Ref_String is access String; --Тип ссылок на строки
        type Main_Menu is array(1..4) of Ref_String; --тип массива ссылок на строки
        type Ref_Main_Menu is access Main_Menu; --тип ссылок на массив ссылок на строки
        --Меню (ссылка на массив ссылок на строки в динамической памяти, => двумерный массив ссылок)
        Menu : Ref_Main_Menu;
     
        --Следующие два объявления - пример переопределения (перегрузки) подпрограмм:
        --Так как типы объявлены как приватные, то процедуры, создаваемые на основе стороннего
        --дженерика, тоже объявляются в приватной части. Для их вызова можно написать
        --подпрограмму (см. procedure Delete_Menu выше)
        --Удаление строк меню. После этой операции ссылки в массиве будут равны NULL
        procedure Free is new Ada.Unchecked_Deallocation(String, Ref_String);
        --Удаление массива (контейнера)
        procedure Free is new Ada.Unchecked_Deallocation(Main_Menu, Ref_Main_Menu);
     
    end My_Menu;

    [свернуть]

    my_menu.adb

    with Ada.Text_IO; use Ada.Text_IO;
    with Ada.Characters.Handling; use Ada.Characters.Handling;
     
    --Для примера создадим меню в динамической памяти
     
    package body My_Menu is
        --------------------------------------------------------------------
        procedure Show_Menu is
        --Показать меню
        begin
            for i in Menu'Range loop
                Put_Line(Menu(i).all);
            end loop;
        end Show_Menu;
     
        --------------------------------------------------------------------
        procedure Delete_Menu is
        --Удалить динамически созданное меню
        --Обращаю внимание: процедура вызывает подпрограммы Free,
        --объявленные в приватной части пакета
        begin
            for i in Menu'Range loop
                Free(Menu(i));
            end loop;
            Free(Menu);
        end Delete_Menu;
     
        --------------------------------------------------------------------
        function Get_Choice return Integer is
        --Получить выбор пользователя + Обработка некорректного ввода
            Choice : String(1..2);
            Choice_Len : Integer;
            ans : Integer;
            ch : Character;
        begin
            loop
                Show_Menu; --Показать меню
                Put("Ваш выбор: ");
                Get_Line(Choice, Choice_Len);
                --Обработка некорректного ввода
                if Choice_Len = Choice'Last or else
                (Is_Digit(Choice(1)) = True and then Integer'Value(Choice(1..1)) not in Menu'Range) then
                    if Choice_Len = Choice'Last then
                        Skip_Line;
                    end if;
                    --Так как в меню всего 6 пунктов, то в данном случае
                    --условие уже нарушено
                    Put_Line("Некорректный ввод. Попробуйте ещё.");
                    Put_Line("Для продолжения нажмите любую клавишу");
                    Get_Immediate(ch);
                --Обработка корректного ввода
                elsif Is_Digit(Choice(1)) = True and then Integer'Value(Choice(1..1)) in Menu'Range then
                    ans := Integer'Value(Choice(1..1));
                    exit;
                end if;
            end loop;
            return ans;
        end Get_Choice;
     
    begin
        --Создание динамического меню:
        --Создаётся двумерный массив (контейнер) строк переменной длины
        --Причём, сами строки создаются в динамической памяти.
        Menu := new Main_Menu'(new String'("1. Добавить элемент"),
                               new String'("2. Удалить элемент"),
                               new String'("3. Показать дерево"),
                               new String'("4. Выйти из программы")
                              );
     
    end My_Menu;

    [свернуть]

    my_tree.ads

    with Ada.Text_IO; use Ada.Text_IO;
    with Ada.Unchecked_Deallocation;
     
    package My_Tree is
        Max_Num : constant Integer := 5; --максимальная длина числа
        File_Name : constant String := "My_File.txt";
        My_File : File_Type;
     
        type Knot is limited private;
        type Ref_Knot is limited private;
     
        procedure Add_Knot; --Добавить элемент к дереву
        procedure Show_Tree; --Показать дерево
        procedure Delete_Tree; --Удалить дерево
        procedure Del_Knot(Num : in Integer); --Удалить один узел
        function Get_User_Number return Integer; --Получить пользовательский ввод
     
    private
     
        --Узел. Здесь происходит ветвление
        type Knot is
            Record
                Num : Integer;
                Prev : Ref_Knot; --Предыдущий элемент
                Right : Ref_Knot; --Элемент справа
                Left : Ref_Knot; --Элемент слева
            end Record;
     
        type Ref_Knot is access Knot;
     
        Root : Ref_Knot; --Корень дерева
     
        procedure Free is new Ada.Unchecked_Deallocation(Knot, Ref_Knot);
     
    end My_Tree;

    [свернуть]

    my_tree.adb

    with Ada.Text_IO;
    with Ada.Characters.Handling;
    with Ada.Integer_Text_IO;
     
    package body My_Tree is
     
        --------------------------------------------------------------------
        function Get_User_Number return Integer is
        --Получить число от пользователя
            use Ada.Characters.Handling;
            use Ada.Text_IO;
            --Пользовательский ввод будет осуществляться в строку (для обработки ошибок)
            str : String(1..Max_Num);
            str_Len : Integer;
     
            True_Number : Boolean;
            Num : Integer;
     
        begin
            loop
                --Предположим, что пользователь введёт всё правильно
                True_Number := True;
     
                Put("Введите число: ");
                Get_Line(str, str_Len);
                if str_Len = Max_Num then
                    Skip_Line;
                end if;
     
                --Проверка, что все символы, введённые пользователем,
                --являются числами
                for i in str'First..str_Len loop
                    if Is_Digit(str(i)) = False then
                        True_Number := False;
                        exit;
                    end if;
                end loop;
                --Если ввод корректный, то преобразуем строку в число
                if True_Number = True then
                    Num := Integer'Value(str(1..str_Len));
                end if;
     
                exit when True_Number = True;
            end loop;
     
            return Num;
        end Get_User_Number;
     
        --------------------------------------------------------------------
        procedure Add_Knot is
        --Добавить элемент (узел, лист) к дереву
            Placed : Boolean := False;
            Num : Integer;
        begin
            Num := Get_User_Number;
            --Если дерево пустое, то вводимый элемент станет корнем:
            if Root = NULL then
                Root := new Knot;
                Root.Left := NULL;
                Root.Right := NULL;
                Root.Prev := NULL;
                Root.Num := Num;
            else --Если дерево уже содержит элементы
                declare
                    Current : Ref_Knot;
                begin
                    Current := Root;
                    while not Placed loop
                        --Если введённое число больше текущего, то двигаемся вправо
                        if Num > Current.Num then
                            if Current.Right /= NULL then
                                Current := Current.Right;
                            else
                                Current.Right := new Knot;
                                Current.Right.Prev := Current;
                                Current.Right.Num := Num;
                                Current.Right.Left := NULL;
                                Current.Right.Right := NULL;
                                Placed := True;
                            end if;
                        --Если введённое число меньше текущего, то двигаемся влево
                        elsif Num < Current.Num then
                            if Current.Left /= NULL then
                                Current := Current.Left;
                            else
                                Current.Left := new Knot;
                                Current.Left.Prev := Current;
                                Current.Left.Num := Num;
                                Current.Left.Left := NULL;
                                Current.Left.Right := NULL;
                                Placed := True;
                            end if;
                        elsif Num = Current.Num then
                            Placed := True;
                        end if;
                        exit when Placed = True;
                    end loop;
                end;
            end if;
        end Add_Knot;
     
        --------------------------------------------------------------------
        procedure Show_Tree is
        --Показать дерево. Нерекурсивный обход.
            use Ada.Integer_Text_IO;
            use Ada.Text_IO;
            Right_Back, Left_Back : Boolean := False;
            Current : Ref_Knot;
            Num : Integer := 1;
            Root_Show : Boolean := False;
            ch : Character;
        begin
            if Root = NULL then
                Put_Line("Дерево не содержит ни одного элемента.");
                Put_Line("Для продолжения нажмите любую клавишу.");
                New_Line;
                Get_Immediate(ch);
                return; --Выход из подпрограммы
            end if;
            Current := Root;
            while Current.Right /= NULL loop
                Current := Current.Right;
            end loop;
     
           loop
               --Условия, при которых происходит вывод на экран
               if Left_Back = False and then (Current.Right = NULL or else Right_Back = True) then
                    for i in 1..(6 + Num * 2) loop
                        Put(' ');
                    end loop;
                    Put("->");
                    Put(Item => Current.Num, Width => 0);
                    New_Line;
                    if Current = Root then
                        Root_Show := True;
                    end if;
                end if;
                --Обход дерева. Сначала правая ветвь узла
                if Current.Right /= NULL and then Right_Back = False then
                    Current := Current.Right;
                    Num := Num + 1;
                    Left_Back := False;
                    Right_Back := False;
                --Если правая ветвь обойдена, то переходим к левой ветви
                elsif Current.Left /= NULL and then Left_Back = False then
                    Current := Current.Left;
                    Num := Num + 1;
                    Left_Back := False;
                    Right_Back := False;
                --Если обе ветви пройдены и в текущую позицию мы пришли с правой ветви
                elsif Current.Prev /= NULL and then Current = Current.Prev.Right then
                    Current := Current.Prev;
                    Right_Back := True;
                    Left_Back := False;
                    Num := Num - 1;
                --Если обе ветви пройдены и в текущую позицию мы пришли с левой ветви
                elsif Current.Prev /= NULL and then Current = Current.Prev.Left then
                    Current := Current.Prev;
                    Right_Back := True; --К этому моменту правая ветвь уже пройдена
                    Left_Back := True;
                    Num := Num - 1;
                end if;
                --Условия выхода из цикла
                if Current = Root and then Root_Show = True and then Root.Left = NULL then
                    exit;
                elsif Current = Root and then Root_Show = True and then Left_Back = True then
                    exit;
                end if;
            end loop;
        end Show_Tree;
     
        --------------------------------------------------------------------
        procedure Del_Knot(Num : in Integer) is
        --Поиск и удаление элемента (узла) в дереве
            use Ada.Text_IO;
            Current, Tmp : Ref_Knot;
            Knot_Find : Boolean := False;
            ch : Character;
        begin
            if Root = NULL then
                Put_Line("Дерево не содержит ни одного элемента.");
                Put_Line("Для продолжения нажмите любую клавишу.");
                New_Line;
                Get_Immediate(ch);
                return; --Выход из подпрограммы
            end if;
     
            --Поиск узла в дереве
            Current := Root;
            loop
                if Num = Current.Num then
                    Knot_Find := True;
                    exit;
                end if;
                if Num > Current.Num and then Current.Right /= NULL then
                    Current := Current.Right;
                elsif Num < Current.Num and then Current.Left /= NULL then
                    Current := Current.Left;
                else
                    Put_Line("Указанный элемент в дереве отсутствует.");
                    Put_Line("Для продолжения нажмите любую клавишу.");
                    Get_Immediate(ch);
                    exit;
                end if;
            end loop;
     
            --Если элемент обнаружен, то удаляем его
            if Knot_Find = True then
                --Удаляем узел правой ветви (узел не Root)
                if Current.Prev /= NULL and then Current = Current.Prev.Right then
                    --Если у самого узла нет правой ветви
                    if Current.Right = NULL then
                        Current.Prev.Right := Current.Left;
                        if Current.Left /= NULL then
                            Current.Left.Prev := Current.Prev;
                        end if;
                    else --Если у узла есть правая ветвь
                        Tmp := Current.Right;
                        while Tmp.Left /= NULL loop
                            Tmp := Tmp.Left;
                        end loop;
                        Tmp.Left := Current.Left;
                        if Current.Left /= NULL then
                            Current.Left.Prev := Tmp;
                        end if;
                        Current.Prev.Right := Current.Right;
                        Current.Right.Prev := Current.Prev;
                    end if;
                --Удаляем узел левой ветви (узел не Root)
                elsif Current.Prev /= NULL and then Current = Current.Prev.Left then
                    --Если у самого узла нет правой ветви
                    if Current.Right = NULL then
                        Current.Prev.Left := Current.Left;
                        if Current.Left /= NULL then
                            Current.Left.Prev := Current.Prev;
                        end if;
                    else --Если у узла есть правая ветвь
                        Tmp := Current.Right;
                        while Tmp.Left /= NULL loop
                            Tmp := Tmp.Left;
                        end loop;
                        Tmp.Left := Current.Left;
                        if Current.Left /= NULL then
                            Current.Left.Prev := Tmp;
                        end if;
                        Current.Prev.Left := Current.Right;
                        Current.Right.Prev := Current.Prev;
                    end if;
                --Удаление корня
                elsif Current.Prev = NULL then
                    if Current.Right /= NULL then
                        Tmp := Current.Right;
                        while Tmp.Left /= NULL loop
                            Tmp := Tmp.Left;
                        end loop;
                        Tmp.Left := Current.Left;
                        if Current.Left /= NULL then
                            Current.Left.Prev := Tmp;
                        end if;
                        Current.Right.Prev := NULL;
                        Root := Current.Right;
                        Current.Right := NULL;
                        Current.Left := NULL;
                    elsif Current.Left /= NULL then
                        Root := Current.Left;
                        Root.Prev := NULL;
                    else
                        Root := NULL;
                    end if;
                end if;
                Free(Current);
            end if;
     
        end Del_Knot;
     
        --------------------------------------------------------------------
        procedure Delete_Tree is
        --Удалить дерево
        begin
            while Root /= NULL loop
                Del_Knot(Root.Num);
            end loop;
        end Delete_Tree;
     
        --------------------------------------------------------------------
    begin
        Root := NULL;
    end My_Tree;

    [свернуть]

    main.adb

    with Ada.Text_IO; use Ada.Text_IO;
    with My_Menu;
    with My_Tree;
     
    procedure main is
        ans : Integer;
        ch : Character;
        Num : Integer;
    begin
        loop
            ans := My_Menu.Get_Choice;
            --Put_Line(Integer'Image(ans));
            case ans is
                when 1 => My_Tree.Add_Knot; --Добавить узел
                when 2 => Num := My_Tree.Get_User_Number; --Получить число от пользователя
                          My_Tree.Del_Knot(Num); --Удалить узел
                when 3 => My_Tree.Show_Tree; --Показать дерево
                when 4 => My_Tree.Delete_Tree; --Удаляем дерево и
                          exit;        --выходим из цикла
                when others => Put_Line("Ошибка ввода. Попробуйте ещё!");
                               Put_Line("Для продолжения нажмите любую клавишу");
                               Get_Immediate(ch);
            end case;
        end loop;
        --Не забываем вычистить мусор из памяти (динамическое меню)
        My_Menu.Delete_Menu;
    end main;

    [свернуть]

    Примерно так. Вы всегда можете предложить своё решение. К тому же на просторах интернета море информации по описанию этой структуры данных.