[Lazarus] How to make this Windows component cross-platform? Thanks.

classic Classic list List threaded Threaded
6 messages Options
Reply | Threaded
Open this post in threaded view
|

[Lazarus] How to make this Windows component cross-platform? Thanks.

Antônio
// Initially developed by Gon Perez-Jimenez. 2002-4th-April for Delphi
unit ULine;

interface

uses
   SysUtils, Classes, Controls, Graphics;

type
  TLineDirection = (drLeftRight, drUpDown, drTopLeftBottomRight, drTopRightBottomLeft);

  TLine = class(TGraphicControl)
  private
    { Private declarations }
    FLineDir: TLineDirection;
    FArrow1: Boolean;
    FArrow2: Boolean;
    FArrowFactor: Integer;
    function GetLineWidth: Integer;
    function GetLineColor: TColor;
    function GetLineStyle: TPenStyle;
    procedure SetLineWidth(const NewWidth: Integer);
    procedure SetLineColor(const NewColor: TColor);
    procedure SetLineDir(const NewDir: TLineDirection);
    procedure SetArrow1(Value: Boolean);
    procedure SetArrow2(Value: Boolean);
    procedure SetArrowFactor(Value: integer);
    procedure SetLineStyle(const NewStyle: TPenStyle);
  protected
    { Protected declarations }
    procedure Paint; override;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    { Published declarations }
    property DragCursor;
    property DragKind;
    property DragMode;
    property Align;
    property ParentShowHint;
    property Hint;
    property ShowHint;
    property Visible;
    property PopupMenu;
    property Direction: TLineDirection read FLineDir write SetLineDir default drLeftRight;
    property Color: TColor read GetLineColor write SetLineColor;
    property LineStyle :TPenStyle read GetLineStyle write SetLineStyle;
    property LineWidth: Integer read GetLineWidth write SetLineWidth;
    property Arrow1: Boolean read FArrow1 write SetArrow1 default False;
    property Arrow2: Boolean read FArrow2 write SetArrow2 default False;
    property ArrowFactor: Integer read FArrowFactor write SetArrowFactor default 3;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnEndDock;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnClick;
    property OnDblClick;
  end;

procedure Register;

implementation

{ TLine }

constructor TLine.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csReplicatable];
  Width := 65;
  Height := 4;
  Canvas.Brush.Color:=clBlack;
  FArrowFactor:=3;
end;

destructor TLine.Destroy;
begin
  inherited Destroy;
end;

procedure TLine.SetArrowFactor(Value: Integer);
begin
  if Value <> FArrowFactor then begin
     FArrowFactor := Value;
     Invalidate;
  end;
end;

procedure TLine.SetArrow1(Value: Boolean);
begin
  if Value <> FArrow1 then begin
     FArrow1 := Value;
     if Value then SetLineWidth(1);
     Invalidate;
  end;
end;

procedure TLine.SetArrow2(Value: Boolean);
begin
  if Value <> FArrow2 then begin
     FArrow2 := Value;
     if Value then SetLineWidth(1);
     Invalidate;
  end;
end;

function TLine.GetLineWidth: Integer;
begin
  Result := Canvas.Pen.Width;
end;

function TLine.GetLineColor: TColor;
begin
  Result := Canvas.Pen.Color;
end;

function TLine.GetLineStyle: TPenStyle;
begin
  Result := Canvas.Pen.Style;
end;

procedure TLine.SetLineWidth(const NewWidth: Integer);
begin
  if NewWidth <> Canvas.Pen.Width then
  begin
    if FArrow1 or FArrow2 then begin
       LineWidth:=1;
       Canvas.Pen.Width:=1;
    end else Canvas.Pen.Width := NewWidth;
    Invalidate;
  end;
end;

procedure TLine.SetLineColor(const NewColor: TColor);
begin
  if NewColor <> Canvas.Pen.Color then
  begin
    Canvas.Pen.Color := NewColor;
    Invalidate;
  end;
end;

procedure TLine.SetLineStyle(const NewStyle: TPenStyle);
begin
  if NewStyle <> Canvas.Pen.Style then
  begin
    Canvas.Pen.Style := NewStyle;
    Invalidate;
  end;
end;

procedure TLine.SetLineDir(const NewDir: TLineDirection);
begin
  if NewDir <> FLineDir then
  begin
    FLineDir := NewDir;
    Invalidate;
  end;
end;

procedure TLine.Paint;
var
  start: Integer;
  p1,p2,p3:TPoint;
  H0,W0,H,W:Integer;
  Alfa:extended;
begin
  inherited;
  case FLineDir of
    drLeftRight:
      begin
        start := (Height - Canvas.Pen.Width) div 2;
        Canvas.Brush.Style := bsClear;
        Canvas.MoveTo(0, start);
        Canvas.LineTo(Width, Start);
        if FArrow1 then begin
          // Arrow left
          p1:=Point(0,start);
          p2:=Point(FArrowFactor,Start-FArrowFactor);
          p3:=Point(FArrowFactor,Start+FArrowFactor);
          Canvas.Brush.Style := bsSolid;
          Canvas.Brush.Color := Canvas.Pen.Color;
          Canvas.Polygon([p1,p2,p3]);
        end;

        if FArrow2 then begin
          // Arrow right
          p1:=Point(Width-1, Start);
          p2:=Point(Width-(FArrowFactor+1),Start-FArrowFactor);
          p3:=Point(Width-(FArrowFactor+1),Start+FArrowFactor);
          Canvas.Brush.Style := bsSolid;
          Canvas.Brush.Color := Canvas.Pen.Color;
          Canvas.Polygon([p1,p2,p3]);
        end;
      end;
    drUpDown:
      begin
        start := (Width - Canvas.Pen.Width) div 2;
        Canvas.Brush.Style := bsClear;
        Canvas.MoveTo(start, 0);
        Canvas.LineTo(start, Height);
        if FArrow1 then begin
          // Arrow up
          p1:=Point(start,0);
          p2:=Point(Start-FArrowFactor,FArrowFactor);
          p3:=Point(Start+FArrowFactor,FArrowFactor);
          Canvas.Brush.Style := bsSolid;
          Canvas.Brush.Color := Canvas.Pen.Color;
          Canvas.Polygon([p1,p2,p3]);
        end;

        if FArrow2 then begin
          // Arrow down
          p1:=Point(start,Height-1);
          p2:=Point(Start-FArrowFactor,Height-(FArrowFactor+1));
          p3:=Point(Start+FArrowFactor,Height-(FArrowFactor+1));
          Canvas.Brush.Style := bsSolid;
          Canvas.Brush.Color := Canvas.Pen.Color;
          Canvas.Polygon([p1,p2,p3]);
        end;
      end;
    drTopLeftBottomRight:
      begin
        Canvas.Brush.Style := bsClear;
        Canvas.MoveTo(0, 0);
        Canvas.LineTo(Width, Height);
        if FArrow1 and(Width>0)then begin
          // Arrow up
          Alfa:=ArcTan(Height/Width);
          H0:=Round((FArrowFactor+1)*Sin(Alfa));
          W0:=Round((FArrowFactor+1)*Cos(Alfa));
          p1:=Point(0,0);
          W:=Round(W0+(FArrowFactor*Cos((Pi/2)-Alfa)));
          H:=Round(H0-(FArrowFactor*Sin((Pi/2)-Alfa)));
          if H<0 then H:=0;
          if W<0 then W:=0;
          p2:=Point(W,H);
          W:=Round(W0-(FArrowFactor*Cos((Pi/2)-Alfa)));
          H:=Round(H0+(FArrowFactor*Sin((Pi/2)-Alfa)));
          if H<0 then H:=0;
          if W<0 then W:=0;
          p3:=Point(W,H);
          Canvas.Brush.Style := bsSolid;
          Canvas.Brush.Color := Canvas.Pen.Color;
          Canvas.Polygon([p1,p2,p3]);
        end;
        if FArrow2 and(Width>0)then begin
          // Arrou down
          Alfa:=ArcTan(Height/Width);
          H0:=Round((FArrowFactor+1)*Sin(Alfa));
          W0:=Round((FArrowFactor+1)*Cos(Alfa));
          p1:=Point(Width-1, Height-1);
          W:=Round(W0-(FArrowFactor*Cos((Pi/2)-Alfa)));
          H:=Round(H0+(FArrowFactor*Sin((Pi/2)-Alfa)));
          W:=Width-W-1;
          H:=Height-H-1;
          if H>=Height then H:=Height-1;
          if W>=Width then W:=Width-1;
          p2:=Point(W,H);
          W:=Round(W0+(FArrowFactor*Cos((Pi/2)-Alfa)));
          H:=Round(H0-(FArrowFactor*Sin((Pi/2)-Alfa)));
          W:=Width-W-1;
          H:=Height-H-1;
          if H>=Height then H:=Height-1;
          if W>=Width then W:=Width-1;
          p3:=Point(W,H);
          Canvas.Brush.Style := bsSolid;
          Canvas.Brush.Color := Canvas.Pen.Color;
          Canvas.Polygon([p1,p2,p3]);
        end;
      end;
    drTopRightBottomLeft:
      begin
        Canvas.Brush.Style := bsClear;
        Canvas.MoveTo(Width, 0);
        Canvas.LineTo(0, Height);
        if FArrow1 and(Width>0)then begin
          // Arrou up
          Alfa:=ArcTan(Height/Width);
          H0:=Round((FArrowFactor+1)*Sin(Alfa));
          W0:=Round((FArrowFactor+1)*Cos(Alfa));
          p1:=Point(Width-1,0);
          W:=Round(W0+(FArrowFactor*Cos((Pi/2)-Alfa)));
          H:=Round(H0-(FArrowFactor*Sin((Pi/2)-Alfa)));
          W:=Width-W-1;
          if H<0 then H:=0;
          if W>=Width then W:=Width-1;
          p2:=Point(W,H);
          W:=Round(W0-(FArrowFactor*Cos((Pi/2)-Alfa)));
          H:=Round(H0+(FArrowFactor*Sin((Pi/2)-Alfa)));
          W:=Width-W-1;
          if H<0 then H:=0;
          if W>=Width then W:=Width-1;
          p3:=Point(W,H);
          Canvas.Brush.Style := bsSolid;
          Canvas.Brush.Color := Canvas.Pen.Color;
          Canvas.Polygon([p1,p2,p3]);
        end;
        if FArrow2 and(Width>0)then begin
          // Arrow down
          Alfa:=ArcTan(Height/Width);
          H0:=Round((FArrowFactor+1)*Sin(Alfa));
          W0:=Round((FArrowFactor+1)*Cos(Alfa));
          p1:=Point(0, Height-1);
          W:=Round(W0-(FArrowFactor*Cos((Pi/2)-Alfa)));
          H:=Round(H0+(FArrowFactor*Sin((Pi/2)-Alfa)));
          H:=Height-H-1;
          if H>=Height then H:=Height-1;
          if W<0 then W:=0;
          p2:=Point(W,H);
          W:=Round(W0+(FArrowFactor*Cos((Pi/2)-Alfa)));
          H:=Round(H0-(FArrowFactor*Sin((Pi/2)-Alfa)));
          H:=Height-H-1;
          if H>=Height then H:=Height-1;
          if W<0 then W:=0;
          p3:=Point(W,H);
          Canvas.Brush.Style := bsSolid;
          Canvas.Brush.Color := Canvas.Pen.Color;
          Canvas.Polygon([p1,p2,p3]);
        end;
      end;
  end;
end;

procedure Register;
begin
  RegisterComponents('Misc', [TLine]);
end;

end.   

--
_______________________________________________
Lazarus mailing list
[hidden email]
http://lists.lazarus.freepascal.org/mailman/listinfo/lazarus
Reply | Threaded
Open this post in threaded view
|

Re: [Lazarus] How to make this Windows component cross-platform? Thanks.

Juha Manninen
Here it compiles well. The answer is: it is already cross-platform.
What kind of problems did you have with it?

Juha

--
_______________________________________________
Lazarus mailing list
[hidden email]
http://lists.lazarus.freepascal.org/mailman/listinfo/lazarus
Reply | Threaded
Open this post in threaded view
|

Re: [Lazarus] How to make this Windows component cross-platform? Thanks.

Juha Manninen
Juha (gmail) kirjoitti keskiviikko, 13. huhtikuuta 2011 09:35:36:
> Here it compiles well. The answer is: it is already cross-platform.
> What kind of problems did you have with it?

Tested with both GTK2 and QT bindings. Works well.

Juha

--
_______________________________________________
Lazarus mailing list
[hidden email]
http://lists.lazarus.freepascal.org/mailman/listinfo/lazarus
Reply | Threaded
Open this post in threaded view
|

Re: [Lazarus] How to make this Windows component cross-platform? Thanks.

Antônio
I htas a problem here:

procedure TLine.SetLineWidth(const NewWidth: Integer);
begin
  if NewWidth <> Canvas.Pen.Width then
  begin
    if FArrow1 or FArrow2 then begin

       //  LineWidth:=1; // this line causes stack overflow

       Canvas.Pen.Width:=1;
    end else Canvas.Pen.Width := NewWidth;
    Invalidate;
  end;
end;

Antônio

--
_______________________________________________
Lazarus mailing list
[hidden email]
http://lists.lazarus.freepascal.org/mailman/listinfo/lazarus
Reply | Threaded
Open this post in threaded view
|

Re: [Lazarus] How to make this Windows component cross-platform? Thanks.

Graeme Geldenhuys
On 13/04/2011 16:23, Antônio wrote:

> I htas a problem here:
>
> procedure TLine.SetLineWidth(const NewWidth: Integer);
> begin
>   if NewWidth <> Canvas.Pen.Width then
>   begin
>     if FArrow1 or FArrow2 then begin
>
>        //  LineWidth:=1; // this line causes stack overflow
>
>        Canvas.Pen.Width:=1;
>     end else Canvas.Pen.Width := NewWidth;
>     Invalidate;
>   end;
> end;

Yes, that will cause a recursive loop and end with a stack overflow.
Setting the value of LineWidth calls SetLineWidth() over and over.

Rather simple to fix. Add a new field variable FLineWidth: integer; Set
the default values in the constructor and LineWidth property declaration.

Then modify SetLineWidth() as follows:

procedure TLine.SetLineWidth(const NewWidth: Integer);
begin
  if FArrow1 or FArrow2 then
  begin
    if FLineWidth <> NewWidth then
    begin
      FLineWidth := 1;
      Canvas.Pen.Width := FLineWidth;
    end;
    Invalidate;
  end
  else
  begin
    if NewWidth <> Canvas.Pen.Width then
    begin
      FLineWidth := NewWidth;
      Canvas.Pen.Width := FLineWidth;
      Invalidate;
    end;
  end;
end;



Regards,
  - Graeme -

--
fpGUI Toolkit - a cross-platform GUI toolkit using Free Pascal
http://fpgui.sourceforge.net/


--
_______________________________________________
Lazarus mailing list
[hidden email]
http://lists.lazarus.freepascal.org/mailman/listinfo/lazarus
Reply | Threaded
Open this post in threaded view
|

Re: [Lazarus] How to make this Windows component cross-platform? Thanks.

Antônio
Although I think it is not necessary, once Getter simply reads the Pen.Width.

Antônio

--
_______________________________________________
Lazarus mailing list
[hidden email]
http://lists.lazarus.freepascal.org/mailman/listinfo/lazarus