Bandbreitenoptimierung für Matrizen

[Bjoerk]

Ich hab den Code jetzt erst mal auf Standard gebracht. Morgen bau ich ihn noch in meine Software ein. Der Aufbau der InitialMatrix und das Auslesen der SolutionMatrix für meine Software fehlen noch. Melde mich dann nochmal.

Delphi-Quellcode:

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.