objgraph.pas

8259中断程序。接口试验程序

{*****************************************************************************
 *
 *  objGraph.pas - Matematical Graph object
 *
 *  Copyright (c) 1999 Diego Amicabile
 *
 *  Author:     Diego Amicabile
 *  E-mail:     [e-mail]
 *  Homepage:   http://www.geocities.com/diegoami
 *
 *  This program is free software; you can redistribute it and/or
 *  modify it under the terms of the GNU General Public License
 *  as published by the Free Software Foundation;
 *
 *  This program is distributed in the hope that it will be useful,
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 *  GNU General Public License for more details.
 *
 *  You should have received a copy of the GNU General Public License
 *  along with this program; if not, write to the Free Software
 *  Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA
 *
 *----------------------------------------------------------------------------
 *
 *  Revision history:
 *
 *     DATE     REV                 DESCRIPTION
 *  ----------- --- ----------------------------------------------------------
 *
 *****************************************************************************}

unit ObjGraph;
interface

uses sysutils, classes, objArray, objbase, objcmp, objperst, objList;

const
  MAX_DISTANCE = 100000;
type

EInvalidObjectType = class(Exception)
end;

EObjectNotInGraph = class(Exception)
end;


TInteger = class
  value : real;
  constructor Create(intvalue : integer);
end;

TStringObj = class(TObject)
    Str : String;
    constructor Create(Caption : String);
end;


TEdgeList = class;
TGraphEdge = class;


TGraphNode = class(TObject)
  obj : TObject;
  constructor Create(Obj : TObject);
  destructor Destroy;
  protected
    PrevInPath : TGraphEdge;
    EdgesFrom : TEdgeList;
    Distance  : real;
  public
    procedure Update(FormerNode : TGraphNode; Distance : real); virtual;
end;

TNodeList = class(TUnOrderedList)
  function indexOf(GraphNode : TGraphNode) : integer;
end;

TGraphEdge = class(TObject)
public
  FromNode : TGraphNode;
  ToNode  : TGraphNode;
  Weight : real;
  constructor Create(FromNode, ToNode : TGraphNode);
  function GetWeight : real; virtual;
  procedure SetWeightFrom(FromNode : TGraphNode); virtual;
end;

TTypedList = class(TList)
  FObjectType   : TClass;       { type of element allowed in container }
  constructor Create(InObjectType : TClass);
  procedure Add(Obj : TObject);
end;

TEdgeList = class(TTypedList)
  constructor Create;
end;

TMathGraph = class
  constructor Create;

  protected
    FArray          : TArray;
    procedure CreateArray;
    procedure AdjMatrixToEdges;
  public
    NodeList        : TNodeList;
    EdgeList        : TEdgeList;

    function GetShortestPath(FromNode, ToNode : TGraphNode) : TEdgeList;
    function GetNode( Obj : TObject) : TGraphNode;
    procedure WriteArray;
    procedure BindEdgesFromNode;
    function isTo(Node : TGraphNode) : boolean;
end;


function CompareInteger(const Lhs, Rhs : TObject) : TComparison;
function CompareNodes(const Lhs, Rhs : TObject) : TComparison;
function CompareArray(const Lhs, Rhs : TObject) : TComparison;

implementation

constructor TStringObj.Create(Caption : String);
begin
  inherited Create;
  Str := Caption;
end;

constructor TInteger.Create(intvalue : integer);
begin
  inherited Create;
     value := intvalue;
end;

function CompareNodes(const Lhs, Rhs : TObject) : TComparison;
begin
  if Lhs = Rhs then
    result := cmpEqual
  else
    result := cmpGreater;
end;

function CompareInteger(const Lhs, Rhs : TObject) : TComparison;
var ILhs, IRhs : TInteger;
    i : integer;
begin
  IRHS := Rhs As TInteger;
  ILhs := Lhs As TInteger;
  if ILhs.value < IRhs.value then
    result := cmpLess
  else if ILhs.value > IRhs.value then
    result := cmpGreater
  else
    result := cmpEqual;
end;

function CompareArray(const Lhs, Rhs : TObject) : TComparison;
var i : integer;
    ALhs, ARhs : TArray;
begin
  if Lhs is TInteger then
    result := CompareInteger(Lhs,Rhs)
  else begin
    ALhs := Lhs as TArray;
    aRhs := Rhs as TArray;
    if aLhs.Size > aRhs.Size then
      result := cmpGreater
    else if aLhs.Size < aRhs.Size then
      result := cmpLess
    else begin
      for i := 1 to aLhs.Size do begin
        result := aLhs.CompareFunc(aLhs[i], aRhs[i]);
        if result <> cmpEqual then exit;
      end;
    end;
  end;
end;

procedure TGraphNode.Update(FormerNode : TGraphNode; Distance : real);
begin
end;

procedure TGraphEdge.SetWeightFrom(FromNode : TGraphNode);
begin
end;

procedure TMathGraph.WriteArray;
var i, j : integer;
  IArray : TArray;
begin
  for i := 1 to FArray.Size do begin
    IArray := FArray[i] As TArray;
    for j := 1 to IArray.Size do
      Write(FloatToStr((IArray[j] as TInteger).value)+' ');
    Writeln;
  end;
end;


procedure TMathGraph.CreateArray;
var i,j : integer;
    IArray : TArray;
    SX, DX : integer;
    Edge : TGraphEdge;
begin
  if FArray <> nil then
    FArray.Free;
  FArray := TArray.Create(TArray, CompareArray, NodeList.Size, 0);
  for i := 1 to NodeList.Size do
    FArray.Insert(TArray.Create(TInteger, CompareInteger, NodeList.Size, 0));
  for i := 1 to NodeList.Size do begin
    IArray := FArray[i] As TArray;
    for j := 1 to NodeList.Size do
      IArray.Insert(TInteger.Create(0));
  end;
  for i := 0 to EdgeList.Count-1 do begin
    Edge := TGraphEdge(EdgeList.Items[i]);
    SX := NodeList.indexOf(Edge.FromNode);
    DX := NodeList.indexOf(Edge.ToNode);
    IArray := FArray[SX] as TArray;
    (IArray[DX] as TInteger).value := Edge.GetWeight;
  end;
end;

function TNodeList.IndexOf(GraphNode : TGraphNode) : integer;
var i : integer;
begin
  GotoFirst;
  for i := 1 to Size do begin
    if CurrentObj = GraphNode then begin
      result := i;
      exit;
    end;
    GotoNext;
  end;
end;

procedure TMathGraph.AdjMatrixToEdges;
var i,j : integer;
    IArray : TArray;
    Edge : TGraphEdge;
    FN, TN : TGraphNode;
begin
  EdgeList := TEdgeList.Create;
  for i := 1 to FArray.Size do begin
    IArray := FArray[i] As TArray;
    for j := 1 to IArray.Size do
      if (IArray[j] as TInteger).Value <> 0 then begin
        FN := TGraphNode(NodeList.At[i]);
        TN := TGraphNode(NodeList.At[j]);
        Edge := TGraphEdge.Create(FN,TN);
        Edge.Weight := (IArray[j] as TInteger).Value;
        EdgeList.Add(Edge);
      end;
  end;
end;

constructor TGraphNode.Create(Obj : TObject);
begin
    inherited Create;
    Self.Obj := Obj;
    EdgesFrom := TEdgeList.Create;
end;


destructor TGraphNode.Destroy;
begin
  EdgesFrom.Free;
  inherited;
end;

constructor TGraphEdge.Create(FromNode, ToNode : TGraphNode);
begin
  inherited Create;
  Self.FromNode := FromNode;
  Self.ToNode := ToNode;
  Weight := 1;
end;

function TGraphEdge.GetWeight : real;
begin
  result := Weight;
end;


constructor TTypedList.Create(InObjectType : TClass);
begin
  inherited Create;
  FObjectType := InObjectType;
end;

procedure TTypedList.Add(Obj : TObject);
begin
  if Obj is FObjectType then
    inherited Add(Obj);
end;

constructor TEdgeList.Create;
begin
  inherited Create(TGraphEdge);
end;

{
constructor TNodeList.Create;
begin
     inherited Create(TGraphNode);
end;
 }

constructor TMathGraph.Create;
begin
     inherited Create;
     NodeList := TNodeList.Create(TGraphNode,CompareNodes);
     EdgeList := TEdgeList.Create;
end;
{
constructor TMathGraph.CreateDynamic(InUpdateData : TUpdateData);
begin
     Create;
     FUpdateData := InUpdateData;
end;

}

function TMathGraph.GetNode( Obj : TObject) : TGraphNode;
var i : integer;
    GraphNode : TGraphNode;
begin
  result := nil;
  for i := 1 to NodeList.Size do  begin
    GraphNode := TGraphNode(NodeList.At[i]);
    if GraphNode.Obj = Obj then
      result := GraphNode;
  end;
end;

procedure TMathGraph.BindEdgesFromNode;
var i : integer;
    Edge : TGraphEdge;
    FromNode : TGraphNode;
begin
  for i := 1 to NodeList.Size do
    (NodeList.At[i] As TGraphNode).EdgesFrom := TEdgeList.Create;
  for i := 0 to EdgeList.Count-1 do begin
    Edge := TGraphEdge(EdgeList.Items[i]);
    Edge.FromNode.EdgesFrom.Add(Edge);
  end;
end;

{
procedure TMathGraph.UpdateWeightsFromNode(FromNode : TGraphNode;
                                           CallBackData  : TObject);
var
  VisitedNodes, NodesToVisit : TUnOrderedList;
  i : integer;
  CurrentNode : TGraphNode;
  CurrentEdges : TEdgeList;
  CurrentEdge : TGraphEdge;
  CurrentDinEdge : TDynamicGraphEdge;
begin
  BindEdgesFromNode;
  VisitedNodes := TUnOrderedList.Create(TGraphNode,CompareNodes);
  NodesToVisit := TUnOrderedList.Create(TGraphNode,CompareNodes);
  NodesToVisit.InsertAtTail(FromNode);
  repeat
    CurrentNode := TGraphNode(NodesToVisit.At[1]);
    if indexOf(CurrentNode,VisitedNodes) < 0 then begin
       VisitedNodes.InsertAtTail(CurrentNode);
       NodesToVisit.Delete(CurrentNode,1);
       CurrentEdges := CurrentNode.EdgesFrom;
       for i := 0 to CurrentEdges.Count-1 do begin
         CurrentEdge := TGraphEdge(CurrentEdges.Items[i]);
         if CurrentEdge is TDynamicGraphEdge then begin

             CurrentDinEdge := CurrentEdge As TDynamicGraphEdge;
             CurrentDinEdge.Weight := FUpdateData(CurrentDinEdge.FromNode.Obj,
                CurrentDinEdge.ToNode.Obj, CallBackData, CurrentDinEdge.StateData);
         end;
         NodesToVisit.InsertAtTail(CurrentEdge.ToNode);
       end;
    end;
  until NodesToVisit.Size = 0;
  VisitedNodes.Free;
  NodesToVisit.Free;
end;

}

function TMathGraph.isTo(Node : TGraphNode) : boolean;
var i : integer;
begin
  for i := 0 to EdgeList.Count-1 do begin
    if Node = TGraphEdge(EdgeList.Items[i]).ToNode then begin
      result := True;
      exit;
    end;
  end;
  result := false;
end;


function TMathGraph.GetShortestPath(FromNode, ToNode : TGraphNode) : TEdgeList;
   { Dijkstra's Algorithm }
   function PopNearestNode(List : TUnOrderedList) : TGraphNode;
   var i : integer;
      FoundNode, TryNode : TGraphNode;
   begin
      if List.Size = 0 then
        result := nil
      else begin
        FoundNode := List.At[1] As TGraphNode;
        for i := 2 to List.Size do begin
          TryNode := TGraphNode(List.At[i] as TGraphNode);
          if TryNode.distance < FoundNode.distance then
            FoundNode := TryNode;
        end;
        result := FoundNode;
        List.Delete(FoundNode,1);
      end;
   end;

var
   NodeIndex : integer;
   i,j  : integer;
   NodesFoundRoute : TUnOrderedList;
   NearestNode, CurrentNode : TGraphNode;
   EdgeList : TEdgeList;
   Edge     : TGraphEdge;
   DistOnToNode : real;

begin
  BindEdgesFromNode;
  DistOnToNode := MAX_DISTANCE;
  NodesFoundRoute := TUnOrderedList.Create(TGraphNode, CompareNodes);
  NodesFoundRoute.OwnerShip := False;
  for i := 1 to NodeList.Size do begin
    CurrentNode := TGraphNode(NodeList.At[i]);
    CurrentNode.distance := MAX_DISTANCE;
    CurrentNode.PrevInPath := nil;
    NodesFoundRoute.InsertAtTail(NodeList.At[i]);
  end;
  FromNode.distance := 0;
  for i := 1 to NodeList.Size do begin
    NearestNode := PopNearestNode(NodesFoundRoute);
    if NearestNode.distance >= DistOnToNode then
      continue;
    EdgeList := NearestNode.EdgesFrom;
    for j := 0 to EdgeList.Count-1 do begin
      Edge := TGraphEdge(EdgeList.Items[j]);
      Edge.SetWeightFrom(NearestNode);
    end;
    for j := 0 to EdgeList.Count-1 do begin
      Edge := TGraphEdge(EdgeList.Items[j]);
      CurrentNode := Edge.ToNode;
      if CurrentNode.Distance > NearestNode.Distance+Edge.Weight then begin
        CurrentNode.PrevInPath := Edge;
        CurrentNode.Distance := NearestNode.Distance+Edge.Weight ;
        CurrentNode.Update(NearestNode,Edge.Weight);
      end;
      if CurrentNode = ToNode then
        DistOnToNode := CurrentNode.Distance;
    end;
  end;
  EdgeList.Clear;
  CurrentNode := ToNode;
  while CurrentNode.PrevInPath <> nil do begin
    EdgeList.Add(CurrentNode.PrevInPath);
    CurrentNode := CurrentNode.PrevInPath.FromNode;
  end;
  result := EdgeList;
end;

procedure WriteIntegerObject( Obj    : TObject; Writer : TObjectWriter );
begin
  Writer.WriteFloat((Obj As TInteger).value);
end;

procedure ReadIntegerObject( Obj    : TObject; Reader : TObjectReader );
var Integ : TInteger;
begin
  Integ := Obj As TInteger;
  Integ.value := Reader.ReadFloat;
end;


procedure WriteStringObject( Obj    : TObject; Writer : TObjectWriter );
begin
  Writer.WriteStr((Obj As TStringObj).Str);
end;

procedure ReadStringObject(Obj    : TObject; Reader : TObjectReader );
var StringObj : TStringObj;
begin
  StringObj := Obj As TStringObj;
  StringObj.Str := Reader.ReadStr;
end;

procedure ReadGraphNode(Node    : TObject; Reader : TObjectReader );
var
    GraphNode : TGraphNode;
begin
  GraphNode := Node As TGraphNode;
  GraphNode.Obj := Reader.ReadChildObject;
end;

procedure WriteGraphNode(Node    : TObject; Writer : TObjectWriter );
var
  GraphNode : TGraphNode;
begin
  GraphNode := Node As TGraphNode;
  Writer.WriteChildObject(GraphNode.Obj);
end;

procedure ReadNodeList(List    : TObject; Reader : TObjectReader );
begin
  ReadList(List, Reader);
end;

procedure WriteNodeList(List    : TObject; Writer : TObjectWriter );
begin
  WriteList(List, Writer);
end;

procedure WriteGraph(Obj    : TObject; Writer : TObjectWriter );
var
  Graph : TMathGraph;
begin
  Graph := Obj As TMathGraph;
  Writer.WriteChildObject(Graph.NodeList);
  Graph.CreateArray;
  Writer.WriteChildObject(Graph.FArray);
end;

procedure ReadGraph(Obj    : TObject; Reader : TObjectReader );
var
  Graph : TMathGraph;
begin
  Graph := Obj As TMathGraph;
  Graph.NodeList := Reader.ReadChildObject As TNodeList;
  Graph.Farray := Reader.ReadChildObject As TArray;
  Graph.AdjMatrixToEdges;
  
end;



initialization

RegisterStreamable(
    TGraphNode,
    [TObjectReadProc(@ReadGraphNode)],
    [TObjectWriteProc(@WriteGraphNode)]
    );

RegisterStreamable(
    TMathGraph,
    [TObjectReadProc(@ReadGraph)],
    [TObjectWriteProc(@WriteGraph)]
    );


RegisterStreamable(
    TInteger,
    [TObjectReadProc(@ReadIntegerObject)],
    [TObjectWriteProc(@WriteIntegerObject)]
    );

RegisterStreamable(
    TNodeList,
    [TObjectReadProc(@ReadNodeList)],
    [TObjectWriteProc(@WriteNodeList)]
    );

RegisterStreamable(
    TStringObj,
    [TObjectReadProc(@ReadStringObject)],
    [TObjectWriteProc(@WriteStringObject)]
    );

RegisterCompareFunction('CompareArray',CompareArray);
RegisterCompareFunction('CompareInteger',CompareInteger);
RegisterCompareFunction('CompareNodes',CompareNodes);

end.