[Lazarus] Adding shapes to TShape

[Frederic Da Vitoria]

Hello,

For a game, I need to be able to draw geometric shapes. TShape is perfect
except for one missing feature: TShape only draws triangles pointing up,
and I need also triangles pointing left, right and down. My first reaction
was to create a derived class, and try to somehow add the missing shapes by
overriding TShape.Paint and in the overriding method just handle the new
shapes. But TShape is designed in such a way that I can't figure out how to
do it. Then I thought that I'd create a derived class but that this class
Paint method would draw all the possible shapes (including the 3 new ones)
and that for that I'd override the Paint method with a modified
implementation of TShape.Paint. Much less clean, not really oo-ish, but it
should at least work. Should, because when I tried this, I discovered
that it would be much more difficult that I had hoped, so that I decided to
stop trying and ask here first.

Does anybody have a good suggestion about how to handle this? Should I
forget about deriving TShape and should I directly modify TShape's code?

-- 
Frederic Da Vitoria
(davitof)

Membre de l'April - « promouvoir et défendre le logiciel libre » -
http://www.april.org
--
___
Lazarus mailing list
Lazarus@lists.lazarus.freepascal.org
http://lists.lazarus.freepascal.org/mailman/listinfo/lazarus

Re: [Lazarus] Adding shapes to TShape

[Howard Page-Clark]

On 26/12/2013 12:03, Frederic Da Vitoria wrote:
  Should I

forget about deriving TShape and should I directly modify TShape's code?


For a project that needed something similar I found that TShape with its 
fixed TShapeType enumeration was too inflexible (though it is 
Delphi-compatible, hence its presence).
Trying to stuff too much shape-drawing code variety into one gloriously 
polymorphic control becomes increasingly complex and difficult to maintain.
I ended up writing a simple (isosceles only) triangle control which you 
are welcome to adapt as suits you, attached here.


unit triangles;

{$mode objfpc}{$H+}

interface

uses
  Classes, Controls, types, Graphics, LCLProc;

type
  {$M+}
  TBaseAlign=(baBottom, baTop, baLeft, baRight);
  {$M+}

  { TTriangle }

  TTriangle=class(TGraphicControl)
  private
FPen: TPen;
FBaseAlign: TBaseAlign;
FBrush: TBrush;
procedure SetBrush(Value: TBrush);
procedure SetPen(Value: TPen);
procedure SetBaseAlign(aValue: TBaseAlign);
  protected
class function GetControlClassDefaultSize: TSize; override;
  public
constructor Create(TheOwner: TComponent); override;
destructor Destroy; override;
procedure Paint; override;
procedure ParamsChanged(Sender: TObject);
  published
property Align;
property Anchors;
property BaseAlign: TBaseAlign read FBaseAlign write SetBaseAlign 
default baBottom;

property BorderSpacing;
property Brush: TBrush read FBrush write SetBrush;
property Constraints;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property ParentShowHint;
property Pen: TPen read FPen write SetPen;
property OnChangeBounds;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnPaint;
property OnResize;
property OnStartDock;
property OnStartDrag;
property ShowHint;
property Visible;
  end;

implementation

{ TTriangle }

procedure TTriangle.SetBrush(Value: TBrush);
begin
  if Value  Brush then
FBrush.Assign(Value);
end;

procedure TTriangle.SetPen(Value: TPen);
begin
   if Value  Pen then
FPen.Assign(Value);
end;

procedure TTriangle.SetBaseAlign(aValue: TBaseAlign);
begin
  if aValueFBaseAlign then begin
FBaseAlign:=aValue;
ParamsChanged(Self);
  end;
end;

class function TTriangle.GetControlClassDefaultSize: TSize;
begin
  Result.cx:=65;
  Result.cy:=65;
end;

constructor TTriangle.Create(TheOwner: TComponent);
begin
  inherited Create(TheOwner);
  with GetControlClassDefaultSize do
SetInitialBounds(0, 0, CX, CY);
  ControlStyle := ControlStyle + [csReplicatable];
  FPen := TPen.Create;
  FPen.OnChange := @ParamsChanged;
  FBrush := TBrush.Create;
  FBrush.OnChange := @ParamsChanged;
  FBaseAlign:=baBottom;
end;

destructor TTriangle.Destroy;
begin
  FreeThenNil(FPen);
  FreeThenNil(FBrush);
  inherited Destroy;
end;

procedure TTriangle.Paint;
var
  PaintRect: TRect;
  P: array[1..3] of TPoint;
  PenInc, PenDec: Integer;

  procedure CalcPoints(aBaseAlign: TBaseAlign);
  begin
case aBaseAlign of
  baBottom: begin P[1].x := (Width - 1) div 2;
P[1].y := PenInc;
P[2].x := Width - PenInc - 1;
P[2].y := Height - PenInc - 1;
P[3].x := PenInc;
P[3].y := Height - PenInc - 1;  end;
  baTop: begin P[3].x := (Width - 1) div 2;
P[1].x := PenInc;
P[2].x := Width - PenInc - 1;
P[3].y := Height - PenInc - 1;
P[1].y := PenInc;
P[2].y := PenInc;  end;
  baLeft: begin P[1].x := PenInc;
P[1].y := PenInc;
P[2].x := Width - PenInc - 1;
P[2].y := (Height - 1) div 2;
P[3].x := PenInc;
P[3].y := Height - PenInc - 1;  end;
  baRight: begin P[1].y := (Height - 1) div 2;
P[1].x := PenInc;
P[2].x := Width - PenInc - 1;
P[2].y := PenInc;
P[3].x := Width - PenInc - 1;
P[3].y := Height - PenInc - 1;  end;
end;
  end;

begin
  Canvas.Pen:=FPen;
  Canvas.Brush:=FBrush;

  PenInc := Pen.Width div 2;
  PenDec := (Pen.Width - 1) div 2;

  PaintRect := Rect(PenInc, PenInc, Self.Width - PenDec, Self.Height - 
PenDec);

  if PaintRect.Left = PaintRect.Right then
PaintRect.Right := PaintRect.Right + 1;
  if PaintRect.Top = PaintRect.Bottom then
PaintRect.Bottom := PaintRect.Bottom + 1;

  CalcPoints(FBaseAlign);
  Canvas.Polygon(P);

  inherited Paint;
end;

procedure TTriangle.ParamsChanged(Sender: TObject);
begin
  if (Parent  nil) and (Visible or (csDesigning in ComponentState)) and
 Parent.HandleAllocated then
Invalidate;
end;

end.



--
___
Lazarus mailing list
Lazarus@lists.lazarus.freepascal.org
http://lists.lazarus.freepascal.org/mailman/listinfo/lazarus