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 Комментариев ·
9039 Прочтений ·
• Не нашли ответ на свой вопрос? Тогда задайте вопрос в комментариях или на форуме! •
Комментарии
Skrip November 11 2010 04:32:02
Вот программку бы еще вообще было б супер ))
Добавить комментарий
Рейтинги
Рейтинг доступен только для пользователей.
Пожалуйста, залогиньтесь или зарегистрируйтесь для голосования.
Нет данных для оценки.
Гость
Вы не зарегистрированны? Нажмите здесь для регистрации.
Главная
Каталог файлов
