Lab.5.2.Full(Delphi)

Unit UnitMain;

Interface

Uses
  Winapi.Windows,
  Winapi.Messages,
  System.SysUtils,
  System.Variants,
  System.Classes,
  Vcl.Graphics,
  Vcl.Controls,
  Vcl.Forms,
  Vcl.Dialogs,
  Vcl.Buttons,
  Vcl.ExtCtrls,
  Vcl.StdCtrls,
  Vcl.Menus,
  System.ImageList,
  Vcl.ImgList,
  Vcl.VirtualImageList,
  Vcl.AppEvnts,
  Vcl.Grids,
  ClipBrd,
  Math;

Type
  TLabeledEdit = Class(Vcl.ExtCtrls.TLabeledEdit)
  Protected
    Procedure WMPaste(Var Msg:TMessage); Message WM_PASTE;
  End;
  TArr = Array Of Integer;
  TfrmMain = Class(TForm)
    pButtons: TPanel;
    sdbtOpenFromFile: TSpeedButton;
    sdbtStart: TSpeedButton;
    sdbtSaveToFile: TSpeedButton;
    sdbtHelp: TSpeedButton;
    pBack: TPanel;
    lbWelcome: TLabel;
    lbTaskInfo: TLabel;
    lbIncorrectPatricipants: TLabel;
    lbeSize: TLabeledEdit;
    btConfirmSize: TButton;
    mmMainMenu: TMainMenu;
    miFileMenu: TMenuItem;
    miOpenFromFile: TMenuItem;
    miSaveToFile: TMenuItem;
    miHelp: TMenuItem;
    miInfoAboutDeveloper: TMenuItem;
    BalloonHint: TBalloonHint;
    svdSaveToFileDialog: TSaveDialog;
    opdOpenFromFileDialog: TOpenDialog;
    strgrSequence: TStringGrid;
    btFind: TButton;
    vilImages_48: TVirtualImageList;
    btDraw: TButton;
    lbFinalResult: TLabel;
    lbAnswer: TLabel;
    Procedure FormCloseQuery(Sender: TObject; Var CanClose: Boolean);
    Procedure miHelpClick(Sender: TObject);
    Procedure miInfoAboutDeveloperClick(Sender: TObject);
    Procedure miOpenFromFileClick(Sender: TObject);
    Procedure sdbtOpenFromFileClick(Sender: TObject);
    Procedure lbeSizeChange(Sender: TObject);
    Procedure btConfirmSizeClick(Sender: TObject);
    Procedure FormCreate(Sender: TObject);
    Procedure btFindClick(Sender: TObject);
    Procedure sdbtStartClick(Sender: TObject);
    Procedure lbeSizeKeyPress(Sender: TObject; Var Key: Char);
    Procedure btDrawClick(Sender: TObject);
    Procedure sdbtSaveToFileClick(Sender: TObject);
    Procedure miSaveToFileClick(Sender: TObject);
    Procedure strgrSequenceGetEditText(Sender: TObject; ACol, ARow: Integer;
      Var Value: String);
    Procedure strgrSequenceKeyPress(Sender: TObject; Var Key: Char);
    Procedure strgrSequenceSetEditText(Sender: TObject; ACol, ARow: Integer;
      Const Value: String);
    Procedure strgrSequenceSelectCell(Sender: TObject; ACol, ARow: Integer;
      Var CanSelect: Boolean);
  End;

Var
  frmMain: TfrmMain;
  PreviousSize: Integer;

Implementation

{$R *.dfm}

Uses UnitData, UnitDraw;

Type
    PNode = ^TNode;
    TNode = Record
      Number : Integer;
      Left, Right : PNode;
    End;

Var
    IsAlreadySubclassing: Boolean = False;
    LastValue: String;

Function IsFileOfArrCorrect(Path: String): Boolean; Stdcall; External 'anticlown.dll';

Procedure GetSizeFromFile(Path: String; Var Size: Single; Var IsCorrect: Boolean); Stdcall; External 'anticlown.dll';

Function GetSequenceFromFile(Path: String; Size: Integer; Sequence: TArr; Var IsCorrect: Boolean): TArr; Stdcall;  External 'anticlown.dll';

Function CheckOnSimilar(Sequence: TArr): Boolean;
Var
    I, J, Temp: Integer;
    IsSimilar: Boolean;
Begin
    IsSimilar := False;
    For I := Low(Sequence) To High(Sequence) - 1 Do
    Begin
        Temp := Sequence[I];
        For J := I + 1 To High(Sequence) Do
            If Temp = Sequence[J] Then
                IsSimilar := True;
    End;
    CheckOnSimilar := IsSimilar;
End;

Procedure AddElem(Var Tree: PNode; Num: Integer);
Var
    IsCorrect : Boolean;
Begin
    IsCorrect := True;

    If Tree = nil Then
    Begin
        New(Tree);
        Tree^.Left := nil;
        Tree^.Right := nil;
        Tree^.Number := Num;

        IsCorrect := False;
    End;
    If (IsCorrect) Then
    Begin
        If Num < Tree^.Number Then
            AddElem(Tree^.Left, Num)
        Else
            AddElem(Tree^.Right, Num);
    End;
End;

Function CreateBinaryTree(Arr: TArr): PNode;
Var
    I: Integer;
    Tree: PNode;
Begin
    For I := Low(Arr) To High(Arr) Do
        AddElem(Tree, Arr[I]);

    CreateBinaryTree := Tree;
End;

Function TakeBinaryTree(): PNode;
Var
    I, Size: Integer;
    Arr: TArr;
    Head: PNode;
Begin
    Size := StrToInt(frmMain.lbeSize.Text);
    SetLength(Arr, Size);

    For I := 1 To Size Do
    Begin
        Arr[I - 1] := StrToInt(frmMain.strgrSequence.Cells[I, 1]);
    End;

    Head := CreateBinaryTree(Arr);
    TakeBinaryTree := Head;
End;

Function FindMaxLengthWay(Var Tree: PNode; Var MaxLength: Integer): Integer;
Var
    LengthLeft, LengthRight, CurrentLength: Integer;
Begin
    Result := 0;
    If Tree <> nil Then
    Begin
        LengthLeft := FindMaxLengthWay(Tree.Left, MaxLength);
        LengthRight := FindMaxLengthWay(Tree.Right, MaxLength);

        If Tree.Left = nil Then
        begin
            FindMaxLengthWay := LengthRight + 1;
            Exit;
        end;

        If Tree.Right = nil Then
        Begin
            FindMaxLengthWay := LengthLeft + 1;
            Exit;
        End;

        CurrentLength := LengthLeft + LengthRight;

        MaxLength := Max(CurrentLength, MaxLength);

        FindMaxLengthWay := Max(LengthRight, LengthLeft) + 1;
    End
End;

Function IsTreeUnary(Var Tree: PNode; IsUnary: Boolean): Boolean;
Begin
    If Tree <> nil Then
    Begin
        If Tree.Right = nil Then
            IsTreeUnary(Tree.Left, IsUnary)
        Else
            IsTreeUnary := False;
    End;
End;

Function FindMaxWay(Var Tree: PNode): Integer;
Var
    MaxLength, Counter: Integer;
    IsUnary: Boolean;
Begin
    MaxLength := 0;
    Counter := 0;
    IsUnary := True;
    MaxLength := FindMaxLengthWay(Tree, MaxLength);

    If MaxLength > 0 Then
    Begin
        IsUnary := IsTreeUnary(Tree, IsUnary);
        If IsUnary Then
            FindMaxWay := MaxLength - 1
        Else
            FindMaxWay := MaxLength;
    End;
End;

Procedure TfrmMain.FormCloseQuery(Sender: TObject; Var CanClose: Boolean);
Begin
    If Application.MessageBox(PChar('Вы уверены, что хотите выйти?'), PChar('Выход'),
        MB_ICONQUESTION + MB_YESNO + MB_DEFBUTTON1 + MB_TASKMODAL) = IDYES Then
            CanClose := True
        Else
            CanClose := False;
End;

Procedure TfrmMain.FormCreate(Sender: TObject);
Begin
    UnitMain.PreviousSize := 0;
    strgrSequence.Cells[0, 0] := '№';
    strgrSequence.Cells[0, 1] := 'Эл.';
End;

Procedure TfrmMain.miHelpClick(Sender: TObject);
Const
    FIRST_MESSAGE = '- Вводимыми значениями могут являться только целые числа!' + #13#10;
    SECOND_MESSAGE = '- Диапазон ввода количество элементов: 2...10' + #13#10;
    THIRD_MESSAGE = '- Диапазон вводимых значений элементов: -99...99. ' + #13#10;
    FOURTH_MESSAGE = '- Для ввода из файла используйте вкладку ''Файл'' - ''Открыть''.' + #13#10;
    FIFTH_MESSAGE = '- Для сохранения в файл используйте вкладку ''Файл'' - ''Сохранить''.' + #13#10;
    SIXTH_MESSAGE = '- Для удобного использования программы представлена панель кнопок на левой панели.';
Begin
    Application.MessageBox(FIRST_MESSAGE + SECOND_MESSAGE + THIRD_MESSAGE +
                            FOURTH_MESSAGE + FIFTH_MESSAGE + SIXTH_MESSAGE, 'Справка');
End;

Procedure TfrmMain.miInfoAboutDeveloperClick(Sender: TObject);
Const
    FIRST_MESSAGE = 'Ф.И.О.: Карась А.С. a.k.a Clownfish' + #13#10;
    SECOND_MESSAGE = 'Группа: 251004' + #13#10;
    THIRD_MESSAGE = 'Контакты: предварительная запись вживую по адресу' + #13#10;
    FOURTH_MESSAGE = 'г.Гродно, ул.Мостовая, д.31';
Begin
    Application.MessageBox(FIRST_MESSAGE + SECOND_MESSAGE + THIRD_MESSAGE + FOURTH_MESSAGE,'О разработчике');
End;

Procedure TfrmMain.miOpenFromFileClick(Sender: TObject);
Var
    SizeFromFile: Single;
    IsCorrect: Boolean;
    Size, I: Integer;
    Sequence, SequenceFromFile: TArr;
Begin
    opdOpenFromFileDialog.Filter := 'Text files (*.txt)|*.txt|All files (*.*)|*.*';
    If opdOpenFromFileDialog.Execute() Then
        If IsFileOfArrCorrect(opdOpenFromFileDialog.FileName) Then
        Begin
            GetSizeFromFile(opdOpenFromFileDialog.FileName, SizeFromFile, IsCorrect);
            Size := Round(SizeFromFile);

            SetLength(Sequence, Size);
            SetLength(SequenceFromFile, Size);
            SequenceFromFile := GetSequenceFromFile(opdOpenFromFileDialog.FileName, Size, Sequence, IsCorrect);

            If (IsCorrect) Then
            Begin
                lbeSize.Text := SizeFromFile.ToString;
                btConfirmSizeClick(Sender);
            End;
            For I := 1 To Size Do
            Begin
                strgrSequence.Cells[I, 1] := IntToStr(SequenceFromFile[I - 1]);
            End;
        End
        Else
            Application.MessageBox('Данные в файле некорректны, попробуйте ещё раз.', 'Ошибка!', MB_ICONERROR);
End;

Procedure TfrmMain.sdbtOpenFromFileClick(Sender: TObject);
Begin
    miOpenFromFileClick(Sender);
End;

Procedure TLabeledEdit.WMPaste(Var Msg: TMessage);
Const
    MIN_VALUE = 2;
    MAX_VALUE = 10;
Begin
    If Clipboard.HasFormat(CF_TEXT) Then  // TryStrToInt(ClipBoard.AsText, TempVar)  тоже подойдет
    Begin
        Try
            If (StrToInt(Clipboard.AsText) < MIN_VALUE) Or (StrToInt(Clipboard.AsText) > MAX_VALUE) Then
            Begin
                Application.MessageBox(Pchar('В буфере обмена содержится неподходящее значение!'), 'Ошибка', MB_ICONWARNING);
                Exit; //ReadOnly := True мб тоже подойдет, не тестил
            End;
        Except
            Application.MessageBox(Pchar('При чтении из буфера произошла ошибка!'), 'Ошибка', MB_ICONWARNING);
            Exit;
        End;
    End
    Else
    Begin
        Application.MessageBox(Pchar('В буфере обмена содержатся некорректные данные!'), 'Ошибка', MB_ICONWARNING);
        Exit;
    End;
    inherited;
End;

Procedure TfrmMain.lbeSizeChange(Sender: TObject);
Const
    MIN_VALUE = 2;
    MAX_VALUE = 10;
Begin
    btDraw.Enabled := False;
    btFind.Enabled := False;
    If (lbeSize.Text <> '') Then
    Begin
        If (StrToInt(lbeSize.Text) < MIN_VALUE) Or (StrToInt(lbeSize.Text) > MAX_VALUE) Then
        Begin
            lbIncorrectPatricipants.Visible := True;
            btConfirmSize.Enabled := False;
        End
        Else
        Begin
            lbIncorrectPatricipants.Visible := False;
            btConfirmSize.Enabled := True;
        End;
    End
    Else
    Begin
        btConfirmSize.Enabled := False;
        sdbtStart.Enabled := False;
    End;
End;

Procedure TfrmMain.lbeSizeKeyPress(Sender: TObject; Var Key: Char);
Begin
    If (Not (Key In ['0'..'9', #08, #127])) Then
        Key := #0;
    If (lbeSize.Text = '0') And (Key = '0') Then
        Key := #0;
End;

Procedure TfrmMain.btConfirmSizeClick(Sender: TObject);
Const
    MIN_VALUE = 2;
    MAX_VALUE = 10;
    MIN_VISIBLE_COLS = 3;
    MAX_VISIBLE_COLS = 7;
Var
    IsCorrect: Boolean;
    Value, I: Integer;
Begin
    IsCorrect := True;

    Try
        Value := StrToInt(lbeSize.Text);

        If (Value < MIN_VALUE) Or (Value > MAX_VALUE) Then
            IsCorrect := False;
    Except
        IsCorrect := False;
    End;

    If IsCorrect Then
    Begin
        btFind.Visible := True;
        strgrSequence.Visible := True;

        If UnitMain.PreviousSize <> StrToInt(lbeSize.Text) Then
        Begin
            For I := 1 To strgrSequence.ColCount - 1 Do
                strgrSequence.Cells[I, 1] := '';
        End;
        UnitMain.PreviousSize := StrToInt(lbeSize.Text);

        btConfirmSize.Default := False;
        btFind.Default := True;
        btFind.Enabled := True;

        strgrSequence.ColCount := UnitMain.PreviousSize + 1;
        If UnitMain.PreviousSize < MIN_VISIBLE_COLS Then
        Begin
            strgrSequence.Width := strgrSequence.DefaultColWidth * (UnitMain.PreviousSize + 1);
        End;

        If (UnitMain.PreviousSize > MIN_VISIBLE_COLS - 1) And (UnitMain.PreviousSize < MAX_VISIBLE_COLS) Then
            strgrSequence.Width := strgrSequence.DefaultColWidth * UnitMain.PreviousSize + 10;
        If UnitMain.PreviousSize > MAX_VISIBLE_COLS  Then
            strgrSequence.Width := strgrSequence.DefaultColWidth * MAX_VISIBLE_COLS + 10;

        For I := 1 To UnitMain.PreviousSize + 1 Do
            strgrSequence.Cells[I, 0] := IntToStr(I);

        strgrSequence.Enabled := True;
    End
    Else
    Begin
        Application.MessageBox('Проверьте корректность данных и повторите попытку!', 'Ошибка');
        btConfirmSize.Default := True;
        btFind.Default := False;
        btFind.Enabled := False;
        strgrSequence.Enabled := False;
        btFind.Enabled := False;
        sdbtStart.Enabled := False;
    End;
End;

Procedure TfrmMain.strgrSequenceKeyPress(Sender: TObject; Var Key: Char);
Begin
    If Not(Key In ['0'..'9', #08, #45, #127]) Then
        Key := #0;
End;

Procedure TfrmMain.strgrSequenceSetEditText(Sender: TObject; ACol,
  ARow: Integer; Const Value: String);
Const
    MAX_VALUE = 99;
Var
    Temp: String;
Begin
    btDraw.Enabled := False;
    btFind.Enabled := True;
    If Abs(StrToIntDef(Value, 0)) > MAX_VALUE Then
    Begin
        strgrSequence.Cells[ACol, ARow] := UnitMain.LastValue;
    End;
End;

Procedure TfrmMain.strgrSequenceSelectCell(Sender: TObject; ACol, ARow: Integer; Var CanSelect: Boolean);
Begin
    UnitMain.LastValue := strgrSequence.Cells[ACol, ARow];
End;

Function NewEditProc(Window: HWND; uMsg: UINT; WindowParametr: WPARAM; lParam:LPARAM): Integer; Stdcall;
Const
    MIN_VALUE = -99;
    MAX_VALUE = 99;
Var
    Col, Row: Integer;
Begin
    Col := frmMain.strgrSequence.Col;
    Row := frmMain.strgrSequence.Row;

    If uMsg = WM_PASTE Then
    Begin
        Try
            If (StrToInt(Clipboard.AsText) < MIN_VALUE) Or (StrToInt(Clipboard.AsText) > MAX_VALUE) Then
            Begin
                Application.MessageBox(Pchar('В буфере обмена содержится неподходящее значение!'), 'Ошибка', MB_ICONWARNING);
                Exit;
            End
            Else
            Begin
                frmMain.strgrSequence.Cells[Col, Row] := Clipboard.AsText;
                Exit;
            End;
        Except
            Application.MessageBox(Pchar('В буфере обмена находятся неподходящие данные!'), 'Ошибка', MB_ICONWARNING);
            Exit;
        End;
    End
    Else
        Result := CallWindowProc(Pointer(GetWindowLong(Window,GWL_USERDATA)), Window, uMsg, WindowParametr, lParam);
End;

Procedure TfrmMain.strgrSequenceGetEditText(Sender: TObject; ACol, ARow: Integer; Var Value: String);
Var
    Window: HWND;
Begin
    If Not IsAlreadySubclassing Then
    Begin
        Window := GetWindow(strgrSequence.Handle, GW_CHILD);
        If IsWindow(Window) Then
            SetWindowLong(Window,GWL_USERDATA,SetWindowLong(Window, GWL_WNDPROC, LPARAM(@NewEditProc)));
        IsAlreadySubclassing := True;
    End;
End;

Procedure TfrmMain.btFindClick(Sender: TObject);
Const
    MAX_VALUE = 99;
Var
    I, TempElem, MaxLength: Integer;
    IsBlanc, IsSimilar, IsCorrect: Boolean;
    BinaryTree: PNode;
    TempSequence: TArr;
Begin
    IsBlanc := False;
    IsSimilar := False;
    SetLength(TempSequence, StrToInt(lbeSize.Text));

    For I := 1 To strgrSequence.ColCount - 1 Do
        If strgrSequence.Cells[I, 1] = '' Then
            IsBlanc:= True;

    If IsBlanc Then
        Application.MessageBox('Вы не заполнили последовательность полностью. Пожалуйста, заполните пустые поля!','Ошибка')
    Else
    Begin
        For I := 1 To strgrSequence.ColCount - 1 Do
        TempSequence[I - 1] := StrToInt(strgrSequence.Cells[I, 1]);

        IsSimilar := CheckOnSimilar(TempSequence);

        If IsSimilar Then
            Application.MessageBox('В последовательности присутствуют одинаковые элементы. Пожалуйста, измените последовательность!','Ошибка')
        Else
        Begin
            I := 1;
            IsCorrect := True;
            While IsCorrect And (I < strgrSequence.ColCount) Do
            Begin
                Try
                    TempElem := StrToInt(strgrSequence.Cells[I, 1]);
                    If (Abs(TempElem) > MAX_VALUE) Then
                        IsCorrect := False;
                Except
                    IsCorrect := False;
                End;
                Inc(I);
                If Not IsCorrect Then
                Begin
                    Application.MessageBox('Вы допустили ошибку в ячейке.', 'Ошибка!', MB_ICONERROR);
                    strgrSequence.SetFocus;
                End;
            End;

            If IsCorrect Then
            Begin
                BinaryTree := TakeBinaryTree();
                MaxLength := FindMaxWay(BinaryTree);

                lbAnswer.Visible := True;
                lbFinalResult.Visible := True;
                lbFinalResult.Caption := IntToStr(MaxLength);
                btDraw.Visible := True;
                btDraw.Enabled := True;
                sdbtStart.Enabled := True;
                miSaveToFile.Enabled := True;
                sdbtSaveToFile.Enabled := True;
            End;
        End;
    End;
End;

Procedure TfrmMain.btDrawClick(Sender: TObject);
Begin
    frmDraw := TfrmDraw.Create(Application);
    frmDraw.ShowModal;
End;

Procedure TfrmMain.sdbtStartClick(Sender: TObject);
Begin
    btDrawClick(Sender);
End;

Procedure TfrmMain.miSaveToFileClick(Sender: TObject);
Var
    OutputFile: TextFile;
    I: Integer;
Begin
    If svdSaveToFileDialog.Execute() And FileExists(svdSaveToFileDialog.FileName) Then
    Begin
        AssignFile(OutputFile, svdSaveToFileDialog.FileName);

        Try
            Try
                Rewrite(OutputFile);

                Writeln(OutputFile, 'Входные данные: ');
                Writeln(OutputFile, lbeSize.Text);
                For I := 1 To strgrSequence.ColCount - 1 Do
                    Write(OutputFile, strgrSequence.Cells[I, 1], ' -> ');

                Write(OutputFile, ' Конец последовательности.' + #13#10 + 'Ответ: ' + #13#10);
                Writeln(OutputFile, lbFinalResult.Caption);

                Application.MessageBox('Данные успешно записаны в файл!', 'Сохранение', MB_ICONINFORMATION);
            Finally
                CloseFile(OutputFile);
            End;
        Except
            Application.MessageBox('Отказано в доступе! Измените параметры файла! ', 'Ошибка!', MB_ICONERROR);
        End;
    End
    Else
    Application.MessageBox('Введено некорректное имя файла или закрыто окно сохранения!', 'Ошибка!', MB_ICONERROR);
End;

Procedure TfrmMain.sdbtSaveToFileClick(Sender: TObject);
Begin
    miSaveToFileClick(Sender);
End;

End.

Unit UnitDraw;

Interface

Uses
  Winapi.Windows,
  Winapi.Messages,
  System.SysUtils,
  System.Variants,
  System.Classes,
  Vcl.Graphics,
  Vcl.Controls,
  Vcl.Forms,
  Vcl.Dialogs,
  Vcl.ExtCtrls,
  Vcl.Menus,
  Vcl.Imaging.jpeg;

Type
  TArr = Array Of Integer;
  TfrmDraw = Class(TForm)
    imTree: TImage;
    mmMainMenu: TMainMenu;
    miFileMenu: TMenuItem;
    miSaveToFile: TMenuItem;
    svdSaveToFileDialog: TSaveDialog;
    imLoad: TImage;
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormShow(Sender: TObject);
    procedure miSaveToFileClick(Sender: TObject);
  End;

Var
  frmDraw: TfrmDraw;

Implementation

{$R *.dfm}

Uses UnitMain, UnitData;

Type
    PNode = ^TNode;
    TNode = Record
      Number : integer;
      Left, Right : PNode;
    End;

Procedure Delay(Value: Cardinal);
Var
    F, N: Cardinal;
Begin
    N := 0;
    While N <= (Value Div 10) Do
    Begin
        SleepEx(1, True);
        Application.ProcessMessages;
        Inc(N);
    End;

    F := GetTickCount;

    Repeat
        Application.ProcessMessages;
        N := GetTickCount;
    Until (N - F >= (Value Mod 10)) Or (N < F);
End;

Procedure AddElem(Var Tree: PNode; Num: Integer);
Var
    IsCorrect : Boolean;
Begin
    IsCorrect := True;

    If Tree = nil Then
    Begin
        New(Tree);
        Tree^.Left := nil;
        Tree^.Right := nil;
        Tree^.Number := Num;

        IsCorrect := False;
    End;
    If(IsCorrect) Then
    Begin
        If Num < Tree^.Number Then
            AddElem(Tree^.Left, Num)
        Else
            AddElem(Tree^.Right, Num);
    End;
End;

Function CreateBinaryTree(Arr: TArr): PNode;
Var
    I: Integer;
    Tree: PNode;
Begin
    For I := Low(Arr) To High(Arr) Do
        AddElem(Tree, Arr[I]);

    CreateBinaryTree := Tree;
End;

Function TakeBinaryTree: PNode;
Var
    I, Size: Integer;
    Arr: TArr;
    Head: PNode;
Begin
    Size := PreviousSize;
    SetLength(Arr, Size);

    For I := 1 To Size Do
    Begin
        Arr[I - 1] := StrToInt(frmMain.strgrSequence.Cells[I, 1]);
    End;

    Head := CreateBinaryTree(Arr);
    TakeBinaryTree := Head;
End;

Procedure DrawLine(X1, Y1, X2, Y2: Integer);
Begin
    frmDraw.imTree.Canvas.MoveTo(X1, Y1);
    frmDraw.imTree.Canvas.LineTo(X2, Y2);
End;

Procedure DrawBinaryTree(Head: Pnode; X1, Y1, X2, Y2, Rad, Diam, Shift: Integer);
Var
    Tree: PNode;
Begin
    Tree := Head;

    frmDraw.imTree.Canvas.Pen.Color := clGreen;
    frmDraw.imTree.Canvas.Pen.Width := 4;
    frmDraw.imTree.Canvas.Ellipse(X1, Y1, X2, Y2);

    frmDraw.imTree.Canvas.Pen.Color := clBlue;
    frmDraw.imTree.Canvas.Font.Size := 10;
    frmDraw.imTree.Canvas.Font.Style := [fsBold];
    Case Length(IntToStr(Tree^.Number)) Of
        1:
        Begin
            frmDraw.imTree.Canvas.TextOut(X1 + 15, Y1 + 10, IntToStr(Tree^.Number));
        End;
        2:
        Begin
            frmDraw.imTree.Canvas.TextOut(X1 + 10, Y1 + 10, IntToStr(Tree^.Number));
        End;
        3:
        Begin
            frmDraw.imTree.Canvas.TextOut(X1 + 5, Y1 + 10, IntToStr(Tree^.Number));
        End;
    End;

    If Tree <> nil Then
    Begin
        frmDraw.imTree.Canvas.Pen.Color := clGreen;
        frmDraw.imTree.Canvas.Pen.Width := 2;

        If Tree.Left <> nil Then
        Begin
            DrawLine(X1 + Rad, Y1 + Diam, X1 - 3 * Shift Div 2 + Rad, Y2 + Diam);
            DrawBinaryTree(Tree.Left, X1 - 3 * Shift Div 2, Y1 + 2 * Diam, X2 - 3 * Shift Div 2, Y2 +  2 * Diam, Rad, Diam, 4* Shift Div 10);
        End;
        If Tree.Right <> nil Then
        Begin
            DrawLine(X2 - Rad, Y1 + Diam, X2 + 3 * Shift Div 2 - Rad, Y2 + Diam);
            DrawBinaryTree(Tree.Right, X1 + 3 * Shift Div 2, Y1 + 2 * Diam, X2 + 3 * Shift Div 2, Y2 + 2 * Diam, Rad, Diam, 4 * Shift Div 10);
        End;
    End;
End;

Procedure TfrmDraw.FormShow(Sender: TObject);
Const
    Rad = 20;
Var
    Tree: PNode;
    X1, Y1, X2, Y2, Shift, Diam: Integer;
Begin
    Diam := 2 * Rad;
    Shift := 4 * Diam;

    X1 := frmDraw.imTree.Width Div 2 - Rad;
    X2 := frmDraw.imTree.Width Div 2 + Rad;
    Y1 := 20;
    Y2 := Y1 + Diam;

    Tree := TakeBinaryTree;
    DrawBinaryTree(Tree, X1, Y1, X2, Y2, Rad, Diam, Shift);
End;

Procedure TfrmDraw.FormClose(Sender: TObject; Var Action: TCloseAction);
Begin
    Action := CaFree;
End;

Procedure TfrmDraw.miSaveToFileClick(Sender: TObject);
Const
    PIC_WIDTH_COEF = 100;
    PIC_HEIGHT_COEF = 100;
Var
    I, OutFileChoice: Integer;
    SaveJpeg: TJPEGImage;
    BitMap : TBitMap;
Begin
    If svdSaveToFileDialog.Execute() And FileExists(svdSaveToFileDialog.FileName) Then
    Begin
        Try
            Try
                SaveJpeg := TjpegImage.Create;

                BitMap := TBitMap.Create;
                BitMap.Width := imTree.Width * PIC_WIDTH_COEF Div 100;
                BitMap.Height := imTree.Height * PIC_HEIGHT_COEF Div 100;
                BitMap.Canvas.CopyRect(BitMap.Canvas.ClipRect, imTree.Canvas, imTree.Canvas.ClipRect);

                SaveJpeg.Assign(Bitmap);
                SaveJpeg.CompressionQuality := 100;
                SaveJpeg.PixelFormat := jf24Bit;
                SaveJpeg.Compress;
                SaveJpeg.SaveToFile(svdSaveToFileDialog.FileName);

                Application.MessageBox('Изображение успешно сохранено в файл!', 'Сохранение', MB_ICONINFORMATION);
            Finally
                BitMap.Free;
                SaveJpeg.Free;
            End;
        Except
            Application.MessageBox('Отказано в доступе! Измените параметры файла! ', 'Ошибка!', MB_ICONERROR);
        End;
    End
    Else
        Application.MessageBox('Введено некорректное имя файла или закрыто окно сохранения!', 'Ошибка!', MB_ICONERROR);
End;

Procedure TfrmDraw.FormCloseQuery(Sender: TObject; Var CanClose: Boolean);
Begin
    If Application.MessageBox(PChar('Вы уверены, что хотите выйти из режима просмотра?'), PChar('Выход'),
        MB_ICONQUESTION + MB_YESNO + MB_DEFBUTTON1 + MB_TASKMODAL) = IDYES Then
            CanClose := True
        Else
            CanClose := False;
End;

End.

Unit UnitData;

Interface

Uses
  System.SysUtils,
  System.Classes,
  Vcl.BaseImageCollection,
  Vcl.ImageCollection,
  System.ImageList,
  Vcl.ImgList,
  Vcl.Controls;

Type
  TdtmdData = Class(TDataModule)
    imcImages: TImageCollection;
    imlIcons: TImageList;
  End;

Var
  dtmdData: TdtmdData;

Implementation

{%CLASSGROUP 'Vcl.Controls.TControl'}

{$R *.dfm}

End.