unit LineConnector;
{
  (C) 2000 - 2002 Jindrich Jindrich, Pavel Pisa, PiKRON Ltd.

  Originators of the CHROMuLAN project:

  Jindrich Jindrich - http://www.jindrich.com
                      http://orgchem.natur.cuni.cz/Chromulan/
                      software developer, project coordinator
  Pavel Pisa        - http://cmp.felk.cvut.cz/~pisa
                      embeded software developer
  PiKRON Ltd.       - http://www.pikron.com
                      project initiator, sponsor, instrument developer

  The CHROMuLAN project is distributed under the GNU General Public Licence.
  See file COPYING for details.

  Originators reserve the right to use and publish sources
  under different conditions too. If third party contributors
  do not accept this condition, they can delete this statement
  and only GNU license will apply.
}

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.
