urtfdcomponents.pas

一个UML建模工具

end;


{ TVisibilityLabel }

const
  IconW = 10;

procedure TVisibilityLabel.Paint;
var
  Rect : TRect;
{$ifdef WIN32}
  Pic : Graphics.TBitmap;
{$endif}
{$ifdef LINUX}
  Pic : QGraphics.TBitmap;
{$endif}
begin
{ifdef WIN32}
  Rect := ClientRect;

  case Entity.Visibility of
    viPrivate : Pic := ((Parent as TRtfdBox).Frame as TRtfdDiagramFrame).VisPrivateImage.Picture.Bitmap;
    viProtected : Pic := ((Parent as TRtfdBox).Frame as TRtfdDiagramFrame).VisProtectedImage.Picture.Bitmap;
    viPublic : Pic := ((Parent as TRtfdBox).Frame as TRtfdDiagramFrame).VisPublicImage.Picture.Bitmap;
  else
    Pic := ((Parent as TRtfdBox).Frame as TRtfdDiagramFrame).VisPublicImage.Picture.Bitmap;
  end;
  Canvas.Draw(Rect.Left,Rect.Top + 1, Pic );

  Canvas.Font := Font;
  Canvas.TextOut(Rect.Left + IconW + 4, Rect.Top, Caption);
{endif}
end;


function TVisibilityLabel.WidthNeeded: integer;
begin
  Result := Width + IconW;
end;

{ TRtfdClassName }

constructor TRtfdClassName.Create(Owner: TComponent; Entity: TModelEntity);
begin
  inherited Create(Owner, Entity);
  Font.Style := [fsBold];
  Alignment := taCenter;
  Entity.AddListener(IAfterClassListener(Self));
  EntityChange(nil);
end;

destructor TRtfdClassName.Destroy;
begin
  Entity.RemoveListener(IAfterClassListener(Self));
  inherited;
end;

procedure TRtfdClassName.EntityChange(Sender: TModelEntity);
var
  Mi : IModelIterator;
begin
  Mi := (Entity as TClass).GetOperations;
  while Mi.HasNext do
    if (Mi.Next as TOperation).IsAbstract then
    begin
      Font.Style := Font.Style + [fsItalic];
      Break;
    end;
  if ((Owner as TRtfdBox).Frame as TDiagramFrame).Diagram.Package<>Entity.Owner then
    Caption := Entity.FullName
  else
    Caption := Entity.Name;
end;


{ TRtfdInterfaceName }

constructor TRtfdInterfaceName.Create(Owner: TComponent;
  Entity: TModelEntity);
begin
  inherited Create(Owner, Entity);
  Font.Style := [fsBold];
  Alignment := taCenter;
  Entity.AddListener(IAfterInterfaceListener(Self));
  EntityChange(nil);
end;

destructor TRtfdInterfaceName.Destroy;
begin
  Entity.RemoveListener(IAfterInterfaceListener(Self));
  inherited;
end;

procedure TRtfdInterfaceName.EntityChange(Sender: TModelEntity);
begin
  if ((Owner as TRtfdBox).Frame as TDiagramFrame).Diagram.Package<>Entity.Owner then
    Caption := Entity.FullName
  else
    Caption := Entity.Name;
end;


{ TRtfdSeparator }

constructor TRtfdSeparator.Create(Owner: TComponent);
begin
  //Cannot inherit from TCustomLabel in Kylix because it does not have a paint-method
  inherited Create(Owner);
  Parent := Owner as TWinControl;
  {$ifdef WIN32}
  AutoSize := False;
  {$endif}
  {$ifdef LINUX}
  { TODO : Fix for Linux }
  {$endif}
  Height := 16;
  //Top must be assigned so that all labels appears beneath each other when align=top
  Top := MaxInt;
  Align := alTop;
end;

procedure TRtfdSeparator.Paint;
var
  R: TRect;
begin
  R := ClientRect;
  //Canvas.FillRect(R);
  Canvas.Pen.Color := clBlack;
  Canvas.MoveTo(R.Left, R.Top + (Height div 2));
  Canvas.LineTo(R.Right, R.Top + (Height div 2));
end;

{ TRtfdPackageName }

constructor TRtfdUnitPackageName.Create(Owner: TComponent;
  Entity: TModelEntity);
begin
  inherited Create(Owner, Entity);
  Font.Style := [fsBold];
  Alignment := taCenter;
  P := Entity as TUnitPackage;
  P.AddListener(IAfterUnitPackageListener(Self));
  EntityChange(nil);
end;

destructor TRtfdUnitPackageName.Destroy;
begin
  P.RemoveListener(IAfterUnitPackageListener(Self));
  inherited;
end;

procedure TRtfdUnitPackageName.EntityChange(Sender: TModelEntity);
begin
  Caption := P.Name;
end;

{ TRtfdOperation }

constructor TRtfdOperation.Create(Owner: TComponent; Entity: TModelEntity);
begin
  inherited Create(Owner, Entity);
  O := Entity as TOperation;
  O.AddListener(IAfterOperationListener(Self));
  EntityChange(nil);
end;

destructor TRtfdOperation.Destroy;
begin
  O.RemoveListener(IAfterOperationListener(Self));
  inherited;
end;

procedure TRtfdOperation.EntityChange(Sender: TModelEntity);
const
  ColorMap: array[TOperationType] of TColor = (clGreen, clRed, clBlack, clGray);
  //   otConstructor,otDestructor,otProcedure,otFunction);
begin
  //Default uml-syntax
  //visibility name ( parameter-list ) : return-type-expression { property-string }
  { TODO : show parameters and returntype for operation }
  Caption := O.Name + '(...)';
  Font.Style := [];
  Font.Color := ColorMap[O.OperationType];
  if O.IsAbstract then
    Font.Style := [fsItalic];
end;

{ TRtfdAttribute }

constructor TRtfdAttribute.Create(Owner: TComponent; Entity: TModelEntity);
begin
  inherited Create(Owner, Entity);
  A := Entity as TAttribute;
  A.AddListener(IAfterAttributeListener(Self));
  EntityChange(nil);
end;

destructor TRtfdAttribute.Destroy;
begin
  A.RemoveListener(IAfterAttributeListener(Self));
  inherited;
end;

procedure TRtfdAttribute.EntityChange(Sender: TModelEntity);
begin
  //uml standard syntax is:
  //visibility name [ multiplicity ] : type-expression = initial-value { property-string }
  if Assigned(A.TypeClassifier) then
    Caption := A.Name + ' : ' + A.TypeClassifier.Name
  else
    Caption := A.Name;
end;

{ TRtfdUnitPackageDiagram }

constructor TRtfdUnitPackageDiagram.Create(Owner: TComponent;
  Entity: TModelEntity);
begin
  //This class is the caption in upper left corner for a unitdiagram
  inherited Create(Owner, Entity);
  Color := clBtnFace;
  Font.Name := 'Times New Roman';
  Font.Style := [fsBold];
  Font.Size := 12;
  Alignment := taLeftJustify;
  P := Entity as TUnitPackage;
  P.AddListener(IAfterUnitPackageListener(Self));
  EntityChange(nil);
end;

destructor TRtfdUnitPackageDiagram.Destroy;
begin
  P.RemoveListener(IAfterUnitPackageListener(Self));
  inherited;
end;

procedure TRtfdUnitPackageDiagram.EntityChange(Sender: TModelEntity);
begin
  Caption := '   ' + P.FullName;
end;


{ TRtfdInterface }

constructor TRtfdInterface.Create(Owner: TComponent; Entity: TModelEntity;
  Frame: TDiagramFrame; MinVisibility : TVisibility);
begin
  inherited Create(Owner, Entity, Frame, MinVisibility);
  Entity.AddListener(IAfterInterfaceListener(Self));
  PopupMenu := Frame.ClassInterfacePopupMenu;
  RefreshEntities;
end;

destructor TRtfdInterface.Destroy;
begin
  Entity.RemoveListener(IAfterInterfaceListener(Self));
  inherited;
end;

procedure TRtfdInterface.RefreshEntities;
var
  NeedW,NeedH,I : integer;
  OMi,AMi : IModelIterator;
  WasVisible : boolean;
  Int : TInterface;
begin
  Int := Entity as TInterface;

  WasVisible := Visible;
  Hide;
  DestroyComponents;

  NeedW := 0;
  NeedH := (ClassShadowWidth * 2) + 4;

  Inc(NeedH, TRtfdStereotype.Create(Self, nil, 'interface').Height);
  Inc(NeedH, TRtfdInterfaceName.Create(Self, Entity).Height);

  //Get names in visibility order
  if FMinVisibility > Low(TVisibility) then
  begin
    Omi := TModelIterator.Create(Int.GetOperations,TOperation,FMinVisibility,ioVisibility);
    Ami := TModelIterator.Create(Int.GetAttributes,TAttribute,FMinVisibility,ioVisibility);
  end
  else
  begin
    Omi := TModelIterator.Create(Int.GetOperations,ioVisibility);
    Ami := TModelIterator.Create(Int.GetAttributes,ioVisibility);
  end;

  //Separator
  if (Ami.Count>0) or (Omi.Count>0) then
    Inc(NeedH, TRtfdSeparator.Create(Self).Height);

  //Attributes
  while Ami.HasNext do
    Inc(NeedH, TRtfdAttribute.Create(Self,Ami.Next).Height);

  //Separator
  if (Ami.Count>0) and (Omi.Count>0) then
    Inc(NeedH, TRtfdSeparator.Create(Self).Height);

  //Operations
  while Omi.HasNext do
    Inc(NeedH, TRtfdOperation.Create(Self,Omi.Next).Height);

  for I := 0 to ControlCount-1 do
    if Controls[I] is TRtfdCustomLabel then
      NeedW := Max( TRtfdCustomLabel(Controls[I]).WidthNeeded,NeedW);

  Height :=  Max(NeedH,cDefaultHeight);
  Width  :=  Max(NeedW,cDefaultWidth);

  Visible := WasVisible;
end;

procedure TRtfdInterface.AddChild(Sender, NewChild: TModelEntity);
begin
  RefreshEntities;
end;

{ TRtfdStereotype }

constructor TRtfdStereotype.Create(Owner: TComponent; Entity: TModelEntity; Caption: string);
begin
  inherited Create(Owner, Entity);
  Alignment := taCenter;
  Self.Caption := '<<' + Caption + '>>';
end;

function TRtfdCustomLabel.GetAlignment: TAlignment;
begin
  Result := FAlignment;
end;

procedure TRtfdCustomLabel.SetAlignment(const Value: TAlignment);
begin
  if Value <> FAlignment then
    begin
    FAlignment := Value;
    Invalidate;
  end;
end;

procedure TRtfdCustomLabel.Paint;
var
  Al: Integer;
  oldFont: TFont;
  r: TRect;
begin
  inherited;
  { TODO : Fix }
  oldFont := Canvas.Font;
  Canvas.Font := Font;
  if FTransparent then
    Canvas.Brush.Style := bsClear
  else
    Canvas.Brush.Style := bsSolid;
{$ifdef WIN32}
  Al := DT_LEFT;
  case FAlignment of
    taLeftJustify: Al := DT_LEFT;
    taRightJustify: Al := DT_RIGHT;
    taCenter: Al := DT_CENTER;
  end;
  r := ClientRect;
  DrawText(Canvas.Handle,PChar(Caption),Length(Caption),r,Al);
{$endif}
{$ifdef LINUX}
  case FAlignment of
    taLeftJustify: Al := Ord(AlignmentFlags_AlignLeft);
    taRightJustify: Al := Ord(AlignmentFlags_AlignRight);
    taCenter: Al := Ord(AlignmentFlags_AlignCenter);
  end;

  Canvas.TextRect(ClientRect,0,0,Caption,Ord(AlignmentFlags_AlignVCenter)+Al);
{$endif}
  Canvas.Font := oldFont;
end;

procedure TRtfdCustomLabel.SetTransparent(const Value: Boolean);
begin
  if FTransparent <> Value then
  begin
    FTransparent := Value;
    Invalidate;
  end;
end;


function TRtfdCustomLabel.GetText: TCaption;
begin
  Result := FCaption;
end;

procedure TRtfdCustomLabel.SetText(const Value: TCaption);
begin
  inherited;
  if FCaption <> Value then
  begin
    FCaption := Value;
    Invalidate;
  end;
end;

{$ifdef WIN32}
procedure TRtfdCustomLabel.CMTextChanged(var Message: TMessage);
begin
  Invalidate;
  Adjustbounds;
end;

procedure TRtfdCustomLabel.AdjustBounds;
const
  WordWraps: array[Boolean] of Word = (0, DT_WORDBREAK);
var
  DC: HDC;
  X: Integer;
  Rect: TRect;
  AAlignment: TAlignment;
begin
  if not (csReading in ComponentState) then
  begin
    Rect := ClientRect;
    DC := GetDC(0);
    Canvas.Handle := DC;
    DoDrawText(Rect, (DT_EXPANDTABS or DT_CALCRECT));
    Canvas.Handle := 0;
    ReleaseDC(0, DC);
    X := Left;
    AAlignment := FAlignment;
    if UseRightToLeftAlignment then ChangeBiDiModeAlignment(AAlignment);
    if AAlignment = taRightJustify then Inc(X, Width - Rect.Right);
    SetBounds(X, Top, Rect.Right, Rect.Bottom);
  end;
end;

procedure TRtfdCustomLabel.DoDrawText(var Rect: TRect; Flags: Longint);
var
  Text: string;
begin
  Text := Caption;
  if (Flags and DT_CALCRECT <> 0) and ((Text = '') and
    (Text[1] = '&') and (Text[2] = #0)) then Text := Text + ' ';
  Flags := Flags or DT_NOPREFIX;
  Flags := DrawTextBiDiModeFlags(Flags);
  Canvas.Font := Font;
  if not Enabled then
  begin
    OffsetRect(Rect, 1, 1);
    Canvas.Font.Color := clBtnHighlight;
    DrawText(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags);
    OffsetRect(Rect, -1, -1);
    Canvas.Font.Color := clBtnShadow;
    DrawText(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags);
  end
  else
    DrawText(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags);
end;
{$endif}


end.