Смекни!
smekni.com

Градиентный метод первого порядка (стр. 9 из 11)

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