laba_5_2_del_v3

unit laba_5_2_f1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.Menus, Vcl.StdCtrls, System.RegularExpressions,
  Vcl.ExtCtrls, Vcl.ComCtrls, System.UITypes, Math, MyTree;

type
    TArrStr = Array of String;

    TFormMain = class(TForm)
    MainMenu1: TMainMenu;
    NHelp: TMenuItem;
    NAuthor: TMenuItem;
    OpenDialog1: TOpenDialog;
    NFile: TMenuItem;
    NOpen: TMenuItem;
    NSaveAs: TMenuItem;
    SaveDialog1: TSaveDialog;
    NSave: TMenuItem;
    NTask: TMenuItem;
    MemoOutput: TMemo;
    ButtonAccept: TButton;
    LabelAnswer: TLabel;
    BalloonHint1: TBalloonHint;
    LabelToMeasureScreenOfUser: TLabel;
    MemoInputCodes: TMemo;
    procedure NAuthorClick(Sender: TObject);
    procedure NOpenClick(Sender: TObject);
    procedure NSaveAsClick(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure FormCreate(Sender: TObject);
    procedure NSaveClick(Sender: TObject);
    procedure NTaskClick(Sender: TObject);
    function MultPixels(PixQuant: Integer) : Integer;
    procedure MemoInputChange(Sender: TObject);
    procedure ButtonAcceptClick(Sender: TObject);
    procedure OutputAnswer(MyTree: TMyTree);

    private
        MultPix: Single;
        StrFile: String;
        IsSaved: Boolean;
    public

    end;

const
    RegExForNumber = '[1-9]\d{0,2}';
    CaptionHereWillBeAnswer = 'Здесь будет ответ';

var
    FormMain: TFormMain;

implementation
{$R *.dfm}

function FindRegEx(SInput, StrRegEx: String; StrIfNothingFound: String = '') : TArrStr; forward;


//******************************************************************************
// Ввод данных

procedure TFormMain.MemoInputChange(Sender: TObject);
var
    Strs: TArrStr;
    StrOneNumber, TextTemp: String;
    i, SelStartTemp: Integer;
    HasSpaceAtTheEnd: Boolean;
    Point: TPoint;

begin
    TextTemp := '';
    with Sender as TMemo do
    begin
        HasSpaceAtTheEnd := (Length(Text) > 0) and
            ((Text[High(Text)] = ' ') or (Text[High(Text)] = #10));
        SelStartTemp := SelStart;
        Strs := FindRegEx(Text, '\d+');

        if Length(Strs) > 999 then
        begin
            SetLength(Strs, 999);
            BalloonHint1.Title := 'Предупреждение';
            BalloonHint1.Description := 'Максисальное количество чисел - 999';
            Point.X := Round(Width * 2 / 3);
            Point.Y := Height;
            Balloonhint1.ShowHint(ClientToScreen(Point));
        end;

        for i := 0 to High(Strs) do
        begin
            StrOneNumber := FindRegEx(Strs[i], RegExForNumber)[0];
            TextTemp := TextTemp + StrOneNumber;
            if i <> High(Strs) then
                TextTemp := TextTemp + ' ';
        end;

        if HasSpaceAtTheEnd then
                TextTemp := TextTemp + ' ';

        if Text <> TextTemp then
        begin
            if Text <> TextTemp + ' ' then
            begin
                BalloonHint1.Title := 'Предупреждение';
                BalloonHint1.Description := 'Разрешены только целые числа от 1 до 999.';
                Point.X := Round(Width * 2 / 3);
                Point.Y := Height;
                Balloonhint1.ShowHint(ClientToScreen(Point));
            end;

            Text := TextTemp;
            SelStart := SelStartTemp;
        end;
    end;

    if MemoInputCodes.Text <> '' then
        ButtonAccept.Enabled := True
    else
        ButtonAccept.Enabled := False;

    NSaveAs.Enabled := False;
    NSave.Enabled := False;

    MemoOutput.Text := CaptionHereWillBeAnswer;
end;

procedure TFormMain.ButtonAcceptClick(Sender: TObject);
var
    StrsMemoInput: TArrStr;
    Str: String;
    MyTree: TMyTree;

begin
    StrsMemoInput := FindRegEx(MemoInputCodes.Text, RegExForNumber);

    MyTree.HeadNode := nil;
    for Str in StrsMemoInput do
        AddNodeInTree(MyTree, StrToInt(Str));

    OutputAnswer(MyTree);
    NSaveAs.Enabled := True;
    NSave.Enabled := StrFile <> '';
end;

//******************************************************************************
// Отрисовка дерева

procedure TFormMain.OutputAnswer(MyTree: TMyTree);
var
    HeightOfTree, LineNumber, Margin, Num: Integer;
    NumbersOnLine: TArrInt;
    OneLine: String;

begin
    MemoOutput.Clear();

    HeightOfTree := CountHeightOfTree(MyTree.HeadNode);

    LineNumber := 1;
    Margin := Round(Power(2, HeightOfTree)) - 2;
    while LineNumber < HeightOfTree + 1 do
    begin
        OneLine := '';
        OneLine := OneLine + format(format('%%%ds', [Margin]), ['']);
        NumbersOnLine := GetNumbersOnLine(MyTree.HeadNode, LineNumber);

        for Num in NumbersOnLine do
             OneLine := OneLine + format('%3s',
                [FindRegEx(IntToStr(Num), '[1-9]\d*')[0]]) + format(format('%%%ds',
                [Margin * 2 + 1]), ['']);

        MemoOutput.Lines.Add(OneLine);
        Margin := Round(Margin / 2) - 1;
        Inc(LineNumber);
    end;
end;


//******************************************************************************
// Работа с файлами

procedure TFormMain.NOpenClick(Sender: TObject);
const
    ErrorDuringInputOccured = 'Возникла ошибка при открытии файла.' + #10#13 +
                'Пожалуйста, выберите файл нужного формата(.datgrad) с ' +
                'корректными данными.';

var
    FileInput : TextFile;
    PathToFile, String1: String;

begin
    if not IsSaved and (MessageDlg('Вы хотите сохранить текущие данные?' +
        #10#13 + 'Иначе после открытия файла текущие записи будут удалены.',
        mtConfirmation, [mbYes, mbNo], 0) = mrYes) then
        NSaveClick(Self);

    if (IsSaved or (MessageDlg('Вы уверены, что хотите открыть другой файл?' + #10#13 +
        'Все текущие записи будут удалены.', mtConfirmation, [mbYes, mbCancel], 0) = mrYes))
        and OpenDialog1.Execute then
    begin
        PathToFile := OpenDialog1.FileName;
        try
            AssignFile(FileInput, PathToFile);
            Reset(FileInput);

            Readln(FileInput, String1);
            MemoInputCodes.Text := String1;

            CloseFile(FileInput);
            ButtonAcceptClick(Self);
        except
            ShowMessage(ErrorDuringInputOccured);
        end;
    end;
end;

procedure TFormMain.NSaveAsClick(Sender: TObject);
var
    FileOutput : TextFile;
    StrFilePath: String;
    ShouldNotRepeat: Boolean;
    Point: TPoint;

begin
    try
        repeat
            ShouldNotRepeat := True;
            if SaveDialog1.Execute then
            begin
                StrFilePath := SaveDialog1.FileName;
                StrFilePath := FindRegEx(StrFilePath, '.+\.txt', StrFilePath + '.txt')[0];

                if FileExists(StrFilePath) then
                    if MessageDlg('Такой файл уже существует.' +
                        #10#13 + 'Вы хотите перезаписать файл? Это действие невозможно отменить.',
                        mtConfirmation, [mbYes, mbNo], 0) = mrYes then
                        ShouldNotRepeat := True
                    else
                        ShouldNotRepeat := False
                else
                    ShouldNotRepeat := True;

                if ShouldNotRepeat then
                begin
                    AssignFile(FileOutput, StrFilePath);
                    Rewrite(FileOutput);

                    Write(FileOutput, 'Введённый список кодов:' + #10#13
                        + MemoInputCodes.Text + #10#13 + 'Ответ:'
                        + #10#13 + MemoOutput.Text + #10#13);

                    CloseFile(FileOutput);
                    IsSaved := True;
                    BalloonHint1.Title := 'Готово';
                    BalloonHint1.Description := 'Ответ успешно записан в файл.';
                    Point.X := Round(MemoOutput.Left + MemoOutput.Width * 2 / 3);
                    Point.Y := MemoOutput.Top + MemoOutput.Height;
                    Balloonhint1.ShowHint(ClientToScreen(Point));


                    NSave.Enabled := True;
                    StrFile := StrFilePath;
                end;
            end;
        until ShouldNotRepeat;
    except
       ShowMessage('Не удается открыть файл для вывода данных или записать в него данные.');
    end;
end;

procedure TFormMain.NSaveClick(Sender: TObject);
var
    FileOutput : TextFile;

begin
    if MessageDlg('Вы хотите перезаписать файл "' + StrFile + '"?' + #10#13 +
        'Это действие невозможно отменить.', mtConfirmation, [mbYes, mbNo], 0) = mrYes then
        if FileExists(StrFile) then
        begin
            AssignFile(FileOutput, StrFile);
            Rewrite(FileOutput);

            Write(FileOutput, 'Введённый список:' + #10#13
                + MemoInputCodes.Text + #10#13 + 'Ответ:'
                + #10#13 + MemoOutput.Text + #10#13);

            CloseFile(FileOutput);
            IsSaved := True;
        end
        else
        begin
            ShowMessage('Этого файла уже не существует.');
            StrFile := '';
            NSave.Enabled := False;
            NSaveAsClick(Self);
        end;
end;


//******************************************************************************
// Form Create

procedure TFormMain.FormCreate(Sender: TObject);
begin
    MultPix := LabelToMeasureScreenOfUser.Width / 100;
    StrFile := '';
    IsSaved := True;
    MemoOutput.Text := CaptionHereWillBeAnswer;
end;

//******************************************************************************
// Прочее

procedure TFormMain.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
    CanClose := IsSaved or (MessageDlg('Вы уверены, что хотите выйти из программы?' +
        #10#13 + 'Все несохранённые данные будут утеряны.',
        mtConfirmation, [mbYes, mbNo], 0) = mrYes);
end;

procedure TFormMain.NAuthorClick(Sender: TObject);
begin
    ShowMessage('Панев Александр, гр. 051007' + #10#13 + 'Минск, 2021');
end;

procedure TFormMain.NTaskClick(Sender: TObject);
begin
    ShowMessage('Из текстового файла (.TXT) вводится ряд чисел, ' +
    'представляющих собой коды работников фирмы. Первым в этом списке код ' +
    'руководителя фирмы, далее коды его  подчиненных, подчиненных этих ' +
    'подчиненных и т.д.' + #10#13 + 'У каждого сотрудника в непосредственном подчинении ' +
    'может быть не больше двух подчиненных. Если код очередного сотрудника ' +
    'меньше кода его непосредственного начальника, то он располагается ' +
    'слева от своего начальника, иначе справа.');
end;

function FindRegEx(SInput, StrRegEx: String; StrIfNothingFound: String = '') : TArrStr;
var
    ArrStr: TArrStr;
    RegEx: TRegEx;
    MatchCollection: TMatchCollection;
    i: Integer;
begin
    RegEx := TRegEx.Create(StrRegEx);
    MatchCollection := RegEx.Matches(SInput);
    SetLength(ArrStr, MatchCollection.Count);
    for i := 0 to MatchCollection.Count - 1 do
        ArrStr[i] := MatchCollection.Item[i].Value;

    if (Length(ArrStr) < 1) then
        ArrStr := [StrIfNothingFound];
    Result := ArrStr;
end;

function TFormMain.MultPixels(PixQuant: Integer) : Integer;
begin
    Result := Round(PixQuant * MultPix);
end;

end.






unit MyTree;

interface
uses System.SysUtils, Math;

type
    TArrInt = Array of Integer;

    PNode = ^TNode;
    TNode = Record
        Number: Integer;
        NextBigger, NextSmaller: PNode;
    End;
    TMyTree = Record
        HeadNode: PNode;
    End;


    procedure AddNodeInTree(var MyTree: TMyTree; Number: Integer);
    function CountHeightOfTree(HeadNode: PNode) : Integer;
    function GetNumbersOnLine(HeadNode : PNode; LineQuantity: Integer) : TArrInt;

implementation

procedure AddNodeInTree(var MyTree: TMyTree; Number: Integer);
var
    NewNode, CurrentNode: PNode;
    NextNodesOfCurr: Array[0..1] of PNode;
    ProcessIsNotDone: Boolean;
    Index: Byte;

begin
    New(NewNode);
    NewNode.Number := Number;
    NewNode.NextSmaller := nil;
    NewNode.NextBigger := nil;

    if MyTree.HeadNode <> nil then
    begin
        ProcessIsNotDone := True;
        CurrentNode := MyTree.HeadNode;

        while ProcessIsNotDone do
        begin
            if CurrentNode.Number = Number then
                ProcessIsNotDone := False
            else
            begin
                NextNodesOfCurr[0] := CurrentNode.NextSmaller;
                NextNodesOfCurr[1] := CurrentNode.NextBigger;
                Index := Ord(Number > CurrentNode.Number);

                if NextNodesOfCurr[Index] <> nil then
                    CurrentNode := NextNodesOfCurr[Index]
                else
                begin
                    ProcessIsNotDone := False;

                    if Index > 0 then
                        CurrentNode.NextBigger := NewNode
                    else
                        CurrentNode.NextSmaller := NewNode;
                end;

            end;
        end;
    end
    else
    begin
        MyTree.HeadNode := NewNode;
    end;
end;

function CountHeightOfTree(HeadNode: PNode) : Integer;
var
    HeightOfTree, HeightFromLeft, HeightFromRight: Integer;

begin
    HeightOfTree := 0;

    if HeadNode <> nil then
    begin
        HeightFromLeft := 0;
        HeightFromRight := 0;

        if HeadNode.NextSmaller <> nil then
            HeightFromLeft := CountHeightOfTree(HeadNode.NextSmaller);
        if HeadNode.NextBigger <> nil then
            HeightFromRight := CountHeightOfTree(HeadNode.NextBigger);

        HeightOfTree := Max(HeightFromRight, HeightFromLeft) + 1;
    end;

    Result := HeightOfTree;
end;

function GetNumbersOnLine(HeadNode : PNode; LineQuantity: Integer) : TArrInt;
var
    NumbersOnLine, NumbersOnLineFromLeft, NumbersOnLineFromRight: TArrInt;
    i: Integer;

begin
    SetLength(NumbersOnLine, Round(Power(2, LineQuantity - 1)));
    if LineQuantity = 1 then
        NumbersOnLine[0] := HeadNode.Number
    else
    begin
        if HeadNode.NextSmaller <> nil then
            NumbersOnLineFromLeft := GetNumbersOnLine(HeadNode.NextSmaller, LineQuantity - 1)
        else
        begin
            SetLength(NumbersOnLineFromLeft, Round(Power(2, LineQuantity - 2)));
            for i := Low(NumbersOnLineFromLeft) to High(NumbersOnLineFromLeft) do
                NumbersOnLineFromLeft[i] := 0;
        end;

        if HeadNode.NextBigger <> nil then
            NumbersOnLineFromRight := GetNumbersOnLine(HeadNode.NextBigger, LineQuantity - 1)
        else
        begin
            SetLength(NumbersOnLineFromLeft, Round(Power(2, LineQuantity - 2)));
            for i := Low(NumbersOnLineFromRight) to High(NumbersOnLineFromRight) do
                NumbersOnLineFromRight[i] := 0;
        end;

        for i := Low(NumbersOnLineFromLeft) to High(NumbersOnLineFromLeft) do
            NumbersOnLine[i] := NumbersOnLineFromLeft[i];
        for i := Low(NumbersOnLineFromRight) to High(NumbersOnLineFromRight) do
            NumbersOnLine[i + Length(NumbersOnLineFromLeft)] := NumbersOnLineFromRight[i];
    end;
    Result := NumbersOnLine;
end;
end.