Главная
База знаний "Allbest"
Программирование, компьютеры и кибернетика
Градиентный метод первого порядка
Градиентный метод первого порядка
Моделирование и программирование динамических систем. Градиентный метод первого порядка; математическое описание системы и значений переменных в виде полиномиальной линейной модели, статистический анализ; алгоритм моделирования, разработка программы.
| Рубрика | Программирование, компьютеры и кибернетика |
| Вид | курсовая работа |
| Язык | русский |
| Дата добавления | 12.06.2011 |
| Размер файла | 447,0 K |
Отправить свою хорошую работу в базу знаний просто. Используйте форму, расположенную ниже
Студенты, аспиранты, молодые ученые, использующие базу знаний в своей учебе и работе, будут вам очень благодарны.
где m - число значимых коэффициентов в уравнении регрессии.
2. После проведения полного факторного эксперимента определены коэффициенты регрессии
Тогда частные производные будут пропорциональны .
3. Делая, с учетом последнего выражения, шаг в сторону, противоположную среднему, определяем новую точку и опять проводим эксперимент.
4. Повторяем первые три шага, пока не приблизимся к точке экстремума. При приближении к точке экстремума алгоритм начинает работать плохо при близости к нулю частных производных, то есть линейная модель становится неадекватной и требует введения квадратичных членов.
По условию дано:
, T = 20, U(t) = 15 - 0.1t, .
Уравнение выхода системы:
, , .
Значение параметров системы:
, .
Характер помехи и ее статистические параметры:
Нормальное распределение
.
Здесь - вектор состояния системы; - вектор наблюдения; - вектор помехи; А, В, С - матрицы коэффициентов (параметров) системы; [0, T] - интервал определения системы.
Необходимо
- составить в соответствии с математическим ожиданием системы ее имитационную модель для формирования реализации вектора и состояния системы на интервале определения;
- составить алгоритм и программу решения задачи построения динамической модели в соответствии с заданным типом модели методом идентификации и точностью решения задачи;
- отладить программу;
- провести расчеты и анализ полученных результатов.
Построение математической модели
Учитывая характер помехи можно составить следующую имитационную модель системы для формирования реализации вектора и состояния системы на интервале определения:
,
, ; .
Здесь - вектор состояния системы; - вектор состояния модели; - матрицы коэффициентов модели.
, T = 20, U(t) = 15 - 0.1t, .
Здесь [0, T] - интервал определения системы.
Уравнение выхода системы:
, , .
Здесь - вектор наблюдения; - вектор помехи; С - матрица коэффициентов (параметров) системы.
Значение параметров системы:
, .
Здесь А, В - матрицы коэффициентов (параметров) системы.
Характер помехи и ее статистические параметры:
Помеха имеет нормальное распределение с математическим ожиданием, равным .
Алгоритм реализации решения задачи построения динамической модели
Идея построения требуемой динамической системы состоит в следующем: для заданного значения параметра t с его интервала определения градиентным методом первого порядка находим соответствующее значение параметра x, который изменяется динамически. Поэтому необходимо в каждый момент ti найти оптимальное соответствующее значение фактора х и функции отклика у, которые наиболее близко описывали бы исходную систему. Помеха имеет нормальное распределение, поэтому включаем ее в функцию отклика таким образом, как показано в выше предложенных формулах.
Для поиска решения необходимо рассчитать оптимальный шаг .
Это делается по выше указанной формуле ( 6 ) - поиск шага варьирования. Именно так и реализуем в программном решении данной задачи.
Для поиска оптимального решения используем матрицы коэффициентов модели , с помощью которых определяем соответствующее значение функции отклика. Все выше сказанное реализовано в предлагаемой программе, в которой реализовано решение задачи построения динамической модели в соответствии с заданным типом модели методом идентификации и точностью решения задачи. Программа отлажена на упрощенных тестовых примерах с использованием информации, полученной от имитационной тестовой модели.
Проведен анализ полученных результатов, что также отражено в предложенной программе.
Апробирование машинной программы
Как было отмечено ранее, в данной программе кроме ручного ввода исходных значений факторов Х (т. е. задание так называемой «нулевой точки») существует задание количества факторов и количества опытов, как по умолчанию, так и непосредственно пользователем.
Программа исследований программного эксперимента:
Решает задачу оптимизации поверхности отклика. В начале работы требуется задать значения функции отклика Y, для которых и будет найдены соответствующие значения факторов X, при которых функция отклика принимает максимальное значение.
1. Задаем количество факторов и экспериментов
Получаем значения факторов в натуральном масштабе, заполняем матрицу планирования.
2. Производим кодирование в безразмерной системе координат, для каждого фактора определяются нулевые уровни и интервалы варьирования. Они будут использованы для определения градиента в данной точке.
3. Получаем значения коэффициентов регрессии.
4. Считаем выборочные дисперсии, и если они однородны, выводим значение дисперсии воспроизводимости
5. Проверяем на значимость коэффициенты регрессии.
В данном случае все коэффициенты значимы.
6. Получаем информацию о том, описывает ли уравнение эксперимент адекватно.
7. Делаем шаг в сторону, противоположную градиенту и находим новую точку (набор факторов).
8. Для нового набора переходим к шагу 2. Выполняем указанные действия до тех пор, пока не приблизимся к точке экстремума, на что указывает убыль последующих значений функции отклика.
Результаты работы программы
Матрица значений функции отклика системы:
.
Матрица помех:
.
Найденные значения факторов, про которых функция отклика принимает максимальное значение:
Вывод
В данном курсовом проекте рассматривался градиентный метод первого порядка, в качестве ядра которого использовался полный факторный эксперимент первого порядка, что предполагает такое проведение исследований, которое позволяет некоторым оптимальным образом получить информацию об объекте, оформить её в виде полиномиальной линейной модели и провести её статистический анализ. Так же в работе был составлен алгоритм моделирования , на основе которого была написана программа для проведения исследований градиентным методом.
Список литературы
Ю.П. Зайченко. Исследование операций. “Вища школа”. Киев 1988.
А.Г. Бондарь, Г.А. Статюха, Т. В. Землянкин , И.А. Потяженко. Планирование эксперимента при оптимизации процессов химической технологии. “Вища школа”. Киев 1980.
В.В. Кафаров. Методы кибернетики в химии и химической технологии. Москва. «Химия». 1985.
А.В. Бондаренко, Г.А. Статюха. Планирование эксперимента в химической технологии. “Вища школа”. Киев 1976.
5. А. Кофман, Р. Крюон “Массовое обслуживание. Теория и приложения”.
6. Е.С. Венцель “Исследование операций”.
Листинг программы
unit MainUnit;
interface
uses Windows,Classes,Graphics,SysUtils,StdCtrls,Math,Grids, ListControl,
Forms;
type
SelType = (stNONE,stPOINT,stCON); // Тип текущего элемента
PPoint = ^TPoint;
TPoint = record
UIN : integer;
Value : integer;
X,Y : integer;
end;
PConnection = ^TConnection;
TConnection = record
toPoint : PPoint;
fromPoint : PPoint;
Value : integer;
end;
CurElement = record
ceType : SelType;
element : pointer;
end;
TGraph = class
private
WasChanged : boolean;
ChangedAfter : boolean;
PointRadius : integer;
MaxUIN : integer;
Points : TList;
Connections : TList;
Selected,Current : CurElement;
function CheckCicle(FP,TP:PPoint):boolean;
function MouseOverPoint(X,Y:integer):PPoint;
function MouseOverConnection(X,Y:integer):PConnection;
procedure
DrawConnections(C:TCanvas;minW,minH,maxW,maxH:integer);
procedure DrawPoints(C:TCanvas;minW,minH,maxW,maxH:integer);
procedure Clear;
public
constructor Create;
destructor Destroy;override;
function MouseOver(X,Y:integer):CurElement;
function DeleteSelected:boolean;
procedure DrawGraph(C:TCanvas;minW,minH,maxW,maxH:integer);
procedure AddPoint(X,Y:integer;Value:integer);
function AddConnection(fromPoint,toPoint:PPoint;Value:integer):boolean;
procedure ChangeCur(dX,dY:integer);
procedure
ChangeCurAndDrawContur(X,Y,GridDelta:integer;C:TCanvas;DrawFirst,D
rawSecond:boolean);
procedure GetDeltaOfCurrent(X,Y:integer;var dX,dY:integer);
procedure SaveToFile(filename:string);
procedure OpenFromFile(filename:string);
procedure SelectCurrent;
procedure DeselectCurrent;
procedure MoveOnTop;
function IsChanged:boolean;
function WasChangedAfter:boolean;
function GetPoints:TList;
function GetConnections:TList;
function GetPointByID(ID:integer):PPoint;
procedure ZoomOn(coef:extended);
procedure ZoomOff(coef:extended);
procedure ChangeValue(Elem:CurElement;Value:integer);
function GetConsCount:integer;
function GetPointsCount:integer;
end;
PProcCon = ^TProcCon;
PProcPoint = ^TProcPoint;
TProcCon = record
Value : integer;
toPoint : PProcPoint;
Next : PProcCon;
end;
TProcPoint = record
UIN : integer;
Value : integer;
Merged : boolean;
UBorder,DBorder : integer;
UCon,DCon : integer;
UFixed,DFixed : boolean;
Prev,Next : PProcCon;
end;
PWay = ^TWay;
TWay = record
Numbers : string;
Length : integer;
Weight : integer;
Current : PProcPoint;
end;
PLinkTask = ^TLinkTask;
PProcTask = ^TProcTask;
PHolder = ^THolder;
THolder = record
Task : PProcTask;
Link : PLinkTask;
Next : PHolder;
end;
TProcTask = record
UIN : integer;
ProcNum : integer;
StartTime : integer;
Length : integer;
Prev : PHolder;
MayBeBefore : boolean;
MayBeAfter : boolean;
Ready : integer;
end;
TLinkTask = record
fromUIN : integer;
toUIN : integer;
fromProc : integer;
toProc : integer;
fromTask : PProcTask;
toTask : PProcTask;
StartTime : integer;
Length : integer;
PrevLink : PLinkTask;
PrevTask : PProcTask;
end;
PPossibleMove = ^TPossibleMove;
TPossibleMove = record
UIN : integer;
processor : integer;
afterUIN : integer;
ProcCount,Time:integer;
CurrentState : boolean;
end;
TSubMerger = class
private
Selected : PProcTask;
MinProcNum:integer;
MaxProcNum:integer;
Points : TList;
Procs : TList;
Links : TList;
AllProcTasks : Tlist;
function GetProcPointByUIN(UIN:integer):PProcPoint;
function GetProcTaskByUIN(UIN:integer):PProcTask;
procedure Clear;
procedure ClearProcs(FreeElements:boolean);
procedure ClearLinks(FreeElements:boolean);
procedure FormLinkTasksAndSetTimes(NumOfProcs:integer);
// -- Optimization -- //
procedure ClearPossibleMoves(var List:TList);
function GetPossibleMoves(UIN:integer):TList;
function GetTime:integer;
function GetProcCount:integer;
procedure SaveBackUp(var List:Tlist);
procedure RestoreBackUp(var
List:Tlist;NOP:integer;ClearCurrent:boolean);
public
constructor Create;
procedure Init(GPoints,GConnections:TList);
procedure DoBazovoe;
procedure SelectTask(UIN:integer);
procedure DeselectTask;
procedure MoveSelectedAfter(ProcNum,UIN:integer);
procedure ShowSubMerging(SG:TStringGrid);
function IncNumOfProc:boolean;
function DecNumOfProc:boolean;
function OptimizeOneStep(L1,L2:TLabel):boolean;
procedure OptimizeAuto(Form:TForm;L1,L2:TLabel);
end;
// --- --- --- //
function MinInt(I1,I2:integer):integer;
function MaxInt(I1,I2:integer):integer;
procedure MinMaxInt(I1,I2:integer;Var Min,Max:integer);
implementation
// -- Native functions -- //
function MinInt(I1,I2:integer):integer;
begin
if I1<I2 then Result:=I1 else Result:=I2
end;
function MaxInt(I1,I2:integer):integer;
begin
if I1>I2 then Result:=I1 else Result:=I2
end;
procedure MinMaxInt(I1,I2:integer;Var Min,Max:integer);
begin
if I1<I2 then
begin
Min:=I1;
Max:=I2
end
else
begin
Min:=I2;
Max:=I1
end
end;
// -- Objects -- //
function TGraph.GetConsCount:integer;
begin
Result:=Connections.Count
end;
function TGraph.GetPointsCount:integer;
begin
Result:=Points.Count
end;
procedure TGraph.ZoomOn(coef:extended);
var PP:PPoint;
i:integer;
begin
for i:=0 to Points.Count-1 do
begin
PP:=Points[i];
PP.X:=round(PP.X*coef);
PP.Y:=round(PP.Y*coef);
end;
end;
procedure TGraph.ZoomOff(coef:extended);
var PP:PPoint;
i:integer;
begin
for i:=0 to Points.Count-1 do
begin
PP:=Points[i];
PP.X:=round(PP.X/coef);
PP.Y:=round(PP.Y/coef);
end;
end;
constructor TGraph.Create;
begin
inherited Create;
MaxUIN:=0;
Points:=TList.Create;
Connections:=TList.Create;
Current.ceType := stNONE;
Current.element := nil;
Selected.ceType := stNONE;
Selected.element := nil;
PointRadius := 15;
WasChanged := false;
ChangedAfter := false;
end;
destructor TGraph.Destroy;
begin
Clear;
Points.Destroy;
Connections.Destroy;
inherited Destroy
end;
procedure TGraph.Clear;
begin
while Points.Count<>0 do
begin
dispose(PPoint(Points.first));
Points.delete(0);
end;
while Connections.Count<>0 do
begin
dispose(PConnection(Connections.first));
Connections.delete(0);
end;
MaxUIN:=0;
Current.ceType := stNONE;
Current.element := nil;
Selected.ceType := stNONE;
Selected.element := nil;
end;
function TGraph.DeleteSelected:boolean;
var i:integer;
PP:PPoint;
PC:PConnection;
begin
if Selected.ceType = stNONE
then Result:=false
else
begin
WasChanged:=true;
ChangedAfter:=true;
Result:=true;
if Selected.ceType = stCON then
begin
PC:=Selected.element;
for i:=0 to Connections.Count-1 do
begin
if Connections[i] = PC then
begin
Connections.delete(i);
break
end;
end;
dispose(PC);
end
else
begin
PP:=Selected.element;
for i:=0 to Points.Count-1 do
begin
if Points[i] = PP then
begin
Points.delete(i);
break
end;
end;
i:=0;
while i<Connections.Count do
begin
PC:=Connections[i];
if(PC.toPoint=PP)or(PC.fromPoint=PP)then
begin
Connections.delete(i);
dispose(PC)
end
else
i:=i+1
end;
dispose(PP)
end;
Selected.ceType:=stNONE;
Selected.element:=nil
end;
end;
procedure TGraph.MoveOnTop;
var PP:PPoint;
num:integer;
begin
if Current.ceType = stPoint then
begin
WasChanged:=true;
// ChangedAfter:=true;
PP:=Current.element;
num:=0;
while num<Points.count do
begin
if Points[num]=PP then break;
num:=num+1
end;
Points.delete(num);
Points.add(PP)
end;
end;
procedure TGraph.SelectCurrent;
begin
Selected:=Current
end;
procedure TGraph.DeselectCurrent;
begin
Selected.ceType:=stNONE;
Selected.element:=nil
end;
function TGraph.MouseOverPoint(X,Y:integer):PPoint;
var PP:PPoint;
d,i:integer;
begin
Result:=nil;
for i:=Points.Count-1 downto 0 do
begin
PP:=Points[i];
d := round(sqrt((X-PP.X)*(X-PP.X)+(Y-PP.Y)*(Y-PP.Y)));
if d<=15 then
begin
Result:=Points[i];
break
end;
end;
end;
function TGraph.MouseOverConnection(X,Y:integer):PConnection;
var PC:PConnection;
i:integer;
TX,TY,FX,FY,d:integer;
begin
Result:=nil;
for i:=Connections.Count-1 downto 0 do
begin
PC:=Connections[i];
if MinInt(PC.fromPoint.X,PC.toPoint.X) = PC.fromPoint.X then
begin
FX:=PC.fromPoint.X;
FY:=PC.fromPoint.Y;
TX:=PC.toPoint.X;
TY:=PC.toPoint.Y
end
else
begin
FX:=PC.toPoint.X;
FY:=PC.toPoint.Y;
TX:=PC.fromPoint.X;
TY:=PC.fromPoint.Y
end;
if (X>=FX-5)and(X<=TX+5)then
begin
d := (TY-FY)*X + (FX-TX)*Y + TX*FY - FX*TY;
d := abs(round(d/sqrt((TY-FY)*(TY-FY)+(FX-TX)*(FX-TX))));
if d<=5 then
begin
Result:=Connections[i];
break
end
end
end
end;
function TGraph.MouseOver(X,Y:integer):CurElement;
begin
current.element:=MouseOverPoint(X,Y);
if current.element<>nil then current.ceType:=stPOINT
else
begin
current.element:=MouseOverConnection(X,Y);
if current.element<>nil then current.ceType:=stCON
else current.ceType:=stNONE
end;
Result:=current;
end;
procedure TGraph.GetDeltaOfCurrent(X,Y:integer;var dX,dY:integer);
var PP:PPoint;
begin
PP:=current.element;
if PP<>nil then
begin
dX:=X - PP.X;
dY:=Y - PP.Y
end
else
begin
dX:=0;
dY:=0
end;
end;
procedure TGraph.ChangeCur(dX,dY:integer);
var PP:PPoint;
begin
WasChanged:=true;
// ChangedAfter:=true;
PP:=current.element;
if PP<>nil then
begin
PP.X:=PP.X+dx;
PP.Y:=PP.Y+dy
end
end;
procedure
TGraph.ChangeCurAndDrawContur(X,Y,GridDelta:integer;C:TCanvas;Dra
wFirst,DrawSecond:boolean);
var PP:PPoint;
begin
WasChanged:=true;
// ChangedAfter:=true;
if current.ceType<>stNONE then
begin
PP:=current.element;
C.Brush.Style:=bsClear;
C.Pen.Mode := pmNotXor;
C.Pen.Color:=clBlack;
C.Pen.Width:=1;
if DrawFirst then C.Ellipse(PP.X-PointRadius,PP.Y-
PointRadius,PP.X+PointRadius,PP.Y+PointRadius);
if GridDelta>1 then
begin
PP.X:=round(X/GridDelta)*GridDelta;
PP.Y:=round(Y/GridDelta)*GridDelta
end
else
begin
PP.X:=X;
PP.Y:=Y
end;
if DrawSecond then C.Ellipse(PP.X-PointRadius,PP.Y-
PointRadius,PP.X+PointRadius,PP.Y+PointRadius);
C.Pen.Mode := pmCopy;
C.Brush.Style:=bsSolid;
end;
end;
procedure getArrowCoord(Fx,Fy,Tx,Ty:integer;R,Alpha:Integer;var
Ar1X,Ar1Y,Ar2X,Ar2Y:integer);
var CosV,SinV,D,CosAd2:extended;
a,b,c,Descr:extended;
y1,y2,x1,x2:extended;
RCosAd2,RSinAd2:integer;
begin
D := sqrt((FX-TX)*(FX-TX)+(FY-TY)*(FY-TY));
if D<>0 then CosV := (FX-TX) / D else CosV:=0;
if CosV = 0 then
begin
RCosAd2 := round(R*Cos(Pi*Alpha/360));
RSinAd2 := round(R*Sin(Pi*Alpha/360));
Ar1X := TX + RSinAd2;
Ar2X := TX - RSinAd2;
if TY>FY then Ar1Y := TY - RCosAd2
else Ar1Y := TY + RCosAd2;
Ar2Y := Ar1Y;
end
else
begin
SinV := (FY-TY) / D;
CosAd2 := Cos(Pi*Alpha/360);
a:=1;
b:=-2*CosAd2*SinV;
c:=CosAd2*CosAd2-CosV*CosV;
Descr := b*b - 4*a*c;
y1 := (-b - sqrt(Descr))/(2*a);
y2 := (-b + sqrt(Descr))/(2*a);
x1 := (cosAd2 - sinV*y1) / cosV;
x2 := (cosAd2 - sinV*y2) / cosV;
Ar1X:=round(x1*R)+Tx;
Ar2X:=round(x2*R)+Tx;
Ar1Y:=round(y1*R)+Ty;
Ar2Y:=round(y2*R)+Ty;
end
end;
procedure
TGraph.DrawConnections(C:TCanvas;minW,minH,maxW,maxH:integer);
var i:integer;
PC:PConnection;
Ar1X,Ar1Y,Ar2X,Ar2Y:integer;
Poly:array[0..2]of Windows.TPoint;
D:extended;
FX,FY,TX,TY:integer;
s:string;
W,H,X,Y:integer;
begin
C.Pen.Color := clBlue;
for i:=0 to Connections.Count-1 do
begin
C.Brush.Color := clBlue;
PC:=Connections[i];
if Selected.element = PC then C.Pen.Width:=2
else C.Pen.Width:=1;
C.moveto(PC.fromPoint.X,PC.fromPoint.Y);
C.lineto(PC.toPoint.X,PC.toPoint.Y);
FX:=PC.fromPoint.X;
FY:=PC.fromPoint.Y;
TX:=PC.toPoint.X;
TY:=PC.toPoint.Y;
D := sqrt((FX-TX)*(FX-TX)+(FY-TY)*(FY-TY));
if D<>0 then
begin
TX := round( TX - PointRadius*(TX-FX)/D );
TY := round( TY - PointRadius*(TY-FY)/D );
end;
getArrowCoord(FX,FY,TX,TY,10,45,Ar1X,Ar1Y,Ar2X,Ar2Y);
//
getArrowCoord(PC.fromPoint.X,PC.fromPoint.Y,PC.toPoint.X,PC.toPoint.
Y,Poin tRadius,10,45,Ar1X,Ar1Y,Ar2X,Ar2Y);
Poly[0].x := TX;
Poly[0].y := TY;
Poly[1].x := Ar1X;
Poly[1].y := Ar1Y;
Poly[2].x := Ar2X;
Poly[2].y := Ar2Y;
C.Polygon(Poly);
s:=inttostr(PC.Value);
H:=C.TextHeight('A');
W:=C.TextWidth(s);
X:=round((FX+TX-W)/2)-3;
Y:=round((FY+TY-H)/2)-1;
C.Brush.Color := clWhite;
C.Rectangle(X,Y,X+W+7,Y+H+2);
C.Brush.style:=bsClear;
C.TextOut(X+3,Y+1,s);
C.Brush.style:=bsSolid;
{ C.moveto(Ar1X,Ar1Y);
C.lineto(PC.toPoint.X,PC.toPoint.Y);
C.moveto(Ar2X,Ar2Y);
C.lineto(PC.toPoint.X,PC.toPoint.Y);
}
end
end;
procedure
TGraph.DrawPoints(C:TCanvas;minW,minH,maxW,maxH:integer);
var i:integer;
PP:PPoint;
H,W:integer;
X1,X2,Y1,Y2:integer;
s:string;
begin
C.Brush.Style := bsSolid;
C.Brush.Color := clWhite;
C.Pen.Color := clBlack;
for i:=0 to Points.Count-1 do
begin
PP:=Points[i];
if Selected.element = PP then C.Pen.Width:=2
else C.Pen.Width:=1;
// C.Ellipse(PP.X-PointRadius,PP.Y-
PointRadius,PP.X+PointRadius,PP.Y+PointRadius+10);
X1:=PP.X-PointRadius;
Y1:=PP.Y-PointRadius;
X2:=PP.X+PointRadius;
Y2:=PP.Y+PointRadius;
if(X1<maxW)and(Y2<=maxH)and(X2>minW)and(Y2>minH)then
C.Ellipse(X1,Y1,X2,Y2);
s:=inttostr(PP.Value);
H:=C.TextHeight('A');
W:=C.TextWidth(s);
C.TextOut(round(PP.X-W/2),round(PP.Y-H/2),s)
end;
C.Brush.Style := bsClear;
C.Font.Color:=clBlack;
C.Font.Style:=[fsBold];
for i:=0 to Points.Count-1 do
begin
PP:=Points[i];
s:=inttostr(PP.UIN);
H:=C.TextHeight('A');
W:=C.TextWidth(s);
C.TextOut(round(PP.X+PointRadius-W/2),PP.Y-PointRadius-H-1,s)
end;
C.Font.Style:=[];
C.Brush.Style := bsSolid;
end;
procedure
TGraph.DrawGraph(C:TCanvas;minW,minH,maxW,maxH:integer);
begin
DrawConnections(C,minW,minH,maxW,maxH);
DrawPoints(C,minW,minH,maxW,maxH);
end;
procedure TGraph.AddPoint(X,Y:integer;Value:integer);
var PP:PPoint;
begin
WasChanged:=true;
ChangedAfter:=true;
MaxUIN:=MaxUIN+1;
new(PP);
PP.UIN:=MaxUIN;
PP.X:=X;
PP.Y:=Y;
PP.Value:=Value;
Points.Add(PP);
end;
function TGraph.CheckCicle(FP,TP:PPoint):boolean;
var List : TList;
PC:PConnection;
CurP:PPoint;
i:integer;
begin
Result:=true;
List:= TList.create;
List.add(TP);
while List.Count<>0 do
begin
CurP:=List.first;
List.delete(0);
if CurP = FP then
begin
Result:=false;
break
end;
for i:=0 to Connections.Count-1 do
begin
PC:=Connections[i];
if PC.fromPoint = CurP then List.Add(PC.toPoint)
end
end;
List.clear;
List.Destroy
end;
function
TGraph.AddConnection(fromPoint,toPoint:PPoint;Value:integer):boolean;
var PC:PConnection;
begin
if(fromPoint<>toPoint) and CheckCicle(fromPoint,toPoint) then
begin
WasChanged:=true;
ChangedAfter:=true;
new(PC);
PC.fromPoint:=fromPoint;
PC.toPoint:=toPoint;
PC.Value:=Value;
Connections.Add(PC);
Result:=true
end
else
Result:=false
end;
procedure TGraph.SaveToFile(filename:string);
var f:file;
PP:PPoint;
PC:PConnection;
i:integer;
begin
assign(f,filename);
rewrite(f,1);
BlockWrite(f,Points.Count,SizeOf(integer));
BlockWrite(f,Connections.Count,SizeOf(integer));
for i:=0 to Points.Count-1 do
begin
PP:=Points[i];
BlockWrite(f,PP,SizeOf(PP));
BlockWrite(f,PP^,SizeOf(PP^));
end;
for i:=0 to Connections.Count-1 do
begin
PC:=Connections[i];
// BlockWrite(f,PC,SizeOf(PC));
BlockWrite(f,PC^,SizeOf(PC^));
end;
close(f);
end;
procedure TGraph.OpenFromFile(filename:string);
type
PAddr = ^TAddr;
TAddr = record
Old,New:pointer;
end;
var f:file;
Addresses:TList;
PA:PAddr;
PP:PPoint;
PC:PConnection;
p:pointer;
i,NOP,NOC:integer;
procedure SetNewAddr(iOld,iNew:pointer);
var PA:PAddr;
begin
new(PA);
PA.Old:=iOld;
Pa.New:=iNew;
Addresses.add(PA)
end;
function GetNewAddr(Old:pointer):pointer;
var i:integer;
begin
Result:=nil;
for i:=0 to Addresses.Count-1 do
if PAddr(Addresses[i]).Old = Old then
begin
Result:=PAddr(Addresses[i]).New;
Break
end;
end;
begin
MaxUIN:=0;
Clear;
WasChanged:=false;
ChangedAfter:=false;
Addresses:=TList.Create;
assign(f,filename);
reset(f,1);
BlockRead(f,NOP,SizeOf(integer));
BlockRead(f,NOC,SizeOf(integer));
for i:=0 to NOP-1 do
begin
new(PP);
BlockRead(f,p,SizeOf(p));
BlockRead(f,PP^,SizeOf(PP^));
Points.Add(PP);
SetNewAddr(p,PP);
If MaxUIN < PP.UIN then MaxUIN:=PP.UIN
end;
for i:=0 to NOC-1 do
begin
new(PC);
BlockRead(f,PC^,SizeOf(PC^));
PC.toPoint:=GetNewAddr(PC.toPoint);
PC.fromPoint:=GetNewAddr(PC.fromPoint);
Connections.Add(PC);
end;
close(f);
while Addresses.Count<>0 do
begin
PA:=Addresses.first;
Addresses.Delete(0);
dispose(PA);
end;
Addresses.Destroy
end;
function TGraph.IsChanged:boolean;
begin
Result:=WasChanged
end;
function TGraph.WasChangedAfter:boolean;
begin
Result:=ChangedAfter;
ChangedAfter:=false;
end;
function TGraph.GetPointByID(ID:integer):PPoint;
var PP:PPoint;
i:integer;
begin
Result:=nil;
for i:=0 to Points.Count-1 do
begin
PP:=Points[i];
if PP.UIN=ID then
begin
Result:=PP;
break
end;
end;
end;
function TGraph.GetPoints:TList;
begin
Result:=Points
end;
function TGraph.GetConnections:TList;
begin
Result:=Connections
end;
procedure TGraph.ChangeValue(Elem:CurElement;Value:integer);
begin
if Elem.element<>nil then
begin
case Elem.ceType of
stPOINT:PPoint(Elem.element).Value:=Value;
stCON :PConnection(Elem.element).Value:=Value;
end;
WasChanged:=true;
ChangedAfter:=true
end
end;
// --- SubMerger --- //
constructor TSubMerger.Create;
begin
Points := TList.Create;
AllProcTasks := TList.Create;
Procs:=TList.Create;
Links:=TList.Create
end;
procedure TSubMerger.ClearProcs(FreeElements:boolean);
var PPT:PProcTask;
PH:PHolder;
tmpPoint:pointer;
List:TList;
begin
Selected:=nil;
while Procs.Count<>0 do
begin
List:=Procs.first;
Procs.delete(0);
while List.Count<>0 do
begin
PPT:=List.first;
List.delete(0);
PH:=PPT.Prev;
while PH<>nil do
begin
tmpPoint:=PH.Next;
dispose(PH);
PH:=tmpPoint
end;
PPT.Prev:=nil;
PPT.MayBeAfter:=false;
PPT.MayBeBefore:=false;
if FreeElements then dispose(PPT);
end;
List.destroy;
end;
if FreeElements then AllProcTasks.clear;
end;
procedure TSubMerger.ClearLinks(FreeElements:boolean);
var PLT:PLinkTask;
List:TList;
begin
while Links.Count<>0 do
begin
List:=Links.first;
Links.delete(0);
while List.Count<>0 do
begin
PLT:=List.first;
List.delete(0);
PLT.PrevLink:=nil;
PLT.PrevTask:=nil;
if FreeElements then dispose(PLT);
end;
List.destroy;
end;
end;
procedure TSubMerger.Clear;
var PPP:PProcPoint;
PPC:PProcCon;
begin
while Points.Count<>0 do
begin
PPP:=Points.first;
Points.delete(0);
while PPP.Prev<>nil do
begin
PPC:=PPP.Prev.Next;
dispose(PPP.Prev);
PPP.Prev:=PPC
end;
while PPP.Next<>nil do
begin
PPC:=PPP.Next.Next;
dispose(PPP.Next);
PPP.Next:=PPC
end;
dispose(PPP)
end;
ClearLinks(true);
ClearProcs(true);
AllProcTasks.Clear;
{
while FProcTasks.Count<>0 do
begin
PPT:=FProcTasks.first;
FProcTasks.delete(0);
dispose(PPT)
end;
while FLinkTasks.Count<>0 do
begin
PLT:=FLinkTasks.first;
FLinkTasks.delete(0);
dispose(PLT)
end;
}
end;
function TSubMerger.GetProcPointByUIN(UIN:integer):PProcPoint;
var i:integer;
begin
Result:=nil;
for i:=0 to Points.Count-1 do
if PProcPoint(Points[i]).UIN = UIN then
begin
Result:=Points[i];
break
end;
end;
function TSubMerger.GetProcTaskByUIN(UIN:integer):PProcTask;
var i:integer;
begin
Result:=nil;
for i:=0 to AllProcTasks.Count-1 do
if PProcTask(AllProcTasks[i]).UIN = UIN then
begin
Result:=AllProcTasks[i];
break
end;
end;
procedure TSubMerger.Init(GPoints,GConnections:TList);
var i:integer;
PP:PPoint;
PC:PConnection;
PPP:PProcPoint;
PPC:PProcCon;
begin
Clear;
for i:=0 to GPoints.Count-1 do
begin
PP:=GPoints[i];
new(PPP);
PPP.UIN := PP.Uin;
PPP.Value := PP.Value;
PPP.UBorder:=0;
PPP.DBorder:=$8FFFFFFF;
PPP.UFixed:=false;
PPP.DFixed:=false;
PPP.UCon:=0;
PPP.DCon:=0;
PPP.Prev:=nil;
PPP.Next:=nil;
Points.Add(PPP);
end;
for i:=0 to GConnections.Count-1 do
begin
PC:=GConnections[i];
PPP := GetProcPointByUIN(PC.fromPoint.UIN);
new(PPC);
PPC.Value := PC.Value;
PPC.toPoint := GetProcPointByUIN(PC.toPoint.UIN);
PPC.Next := PPP.Next;
PPP.Next := PPC;
PPP := GetProcPointByUIN(PC.toPoint.UIN);
new(PPC);
PPC.Value := PC.Value;
PPC.toPoint := GetProcPointByUIN(PC.fromPoint.UIN);
PPC.Next := PPP.Prev;
PPP.Prev := PPC;
end;
end;
procedure SetUBorderToPPP(PPP:PProcPoint;Value:integer);
var PPC:PProcCon;
Fix:boolean;
begin
if PPP.UBorder < Value then PPP.UBorder := Value;
PPC:=PPP.Prev;
Fix:=true;
while PPC<>nil do
begin
if not PPC.toPoint.DFixed then
begin
Fix:=false;
Break
end;
PPC:=PPC.Next
end;
PPP.UFixed:=Fix
end;
procedure SetDBorderToPPP(PPP:PProcPoint;Value:integer);
var PPC:PProcCon;
Fix:boolean;
begin
if PPP.DBorder > Value then PPP.DBorder := Value;
PPC:=PPP.Next;
Fix:=true;
while PPC<>nil do
begin
if not PPC.toPoint.UFixed then
begin
Fix:=false;
Break
end;
PPC:=PPC.Next
end;
PPP.DFixed:=Fix
end;
procedure SetUBorderDown(PPP:PProcPoint;Value:integer);
var PPC:PProcCon;
workPPP:PProcPoint;
List:TList;
begin
List:=TList.create;
if PPP.UBorder < Value then
begin
PPP.UBorder := Value;
List.Add(PPP);
while List.Count<>0 do
begin
workPPP:=List[0];
List.delete(0);
PPC:=workPPP.Next;
while PPC<>nil do
begin
if PPC.toPoint.UBorder < workPPP.UBorder+1 then
begin
PPC.toPoint.UBorder:=workPPP.UBorder+1;
List.Add(PPC.toPoint)
end;
PPC:=PPC.Next
end;
end;
end;
List.Destroy;
end;
procedure SetDBorderUp(PPP:PProcPoint;Value:integer);
var PPC:PProcCon;
workPPP:PProcPoint;
List:TList;
begin
List:=TList.create;
if PPP.DBorder > Value then
begin
PPP.DBorder := Value;
List.Add(PPP);
while List.Count<>0 do
begin
workPPP:=List[0];
List.delete(0);
PPC:=workPPP.Prev;
while PPC<>nil do
begin
if PPC.toPoint.DBorder > workPPP.DBorder-1 then
begin
PPC.toPoint.DBorder:=workPPP.DBorder-1;
List.Add(PPC.toPoint)
end;
PPC:=PPC.Next
end;
end;
end;
List.Destroy;
end;
procedure SetProcToPPP(PPP:PProcPoint;Value:integer);
var PPC:PProcCon;
begin
PPP.UBorder:=Value;
PPP.DBorder:=Value;
PPP.UFixed:=true;
PPP.DFixed:=true;
PPP.Merged:=true;
PPC:=PPP.Prev;
while PPC<>nil do
begin
if not PPC.toPoint.Merged then
begin
//if PPC.toPoint.DBorder>PPP.UBorder-1 then
SetDBorderToPPP(PPC.toPoint,PPP.UBorder-1);
SetDBorderToPPP(PPC.toPoint,PPP.UBorder-1);
PPC.toPoint.DCon:=PPC.toPoint.DCon+PPC.Value;
end;
PPC:=PPC.Next;
end;
PPC:=PPP.Next;
while PPC<>nil do
begin
if not PPC.toPoint.Merged then
begin
//if PPC.toPoint.UBorder<PPP.DBorder+1 then
SetUBorderToPPP(PPC.toPoint,PPP.DBorder+1);
SetUBorderToPPP(PPC.toPoint,PPP.DBorder+1);
PPC.toPoint.UCon:=PPC.toPoint.UCon+PPC.Value;
end;
PPC:=PPC.Next;
end;
end;
procedure TSubMerger.DoBazovoe;
var i,j,p:integer;
PPP:PProcPoint;
PPC:PProcCon;
PW,newPW:PWay;
WorkList : TList;
WaysList : TList;
MaxWayLength : integer;
s : string;
//-->>
Pretender:PProcPoint;
NoChange:boolean;
PretenderCon : integer;
//-->>
PPT:PProcTask;
begin
ClearLinks(true);
ClearProcs(true);
AllProcTasks.Clear;
WaysList := TList.Create;
WorkList := TList.Create;
for i:=0 to Points.Count-1 do
begin
PPP:=Points[i];
PPP.UBorder:=0;
PPP.DBorder:=$7FFFFFFF;
PPP.UCon:=0;
PPP.DCon:=0;
PPP.UFixed:=false;
PPP.DFixed:=false;
PPP.Merged:=false;
WorkList.Add(PPP)
end;
for i:=0 to Points.Count-1 do
begin
PPP:=Points[i];
PPC:=PPP.Next;
while PPC<>nil do
begin
for j:=0 to WorkList.Count-1 do
if PPC.toPoint = WorkList[j] then
begin
WorkList.delete(j);
break
end;
PPC:=PPC.Next
end;
end;
for i:=0 to WorkList.Count-1 do
begin
PPP:=WorkList[i];
new(PW);
PW.Length:=1;
PW.Numbers:=inttostr(PPP.UIN)+',';
PW.Weight:=PPP.Value;
PW.Current:=PPP;
WorkList[i]:=PW
end;
while WorkList.Count<>0 do
begin
PW:=WorkList.first;
WorkList.delete(0);
if PW.Current.Next=nil then WaysList.Add(PW)
else
begin
PPC:=PW.Current.Next;
while PPC<>nil do
begin
new(newPW);
newPW.Length:=PW.Length+1;
newPW.Weight:=PW.Weight+PPC.Value+PPC.toPoint.Value;
newPW.Numbers:=PW.Numbers+inttostr(PPC.toPoint.UIN)+',';
newPW.Current:=PPC.toPoint;
WorkList.Add(newPW);
PPC:=PPC.Next
end;
dispose(PW)
end;
end;
MaxWayLength := 0;
for i:=0 to WaysList.Count-1 do
begin
PW:=WaysList[i];
if PW.Length > MaxWayLength then MaxWayLength:=PW.Length
end;
for i:=0 to Points.Count-1 do
begin
PPP:=Points[i];
if PPP.Prev = nil then SetUBorderDown(PPP,1);
if PPP.Next = nil then SetDBorderUp(PPP,MaxWayLength);
end;
for i:=0 to Points.Count-1 do
begin
PPP:=Points[i];
if PPP.UBorder = PPP.DBorder then SetProcToPPP(PPP,PPP.UBorder);
end;
Pretender:=nil;
PretenderCon:=0;
repeat
NoChange:=true;
for i:=0 to Points.Count-1 do
begin
PPP:=Points[i];
if not PPP.merged then
begin
if PPP.UFixed and PPP.DFixed then
begin
if PPP.UCon > PPP.DCon then SetProcToPPP(PPP,PPP.UBorder)
else SetProcToPPP(PPP,PPP.DBorder);
Pretender:=nil;
NoChange:=false;
break
end
else
begin
if PPP.UFixed then
begin
if(Pretender = nil)or(PretenderCon < PPP.UCon) then
begin
Pretender:=PPP;
PretenderCon := PPP.UCon
end;
end
else
if PPP.DFixed then
begin
if(Pretender = nil)or(PretenderCon < PPP.DCon) then
begin
Pretender:=PPP;
PretenderCon := PPP.DCon
end;
end;
end;
end;
end;
if Pretender<>nil then
begin
if Pretender.UFixed then SetProcToPPP(Pretender,Pretender.UBorder)
else SetProcToPPP(Pretender,Pretender.DBorder);
Pretender:=nil;
PretenderCon:=0;
NoChange:=false;
end;
until NoChange;
for i:=0 to Points.Count-1 do
begin
PPP:=Points[i];
new(PPT);
PPT.ProcNum:=PPP.UBorder;
PPT.ProcNum:=PPP.DBorder;
PPT.Ready:=0;
PPT.UIN:=PPP.UIN;
PPT.StartTime:=0;
PPT.Length:=PPP.Value;
PPT.Prev:=nil;
PPT.MayBeAfter:=false;
PPT.MayBeBefore:=false;
PPC:=PPP.Prev;
while PPC<>nil do
begin
PPT.Ready:=PPT.Ready+1;
PPC:=PPC.next
end;
j:=0;
while j<=AllProcTasks.Count-1 do
begin
if PProcTask(AllProcTasks[j]).Ready > PPT.Ready then break;
j:=j+1;
end;
AllProcTasks.Add(PPT);
end;
FormLinkTasksAndSetTimes(MaxWayLength);
end;
procedure SetProcTimes(List:TList);
var i,j:integer;
PPT:PProcTask;
PH:PHolder;
Time,dTime:integer;
begin
Time:=1;
for i:=0 to List.Count-1 do
begin
PPT:=List[i];
PPT.StartTime:=Time;
Time:=Time+PPT.Length;
end;
for i:=0 to List.Count-1 do
begin
PPT:=List[i];
Time:=PPT.StartTime;
PH:=PPT.Prev;
while PH<>nil do
begin
if PH.Task<>nil then
begin
if Time < PH.Task.StartTime+PH.Task.Length then
Time:= PH.Task.StartTime+PH.Task.Length
end
else
begin
if Time < PH.Link.StartTime+PH.Link.Length then
Time:= PH.Link.StartTime+PH.Link.Length
end;
PH:=PH.Next
end;
if Time > PPT.StartTime then
begin
dTime:=Time-PPT.StartTime;
PPT.StartTime:=Time;
for j:=i+1 to List.Count-1 do
PProcTask(List[j]).StartTime:=PProcTask(List[j]).StartTime+dTime
end;
end;
end;
procedure SetProcStartTimes(List:TList);
var i:integer;
PPT:PProcTask;
Time:integer;
begin
Time:=1;
for i:=0 to List.Count-1 do
begin
PPT:=List[i];
PPT.StartTime:=Time;
Time:=Time+PPT.Length;
end;
end;
function PLT_TimeCompare(I1,I2:Pointer):integer;
var D1,D2:integer;
Item1,Item2:PLinkTask;
begin
Item1:=I1;
Item2:=I2;
if Item1.StartTime<Item2.StartTime then Result:=-1
else
if Item1.StartTime>Item2.StartTime then Result:=1
else
begin
if Item1.toProc = Item2.toProc then
begin
if Item1.toTask.StartTime<Item2.toTask.StartTime then Result:=-1
else
if Item1.toTask.StartTime>Item2.toTask.StartTime then Result:=1
else Result:=0
end
else
begin
D1:=Item1.toProc - Item1.fromProc;
D2:=Item2.toProc - Item2.fromProc;
if D1>D2 then Result:=1
else
if D1<D2 then Result:=-1
else
begin
if Item1.toProc<Item2.toProc then Result:=-1
else
if Item1.toProc>Item2.toProc then Result:=1
else
Result:=0
end;
end;
end;
end;
procedure SetLinkTimes(List:TList);
var i:integer;
PLT:PLinkTask;
Time:integer;
begin
for i:=0 to List.Count-1 do
begin
PLT:=List[i];
if PLT.PrevTask<>nil then
Time:= PLT.PrevTask.StartTime+PLT.PrevTask.Length
else
Time:= PLT.PrevLink.StartTime+PLT.PrevLink.Length;
PLT.StartTime:=Time;
end;
List.Sort(PLT_TimeCompare);
Time:=1;
for i:=0 to List.Count-1 do
begin
PLT:=List[i];
if Time>PLT.StartTime then PLT.StartTime:=Time;
Time:=PLT.StartTime+PLT.Length;
end;
end;
зrocedure TSubMerger.FormLinkTasksAndSetTimes(NumOfProcs:integer);
var i,j,k:integer;
PPT,toPPT:PProcTask;
PLT:PLinkTask;
PPP:PProcPoint;
PPC:PProcCon;
PH:PHolder;
tmpPoint : pointer;
List:TList;
begin
ClearLinks(true);
ClearProcs(false);
if NumOfProcs<>0 then
begin
List:=TList.Create;;
Procs.Add(list);
for i:=1 to NumOfProcs-1 do
begin
List:=TList.Create;;
Procs.Add(list);
List:=TList.Create;
Links.Add(List)
end;
end;
for i:=0 to AllProcTasks.Count-1 do
begin
PPT:=AllProcTasks[i];
List:=Procs[PPT.ProcNum-1];
List.Add(PPT);
end;
// Формированик Линков
for i:=1 to Procs.Count-1 do
begin
List:=Procs[i];
for j:=0 to List.Count-1 do
begin
PPT:=List[j];
PPP:=GetProcPointByUIN(PPT.UIN);
PPC:=PPP.Prev;
while PPC<>nil do
begin
toPPT:=GetProcTaskByUIN(PPC.toPoint.UIN);
if toPPT.ProcNum = PPT.ProcNum then
begin
new(PH);
PH.Task:=toPPT;
PH.Link:=nil;
PH.Next:=PPT.Prev;
PPT.Prev:=PH;
end
else
begin
new(PLT);
PLT.length:=PPC.Value;
PLT.fromUIN:=toPPT.UIN;
PLT.fromProc:=toPPT.ProcNum;
PLT.toUIN:=PPT.UIN;
PLT.toProc:=PPT.ProcNum;
PLT.fromTask:=toPPT;
PLT.toTask:=PPT;
PLT.StartTime:=0;
PLT.PrevTask:=toPPT;
PLT.PrevLink:=nil;
Tlist(Links[toPPT.ProcNum-1]).Add(PLT);
tmpPoint:=PLT;
for k:=toPPT.ProcNum to PPT.ProcNum-2 do
begin
new(PLT);
PLT.length:=PPC.Value;
PLT.fromUIN:=toPPT.UIN;
PLT.fromProc:=toPPT.ProcNum;
PLT.toUIN:=PPT.UIN;
PLT.toProc:=PPT.ProcNum;
PLT.fromTask:=toPPT;
PLT.toTask:=PPT;
PLT.StartTime:=0;
PLT.PrevTask:=nil;
PLT.PrevLink:=tmpPoint;
Tlist(Links[k]).Add(PLT);
tmpPoint:=PLT
end;
new(PH);
PH.Task:=nil;
PH.Link:=tmpPoint;
PH.Next:=PPT.Prev;
PPT.Prev:=PH;
end;
PPC:=PPC.next
end;
end;
end;
for i:=0 to Procs.Count-1 do
SetProcStartTimes(Procs[i]);
for i:=0 to Procs.Count+Links.Count-1 do
if i mod 2 = 0 then SetProcTimes(Procs[i div 2])
else SetLinkTimes(Links[i div 2])
end;
procedure TSubMerger.ShowSubMerging(SG:TStringGrid);
var i,j,k:integer;
NumOfRows:integer;
List:TList;
PPT:PProcTask;
PLT:PLinkTask;
begin
NumOfRows:=1;
for i:=0 to Procs.Count-1 do
begin
List:=Procs[i];
if List.Count<>0 then
begin
PPT:=List.last;
if NumOfRows<PPT.StartTime+PPT.Length then
NumOfRows:=PPT.StartTime+PPT.Length;
end;
end;
for i:=0 to Links.Count-1 do
begin
List:=Links[i];
if List.Count<>0 then
begin
PLT:=List.last;
if NumOfRows<PLT.StartTime+PLT.Length then
NumOfRows:=PLT.StartTime+PLT.Length;
end;
end;
// Чистим сетку //
SG.RowCount:=NumOfRows;
if Procs.Count<>0 then SG.ColCount:=2*Procs.Count
else SG.ColCount:=0;
for i:=1 to SG.RowCount-1 do
for j:=1 to SG.ColCount-1 do SG.Cells[j,i]:='';
for i:=1 to SG.RowCount-1 do
SG.Cells[0,i]:=inttostr(i);
for i:=1 to SG.ColCount-1 do
if i mod 2 = 1 then SG.Cells[i,0]:=inttostr((i div 2)+1)
else SG.Cells[i,0]:='->';
if Selected<>nil then
for i:=MinProcNum-1 to MaxProcNum-1 do
begin
List:=Procs[i];
if List.Count<>0 then
begin
if(PProcTask(List.first).MayBeBefore)or(Selected=List.first)then
SG.Cells[2*i+1,0]:='m'+SG.Cells[2*i+1,0]
end
else
SG.Cells[2*i+1,0]:='m'+SG.Cells[2*i+1,0]
end;
SG.Cells[0,0]:='';
if SG.ColCount<>1 then
begin
SG.FixedCols:=1;
SG.FixedRows:=1;
end;
// Вывод
for i:=0 to Procs.Count-1 do
begin
List:=Procs[i];
for j:=0 to List.Count-1 do
begin
PPT:=List[j];
for k:=PPT.StartTime to PPT.StartTime+PPT.Length-1 do
begin
SG.Cells[2*i+1,k]:=inttostr(PPT.UIN);
if Selected = PPT then SG.Cells[2*i+1,k]:='s'+SG.Cells[2*i+1,k]
else
if PPT.MayBeAfter then SG.Cells[2*i+1,k]:='m'+SG.Cells[2*i+1,k]
end
end;
end;
for i:=0 to Links.Count-1 do
begin
List:=Links[i];
for j:=0 to List.Count-1 do
begin
PLT:=List[j];
for k:=PLT.StartTime to PLT.StartTime+PLT.Length-1 do
SG.Cells[2*i+2,k]:=inttostr(PLT.fromUIN)+':'+inttostr(PLT.toUIN);
end;
end;
end;
procedure TSubMerger.SelectTask(UIN:integer);
var i,j:integer;
PPP,tmpPPP:PProcPoint;
PPC,prevPPC:PProcCon;
PPT:PProcTask;
PH:PHolder;
List:TList;
newStartIndex,StartIndex,EndIndex:integer;
Reset:boolean;
begin
Selected:=GetProcTaskByUIN(UIN);
for i:=0 to AllProcTasks.Count-1 do
begin
PPT:=AllProcTasks[i];
PPT.MayBeAfter:= PPT.UIN<>UIN;
PPT.MayBeBefore:=PPT.MayBeAfter
end;
List:=TList.Create;
MinProcNum:=1;
MaxProcNum:=Procs.Count;
PPP:=GetProcPointByUIN(UIN);
PPC:=PPP.Prev;
while PPC<>nil do
begin
PPT:=GetProcTaskByUIN(PPC.toPoint.UIN);
if PPT.ProcNum > MinProcNum then MinProcNum:=PPT.ProcNum;
PPC:=PPC.Next
end;
PPC:=PPP.Next;
while PPC<>nil do
begin
PPT:=GetProcTaskByUIN(PPC.toPoint.UIN);
if PPT.ProcNum < MaxProcNum then MaxProcNum:=PPT.ProcNum;
PPC:=PPC.Next
end;
PPC:=PPP.Next;
while PPC<>nil do
begin
List.Add(PPC.toPoint);
PPC:=PPC.Next
end;
while List.Count<>0 do
begin
tmpPPP:=List.first;
GetProcTaskByUIN(tmpPPP.UIN).MayBeAfter:=false;
List.Delete(0);
PPC:=tmpPPP.Next;
while PPC<>nil do
begin
List.Add(PPC.toPoint);
PPC:=PPC.next
end;
end;
PPC:=PPP.Prev;
while PPC<>nil do
begin
List.Add(PPC.toPoint);
PPC:=PPC.Next
end;
while List.Count<>0 do
begin
tmpPPP:=List.first;
GetProcTaskByUIN(tmpPPP.UIN).MayBeBefore:=false;
List.Delete(0);
PPC:=tmpPPP.Prev;
while PPC<>nil do
begin
List.Add(PPC.toPoint);
PPC:=PPC.next
end;
end;
{ PPC:=PPP.Prev;
while PPC<>nil do
begin
PPT:=GetProcTaskByUIN(PPC.toPoint.UIN);
PPT.MayBeAfter:= not (PPT.ProcNum < MinProcNum);
prevPPC:=PPC.toPoint.Prev;
while prevPPC<>nil do
begin
List.Add(prevPPC.toPoint);
prevPPC:=prevPPC.Next
end;
PPC:=PPC.Next
end;
while List.Count<>0 do
begin
tmpPPP:=List.First;
List.delete(0);
PPT:=GetProcTaskByUIN(tmpPPP.UIN);
PPT.MayBeAfter:=false;
PPC:=tmpPPP.Prev;
while PPC<>nil do
begin
List.Add(PPC.toPoint);
PPC:=PPC.Next
end;
end;
//<<<
PPC:=PPP.Next;
while PPC<>nil do
begin
PPT:=GetProcTaskByUIN(PPC.toPoint.UIN);
PPT.MayBeBefore:= not (PPT.ProcNum > MaxProcNum);
prevPPC:=PPC.toPoint.Next;
while prevPPC<>nil do
begin
List.Add(prevPPC.toPoint);
prevPPC:=prevPPC.Next
end;
PPC:=PPC.Next
end;
while List.Count<>0 do
begin
tmpPPP:=List.First;
List.delete(0);
PPT:=GetProcTaskByUIN(tmpPPP.UIN);
PPT.MayBeBefore:=false;
PPC:=tmpPPP.Next;
while PPC<>nil do
begin
List.Add(PPC.toPoint);
PPC:=PPC.Next
end;
end;
}
List.Destroy;
for i:=1 to MinProcNum-1 do
begin
List:=Procs[i-1];
for j:=0 to List.Count-1 do
begin
PPT:= PProcTask(List[j]);
PPT.MayBeAfter:=false;
PPT.MayBeBefore:=false
end;
end;
for i:=MaxProcNum+1 to Procs.Count do
begin
List:=Procs[i-1];
for j:=0 to List.Count-1 do
begin
PPT:= PProcTask(List[j]);
PPT.MayBeAfter:=false;
PPT.MayBeBefore:=false
end;
end;
for i:=MinProcNum to MaxProcNum do
begin
List:=Procs[i-1];
Reset:=false;
for j:=0 to List.Count-1 do
if Selected<>List[j] then
begin
if Reset then
begin
PPT:=PProcTask(List[j]);
PPT.MayBeAfter:=false;
end
else Reset:=not PProcTask(List[j]).MayBeAfter
end;
Reset:=false;
for j:=List.Count-1 downto 0 do
if Selected<>List[j] then
begin
if Reset then
begin
PPT:=PProcTask(List[j]);
PPT.MayBeAfter:=false;
PPT.MayBeBefore:=false;
end
else Reset:=not PProcTask(List[j]).MayBeBefore
end;
end;
end;
procedure TSubMerger.DeselectTask;
var i:integer;
PPT:PProcTask;
begin
Selected:=nil;
for i:=0 to AllProcTasks.Count-1 do
begin
PPT:=AllProcTasks[i];
PPT.MayBeAfter:= false;
PPT.MayBeBefore:=false;
end;
end;
procedure TSubMerger.MoveSelectedAfter(ProcNum,UIN:integer);
var i:integer;
PPT:PProcTask;
begin
if Selected<>nil then
begin
if UIN<>-1 then
begin
PPT:=GetProcTaskByUIN(UIN);
if PPT.MayBeAfter then
begin
Selected.ProcNum:=PPT.ProcNum;
AllProcTasks.delete(AllProcTasks.IndexOf(Selected));
AllProcTasks.insert(AllProcTasks.IndexOf(PPT)+1,Selected);
FormLinkTasksAndSetTimes(Procs.Count);
end;
end
else
begin
Selected.ProcNum:=ProcNum;
AllProcTasks.delete(AllProcTasks.IndexOf(Selected));
i:=0;
while i<AllProcTasks.Count do
begin
if PProcTask(AllProcTasks[i]).ProcNum=ProcNum then break;
i:=i+1
end;
AllProcTasks.insert(i,Selected);
end;
FormLinkTasksAndSetTimes(Procs.Count);
end;
end;
function TSubMerger.IncNumOfProc:boolean;
var List:TList;
begin
if Procs.Count<>0 then
begin
List:=TList.Create;
Procs.Add(List);
List:=TList.Create;
Links.Add(List);
List:=nil;
Result:=true
end
else Result:=false
end;
function TSubMerger.DecNumOfProc:boolean;
var i,FoundNum:integer;
PPT:PProcTask;
begin
FoundNum:=0;
while FoundNum<Procs.Count do
begin
if TList(Procs[FoundNum]).Count=0 then break;
FoundNum:=FoundNum+1
end;
if FoundNum<Procs.Count then
begin
Procs.Delete(FoundNum);
for i:=0 to AllProcTasks.Count-1 do
begin
PPT:=AllProcTasks[i];
if PPT.ProcNum>FoundNum then PPT.ProcNum:=PPT.ProcNum-1;
end;
FormLinkTasksAndSetTimes(Procs.Count);
Result:=true
end
else Result:=false;
end;
procedure TSubMerger.ClearPossibleMoves(var List:TList);
var PMT:PPossibleMove;
begin
while List.Count<>0 do
begin
PMT:=List.first;
List.delete(0);
dispose(PMT)
end;
List.Destroy
end;
function TSubMerger.GetPossibleMoves(UIN:integer):TList;
var i:integer;
PMT:PPossibleMove;
PPT:PProcTask;
List:TList;
begin
Result:=TList.Create;
SelectTask(UIN);
for i:=MinProcNum-1 to MaxProcNum-1 do
begin
List:=Procs[i];
if(List.Count=0)or((List.Count<>0)and(PProcTask(List.first).MayBeBefore)
or(Selected=List.first))then
begin
new(PMT);
PMT.UIN:=UIN;
PMT.processor:=i+1;
PMT.afterUIN:=-1;
PMT.Time:=$7FFFFFFF;
PMT.ProcCount:=$7FFFFFFF;
PMT.CurrentState:=false;
Result.Add(PMT);
end;
end;
for i:=0 to AllProcTasks.Count-1 do
begin
PPT:=AllProcTasks[i];
if PPT.MayBeAfter then
begin
new(PMT);
PMT.UIN:=UIN;
PMT.processor:=PPT.ProcNum;
PMT.afterUIN:=PPT.UIN;
PMT.Time:=$7FFFFFFF;
PMT.ProcCount:=$7FFFFFFF;
PMT.CurrentState:=false;
Result.Add(PMT);
end;
end;
DeselectTask;
end;
function TSubMerger.GetTime:integer;
var i:integer;
PPT:PProcTask;
List:TList;
begin
Result:=0;
for i:=0 to Procs.Count-1 do
begin
List:=Procs[i];
if List.Count<>0 then
begin
PPT:=List.Last;
if Result < PPT.StartTime+PPT.Length-1 then Result :=
PPT.StartTime+PPT.Length-1
end;
end;
end;
function TSubMerger.GetProcCount:integer;
var i:integer;
begin
Result:=0;
for i:=0 to Procs.Count-1 do
if TList(Procs[i]).Count<>0 then Result:=Result+1
end;
function TSubMerger.OptimizeOneStep(L1,L2:TLabel):boolean;
var i,j:integer;
List,AllMoves:TList;
PPM,bestPPM,workPPM:PPossibleMove;
PPT:PProcTask;
BackUpList:TList;
BackUpNOP:integer;
BestFit:integer;
CurProcCount,CurTime:integer;
MinTime:integer;
Unique:boolean;
PH:PHolder;
CurUIN,MinProcessor:integer;
begin
DeselectTask;
AllMoves:=TList.create;
for i:=0 to AllProcTasks.Count-1 do
begin
PPT:=AllProcTasks[i];
List:=GetPossibleMoves(PPT.UIN);
for j:=0 to List.Count-1 do AllMoves.add(List[j]);
List.clear;
List.Destroy;
end;
CurProcCount:=GetProcCount;
CurTime:=GetTime;
BackUpNOP:=Procs.Count;
SaveBackUp(BackUpList);
for i:=0 to AllMoves.Count-1 do
begin
PPM:=AllMoves[i];
Selected:=GetProcTaskByUIN(PPM.UIN);
Unique:=true;
if Selected.ProcNum = PPM.processor then
begin
List:=Procs[Selected.ProcNum-1];
PPT:=nil;
for j:=0 to List.Count-1 do
begin
if PProcTask(List[j]).UIN = PPM.UIN then break;
PPT:=List[j];
end;
if((PPT<>nil)and(PPT.UIN=PPM.afterUIN))or
((PPT=nil)and(PPM.afterUIN=-1))then Unique:=false;
end;
PPM.CurrentState := not Unique;
if Unique then
begin
if PPM.afterUIN<>-1 then
(GetProcTaskByUIN(PPM.afterUIN)).MayBeAfter:=true;
MoveSelectedAfter(PPM.processor,PPM.afterUIN);
while GetProcCount<>Procs.Count do DecNumOfProc;
PPM.Time:=GetTime;
PPM.ProcCount:=Procs.Count;
RestoreBackUp(BackUpList,BackUpNOP,false);
end
else
begin
PPM.Time:=CurTime;
PPM.ProcCount:=CurProcCount;
end;
end;
Selected:= nil;
RestoreBackUp(BackUpList,BackUpNOP,true); //??
MinTime:=$7FFFFFFF;
for i:=0 to AllMoves.Count-1 do
if MinTime>PPossibleMove(AllMoves[i]).Time then
MinTime:=PPossibleMove(AllMoves[i]).Time;
//-->>
{ Memo.Lines.Clear;
for i:=0 to AllMoves.Count-1 do
begin
PPM:=AllMoves[i];
Memo.Lines.Add(inttostr(PPM.UIN)+' <>
'+inttostr(PPM.processor)+':'+inttostr(PPM.afterUIN)+' Time=
'+inttostr(PPM.Time)+' PC='+inttostr(PPM.ProcCount));
if PPM.CurrentState then Memo.Lines.Add('Was current state!')
end;}
//<<--
// выделяем минимальные времена
i:=0;
while i<>AllMoves.Count do
begin
PPM:=AllMoves[i];
if PPM.Time > MinTime then
begin
AllMoves.delete(i);
dispose(PPM);
end
else i:=i+1
end;
MinProcessor:=$7FFFFFFF;
for i:=0 to AllMoves.Count-1 do
if MinProcessor>PPossibleMove(AllMoves[i]).ProcCount then
MinProcessor:=PPossibleMove(AllMoves[i]).ProcCount;
i:=0;
while i<>AllMoves.Count do
begin
PPM:=AllMoves[i];
if PPM.ProcCount > MinProcessor then
begin
AllMoves.delete(i);
dispose(PPM);
end
else i:=i+1
end;
i:=0;
CurUIN:=0;
MinProcessor:=0;
while i<>AllMoves.Count do
begin
PPM:=AllMoves[i];
if PPM.UIN<>CurUIN then
begin
CurUIN:=PPM.UIN;
MinProcessor:=PPM.processor;
j:=i+1;
while j<>AllMoves.Count do
begin
workPPM:=AllMoves[j];
if workPPM.UIN<>CurUIN then break;
if workPPM.processor<MinProcessor then
MinProcessor:=workPPM.processor;
j:=j+1;
end;
end;
if (PPM.CurrentState)or(PPM.processor>MinProcessor)
then
begin
AllMoves.delete(i);
dispose(PPM);
end
else i:=i+1
end;
i:=0;
if MinTime = CurTime then
while i<AllMoves.Count do
begin
PPM:=AllMoves[i];
PPT:=GetProcTaskByUIN(PPM.UIN);
if PPM.processor = PPT.ProcNum then
begin
AllMoves.delete(i);
dispose(PPM);
end
else i:=i+1
end;
BestFit:=AllMoves.Count-1;
for i:=0 to AllMoves.Count-2 do
begin
PPM:=AllMoves[i];
bestPPM:=AllMoves[BestFit];
if(PPM.Time<bestPPM.Time)or
((PPM.Time=bestPPM.Time)and(PPM.ProcCount<bestPPM.ProcCount))
then BestFit:=i
end;
if BestFit<>-1 then
begin
bestPPM:=AllMoves[BestFit];
Selected:=GetProcTaskByUIN(bestPPM.UIN);
if bestPPM.afterUIN<>-1 then
(GetProcTaskByUIN(bestPPM.afterUIN)).MayBeAfter:=true;
MoveSelectedAfter(bestPPM.processor,bestPPM.afterUIN);
while GetProcCount<>Procs.Count do DecNumOfProc;
if L1<>nil then L1.Caption:=inttostr(bestPPM.Time);
if L2<>nil then L2.Caption:=inttostr(bestPPM.ProcCount);
Result:=true
end
else Result:=false;
//-->>
{ Memo.Lines.Add('');
Memo.Lines.Add('--- Min ---');
Memo.Lines.Add('');
for i:=0 to AllMoves.Count-1 do
begin
PPM:=AllMoves[i];
Memo.Lines.Add(inttostr(PPM.UIN)+' <>
'+inttostr(PPM.processor)+':'+inttostr(PPM.afterUIN)+' Time=
'+inttostr(PPM.Time)+' PC='+inttostr(PPM.ProcCount));
if PPM.CurrentState then Memo.Lines.Add('Was current state!')
end;}
//<<--
ClearPossibleMoves(AllMoves);
DeselectTask;
end;
function ComparePPT(Item1, Item2: Pointer): Integer;
begin
if PProcTask(Item1).StartTime<PProcTask(Item2).StartTime then Result:=-
1
else
if PProcTask(Item1).StartTime>PProcTask(Item2).StartTime then Result:=1
else Result:=0
end;
procedure TSubMerger.OptimizeAuto(Form:TForm;L1,L2:TLabel);
var i,j,k:integer;
List,UINList:TList;
PPT,nextPPT:PProcTask;
Time:integer;
MatchError:boolean;
NewProc:TList;
NOP:integer;
NoChange:boolean;
StartFrom,NewStartFrom:integer;
BackList:TList;
BackTime:integer;
begin
while OptimizeOneStep(L1,L2) do Form.Update;
Time:=GetTime;
UINList:=TList.Create;
NewStartFrom:=0;
repeat
StartFrom:=NewStartFrom;
NoChange:=true;
for i:=0 to Procs.Count-2 do
begin
NewStartFrom:=i+1;
List:=Procs[i];
for j:=0 to List.Count-1 do UINList.Add(List[j]);
List:=Procs[i+1];
for j:=0 to List.Count-1 do UINList.Add(List[j]);
UINList.Sort(ComparePPT);
MatchError:=false;
PPT:=UINList.first;
for j:=1 to UINList.Count-1 do
begin
nextPPT:=UINList[j];
if (PPT.StartTime = nextPPT.StartTime) or
(PPT.StartTime+PPT.Length>nextPPT.StartTime) then
begin
MatchError:=true;
break
end;
PPT:=nextPPT;
end;
if not MatchError then
begin
SaveBackUp(BackList);
BackTime:=GetTime;
NOP:=Procs.Count-1;
ClearLinks(true);
ClearProcs(false);
for j:=0 to UINList.Count-1 do
begin
PPT:=UINList[j];
PPT.ProcNum:=i+1;
AllProcTasks.delete(AllProcTasks.indexOf(PPT));
end;
for j:=0 to AllProcTasks.Count-1 do
begin
PPT:=AllProcTasks[j];
if PPT.ProcNum>i+1 then PPT.ProcNum:=PPT.ProcNum-1
end;
for j:=0 to UINList.Count-1 do AllProcTasks.add(UINList[j]);
FormLinkTasksAndSetTimes(NOP);
if BackTime>=GetTime then
begin
NoChange:=false;
NewStartFrom:=0;
while BackList.Count<>0 do
begin
PPT:=BackList.first;
BackList.delete(0);
dispose(PPT)
end;
end
else RestoreBackUp(BackList,NOP+1,true);
break;
end;
UINList.Clear;
end;
UINList.Clear;
until NoChange;
UINList.Destroy;
end;
procedure TSubMerger.SaveBackUp(var List:Tlist);
var backPPT,PPT:PProcTask;
i:integer;
begin
List:=TList.Create;
for i:=0 to AllProcTasks.Count-1 do
begin
PPT:=AllProcTasks[i];
new(backPPT);
backPPT^:=PPT^;
backPPT.Prev:=nil;
List.add(backPPT);
end;
end;
procedure TSubMerger.RestoreBackUp(var
List:Tlist;NOP:integer;ClearCurrent:boolean);
var backPPT,PPT:PProcTask;
i:integer;
begin
Selected:=nil;
ClearLinks(true);
ClearProcs(true);
for i:=0 to List.Count-1 do
begin
backPPT:=List[i];
new(PPT);
PPT^:=backPPT^;
AllProcTasks.add(PPT);
if ClearCurrent then dispose(backPPT);
end;
if ClearCurrent then List.Destroy;
FormLinkTasksAndSetTimes(NOP);
end;
end.
Размещено на Allbest.ru
Подобные документы
Необходимые условия экстремума. Разработка машинного алгоритма и программы многомерной оптимизации для градиентного метода с использованием метода равномерного поиска. Проверка необходимых и достаточных условий экстремума для найденной точки минимума.
курсовая работа [249,8 K], добавлен 25.09.2013Простейшие электрические цепи первого порядка. Характеристика электрических цепей второго порядка, их параметры. Элементы нелинейных цепей. Основные этапы моделирования схем с помощью программы схемотехнического проектирования и моделирования Micro-Cap.
контрольная работа [196,6 K], добавлен 17.03.2011Описание математических методов решения систем линейных уравнений. Метод Гаусса, матричный метод. Вычисление определителей второго и третьего порядка. Язык программирования Паскаль. Структура программы, описание переменных, основные конструкции языка.
курсовая работа [137,3 K], добавлен 20.07.2010Методы ветвей и границ первого и второго порядка. Оптимальный и пассивный поиск. Недостатки метода Ньютона. Метод золотого сечения. Примеры унимодальных функций. Динамическое и линейное программирование. Метод Жордана-Гаусса. Решение задачи коммивояжера.
курсовая работа [1,1 M], добавлен 20.07.2012Математическое описание элементов автоматической системы моделирования. Определение передаточной функции объекта по переходной характеристике методом площадей. Вычисление статических характеристик случайного процесса по заданной реакции, расчет дисперсии.
курсовая работа [337,2 K], добавлен 10.02.2012Математическое описание и аналитическое исследование методов оптимизации: Нелдера-Мида и градиентный с дроблением шага. Зависимость числа итераций от заданной точности. Решение задачи минимизации для каждого из методов и ее графическая интерпретация.
курсовая работа [472,8 K], добавлен 22.11.2009Структурно-информационный анализ методов моделирования динамических систем. Математическое моделирование. Численные методы решения систем дифференциальных уравнений. Разработка структуры програмного комплекса для анализа динамики механических систем.
дипломная работа [1,1 M], добавлен 14.05.2010Стадии и этапы разработки программы для моделирования распространения тепла в стержне (бесконечном, полубесконечном и ограниченном) методом разделения переменных. Возможности системы компьютерной математики Maple. Описание логической структуры программы.
курсовая работа [307,5 K], добавлен 04.06.2013Основные этапы математического моделирования. Метод Эйлера как наиболее простой численный метод решения обыкновенных дифференциальных уравнений. Написание компьютерной программы, которая позволит изучать графики системы дифференциальных уравнений.
курсовая работа [1,9 M], добавлен 05.01.2013Обзор методов решения в Excel. Рекурентные формулы метода Эйлера. Метод Рунге-Кутта четвертого порядка для решения уравнения первого порядка. Метод Эйлера с шагом h/2. Решение дифференциальных уравнений с помощью Mathcad. Модифицированный метод Эйлера.
курсовая работа [580,1 K], добавлен 18.01.2011
