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