urtfddiagram.pas

一个UML建模工具

{
  ESS-Model
  Copyright (C) 2002  Eldean AB, Peter S鰀erman, Ville Krumlinde

  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; either version 2
  of the License, or (at your option) any later version.

  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.
}

unit uRtfdDiagram;

interface
{$ifdef WIN32}
uses uViewIntegrator, essConnectPanel, uModelEntity, uModel, Controls, uListeners, Graphics,
  Classes, Forms, uDiagramFrame, uRtfdComponents, uFeedback, Types;
{$endif}
{$ifdef LINUX}
uses uViewIntegrator, essConnectPanel, uModelEntity, uModel, QControls, uListeners, QGraphics,
  Classes, QForms, uDiagramFrame, uRtfdComponents, uFeedback;
{$endif}


type
  TRtfdDiagram = class(TDiagramIntegrator,
      IBeforeObjectModelListener, IAfterObjectModelListener,
      IAfterUnitPackageListener)
  private
    Panel: TessConnectPanel;
    Frame: TDiagramFrame;
    //Map Entity.fullName -> TRtfdCustomPanel
    BoxNames: TStringList;
    FHasHidden : boolean;
    FHasChanged : boolean;
    IsAllClasses : boolean;
    ZoomFocusW,ZoomFocusH : integer;
    procedure ClearDiagram;
    procedure AddBox(E: TModelEntity);
    function GetBox(const S : string) : TRtfdBox;
    procedure ResolveAssociations;
    //Model listeners
    procedure ModelBeforeChange(Sender: TModelEntity);
    procedure ModelAfterChange(Sender: TModelEntity);
    procedure IBeforeObjectModelListener.Change = ModelBeforeChange;
    procedure IAfterObjectModelListener.Change = ModelAfterChange;
    //Unitpackage listeners
    procedure UnitPackageAfterChange(Sender: TModelEntity);
    procedure UnitPackageAfterAddChild(Sender: TModelEntity; NewChild: TModelEntity);
    procedure UnitPackageAfterRemove(Sender: TModelEntity);
    procedure UnitPackageAfterEntityChange(Sender: TModelEntity);
    procedure IAfterUnitPackageListener.Change = UnitPackageAfterChange;
    procedure IAfterUnitPackageListener.AddChild = UnitPackageAfterAddChild;
    procedure IAfterUnitPackageListener.Remove = UnitPackageAfterRemove;
    procedure IAfterUnitPackageListener.EntityChange = UnitPackageAfterEntityChange;
    procedure OnNeedZoomUpdate(Sender : TObject);
  protected
    procedure StoreDiagram; override;
    function FetchDiagram : integer; override;
    function HasChanged : boolean;
    procedure SetVisibilityFilter(const Value: TVisibility); override;
    procedure CurrentEntityChanged; override;
    procedure SetShowAssoc(const Value: boolean); override;
  public
    constructor Create(om: TObjectModel; Parent: TWinControl; Feedback : IEldeanFeedback = nil); override;
    destructor Destroy; override;
    procedure InitFromModel; override;
    procedure PaintTo(Canvas: TCanvas; X, Y: integer; SelectedOnly : boolean); override;
    procedure GetDiagramSize(var W,H : integer); override;
    procedure SetPackage(const Value: TAbstractPackage); override;
    procedure DoLayout; override;
    function GetClickAreas : TStringList; override;
    procedure OpenSelectedPackage;
    procedure DrawZoom(Canvas : TCanvas; W,H : integer); override;
    procedure SetZoomedScroll(ScrollX,ScrollY,W,H : integer); override;
    procedure HideSelectedDiagramElements; override;
    function HasHiddenElements : boolean; override;
    procedure UnHideAllElements; override;
    function GetSelectedRect : TRect; override;
    procedure ScreenCenterEntity(E : TModelEntity); override;
  end;

implementation

{$ifdef WIN32}
uses uRtfdDiagramFrame, Math, Windows, uError, SysUtils,
  uIterators, IniFiles, Dialogs, EssLayout, uConfig, contnrs, ExtCtrls,
  uIntegrator;
{$endif}
{$ifdef LINUX}
uses uRtfdDiagramFrame, Math, uError, SysUtils,
  uIterators, IniFiles, QDialogs, EssLayout, uConfig, contnrs;
{$endif}


{ TRtfdDiagram }

constructor TRtfdDiagram.Create(om: TObjectModel; Parent: TWinControl; Feedback : IEldeanFeedback = nil);
begin
  inherited Create(Om, Parent, Feedback);
  Frame := TRtfdDiagramFrame.Create(Parent, Self);
  Frame.Parent := Parent;

  Panel := TessConnectPanel.Create(Parent);
  if not Config.IsLimitedColors then
    Panel.BackBitmap := TRtfdDiagramFrame(Frame).DiaBackImage.Picture.Bitmap;
  Panel.Parent := Frame.ScrollBox;

  //Both these events triggers refresh of zoomimage
  Panel.OnContentChanged := OnNeedZoomUpdate;
  Frame.ScrollBox.OnResize := OnNeedZoomUpdate;

  BoxNames := TStringList.Create;
  BoxNames.CaseSensitive := True;
  BoxNames.Sorted := True;
  BoxNames.Duplicates := dupIgnore;

  Model.AddListener(IBeforeObjectModelListener(Self));
  ClearDiagram;
end;

destructor TRtfdDiagram.Destroy;
begin
  //Force listeners to release, and diagram to persist.
  Panel.Hide;
  Package := nil;
  ClearDiagram;
  Model.RemoveListener(IBeforeObjectModelListener(Self));
  FreeAndNil(BoxNames);
  inherited;
end;

procedure TRtfdDiagram.InitFromModel;
var
  Mi : IModelIterator;
  FetchCount : integer;

  procedure InAddUnit(Up: TUnitPackage);
  var
    Mi : IModelIterator;
  begin
    Mi := Up.GetClassifiers;
    while Mi.HasNext do
      AddBox( Mi.Next );
  end;

begin
  IsAllClasses := Package=AllClassesPackage;
  Panel.Hide;
  if not Assigned(FPackage) then
  begin
    Package := Model.ModelRoot;
    //If there is only one package (except unknown) then show it.
    //Assign with Package-property to trigger listeners
    Mi := (FPackage as TLogicPackage).GetPackages;
    if Mi.Count=2 then
    begin
      Mi.Next;
      Package := Mi.Next as TAbstractPackage;
    end;
  end;

  //Clean old
  ClearDiagram;

  //Create boxes
  if FPackage is TUnitPackage then
  begin
    TRtfdUnitPackageDiagram.Create(Panel, FPackage);
    InAddUnit(FPackage as TUnitPackage);
  end
  else
  begin
    //Logic package
    //Exclude unknown-package, otherwise all temp-classes will be included on showallclasses.
    //Also, unkown-package will be shown on package-overview (including docgen)
    if IsAllClasses then
    begin
      //These lines show all members of a package on one diagram
      Mi := TModelIterator.Create( (Model.ModelRoot as TLogicPackage).GetPackages, TEntitySkipFilter.Create(Model.UnknownPackage) );
      while Mi.HasNext do
        InAddUnit( Mi.Next as TUnitPackage )
    end
    else
    begin
      Mi := TModelIterator.Create( (FPackage as TLogicPackage).GetPackages, TEntitySkipFilter.Create(Model.UnknownPackage) );
      while Mi.HasNext do
        AddBox( Mi.Next );
    end;
  end;

  //Fetch layout for this diagram
  FetchCount := FetchDiagram;

  //Create arrow between boxes
  //This must be done after fetchdiagram because Connection-setting might be stored
  ResolveAssociations;

  //Make auto-layout
  if FetchCount=0 then
    DoLayout
  else if FetchCount<BoxNames.Count-2 then
      //if MessageDlg('Model has changed since diagram was saved.'#13'Re-layout?',mtConfirmation,mbOKCancel,0) = mrOk then
      DoLayout
  else
  begin
    with GetStorage(False) do
    begin
      Feedback.Message('Diagram layout and settings was read from file: ' + FileName);
      Free;
    end;
  end;

  Panel.RecalcSize;
  Panel.IsModified := False;

  DoOnUpdateToolbar;
  DoOnUpdateZoom;
  Panel.Show;
  Panel.SetFocus;
  FHasChanged := False;
end;



procedure TRtfdDiagram.ModelBeforeChange(Sender: TModelEntity);
begin
  ErrorHandler.Trace(Format('%s : %s', ['ModelBeforeChange', ClassName]));
  Package := nil;
  IsAllClasses := False;
  ClearDiagram;
end;


procedure TRtfdDiagram.ModelAfterChange(Sender: TModelEntity);
begin
  ErrorHandler.Trace(Format('%s : %s', ['ModelAfterChange', ClassName]));
  InitFromModel;
end;


procedure TRtfdDiagram.PaintTo(Canvas: TCanvas; X, Y: integer; SelectedOnly : boolean);
var
{$ifdef WIN32}
  OldBit : Graphics.TBitmap;
{$endif}
{$ifdef LINUX}
  OldBit : QGraphics.TBitmap;
{$endif}
begin
  OldBit := Panel.BackBitmap;
  Panel.BackBitmap := nil;

  if SelectedOnly then
  begin
    if (Panel.GetFirstSelected<>nil) then
      Panel.SelectedOnly := True;
  end
  else
    //Selection-markers should not be visible in the saved picture
    Panel.ClearSelection;

{$ifdef WIN32}
  Panel.PaintTo(Canvas.Handle, X, Y);
{$endif}
{$ifdef LINUX}
  { TODO : Fix for Linux }
{$endif}
  Panel.SelectedOnly := False;
  Panel.BackBitmap := OldBit;
end;


procedure TRtfdDiagram.ClearDiagram;
begin
  if not (csDestroying in Panel.ComponentState) then
  begin
    Panel.ClearManagedObjects;
    Panel.DestroyComponents;
  end;
  BoxNames.Clear;
  FHasHidden := False;
  FHasChanged := False;
end;



//Add a 'Box' to the diagram (class/interface/package).
procedure TRtfdDiagram.AddBox(E: TModelEntity);
var
  Mi : IModelIterator;
  Int : TInterface;
  C : TClass;
  A : TAttribute;

  function InCreateBox(E: TModelEntity; BoxT: TRtfdBoxClass): TRtfdBox;
  begin
    Result := BoxT.Create(Panel, E, Frame, VisibilityFilter);
    BoxNames.AddObject(E.FullName, Result);
  end;

begin
  if E is TUnitPackage then
    Panel.AddManagedObject( InCreateBox(E,TRtfdUnitPackage) )
  else if E is TClass then
  //Class
  begin
    //Insert related boxes from other packages
    //This should not be done if IsAllClasses, because then all boxes are inserted anyway
    if not IsAllClasses then
    begin
      //Ancestor that is in another package and that is not already inserted
      //is added to the diagram.
      C := (E as TClass);
      if Assigned(C.Ancestor) and
        (C.Ancestor.Owner<>E.Owner) and
        ( GetBox(C.Ancestor.FullName)=nil ) then
        Panel.AddManagedObject( InCreateBox(C.Ancestor,TRtfdClass) );
      //Implementing interface that is in another package and is not already inserted
      //is added to the diagram.
      Mi := C.GetImplements;
      while Mi.HasNext do
      begin
        Int := Mi.Next as TInterface;
        if (Int.Owner<>E.Owner) and
          ( GetBox( Int.FullName )=nil ) then
          Panel.AddManagedObject( InCreateBox(Int,TRtfdInterface) );
      end;
      //Attribute associations that are in other packages are added
      if ShowAssoc then
      begin
        Mi := C.GetAttributes;
        while Mi.HasNext do
        begin
          A := TAttribute(Mi.Next);
          if Assigned(A.TypeClassifier) and (GetBox(A.TypeClassifier.FullName)=nil) and
            (A.TypeClassifier<>C) and (A.TypeClassifier<>C.Ancestor) and
            (A.TypeClassifier.Owner<>Model.UnknownPackage) then //Avoid getting temp-types from unknown (java 'int' for example)
          begin
            if A.TypeClassifier is TClass then
              Panel.AddManagedObject( InCreateBox(A.TypeClassifier,TRtfdClass) );
            if A.TypeClassifier is TInterface then
              Panel.AddManagedObject( InCreateBox(A.TypeClassifier,TRtfdInterface) );
          end;
        end;
      end;
    end;
    if GetBox(E.FullName)=nil then
      Panel.AddManagedObject( InCreateBox(E,TRtfdClass) );
  end
  else if E is TInterface then
  //Interface
  begin
    //Ancestor that is in another package and that is not already inserted
    //is added to the diagram.
    if (not IsAllClasses) and
      Assigned((E as TInterface).Ancestor) and
      (TInterface(E).Ancestor.Owner<>E.Owner) and
      ( GetBox(TInterface(E).Ancestor.FullName)=nil ) then
      Panel.AddManagedObject( InCreateBox((E as TInterface).Ancestor,TRtfdInterface) );
    if GetBox(E.FullName)=nil then
      Panel.AddManagedObject( InCreateBox(E,TRtfdInterface) );
  end;
end;


//Make arrows between boxes
procedure TRtfdDiagram.ResolveAssociations;
var
  I : integer;
  CBox: TRtfdClass;
  IBox : TRtfdInterface;
  A : TAttribute;

  UBox : TRtfdUnitPackage;
  U : TUnitPackage;
  Dep : TUnitDependency;

  Mi : IModelIterator;
  DestBox: TRtfdBox;
begin
  for I := 0 to BoxNames.Count - 1 do
    if (BoxNames.Objects[I] is TRtfdClass) then
    begin //Class
      CBox := (BoxNames.Objects[I] as TRtfdClass);
      //Ancestor
      if Assigned((CBox.Entity as TClass).Ancestor) then
      begin
        DestBox := GetBox( (CBox.Entity as TClass).Ancestor.FullName );
        if Assigned(DestBox) then
          Panel.ConnectObjects(CBox,DestBox);
      end;
      //Implements
      Mi := (CBox.Entity as TClass).GetImplements;
      while Mi.HasNext do
      begin
        DestBox := GetBox( Mi.Next.FullName );
        if Assigned(DestBox) then
          Panel.ConnectObjects(CBox,DestBox,csThinDash);
      end;
      //Attributes associations
      if ShowAssoc then
      begin
        Mi := (CBox.Entity as TClass).GetAttributes;
        while Mi.HasNext do
        begin
          A := TAttribute(Mi.Next);
          //Avoid arrows that points to themselves, also associations to ancestor (double arrows)
          if Assigned(A.TypeClassifier) and
            (A.TypeClassifier<>CBox.Entity) and
            (A.TypeClassifier<>(CBox.Entity as TClass).Ancestor) then
          begin
            DestBox := GetBox( A.TypeClassifier.FullName );
            //Test for same entity, this will filter out TDatatype that can have same name as a class
            if Assigned(DestBox) and (DestBox.Entity=A.TypeClassifier) then
              Panel.ConnectObjects(CBox,DestBox,csThin,asEmptyOpen);
          end;
        end;
      end;
    end else if (BoxNames.Objects[I] is TRtfdInterface) then
    begin //Interface
      IBox := (BoxNames.Objects[I] as TRtfdInterface);
      //Ancestor
      if Assigned((IBox.Entity as TInterface).Ancestor) then
      begin
        DestBox := GetBox( (IBox.Entity as TInterface).Ancestor.FullName );
        if Assigned(DestBox) then
          Panel.ConnectObjects(IBox,DestBox);
      end;
    end else if (BoxNames.Objects[I] is TRtfdUnitPackage) then
    begin //Unit
      UBox := (BoxNames.Objects[I] as TRtfdUnitPackage);
      U := UBox.Entity as TUnitPackage;
      Mi := U.GetUnitDependencies;
      while Mi.HasNext do
      begin
        Dep := Mi.Next as TUnitDependency;
        if Dep.Visibility=viPublic then
        begin
          DestBox := GetBox( Dep.Package.FullName );
          if Assigned(DestBox) then
            Panel.ConnectObjects(UBox,DestBox,csThinDash,asEmptyOpen);
        end;
      end;
    end;
end;