Untitled

altervisi0n

Jun 30th, 2023

Never

Add comment

Not a member of Pastebin yet? Sign Up, it unlocks many cool features!

Delphi 19.38 KB | None | 0 0

raw download clone embed print report

Unit Main;
Interface
Uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.Grids, Vcl.Menus, System.Actions,
Vcl.ActnList;
Type
TMainForm = Class(TForm)
MainGrid: TStringGrid;
MainMenu: TMainMenu;
ManageBtn: TMenuItem;
DrawBtn: TMenuItem;
MainActionList: TActionList;
AManageNodes: TAction;
AdjacencyListBtn: TMenuItem;
Savebtn: TMenuItem;
SaveDialog1: TSaveDialog;
N1: TMenuItem;
N2: TMenuItem;
Procedure FormActivate(Sender: TObject);
Procedure FormResize(Sender: TObject);
Procedure ManageBtnClick(Sender: TObject);
Procedure AManageNodesExecute(Sender: TObject);
Procedure DrawBtnClick(Sender: TObject);
Procedure AdjacencyListBtnClick(Sender: TObject);
Procedure MainGridKeyPress(Sender: TObject; Var Key: Char);
Procedure GetVerticesCoverBtnClick(Sender: TObject);
Procedure SavebtnClick(Sender: TObject);
procedure N2Click(Sender: TObject);
procedure N1Click(Sender: TObject);
Private
{ Private declarations }
Public
End;
Var
MainForm: TMainForm;
Implementation
{$R *.dfm}
Uses Manage, Draw, Adjacency,
UAddLinks;
Type
TEdge = Record
P1, P2: Byte;
End;
TEArray = Array Of TEdge;
Procedure NameFixedCells(MainGrid: TStringGrid);
Var
I: Integer;
Begin
For I := 1 To MainGrid.ColCount - 1 Do
Begin
MainGrid.Cells[I, 0] := IntToStr(I);
End;
For I := 1 To MainGrid.RowCount - 1 Do
Begin
MainGrid.Cells[0, I] := IntToStr(I);
End;
End;
Procedure ClearTable(TablForClear: TStringGrid);
Var
I, J: Integer;
Begin
With TablForClear Do
For I := 1 To (RowCount - 1) Do
For J := 1 To (ColCount - 1) Do
TablForClear.Cells[J, I] := '';
End;
Procedure MakeStringGridSameSize(MainGrid: TStringGrid);
Begin
MainGrid.Width := MainForm.ClientWidth;
MainGrid.Height := MainForm.ClientHeight;
MainGrid.DefaultColWidth := Round(MainForm.ClientWidth / MainGrid.ColCount);
End;
Procedure TMainForm.AdjacencyListBtnClick(Sender: TObject);
Begin
AdjacencyForm.Show;
End;
Procedure TMainForm.AManageNodesExecute(Sender: TObject);
Begin
AdjacencyForm.ClearImage(AdjacencyForm.Image1);
ClearTable(MainGrid);
Savebtn.Enabled := False;
MainGrid.ColCount := StrToInt(ManageForm.NodeCountEdit.Text) + 1;
MainGrid.RowCount := StrToInt(ManageForm.NodeCountEdit.Text) + 1;
MakeStringGridSameSize(MainGrid);
NameFixedCells(MainGrid);
End;
Procedure TMainForm.DrawBtnClick(Sender: TObject);
Begin
DrawForm.Show;
End;
Procedure TMainForm.FormActivate(Sender: TObject);
Begin
MakeStringGridSameSize(MainGrid);
NameFixedCells(MainGrid);
End;
Procedure TMainForm.FormResize(Sender: TObject);
Begin
MakeStringGridSameSize(MainGrid);
End;
Function NoSameEdges(EdgesArray: TEArray; P1: Byte; P2: Byte): Boolean;
Var
I: Integer;
Begin
Result := True;
For I := 0 To Length(EdgesArray) - 1 Do
Begin
If ((EdgesArray[I].P1 = P1) And (EdgesArray[I].P2 = P2)) Or
((EdgesArray[I].P1 = P2) And (EdgesArray[I].P2 = P1)) Then
Begin
Result := False;
Break;
End;
End;
End;
Function VerticleHasEdge(Ver: Byte; EdgesArray: TEArray): Boolean;
Var
I: Integer;
Begin
Result := False;
For I := 0 To Length(EdgesArray) - 1 Do
Begin
If (EdgesArray[I].P1 = Ver) Or (EdgesArray[I].P2 = Ver) Then
Begin
Result := True;
Break;
End;
End;
End;
Function DeleteElemFromArr(Index: Byte; EdgesArray: TEArray): TEArray;
Var
I: Integer;
Begin
For I := Index To Length(EdgesArray) - 2 Do
EdgesArray[I] := EdgesArray[I + 1];
SetLength(EdgesArray, Length(EdgesArray) - 1);
Result := EdgesArray;
End;
Function DeleteAllEdgesWithVer(Ver: Byte; EdgesArray: TEArray): TEArray;
Var
IsDeletedAll: Boolean;
I: Integer;
Begin
IsDeletedAll := True;
Repeat
For I := 0 To Length(EdgesArray) - 1 Do
Begin
If (EdgesArray[I].P1 = Ver) Or (EdgesArray[I].P2 = Ver) Then
Begin
IsDeletedAll := False;
EdgesArray := DeleteElemFromArr(I, EdgesArray);
Break;
End;
End;
If I = Length(EdgesArray) Then
IsDeletedAll := True;
Until IsDeletedAll;
Result := EdgesArray;
End;
Procedure TMainForm.GetVerticesCoverBtnClick(Sender: TObject);
Var
EdgesArray: TEArray;
ACover: Array Of Byte;
I, J: Byte;
ResStr: String;
Begin
SetLength(EdgesArray, 0);
For I := 1 To MainGrid.ColCount Do
Begin
For J := 1 To MainGrid.ColCount Do
Begin
If (I <> J) And (MainGrid.Cells[I, J] = MainGrid.Cells[J, I]) And
((MainGrid.Cells[I, J] <> '') And (MainGrid.Cells[I, J] <> '0')) Then
Begin
If NoSameEdges(EdgesArray, I, J) Then
Begin
SetLength(EdgesArray, Length(EdgesArray) + 1);
EdgesArray[Length(EdgesArray) - 1].P1 := I;
EdgesArray[Length(EdgesArray) - 1].P2 := J;
End;
End;
End;
End;
SetLength(ACover, 0);
For I := 1 To MainGrid.ColCount Do
Begin
If VerticleHasEdge(I, EdgesArray) Then
Begin
SetLength(ACover, Length(ACover) + 1);
ACover[Length(ACover) - 1] := I;
EdgesArray := DeleteAllEdgesWithVer(I, EdgesArray);
End;
End;
ResStr := '';
For I := 0 To Length(ACover) - 1 Do
Begin
ResStr := ResStr + ' ' + IntToStr(ACover[I]);
End;
ShowMessage(ResStr);
End;
Procedure TMainForm.MainGridKeyPress(Sender: TObject; Var Key: Char);
Begin
If Not(Key In ['0' .. '1', #8]) Then
Begin
Key := #0;
End;
End;
Procedure TMainForm.ManageBtnClick(Sender: TObject);
Begin
ManageForm.NodeCountEdit.Text := IntToStr(MainGrid.ColCount - 1);
NameFixedCells(MainGrid);
ManageForm.ShowModal;
FrmAddLinkns.Nheights := StrToInt(ManageForm.NodeCountEdit.Text);
FrmAddLinkns.ShowModal;
End;
procedure TMainForm.N1Click(Sender: TObject);
begin
Application.MessageBox
('Импортировать список (неориентированный граф), инструкция:' +
#13#10'1. Файл должен содержать только числа, которые не превышают максимальной вершины.'#13#10
+ '2. Если вершине не нужно задавать n-ую связь, то ставится пробел, смотреть пример ниже.'#13#10
+ '3. Первая строка - число вершин в графе'#13#10 + 'Пример:'#13#10 +
'3'#13#10 + '2 3'#13#10 + '1 '#13#10 + '1 3'#13#10,
'Инструкция к программе', MB_OK + MB_ICONINFORMATION);
end;
procedure TMainForm.N2Click(Sender: TObject);
begin
Application.MessageBox('Выполнил студент группы 251004, Асепков Данила.',
'О разработчике', MB_OK + MB_ICONINFORMATION);
end;
Procedure SaveStringGridToFile(StringGrid: TStringGrid; Const FileName: String);
Var
FileStream: TFileStream;
StreamWriter: TStreamWriter;
Row, Col: Integer;
Begin
Try
// Проверяем, существует ли файл
If Not(FileExists(FileName)) Then
Raise Exception.Create('Файл уже существует.');
FileStream := TFileStream.Create(FileName, FmCreate);
Try
StreamWriter := TStreamWriter.Create(FileStream);
Try
For Row := 0 To StringGrid.RowCount - 1 Do
Begin
For Col := 0 To StringGrid.ColCount - 1 Do
Begin
StreamWriter.Write(StringGrid.Cells[Col, Row]);
If Col < StringGrid.ColCount - 1 Then
StreamWriter.Write(#9);
// Добавляем разделитель между ячейками
End;
StreamWriter.WriteLine; // Переходим на новую строку
End;
Finally
StreamWriter.Free;
End;
Finally
FileStream.Free;
End;
Except
On E: Exception Do
Begin
// Обработка ошибки
ShowMessage('Ошибка при сохранении файла: ' + E.Message);
End;
End;
End;
Procedure TMainForm.SavebtnClick(Sender: TObject);
Begin
If (SaveDialog1.Execute) Then
SaveStringGridToFile(MainGrid, SaveDialog1.FileName);
End;
End.
unit Adjacency;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls;
type
TAdjacencyForm = class(TForm)
Image1: TImage;
procedure FormActivate(Sender: TObject);
private
{ Private declarations }
public
Procedure ClearImage(Image: TImage);
end;
var
AdjacencyForm: TAdjacencyForm;
implementation
{$R *.dfm}
Uses Main;
Procedure TAdjacencyForm.ClearImage(Image: TImage);
Begin
With Image.Canvas do
Begin
Pen.Color := clWhite;
Brush.Color := clWhite;
Rectangle(0, 0, Image.Width, Image.Height);
End;
End;
Procedure TAdjacencyForm.FormActivate(Sender: TObject);
Var
I, J: Integer;
PosY, TempX: Integer;
Begin
PosY := 20;
For I := 1 to MainForm.MainGrid.ColCount - 1 do
Begin
With Image1.Canvas do
Begin
Pen.Color := clBlack;
Brush.Color := clWhite;
Rectangle(30, PosY - 10, 60, PosY + 20);
TextOut(33, PosY - 3, MainForm.MainGrid.Cells[I, 0]);
Rectangle(59, PosY - 10, 90, PosY + 20);
TempX := 90;
For J := 1 to MainForm.MainGrid.ColCount - 1 do
Begin
With MainForm.MainGrid do
Begin
If (I <> J) and (Cells[I, J] = Cells[J, I]) and (Cells[I, J] <> '')
then
Begin
MoveTo(TempX, PosY);
TempX := TempX + 20;
LineTo(TempX, PosY);
Rectangle(TempX, PosY - 10, TempX + 30, PosY + 20);
TextOut(TempX + 3, PosY - 3, IntToStr(J));
TempX := TempX + 30 - 1;
Rectangle(TempX, PosY - 10, TempX + 30, PosY + 20);
TempX := TempX + 30;
End;
End;
End;
End;
Inc(PosY, 40);
End;
End;
end.
Unit Manage;
Interface
Uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.Samples.Spin;
Type
TManageForm = class(TForm)
NodeCountEdit: TSpinEdit;
Label1: TLabel;
SaveBtn: TButton;
procedure SaveBtnClick(Sender: TObject);
Private
{ Private declarations }
Public
{ Public declarations }
End;
Var
ManageForm: TManageForm;
Implementation
{$R *.dfm}
Uses Main, uAddLinks;
Procedure TManageForm.SaveBtnClick(Sender: TObject);
Begin
If StrToInt(NodeCountEdit.Text) > 10 then
NodeCountEdit.Text := '10'
Else If StrToInt(NodeCountEdit.Text) < 0 then
NodeCountEdit.Text := '1';
MainForm.aManageNodes.Execute;
frmAddLinkns.nHeights := NodeCountEdit.Value;
frmAddLinkns.ClearSgTable(frmAddLinkns.SgLinks);
Self.Close;
End;
End.
Unit uAddLinks;
Interface
Uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.Grids, Main,
Vcl.Menus, Manage;
Type
TfrmAddLinkns = Class(TForm)
Label1: TLabel;
SgLinks: TStringGrid;
SgHeights: TStringGrid;
Label2: TLabel;
Label3: TLabel;
MainMenu1: TMainMenu;
N1: TMenuItem;
OpenDialog1: TOpenDialog;
Procedure FormShow(Sender: TObject);
Procedure FormKeyPress(Sender: TObject; Var Key: Char);
Procedure ChangeTable();
Procedure N1Click(Sender: TObject);
Procedure FormClose(Sender: TObject; Var Action: TCloseAction);
Procedure SgLinksSetEditText(Sender: TObject; ACol, ARow: Integer;
Const Value: String);
Private
Function NotRepeated(Str: String; Pos: Integer): Boolean;
Public
Nheights: Integer;
Procedure ClearSgTable(STRGRID: TStringGrid);
End;
Var
FrmAddLinkns: TfrmAddLinkns;
Implementation
{$R *.dfm}
Procedure TfrmAddLinkns.ClearSgTable(STRGRID: TStringGrid);
Var
I, J: Integer;
Begin
With STRGRID Do
For I := 0 To (RowCount - 1) Do
For J := 0 To (ColCount - 1) Do
STRGRID.Cells[J, I] := '';
End;
Procedure TfrmAddLinkns.FormClose(Sender: TObject; Var Action: TCloseAction);
Var
I, J, Pos: Integer;
Begin
For I := 0 To Nheights - 1 Do
For J := 0 To Nheights - 2 Do
Begin
If (SgLinks.Cells[J, I] <> '') Then
Begin
Pos := StrToInt(SgLinks.Cells[J, I]);
MainForm.MainGrid.Cells[Pos, I + 1] := '1';
MainForm.MainGrid.Cells[I + 1, Pos] := '1';
End;
End;
MainForm.Savebtn.Enabled := True;
End;
Procedure TfrmAddLinkns.FormKeyPress(Sender: TObject; Var Key: Char);
Var
Num, ARow: Integer;
Begin
ARow := SgLinks.Row + 1;
If Not CharInSet(Key, ['1' .. '9', #08]) Then
Key := #0;
Num := Ord(Key) - 48;
If (Num > Nheights) Or (ARow = Num) Then
Key := #0;
End;
Procedure TfrmAddLinkns.ChangeTable();
Var
I: Integer;
Begin
SgHeights.RowCount := Nheights;
SgLinks.ColCount := Nheights - 1;
SgLinks.RowCount := Nheights;
SgHeights.Height := 35 * (Nheights + 1);
SgLinks.Width := 35 * Nheights;
SgLinks.Height := 35 * (Nheights + 1);
For I := 0 To Nheights - 1 Do
SgHeights.Cells[0, I] := IntToStr(I + 1);
End;
Procedure TfrmAddLinkns.FormShow(Sender: TObject);
Begin
ChangeTable;
End;
Function IsFileCorrect(Path: String): Boolean;
Var
ISize, JSize, Num: Integer;
IsCorrect: Boolean;
MatrixFile: TextFile;
Size: Integer;
Begin
ISize := 0;
JSize := 0;
IsCorrect := True;
AssignFile(MatrixFile, Path);
Reset(MatrixFile);
Readln(MatrixFile, Size);
If (Size < 1) Or (Size > 9) Then
Begin
IsCorrect := False;
MessageBox(Application.Handle,
'Файл содержит некорректные данные. Первая строка - размер. Значение от 1 до 5',
'Уведомление об ошибке', MB_ICONERROR);
End;
ManageForm.NodeCountEdit.Value := Size;
FrmAddLinkns.Nheights := Size;
FrmAddLinkns.ChangeTable;
MainForm.AManageNodes.Execute;
While Not(SeekEof(MatrixFile)) And IsCorrect Do
Begin
While Not(SeekEoln(MatrixFile)) And IsCorrect Do
Begin
Try
Read(MatrixFile, Num);
If (Num > Size) Or (Num < 0) Then
Begin
IsCorrect := False;
MessageBox(Application.Handle,
'Файл содержит некорректные данные. число должно быть вершиной ',
'Уведомление об ошибке', MB_ICONERROR);
End;
If Num = 0 Then
FrmAddLinkns.SgLinks.Cells[JSize, ISize] := ''
Else
FrmAddLinkns.SgLinks.Cells[JSize, ISize] := IntToStr(Num);
Except
IsCorrect := False;
End;
Inc(JSize);
End;
Inc(ISize);
Readln(MatrixFile);
JSize := 0;
End;
If ISize <> Size Then
Begin
IsCorrect := False;
MessageBox(Application.Handle,
'Файл содержит некорректные данные. Недостаточно строк',
'Уведомление об ошибке', MB_ICONERROR);
End;
CloseFile(MatrixFile);
IsFileCorrect := IsCorrect;
End;
Procedure TfrmAddLinkns.N1Click(Sender: TObject);
Begin
ManageForm.NodeCountEdit.Value := 1;
If Not((OpenDialog1.Execute) And (IsFileCorrect(OpenDialog1.Filename))) Then
ManageForm.NodeCountEdit.Value := 1
End;
Function TfrmAddLinkns.NotRepeated(Str: String; Pos: Integer): Boolean;
Var
I: Integer;
IsNotRepeated: Boolean;
Begin
IsNotRepeated := True;
For I := 0 To Nheights - 1 Do
Begin
If SgHeights.Cells[I, Pos] = Str Then
IsNotRepeated := False;
End;
NotRepeated := IsNotRepeated;
End;
Procedure TfrmAddLinkns.SgLinksSetEditText(Sender: TObject; ACol, ARow: Integer;
Const Value: String);
Var
I, J: Integer;
Begin
For I := 0 To SgLinks.ColCount - 1 Do
For J := 0 To SgLinks.ColCount - 1 Do
Begin
If Length(SgLinks.Cells[J, I]) > 1 Then
SgLinks.Cells[J, I] := '';
End;
End;
End.
Unit Draw;
Interface
Uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls, System.IOUtils, Math;
Type
TDrawForm = class(TForm)
Image: TImage;
procedure FormActivate(Sender: TObject);
Private
{ Private declarations }
Public
{ Public declarations }
End;
Var
DrawForm: TDrawForm;
Implementation
{$R *.dfm}
Uses Main;
Type
TCoor = Record
X, Y: Integer;
End;
TArray = Array of Byte;
Const
X_LOC: Array [1 .. 10] of Integer = (300, 200, 400, 100, 500, 100, 500, 200,
400, 300);
Y_LOC: Array [1 .. 10] of Integer = (30, 70, 70, 110, 110, 200, 200, 240,
240, 280);
Function IsAlreadyAdded(Arr: TArray; Pos: Byte): Boolean;
Var
I: Integer;
Begin
If Length(Arr) = 0 then
Result := False
Else
Begin
Result := False;
For I := 0 to Length(Arr) - 1 do
Begin
If Pos = Arr[I] then
Begin
Result := True;
Break;
End;
End;
End;
End;
Procedure Visualize(Image: TImage);
Var
I, J, Pos: Integer;
CreatedPosArray: TArray;
Begin
SetLength(CreatedPosArray, 0);
For I := 1 to MainForm.MainGrid.ColCount - 1 do
Begin
Repeat
Pos := RandomRange(1, 11);
Until not IsAlreadyAdded(CreatedPosArray, Pos);
SetLength(CreatedPosArray, Length(CreatedPosArray) + 1);
CreatedPosArray[Length(CreatedPosArray) - 1] := Pos;
End;
For I := 1 to MainForm.MainGrid.ColCount - 1 do
Begin
For J := 1 to MainForm.MainGrid.RowCount - 1 do
Begin
If I <> J then
Begin
With MainForm.MainGrid do
Begin
If (Cells[I, J] = Cells[J, I]) and
((Cells[I, J] <> '') and (Cells[I, J] <> '0')) and
(Cells[J, I] <> '') then
Begin
With Image.Canvas do
Begin
Pen.Color := clBlack;
MoveTo(X_LOC[CreatedPosArray[I - 1]],
Y_LOC[CreatedPosArray[I - 1]]);
LineTo(X_LOC[CreatedPosArray[J - 1]],
Y_LOC[CreatedPosArray[J - 1]]);
End;
End;
End;
End;
End;
End;
For I := 1 to MainForm.MainGrid.ColCount - 1 do
Begin
With Image.Canvas do
Begin
Pen.Color := clBlack;
Brush.Color := clWhite;
Rectangle((X_LOC[CreatedPosArray[I - 1]] - 20),
(Y_LOC[CreatedPosArray[I - 1]] - 20),
(X_LOC[CreatedPosArray[I - 1]] + 20),
(Y_LOC[CreatedPosArray[I - 1]] + 20));
TextOut(X_LOC[CreatedPosArray[I - 1]] - 10, Y_LOC[CreatedPosArray[I - 1]]
- 7, IntToStr(I));
End;
End;
End;
Procedure ClearImage(Image: TImage);
Begin
With Image.Canvas do
Begin
Pen.Color := clWhite;
Brush.Color := clWhite;
Rectangle(0, 0, Image.Width, Image.Height);
End;
End;
Procedure TDrawForm.FormActivate(Sender: TObject);
Begin
Image.Width := Self.ClientWidth;
Image.Height := Self.ClientHeight;
ClearImage(Image);
Visualize(Image);
End;
End.

Add Comment

Please, Sign In to add comment