private
{ Private declarations }
public
{ Public declarations }
end;
Const
MaxN = 50; //Максимальное число элементов
type
TVector = Record
M : Array[1..MaxN] of Word; // Элементы строки
S : Word; // Сумма элементов строки
Num : Word; // Первоначальный номер элемента
End;
TArray = Array[1..MaxN] of TVector;
var
FormReturnAllocation: TFormReturnAllocation;
C, D : TArray; //Массивы данных
N : Word; //Число элементов на плате
//////////////////////////////////////////////////////////////////////
//// Процедуры обработки данных
//////////////////////////////////////////////////////////////////////
// Суммирует элементы строк массива и записывает суммы в специальный элемент
// записи
//Параметры:
//Arr - тип TArray - передается по ссылке
// обрабатываемый массив
Procedure CalculateLinesSum(Var Arr : TArray);
//Производит сортировку переданного массива по возрастанию или убыванию
//значения суммы строки
//Параметры:
//Arr - тип TArray - передается по ссылке
// обрабатываемый массив
//Direction - тип Boolean - передается по значению
// True - по возрастанию, False - по убыванию
Procedure SortArrayByLineSum(Var Arr : TArray; Direction : boolean = True);
// Вычисляет число L по переданным массивам
//Параметры:
//C, D - тип TArray - передаются по значению
// массивы по данным которых вычисляется оценка L
//Возвращаемое значение:
// Оценка L, тип double
Function CalculateL(C, D : TArray) : Double;
////////////////////////////////////////////////////////////////////
//// Интерфейсные процедуры и функции
////////////////////////////////////////////////////////////////////
//Прорисовка заголовков строк и столбцов
//Параметры:
// MaxCount - тип Word
// - число столбцов и строк
// Obj - тип TStringGrid, нулевые строки и столбцы заполняются цифрами
// от 1 до MaxCount
Procedure DrawColumnHeaders(MaxDimension : Word; Var Obj : TStringGrid);
//Отображает результат размещения в таблице SG по данным из
//массивов Arr1 и Arr2
Procedure LoadResult(Arr1, Arr2 : TArray; Var SG : TStringGrid);
////////////////////////////////////////////////////////////////////
//// Процедуры преобразования данных массивов и таблиц формы
////////////////////////////////////////////////////////////////////
//Обновляет массив по таблице StringGrid
//с проверкой корректности введенных данных;
//некорректные данные заменяются нулями
//Параметры:
// SG - тип TStringGrid
// - таблица с данными, которые ввел пользователь
// Arr - тип TArray
// - массив, в который будут загружены корректные данные
Procedure StringGridToArray(SG : TStringGrid; Var Arr : TArray);
//Обновляет таблицу SG из массива Arr
//Параметры:
// SG - тип TStringGrid
// - таблица с данными, которые отображаются пользователю
// Arr - тип TArray
// - массив, из который будут загружены данные
Procedure ReloadStringGrid(Var SG : TStringGrid; Arr : TArray);
implementation
{$R *.dfm}
//////////////////////////////////////////////////////////////////////
//// Процедуры обработки данных
// Суммирует элементы строк массива и записывает суммы в специальный элемент
// записи
//Параметры:
//Arr - тип TArray - передается по ссылке
// обрабатываемый массив
Procedure CalculateLinesSum(Var Arr : TArray);
Var S : Word;
i,j : word;
Begin
// перебор по строкам
For i := 1 To N-1 do
begin
// инициализация накопителя суммы
S := 0;
// перебор элементов вектора
For j := 1 to N-1 do
S := S + Arr[i].M[j]; // накопление суммы
// присвоение суммы соотв. элементу записи
Arr[i].S := S;
end;
End;
//Производит сортировку переданного массива по возрастанию или убыванию
//значения суммы строки
//Параметры:
//Arr - тип TArray - передается по ссылке
// обрабатываемый массив
//Direction - тип Boolean - передается по значению
// True - по возрастанию, False - по убыванию
Procedure SortArrayByLineSum(Var Arr : TArray; Direction : boolean = True);
Var i, t : Word; // вспомогательные переменные
A : TVector; // Аккумулятор
Begin
If Direction
Then
For t := 2 to N-1 Do
For i:=t to N-1 Do
Begin
// сравниваем сумму строки с суммой предыдущей строки
// если сумма больше, то меняем строки местами
If Arr[i].S < Arr[i-1].S
Then
Begin
A := Arr[i];
Arr[i] := Arr[i-1];
Arr[i-1] := A;
End;
End
Else
For t := N-1 DownTo 2 Do
For i := N-1 DownTo 2 Do
Begin // сравниваем сумму строки с суммой предыдущей строки
// если сумма больше, то меняем строки местами
If Arr[i].S > Arr[i-1].S
Then
Begin
A := Arr[i];
Arr[i] := Arr[i-1];
Arr[i-1] := A;
End;
End;
End; // Procerure SortArrayByLineSum
// Вычисляет число L по переданным массивам
//Параметры:
//C, D - тип TArray - передаются по значению
// массивы по данным которых вычисляется оценка L
//Возвращаемое значение:
// Оценка L, тип double
Function CalculateL(C, D : TArray) : Double;
var Sum : Extended; //Переменная для накопления суммы
i,j : word; //Итераторы циклов
Begin
// инициализация суммы
Sum := 0;
// циклы перебора элементов
For i := 1 to N-1 do
For j := 1 to N-1 do
Sum := Sum + C[i].M[j] * D[i].M[j];
//Вычисляем 1/2 от суммы согласно алгоритму
Sum := 0.5 * Sum;
//Возврат вычисленного значения
CalculateL := Sum;
End; // Function CalculateL
////////////////////////////////////////////////////////////////////
//// Интерфейсные процедуры и функции
//Прорисовка заголовков строк и столбцов
//Параметры:
// MaxCount - тип Word
// - число столбцов и строк
// Obj - тип TStringGrid, нулевые строки и столбцы заполняются цифрами
// от 1 до MaxCount
Procedure DrawColumnHeaders(MaxDimension : Word; Var Obj : TStringGrid);
Var i : Word; //итератор цикла
Begin
//Проверить, является ли переданный объект
//таблицей результата
If Obj.ColCount = 2
Then //Переданный объект является таблицей результата
begin
Obj.Cells[0,0] := 'Элемент';
Obj.Cells[1,0] := 'Позиция';
Obj.RowCount := MaxDimension;
Obj.FixedRows := 1;
//Obj.RowCount := MaxDimension;
end
Else //Переданный объект является таблицей данных
Begin
Obj.ColCount := MaxDimension;
Obj.RowCount := MaxDimension;
Obj.FixedCols := 1;
Obj.FixedRows := 1;
For i := 1 to N-1 Do
begin
//заполнение значениями
Obj.Cells[0, i] := IntToStr(i);
Obj.Cells[i, 0] := IntToStr(i);
end;
End;
End; // Procedure DrawColumnHeaders
//Отображает результат размещения в таблице SG по данным из
//массивов Arr1 и Arr2
Procedure LoadResult(Arr1, Arr2 : TArray; Var SG : TStringGrid);
Var
i : Word; //итератор цикла
Begin
For i := 1 To N-1 Do
Begin
SG.Cells[0, i] := IntToStr(Arr1[i].Num);
SG.Cells[1, i] := IntToStr(Arr2[i].Num);
End;
End; //Procedure LoadResult
///////////////////////////////////////////////////////////////////////
//// Обработка событий формы
//Обработка события отображения формы
procedure TFormReturnAllocation.FormShow(Sender: TObject);
Var Num : Integer;
begin
// Инициализируем файловые диалоги
OpenDialog.InitialDir := Copy(ParamStr(0), 0, Length(Application.ExeName));
SaveDialog.InitialDir := Copy(ParamStr(0), 0, Length(Application.ExeName));
// Задание начального количества элементов
N := 5;
// Заполнение таблиц нулями
DataClearClick(Sender);
//Установка заголовков таблиц
DrawColumnHeaders(N, SGC);
DrawColumnHeaders(N, SGD);
DrawColumnHeaders(N, SGR);
end;
///////////////////////////////////////////////////////////////////////////
//// Процедуры преобразования данных массивов и таблиц формы
//Обновляет массив по таблице StringGrid
//с проверкой корректности введенных данных;
//некорректные данные заменяются нулями
//Параметры:
// SG - тип TStringGrid
// - таблица с данными, которые ввел пользователь
// Arr - тип TArray
// - массив, в который будут загружены корректные данные
Procedure StringGridToArray(SG : TStringGrid; Var Arr : TArray);
Var
i,j : Integer; // Итераторы циклов
NumInt : Integer; // Вспомогательная переменная для попытки преобразования
// строки в целое
Begin
For i:=1 to N-1 do
Begin
For j:=1 to N-1 do // Проверка правильности введенных данных
If TryStrToInt(SG.Cells[j,i], NumInt)
Then
Arr[i].M[j] := NumInt
Else
Arr[i].M[j] := 0;
Arr[i].Num := 0;
End;
End; //Procedure StringGridToArray
//Обновляет таблицу SG из массива Arr
//Параметры:
// SG - тип TStringGrid
// - таблица с данными, которые отображаются пользователю
// Arr - тип TArray
// - массив, из который будут загружены данные
Procedure ReloadStringGrid(Var SG : TStringGrid; Arr : TArray);
Var
i,j : Word; //Вспомогательные переменные циклов
Begin
For i:=1 to N-1 do
For j:=1 to N-1 do
SG.Cells[j,i] := IntToStr(Arr[i].M[j]);
End; //Procedure ReloadStringGrid
//////////////////////////////////////////////////////////////////////////
//// Обработка событий главного меню
// Меню: Файл - Открыть
// Производится выбор открываемого файла с данными,
// проверка соответствия размерности данных в файле
// и размерности N в массив и обновление StringGrid
procedure TFormReturnAllocation.FileOpenClick(Sender: TObject);
Var F : File Of Word; // Файловая переменная
FileName : String; // Путь к открыаемому файлу
i,j : Word; //Переменные итераторы циклов
NewN : Word; //Переменная размерности файла
Num : Word; //Вспомогат. для загрузки числа из файла
begin
// Открываем диалог выбора файла
If OpenDialog.Execute Then
Begin
//Берем путь к имени файла
FileName := OpenDialog.FileName;
//Направляем файловую переменную на файл
AssignFile(F, FileName);
//Открываем файл для чтения
Try //попытка
Reset(F);
Except
MessageDlg('Ошибка чтения из файла!', mtError, [mbOK], 0);
//Выход из процедуры
Exit;
End; // Try
//Считываем размерность из файла
Read(F, NewN);
//Проверяем соответствует ли размерность файла и текущая размерность
//в программе
If N = NewN Then
begin
//Если соответствует, то загружаем данные из файла
For i := 1 To N-1 do
For j := 1 To N-1 do
Begin
Try
Read(F, Num);
Except
MessageDlg('Ошибка чтения файла. Операция прервана.', mtError, [mbOK], 0);
exit;
End;
C[i].M[j] := Num;
End;
For i := 1 To N-1 do
For j := 1 To N-1 do
Begin
Try
Read(F, Num);
Except
MessageDlg('Ошибка чтения файла. Операция прервана.', mtError, [mbOK], 0);
exit;
End;
D[i].M[j] := Num;
End;
//Обновление отображения данных в StringGrid
ReloadStringGrid(SGC, C);
ReloadStringGrid(SGD, D);
//Пересчет сумм строк по загруженным данным
CalculateLinesSum(C);
CalculateLinesSum(D);
end
else
If MessageDlg('Количество элементов из файла отличается от текущего числа элементов. Загрузить данные из файла?', mtConfirmation, [mbYes, mbNo], 0) = mrYes
Then
Begin
//Присвоение значения N записанного в файле
N := NewN;
//Перерисовать интерфейсные объекты
DrawColumnHeaders(N, SGC);
DrawColumnHeaders(N, SGD);
DrawColumnHeaders(N, SGR);
//Чтение данных из файла
For i := 1 To N-1 do
For j := 1 To N-1 do
Begin
Try
Read(F, Num);
Except
MessageDlg('Ошибка чтения файла. Операция прервана.', mtError, [mbOK], 0);
exit;
End;
C[i].M[j] := Num;
End;
For i := 1 To N-1 do
For j := 1 To N-1 do
Begin
Try
Read(F, Num);
Except
MessageDlg('Ошибка чтения файла. Операция прервана.', mtError, [mbOK], 0);
exit;
End;
D[i].M[j] := Num;
End;
//обновление отображаемых данных
ReloadStringGrid(SGC, C);
ReloadStringGrid(SGD, D);
//Пересчет сумм строк по загруженным данным
CalculateLinesSum(C);
CalculateLinesSum(D);
End;
// Очистим индексы
For i := 1 to N-1 do
Begin
C[i].Num := 0;
D[i].Num := 0;
End;
//Закрыть файл
CloseFile(F);
end; // If OpenDialog.Execute
end;
// Меню Файл - Сохранить
procedure TFormReturnAllocation.FileSaveClick(Sender: TObject);
Var F : File Of Word; // Файловая переменная
FileName : String; //Путь к файлу
i, j : Word; //Вспомогательные переменные циклов
Num : Word; //Переменная для перегрузки значений
N1 : Word; //Вспомогательная переменная
begin
//Обновить массивы по таблицам StringGrid
StringGridToArray(SGC, C);
StringGridToArray(SGD, D);
//Открытие диалога сохранения файла
If SaveDialog.Execute Then
Begin
//Берем путь и имя файла
FileName := SaveDialog.FileName;
Try //Попытка
//Связываем файловую переменную с файлом
AssignFile(F, FileName);
//Перезаписываем файл
Rewrite(F);
Except //Исключение
MessageDlg('Ошибка записи в файл!', mtError, [mbOK], 0);
end; //Конец попытки
//Запись размерности в файл
N1 := N;
Write(F, N1);
//Запись данных массивов в файл
For i := 1 To N-1 do
For j := 1 To N-1 do
Begin
Num := C[i].M[j];
Write(F, Num);
End;
For i := 1 To N-1 do
For j := 1 To N-1 do
Begin
Num := D[i].M[j];
Write(F, Num) ;
End;
//Закрыть файл
CloseFile(F);
End
end; //procedure TFormReturnAllocation.FileSaveClick
//
// Очищает данные в интерфейсных таблицах
procedure TFormReturnAllocation.DataClearClick(Sender: TObject);
Var i,j : Word;
begin
For i := 1 to N-1 do
Begin
For j := 1 to N-1 do
begin
SGC.Cells[i,j] := '0';
SGD.Cells[i,j] := '0';
end;
SGR.Cells[0,i] := '';
SGR.Cells[1,i] := '';
End;
end; // Procedure
// Меню Данные - Обработать
procedure TFormReturnAllocation.DataCalculateClick(Sender: TObject);
Var i,j : word; //Переменные циклов
L : Extended; //Значение L
begin
// Проверка правильности введенных данных
//и загрузка данных в массивы
StringGridToArray(SGC, C);
StringGridToArray(SGD, D);
// вычисление L1
L := CalculateL(C, D);
//Вывод L1 на экран
EditL1.Text := FloatToStr(L);
// запись первоначальных номеров векторов в соотв. элементы записей
For i := 1 to N-1 do
Begin
C[i].Num := i;
D[i].Num := i;
End;
//Перерасчет сумм строк по данным
CalculateLinesSum(C);
CalculateLinesSum(D);
//Сортируем строки массива C по возрастанию сумм строк
SortArrayByLineSum(C);
//Сортируем строки массива D по убыванию сумм строк
SortArrayByLineSum(D, False);
//Обновление отображения в таблицах StringGrid
ReloadStringGrid(SGC, C);
ReloadStringGrid(SGD, D);
//Отобразить результат размещения в таблице SGК
LoadResult(C, D, SGR);
//Вычислить L после применения метода обр.размещения
L := CalculateL(C, D);
// Показать L
EditL2.Text := FloatToStr(L);
end; // меню Данные - Обработать
// Меню файл/Выход
procedure TFormReturnAllocation.FileExitClick(Sender: TObject);
begin
Close;
end;
//Меню Данные/Количество элементов
procedure TFormReturnAllocation.CountElemClick(Sender: TObject);
Var Num : Integer;
begin
//Ввод числа элементов
Repeat
TryStrToInt(InputBox('Ввод числа элементов','Число элементов:',IntToStr(N-1)), Num);
Until (Num>2) AND (Num<=MaxN);
N := Num+1;
DrawColumnHeaders(N, SGC);
DrawColumnHeaders(N, SGD);
DrawColumnHeaders(N, SGR);
end;
end. //Конец модуля
Опубликовал Kest
January 02 2009 19:17:04 ·
1 Комментариев ·
9695 Прочтений ·
• Не нашли ответ на свой вопрос? Тогда задайте вопрос в комментариях или на форуме! •
Комментарии
Skrip November 11 2010 04:32:02
Вот программку бы еще вообще было б супер ))
Добавить комментарий
Рейтинги
Рейтинг доступен только для пользователей.
Пожалуйста, залогиньтесь или зарегистрируйтесь для голосования.
Нет данных для оценки.
Гость
Вы не зарегистрированны? Нажмите здесь для регистрации.