laba_5_1_del_v3

unit laba_5_1_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, MyList;

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;
    LabelToMeasureScreenOfUser: TLabel;
    MemoInputList: TMemo;
    MemoOutput: TMemo;
    ButtonAccept: TButton;
    MemoInputArray: TMemo;
    LabelList: TLabel;
    LabelArray: TLabel;
    LabelAnswer: TLabel;
    BalloonHint1: TBalloonHint;
    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 MemoInputListChange(Sender: TObject);
    procedure ButtonAcceptClick(Sender: TObject);

    procedure ComputeAndOutputAnswer(List: TMyList; Arr: TArrInt);

    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.MemoInputListChange(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 (MemoInputList.Text <> '') and (MemoInputArray.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
    StrsMemoList, StrsMemoArray: TArrStr;
    Str: String;
    MyList, MyList2: TMyList;
    Arr: TArrInt;
    i, Number: Integer;
    IsCorrect: Boolean;
    Current: PNode;

begin
    IsCorrect := True;

    StrsMemoList := FindRegEx(MemoInputList.Text, RegExForNumber);
    StrsMemoArray := FindRegEx(MemoInputArray.Text, RegExForNumber);

    MyList.HeadNode := nil;
    for Str in StrsMemoList do
        AddNodeInList(MyList, StrToInt(Str));

    MyList2.HeadNode := nil;
    for Str in StrsMemoArray do
        AddNodeInList(MyList2, StrToInt(Str));

    Arr := ConvertListIntoArray(MyList2);

    MemoInputArray.Clear();
    for Number in Arr do
        With MemoInputArray do
            Text := Text + IntToStr(Number) + ' ';
    MemoInputList.Clear();
    Current := MyList.HeadNode;
    while Current <> nil do
    begin
        With MemoInputList do
            Text := Text + IntToStr(Current.Number) + ' ';
        Current := Current.NextNode;
    end;

    if Length(Arr) <> MyList.ListSize then
    begin
        ShowMessage('Числа в массиве не соответствуют реальному размеру списка');
        IsCorrect := False;
    end;

    i := 0;
    while IsCorrect and (i < Length(Arr)) do
    begin
        if Arr[i] > MyList.ListSize then
        begin
            ShowMessage('Числа в массиве не соответствуют реальному размеру списка');
            IsCorrect := False;
        end
        else
            Inc(i);
    end;

    if IsCorrect then
    begin
        ComputeAndOutputAnswer(MyList, Arr);
        NSaveAs.Enabled := True;
        NSave.Enabled := StrFile <> '';
    end;
end;

procedure TFormMain.ComputeAndOutputAnswer(List: TMyList; Arr: TArrInt);
var
    Current, ToSwapWith: PNode;
    SerNum, i, j: Integer;
    ListOut: TMyList;

begin
    MemoOutput.Clear();
    ListOut.HeadNode := nil;

    for SerNum in Arr do
    begin
        Current := List.HeadNode;
        i := 1;
        while i < SerNum do
        begin
            Current := Current.NextNode;
            Inc(i);
        end;

        AddNodeInList(ListOut, Current.Number);
    end;

    Current := ListOut.HeadNode;
    while Current <> nil do
    begin
        With MemoOutput do
            Text := Text + IntToStr(Current.Number) + ' ';
        Current := Current.NextNode;
    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);
            MemoInputList.Text := String1;
            Readln(FileInput, String1);
            MemoInputArray.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
                        + MemoInputList.Text + #10#13 + 'Введённый массив:'
                        + #10#13 + MemoInputArray.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
                + MemoInputList.Text + #10#13 + 'Введённый массив:' + #10#13
                + MemoInputArray.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('Дан неупорядоченный линейный односвязный список и массив, ' +
    'содержащий номера соответствующих элементов в упорядоченном списке. ' +
    'Перестроить данный список в соответствии с номерами, заданными массивом.');
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 MyList;

interface

uses System.SysUtils;

type
    TArrInt = Array of Integer;

    PNode = ^TNode;
    TNode = Record
        Number: Integer;
        NextNode: PNode;
    End;
    TMyList = Record
        HeadNode: PNode;
        ListSize: Integer;
    End;

    procedure AddNodeInList(var List: TMyList; Number: Integer);
    function ConvertListIntoArray(var List: TMyList) : TArrInt;

implementation

procedure AddNodeInList(var List: TMyList; Number: Integer);
var
    NewNode, CurrentNode: PNode;
    ProcessIsNotDone: Boolean;

begin
    New(NewNode);
    with List do
    begin
        if HeadNode = nil then
        begin
            HeadNode := NewNode;
            ListSize := 1;
        end
        else
        begin
            ProcessIsNotDone := True;
            CurrentNode := HeadNode;
            while (CurrentNode <> nil) and ProcessIsNotDone do
            begin
                if CurrentNode.Number = Number then
                    ProcessIsNotDone := False
                else
                    if CurrentNode.NextNode = nil then
                    begin
                        CurrentNode.NextNode := NewNode;
                        Inc(ListSize);
                        ProcessIsNotDone := False;
                    end
                    else
                        CurrentNode := CurrentNode.NextNode;
            end;
        end;

        NewNode.Number := Number;
        NewNode.NextNode := nil;
    end;
end;

function ConvertListIntoArray(var List: TMyList) : TArrInt;
var
    QuantityOfElem: Integer;
    CurrentNode: PNode;
    ArrOutput: TArrInt;

begin
    SetLength(ArrOutput, 8);
    QuantityOfElem := 0;

    CurrentNode := List.HeadNode;
    while CurrentNode <> nil do
    begin
        Inc(QuantityOfElem);
        if QuantityOfElem > Length(ArrOutput) then
            SetLength(ArrOutput, Round(Length(ArrOutput) * 1.5));

        ArrOutput[QuantityOfElem - 1] := CurrentNode.Number;
        CurrentNode := CurrentNode.NextNode;
    end;
    SetLength(ArrOutput, QuantityOfElem);
    Result := ArrOutput;
end;

end.