unit LineConnector;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Math;

type
  TSourceLinePos = (spBottom, spRight, spTop, spLeft);
  TDestLinePos = (dpTop, dpLeft, dpBottom, dpRight);
  TArrowPos = (apStart, apMiddle, apEnd);
  TArrowOpt = set of TArrowPos;

  TLineConnector = class(TCustomControl) {twincontrol}
  private
    { Private declarations }
    FSource: TWinControl;
    FDest: TWinControl;
    FSourceConnectCount: integer;
    FSourceConnectIndex: integer;
    FSourceConnectFract: single;
      { what fraction (in the center) of the whole source width should be
        used for connection lines (e.g. if = 0.5, half of the widht will be used)}
    FDestConnectCount: integer;
    FDestConnectIndex: integer;
    FDestConnectFract: single;

    FDirectLine: boolean;
    FSourceLinePos: TSourceLinePos;
    FDestLinePos: TDestLinePos;
    FArrowOpt: TArrowOpt;
    FArrowLen: integer;
    FArrowWidth: integer;
    {procedure WMERASEBKGND(var Msg: TMessage); message WM_ERASEBKGND;}
  protected
    { Protected declarations }
    procedure CreateParams(var Params: TCreateParams); override;
    procedure Paint;override;
    procedure SetSource(ASource: TWinControl);
    procedure SetDest(ADest: TWinControl);
    procedure SetSourceConnectCount(ACount:integer);
    procedure SetDestConnectCount(ACount:integer);
    procedure SetSourceConnectIndex(AIndex:integer);
    procedure SetDestConnectIndex(AIndex:integer);
    procedure SetDirectLine(OnOff:boolean);
    procedure SetSourceConnectFract(AFract: single);
    procedure SetDestConnectFract(AFract: single);
    procedure SetSourceLinePos(ASourceLinePos: TSourceLinePos);
    procedure SetDestLinePos(ADestLinePos: TDestLinePos);
    procedure SetArrowOpt(AArrowOpt: TArrowOpt);

    procedure UpdateSize;
    {procedure WMDestroyed tform WMSize}
    procedure Loaded; override;
    procedure AskRepaint;
    procedure Notification(AComponent: TComponent;
              Operation: TOperation); override;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;


  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published {tlabel}
    { Published declarations }
    property Source: TWinControl read FSource write SetSource;
    property Dest: TWinControl read FDest write SetDest;
    property SourceConnectCount: integer read FSourceConnectCount write SetSourceConnectCount default 1;
    property SourceConnectIndex: integer read FSourceConnectIndex write SetSourceConnectIndex default 0;
    property DestConnectCount: integer read FDestConnectCount write SetDestConnectCount default 1;
    property DestConnectIndex: integer read FDestConnectIndex write SetDestConnectIndex default 0;
    property DirectLine: boolean read FDirectLine write SetDirectLine default false;
    property SourceConnectFract: single read FSourceConnectFract write SetSourceConnectFract;
    property DestConnectFract: single read FDestConnectFract write SetDestConnectFract;
    property SourceLinePos: TSourceLinePos read FSourceLinePos write SetSourceLinePos;
    property DestLinePos: TDestLinePos read FDestLinePos write SetDestLinePos;
    property ArrowOpt: TArrowOpt read FArrowOpt write SetArrowOpt;
    property ArrowWidth: integer read FArrowWidth write FArrowWidth;
    property ArrowLen: integer read FArrowLen write FArrowLen;
  end;

procedure Register;

implementation

constructor TLineConnector.Create(AOwner: TComponent);
{var cs: TControlState;}
begin
  inherited Create(AOwner);
  Width := 10;
  Height := 10;                { twincontrol beginpaint windows messages WM_PAINT}
  FSourceConnectCount := 1;
  FDestConnectCount := 1;
  FSourceConnectIndex := 0;
  FDestConnectIndex := 0;
  {Canvas.Brush.Style := bsClear;}
  if not (csDesigning in ComponentState) then
    Enabled := false;
  {v0.32}
  {ControlStyle := ControlStyle - [csOpaque];}
  {/v0.32}
end;

procedure TLineConnector.CreateParams(var Params: TCreateParams);
begin
  inherited;
  {Params.Style := Params.Style or WS_DISABLED;}
{  Params.ExStyle := Params.ExStyle or WS_EX_TRANSPARENT;{createwindowex}
end;

{procedure TLineConnector.WMERASEBKGND(var Msg:TMessage);
begin
  Msg.Result := 1;
  inherited;
end;}

procedure TLineConnector.SetSource(ASource: TWinControl);
begin
  FSource := ASource;{wm_paint settimer paint }
  UpdateSize;
end;

procedure TLineConnector.UpdateSize;
var
  r: TRect;{x1, x2, y1, y2: integer; {controlstyle}
begin
  if (FSource <> nil) and (FDest <> nil) then begin
     exit;

    if csDesigning in ComponentState then
      exit;
    r.Left := Min(FSource.Left, FDest.Left);
    r.Right := Max(FSource.Left + FSource.Width, FDest.Left + FDest.Width);
    r.Top := Min(FSource.Top, FDest.Top);
    r.Bottom := Max(FSource.Top + FSource.Height, FDest.Top +  FDest.Height);
    BoundsRect := r;

    {Width := 1;{abs(FSource.Left + FSource.Width div 2 - (FDest.Left + FDest.Width div 2));}
    {Height := 1;{abs(FDest.Top - (FSource.Top + FSource.Height));}
  end;
  AskRepaint;
end;

procedure TLineConnector.SetDest(ADest: TWinControl);
begin
  FDest := ADest;
  UpdateSize;
end;

procedure TLineConnector.Paint;
var
  sl, sw, st, sh,
  sr, sb, sx, sy,

  scc, sci, scd,

  dl, dw, dt, dh,
  {dr, db, }dx, dy,

  dcc, dci, dcd,

  mx, my, my1, my2, mx1, mx2
  :  integer;

  scf, dcf: single;

  slp: TSourceLinePos;
  dlp: TDestLinePos;

  {v0.26}
  leftOffs, topOffs: integer;
  canv: TCanvas;
  {/v0.26}

const
  Dist = 10;
  {ArrowLen = 6;
  ArrowWidth = 4;}

  ConWidthFract = 3;

  procedure DrawArrow(x1,y1,x2,y2:integer);
  begin
    with Canv do begin
    if x1 < x2 then begin
      MoveTo(x2 - ArrowLen, y2 + ArrowWidth div 2);
      LineTo(x2, y2);
      LineTo(x2 - ArrowLen, y2 - ArrowWidth div 2);
    end else if x1 = x2 then begin
      if y1 < y2 then begin
        MoveTo(x2 - ArrowWidth div 2, y2 - ArrowLen);
        LineTo(x2, y2);
        LineTo(x2 + ArrowWidth div 2, y2 - ArrowLen);
      end else begin
        MoveTo(x2 - ArrowWidth div 2, y2 + ArrowLen);
        LineTo(x2, y2);
        LineTo(x2 + ArrowWidth div 2, y2 + ArrowLen);
      end;
    end else begin
      MoveTo(x2 + ArrowLen, y2 + ArrowWidth div 2);
      LineTo(x2, y2);
      LineTo(x2 + ArrowLen, y2 - ArrowWidth div 2);
    end;
    end;
  end;

  procedure DrawBottomTop;
  begin
    with Canv do begin

      sx := sl + sw div 2;

      if scc > 1 then begin
        sx := sx - ( (scc - 1) * scd div 2 ) + sci * scd;
      end;
      sy := sb;

      dx := dl + dw div 2;
      if dcc > 1 then begin
        dx := dx - ( (dcc - 1) * dcd div 2 ) + dci * dcd;
      end;

      dy := dt;
      mx := (sx + (sw div 2) + dx - (dw div 2)) div 2;

      if DirectLine then begin

        MoveTo(sx, sy);
        LineTo(dx, dy);

      end else begin
        my := (sy + dy) div 2;
        if (sb + Dist) < dt then begin
          MoveTo(sx, sy);
          LineTo(sx, my);
          LineTo(dx, my);
          LineTo(dx, dy);
          if apMiddle in ArrowOpt then begin
            DrawArrow(mx - ArrowLen, my, mx, my);
          end;
        end else begin
          my1 := sy + Dist;
          my2 := dy - Dist;
          MoveTo(sx, sy);
          LineTo(sx, my1);
          LineTo(mx, my1);
          LineTo(mx, my2);
          LineTo(dx, my2);
          LineTo(dx, dy);
          if apMiddle in ArrowOpt then begin
            DrawArrow(mx, my + ArrowLen, mx, my);
          end;
        end;
        if apStart in ArrowOpt then begin
          DrawArrow(sx, sy + ArrowLen, sx, sy + 2 * ArrowLen);
        end;
        if apEnd in ArrowOpt then begin
          DrawArrow(dx, dy - 2 * ArrowLen, dx, dy -ArrowLen);
        end;
      end;


    end;
  end;

  procedure DrawRightLeft;
  begin
    with Canv do begin

      sx := sr;

      sy := st + sh div 2;
      if scc > 1 then begin
        sy := sy - ( (scc - 1) * scd div 2 ) + sci * scd;
      end;

      dx := dl;
      dy := dt + dh div 2;
      if dcc > 1 then begin
        dy := dy - ( (dcc - 1) * dcd div 2 ) + dci * dcd;
      end;

      my := (sy + (sh div 2) + dy - (dh div 2)) div 2;

      if DirectLine then begin

        MoveTo(sx, sy);
        LineTo(dx, dy);

      end else begin
        if (sr + Dist) < dl then begin

          mx := (sx + dx) div 2;

          MoveTo(sx, sy);
          LineTo(mx, sy);
          LineTo(mx, dy);
          LineTo(dx, dy);

        end else begin
          mx1 := sx + Dist;
          mx2 := dx - Dist;
          MoveTo(sx, sy);
          LineTo(mx1,sy);
          LineTo(mx1, my);
          LineTo(mx2, my);
          LineTo(mx2, dy);
          LineTo(dx, dy);
        end;
      end;

    end;
  end;


  procedure error;
  begin
    if not (csDesigning in ComponentState) then
      raise Exception.Create('LineConnector.' + Name + ': Unsupported combination of LinePos');
  end;

begin
  if csDesigning in ComponentState then
  begin
    {Canvas.Rectangle(0, 0, Width, Height);}
    {Canvas.Brush.Style := bsClear;}

    Canvas.MoveTo(0, Height div 4);
    Canvas.LineTo(Width div 2, Height div 4);
    Canvas.LineTo(Width div 2, Height div 4 * 3);
    Canvas.LineTo(Width, Height div 4 * 3);
  end else begin
    {minimize at runtime}
    {v0.26 should ignore these lines if will be using Canvas instead of OwnerForm.Canvas}
    if Height <> 1 then
      Height := 1;
    if Width <> 1 then
      Width := 1;
    {/v0.26
    if Height <> 1 then
      Height := 1;
    if Width <> 1 then
      Height := 1;}
  end;
  if (FSource = nil) or (FDest = nil) then
    exit;

  {v0.26}
  if true {csDesigning in ComponentState} then begin
    Canv := TForm(Owner).Canvas;{exelogu}
    leftOffs := 0;
    topOffs := 0;
  end else begin
    Canv := Canvas;{TForm(Owner).Canvas}
    leftOffs := Left;
    topOffs := Top;
  end;
  {/v0.26}
  if ArrowLen = 0 then
    ArrowLen := 6;
  if ArrowWidth = 0 then
    ArrowWidth := 4;
  sl := FSource.Left - leftOffs;
  sw := FSource.Width;
  st := FSource.Top - topOffs;
  sh := FSource.Height;
  slp := FSourceLinePos;

  scc := FSourceConnectCount;
  if scc = 0 then
    scc := 1;
  scf := FSourceConnectFract;
  if scf = 0 then
    scf := 1/ConWidthFract;

  sci := FSourceConnectIndex;
  case slp of
    spBottom, spTop: scd := round(scf * sw) div scc;
    spLeft, spRight: scd := round(scf * sh) div scc;
  end;

  sr := sl + sw;
  sb := st + sh;

  dl := FDest.Left - leftOffs;
  dw := FDest.Width;
  dt := FDest.Top - topOffs;
  dh := FDest.Height;
  dlp := FDestLinePos;

  {dr := dl + dw;}
  {db := dt + dh;}

  dcc := FDestConnectCount;
  if dcc = 0 then
    dcc := 1;
  dcf := FDestConnectFract;
  if dcf = 0 then
    dcf := 1/ConWidthFract;

  dci := FDestConnectIndex;
  case dlp of
    dpTop, dpBottom: dcd := round(dcf * dw) div dcc;
    dpLeft, dpRight: dcd := round(dcf * dh) div dcc;
  end;

  case slp of
    spBottom: begin
      case dlp of
        dpTop: begin
          DrawBottomTop;
        end;
      else
        error;
      end;
    end;
    spRight: begin
      case dlp of
        dpLeft: begin
          DrawRightLeft;
        end;
      else
        error;
      end;
    end;
  else
    error;
  end;
  {inherited Paint;}
end;

destructor TLineConnector.Destroy;
begin
  if Owner is TForm then with Owner as TForm do begin
    AskRepaint;
  end;
  inherited Destroy;
end;

procedure TLineConnector.Loaded;
begin
  inherited Loaded;
  if FSourceConnectCount = 0 then
    SourceConnectCount := 1;
  if FDestConnectCount = 0 then
    DestConnectCount := 1;
end;

procedure TLineConnector.SetSourceConnectCount(ACount:integer);
begin
  if FSourceConnectCount <> ACount then begin
    FSourceConnectCount := ACount;
      AskRepaint;
  end;
end;

procedure TLineConnector.SetDestConnectCount(ACount:integer);
begin
  if FDestConnectCount <> ACount then begin
    FDestConnectCount := ACount;
    AskRepaint;
  end;
end;

procedure TLineConnector.SetSourceConnectIndex(AIndex:integer);
begin
  if FSourceConnectIndex <> AIndex then begin
    FSourceConnectIndex := AIndex;
    Invalidate;
  end;
end;

procedure TLineConnector.SetDestConnectIndex(AIndex:integer);
begin
  if FDestConnectIndex <> AIndex then begin
    FDestConnectIndex := AIndex;
    Invalidate;
  end;
end;

procedure TLineConnector.SetDirectLine(OnOff:boolean);
begin
  if FDirectLine <> OnOff then begin
    FDirectLine := OnOff;
    AskRepaint;
  end;
end;

procedure TLineConnector.SetSourceConnectFract(AFract: single);
begin
  if FSourceConnectFract <> AFract then begin
    FSourceConnectFract := AFract;
    AskRepaint;
  end;
end;

procedure TLineConnector.SetDestConnectFract(AFract: single);
begin
  if FDestConnectFract <> AFract then begin
    FDestConnectFract := AFract;
    AskRepaint;
  end;
end;

procedure TLineConnector.SetSourceLinePos(ASourceLinePos: TSourceLinePos);
begin
  if ASourceLinePos <> FSourceLinePos then begin
    FSourceLinePos := ASourceLinePos;
    AskRepaint;
  end;
end;

procedure TLineConnector.SetDestLinePos(ADestLinePos: TDestLinePos);
begin
  if ADestLinePos <> FDestLinePos then begin
    FDestLinePos := ADestLinePos;
    AskRepaint;
  end;
end;

procedure TLineConnector.SetArrowOpt(AArrowOpt: TArrowOpt);
begin
  if AArrowOpt <> FArrowOpt then begin
    FArrowOpt := AArrowOpt;
    AskRepaint;
  end;
end;

procedure TLineConnector.AskRepaint;
begin
  if Owner is TForm then with Owner as TForm do begin
    Invalidate;
  end;
  Invalidate;
end;

procedure TLineConnector.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) then begin
    if (AComponent = FDest) then
      FDest := nil
    else if (AComponent = FSource) then
      FSource := nil;
  end;
end;

procedure TLineConnector.WMSize(var Message: TWMSize);
begin
  inherited;
{  AskRepaint;}
{  GridLines := 6 * GridLineWidth;
  DefaultColWidth := (Message.Width - GridLines) div 7;
  DefaultRowHeight := (Message.Height - GridLines) div 7;}
end;

procedure Register;
begin
  RegisterComponents('Chromulan', [TLineConnector]);
end;

end.
