unit uCuthillMcKee;
interface
uses
SysUtils, Dialogs, Classes, Contnrs;
type
TSymmetricMatrix =
class
private
FItems:
array of array of integer;
function GetCount: integer;
procedure SetCount(
const Value: integer);
function GetItems(Row, Col: integer): integer;
procedure SetItems(Row, Col: integer;
const Value: integer);
public
procedure LoadFromFile(
const FileName:
string);
procedure SaveToFile(
const FileName:
string);
procedure Clear;
property Count: integer
read GetCount
write SetCount;
property Items[Row, Col: integer]: integer
read GetItems
write SetItems;
default;
destructor Destroy;
override;
end;
TIntVector =
class
private
FItems:
array of integer;
function GetCount: integer;
procedure SetCount(
const Value: integer);
function GetItems(
Index: integer): integer;
procedure SetItems(
Index: integer;
const Value: integer);
public
procedure Clear;
function Add(
const Value: integer): integer;
function AsString:
string;
property Count: integer
read GetCount
write SetCount;
property Items[
Index: integer]: integer
read GetItems
write SetItems;
default;
destructor Destroy;
override;
end;
TCuthillMcKeeNode =
class
private
FInitialLabel: integer;
FNewLabel: integer;
FNeighbours: TIntVector;
public
procedure Clear;
property InitialLabel: integer
read FInitialLabel
write FInitialLabel;
property NewLabel: integer
read FNewLabel
write FNewLabel;
property Neighbours: TIntVector
read FNeighbours;
constructor Create;
destructor Destroy;
override;
end;
TCuthillMcKeeNodes =
class
private
FItems: TObjectList;
function GetItems(
Index: integer): TCuthillMcKeeNode;
function GetCount: integer;
procedure SetCount(
const Value: integer);
public
procedure Clear;
property Items[
Index: integer]: TCuthillMcKeeNode
read GetItems;
default;
property Count: integer
read GetCount
write SetCount;
constructor Create;
destructor Destroy;
override;
end;
TCuthillMcKee =
class
private
FInitialMatrix: TSymmetricMatrix;
FSolutionMatrix: TSymmetricMatrix;
FSolution: TIntVector;
procedure GenerateSolutionMatrix;
public
procedure Clear;
procedure BandwidthReduction;
property InitialMatrix: TSymmetricMatrix
read FInitialMatrix;
property SolutionMatrix: TSymmetricMatrix
read FSolutionMatrix;
property Solution: TIntVector
read FSolution;
constructor Create;
destructor Destroy;
override;
end;
implementation
{ TSymmetricMatrix }
destructor TSymmetricMatrix.Destroy;
begin
Clear;
inherited;
end;
procedure TSymmetricMatrix.Clear;
begin
SetLength(FItems, 0);
end;
function TSymmetricMatrix.GetCount: integer;
begin
Result := Length(FItems);
end;
procedure TSymmetricMatrix.SetCount(
const Value: integer);
begin
SetLength(FItems, Value, Value);
end;
function TSymmetricMatrix.GetItems(Row, Col: integer): integer;
begin
Result := FItems[Row, Col];
end;
procedure TSymmetricMatrix.SetItems(Row, Col: integer;
const Value: integer);
begin
FItems[Row, Col] := Value;
end;
procedure TSymmetricMatrix.LoadFromFile(
const FileName:
string);
var
F: TextFile;
N, I, J: integer;
begin
AssignFile(F, FileName);
Reset(F);
Readln(F, N);
Count := N;
for I := 0
to Count - 1
do
begin
for J := 0
to Count - 1
do
Read(F, FItems[I, J]);
Readln(F);
end;
CloseFile(F);
end;
procedure TSymmetricMatrix.SaveToFile(
const FileName:
string);
var
F: TextFile;
I, J: integer;
begin
AssignFile(F, FileName);
Rewrite(F);
Writeln(F, Count);
for I := 0
to Count - 1
do
begin
for J := 0
to Count - 1
do
Write(F, FItems[I, J], #32);
Writeln(F);
end;
CloseFile(F);
end;
{ TIntVector }
destructor TIntVector.Destroy;
begin
Clear;
inherited;
end;
procedure TIntVector.Clear;
begin
SetLength(FItems, 0);
end;
function TIntVector.GetCount: integer;
begin
Result := Length(FItems);
end;
procedure TIntVector.SetCount(
const Value: integer);
begin
SetLength(FItems, Value);
end;
function TIntVector.GetItems(
Index: integer): integer;
begin
Result := FItems[
Index];
end;
procedure TIntVector.SetItems(
Index: integer;
const Value: integer);
begin
FItems[
Index] := Value;
end;
function TIntVector.Add(
const Value: integer): integer;
begin
Result := Count;
Count := Result + 1;
FItems[Result] := Value;
end;
function TIntVector.AsString:
string;
var
I: integer;
begin
Result := '
';
for I := 0
to Count - 1
do
Result := Result + Format('
%d ', [FItems[I]]);
end;
{ TCuthillMcKeeNode }
constructor TCuthillMcKeeNode.Create;
begin
FNeighbours := TIntVector.Create;
end;
destructor TCuthillMcKeeNode.Destroy;
begin
FNeighbours.Free;
inherited;
end;
procedure TCuthillMcKeeNode.Clear;
begin
FNeighbours.Clear;
end;
{ TCuthillMcKeeNodes }
constructor TCuthillMcKeeNodes.Create;
begin
FItems := TObjectList.Create;
end;
destructor TCuthillMcKeeNodes.Destroy;
begin
FItems.Free;
inherited;
end;
procedure TCuthillMcKeeNodes.Clear;
begin
FItems.Clear;
end;
function TCuthillMcKeeNodes.GetCount: integer;
begin
Result := FItems.Count;
end;
procedure TCuthillMcKeeNodes.SetCount(
const Value: integer);
var
I, N: integer;
begin
N := Count;
if Value > Count
then
for I := N
to Value - 1
do
FItems.Add(TCuthillMcKeeNode.Create)
else
if Value < Count
then
for I := N - 1
downto Value
do
FItems.Delete(I);
end;
function TCuthillMcKeeNodes.GetItems(
Index: integer): TCuthillMcKeeNode;
begin
Result := TCuthillMcKeeNode(FItems[
Index]);
end;
{ TCuthillMcKee }
constructor TCuthillMcKee.Create;
begin
FInitialMatrix := TSymmetricMatrix.Create;
FSolutionMatrix := TSymmetricMatrix.Create;
FSolution := TIntVector.Create;
end;
destructor TCuthillMcKee.Destroy;
begin
Clear;
FInitialMatrix.Free;
FSolutionMatrix.Free;
FSolution.Free;
inherited;
end;
procedure TCuthillMcKee.Clear;
begin
FInitialMatrix.Clear;
FSolutionMatrix.Clear;
FSolution.Clear;
end;
procedure TCuthillMcKee.GenerateSolutionMatrix;
var
I, J: integer;
begin
FSolutionMatrix.Count := FInitialMatrix.Count;
for I := 0
to FSolutionMatrix.Count - 1
do
for J := 0
to FSolutionMatrix.Count - 1
do
FSolutionMatrix[I, J] := 0;
for I := 0
to FSolutionMatrix.Count - 1
do
FSolutionMatrix[I, I] := 1;
end;
procedure TCuthillMcKee.BandwidthReduction;
var
Nodes: TCuthillMcKeeNodes;
Selected: TIntVector;
N, I, J, K, MinCount, MinIndex, A, B: integer;
UnConnected: boolean;
begin
Nodes := TCuthillMcKeeNodes.Create;
Selected := TIntVector.Create;
try
N := FInitialMatrix.Count;
Nodes.Count := N;
Selected.Count := N;
FSolution.Count := N;
for I := 0
to N - 1
do
begin
Nodes[I].InitialLabel := I;
Nodes[I].NewLabel := 0;
Selected[I] := 0;
FSolution[I] := -1;
for J := I + 1
to N - 1
do
if FInitialMatrix[I, J] <> 0
then
begin
Nodes[I].Neighbours.Add(J);
Nodes[J].Neighbours.Add(I);
end;
end;
MinCount := N;
MinIndex := -1;
for I := 0
to N - 1
do
begin
for J := 0
to Nodes[I].Neighbours.Count - 2
do
for K := J + 1
to Nodes[I].Neighbours.Count - 1
do
begin
A := Nodes[I].Neighbours[J];
B := Nodes[I].Neighbours[K];
if Nodes[A].Neighbours.Count > Nodes[B].Neighbours.Count
then
begin
Nodes[I].Neighbours[J] := B;
Nodes[I].Neighbours[K] := A;
end;
end;
if Nodes[I].Neighbours.Count < MinCount
then
begin
MinCount := Nodes[I].Neighbours.Count;
MinIndex := I;
end;
end;
A := 0;
B := 0;
Selected[MinIndex] := 1;
FSolution[A] := MinIndex;
Inc(B);
Nodes[MinIndex].NewLabel := A;
repeat
UnConnected := false;
while B < N
do
begin
for I := 0
to Nodes[FSolution[A]].Neighbours.Count - 1
do
if Selected[Nodes[FSolution[A]].Neighbours[I]] = 0
then
begin
Selected[Nodes[FSolution[A]].Neighbours[I]] := 1;
Inc(B);
Nodes[Nodes[FSolution[A]].Neighbours[I]].NewLabel := B - 1;
FSolution[B - 1] := Nodes[FSolution[A]].Neighbours[I];
end;
Inc(A);
if A >= B
then
begin
UnConnected := true;
Break;
end;
end;
if UnConnected
then
begin
MinIndex := -1;
MinCount := N;
for I := 0
to N - 1
do
begin
if Selected[Nodes[I].InitialLabel] = 0
then
if Nodes[I].Neighbours.Count < MinCount
then
begin
MinCount := Nodes[I].Neighbours.Count;
MinIndex := I;
end;
end;
FSolution[A] := MinIndex;
Inc(B);
Nodes[MinIndex].NewLabel := A;
Selected[MinIndex] := 1;
end;
until not UnConnected;
GenerateSolutionMatrix;
for I := 0
to N - 1
do
for J := 0
to Nodes[I].Neighbours.Count - 1
do
begin
Nodes[I].Neighbours[J] := Nodes[Nodes[I].Neighbours[J]].NewLabel;
FSolutionMatrix[Nodes[I].NewLabel, Nodes[I].Neighbours[J]] := 1;
end;
finally
Nodes.Free;
Selected.Free;
end;
end;
end.