[lazarus] My opinions
Florian Klaempfl
Florian.Klaempfl at gmx.de
Tue Oct 26 08:29:31 EDT 1999
Shane Miller wrote:
>
> The graphics unit was mine.
> I'll agree to you modifying it assuming that all you are really going to do it cause TCanvas to call DrawLine or DrawRect instead of the SendMessage procedure. Also, I would like to look at your idea about using abstract classes, but I'm not sure we can implement it real easy without changing a lot of stuff. If you think we can (and I haven't really put time into thinking about it) try it and let me take a look at it.
>
> I don't mind using someone elses idea, as long as it's better than mine...
>
> Shane
>
>
> >>> Florian Klaempfl <Florian.Klaempfl at gmx.de> 10/25/99 02:59PM >>>
> Shane Miller wrote:
> >
> > Florian brings up a good point. We COULD call the functions directly in SOME cases, like drawpixel as long as we made sure that each ???object.pp file has those functions in them. This certainly would speed things up.
>
> This should be no problem, you make simple an abstract class where all procedures are
> declared as abstract.
>
> >
> > I like the send message function because then we only need to have one real public function in the object interface
>
> What's the problem with having more public functions ? I would even propose don't putting
> everything in
> gtkinterface class, but is a matter of taste I think, but it would lead to a little bit
> more structured
> class library.
>
> I don't know who is currently working on the graphics unit, if you want me I can implement
> the graphics
> stuff at least for win32/gtk as I propose.
>
> > (gtkinterface class) but if we were able to call the functions directgly, we would aviod the large CASE statement but then we would have to make sure that we add a function called DRAWPIXEL in the win32 interface, the QT interface, etc. I think in this case that would work though....
I attached a first study to clearify the ideas.
The important files are graphint and gtkgraphint, these routines
are called by the implementation of tcanvas methods.
{ TCANVAS }
{-----------------------------------------------}
{-- TCanvas.Draw --}
{-----------------------------------------------}
Procedure TCanvas.Draw(X,Y : Integer; Graphic : TGraphic);
begin
end;
{-----------------------------------------------}
{-- TCanvas.Polyline --}
{-----------------------------------------------}
Procedure TCanvas.Polyline(const Points: array of TPoint);
begin
graphint.Polyline(self,points);
end;
{-----------------------------------------------}
{-- TCanvas.CopyRect --}
{-----------------------------------------------}
Procedure TCanvas.CopyRect(const Dest : TRect; Canvas : TCanvas; const Source : TREct);
Begin
//this SHOULD stretch the image to the new canvas, but it doesn't yet.....
end;
{-----------------------------------------------}
{-- TCanvas.GetPixel --}
{-----------------------------------------------}
Function TCanvas.GetPixel(X,Y : Integer) : TColor;
var
Msg : TLMSetGetPixel;
{TLMSetGetPixel = record
X,Y : Integer;
PixColor : TColor;
end;
}
Begin
msg.X := x;
msg.Y := Y;
SendMessage(LM_GetPixel, Self, @msg);
Result := msg.PixColor;
end;
{-----------------------------------------------}
{-- TCanvas.SetPixel --}
{-----------------------------------------------}
Procedure TCanvas.SetPixel(X,Y: Integer; Value : TColor);
var
Msg : TLMSetGetPixel;
Begin
Msg.X := X;
msg.Y := Y;
MSg.PixColor := Value;
SendMessage(LM_SetPixel, Self, @msg);
end;
procedure TCanvas.CreateBrush;
begin
FBrush := TBrush.Create;
end;
procedure TCanvas.CreatePen;
begin
FPen := TPen.Create;
end;
procedure TCanvas.CreateFont;
begin
FFont := TFont.Create;
end;
function TCanvas.GetPenPos: TPoint;
begin
result := FPenPos;
end;
procedure TCanvas.SetAutoReDraw(Value : Boolean);
var
Msg : String;
begin
FAutoRedraw := Value;
msg := '';
If FAutoReDraw then
SendMessage(LM_REDraw, Self, nil);
end;
procedure TCanvas.SetPenPos(Value : TPoint);
begin
FPenPos := Value;
end;
procedure TCanvas.SetBrush(Value : TBrush);
begin
end;
procedure TCanvas.SetFont(Value : TFont);
begin
end;
procedure TCanvas.SetPen(Value : TPen);
begin
end;
procedure TCanvas.Arc(x,y,width,height,angle1,angle2 : Integer);
begin
end;
procedure TCanvas.FillRect(const Rect : TRect);
var
Msg : TLMCanvasDrawRect;
begin
// Writeln('Calling interface to draw fillrect');
Msg.R := Rect;
Msg.PenColor := Brush.Color;
Msg.Redraw := FAutoReDraw;
SendMessage(LM_DrawFillRect, Self, @msg);
end;
procedure TCanvas.Rectangle(X1,Y1,X2,Y2 : Integer);
var
Msg : TLMCanvasDrawRect;
begin
Msg.R.Left := X1;
Msg.R.Right := X2;
Msg.R.Top := Y1;
Msg.R.Bottom := Y2;
Msg.PenColor := Brush.Color;
Msg.Redraw := FAutoReDraw;
SendMessage(LM_DrawRect, Self, @msg);
end;
procedure TCanvas.TextOut(X,Y: Integer; const Text: String);
var
Msg : TLMCanvasDrawText;
begin
Msg.X1 := X;
Msg.Y1 := Y;
Msg.Str := Text;
Msg.Font := Font;
Msg.PenColor := Font.Color;
Msg.Redraw := FAutoReDraw;
//Writeln('X,Y = '+Inttostr(msg.X1)+','+inttostr(Msg.Y1));
SendMessage(LM_DrawText, Self, @msg);
end;
procedure TCanvas.Polygon(const Points: array of TPoint);
begin
end;
Procedure TCanvas.MoveTo(X1, Y1 : Integer);
Var
Point : TPoint;
Begin
Point.X := X1;
Point.Y := Y1;
PenPos := Point;
End;
procedure TCanvas.LineTo(X1,Y1 : Integer);
var
Msg : TLMCanvasDrawLine;
Point : TPoint;
begin
Point := PenPos;
Msg.x1 := Point.X;
Msg.y1 := Point.Y;
Msg.x2 := X1;
Msg.y2 := Y1;
Msg.PenColor := Brush.Color;
Msg.Redraw := FAutoReDraw;
SendMessage(LM_DrawLine, Self, @msg);
end;
procedure TCanvas.Line(X1,Y1,X2,Y2 : Integer);
begin
graphint.line(self,x1,y1,x2,y2);
end;
function TCanvas.GetColor:TColor;
begin
Result:=Brush.Color;
end;
procedure TCanvas.SetColor(c:TColor);
begin
Brush.Color:=c;
end;
constructor TCanvas.Create;
var
Point : TPoint;
begin
inherited Create;
Createbrush;
CreatePen;
CreateFont;
Point.X := 0;
Point.Y := 0;
PenPos := Point;
Writeln('Exiting Canvas.Create');
end;
destructor TCanvas.Destroy;
begin
inherited Destroy;
end;
unit gtkgraphint;
interface
uses
graphint;
type
tgtkraphinterface = class(tabstractgraphinterface)
procedure line(canvas : tobject;x1,y1,x2,y2 : Integer);override;
end;
implementation
uses
graphics;
{ to speed up things we reimplement line for gtk to speed up things }
{ !!!! This only a rough translation from drawline in gtkobject !!!!! }
procedure tgtkraphinterface.line(canvas : tobject;x1,y1,x2,y2 : Integer);override;
var
r : TRect;
widget : PgtkWIdget;
ColorMap : pgdkColorMap;
PixMap : pgdkPixMap;
DrawIt : Boolean;
TheStyle : pgtkStyle;
fWindow :pGdkWindow;
gc : pgdkGC;
I : Integer;
PenColor : TColor;
begin
//Writeln('Drawing a Rectangle in gtkint');
widget := gtk_Object_get_data(pgtkobject(canvas),'Fixed');
pixmap := gtk_Object_get_data(pgtkobject(canvas),'Pixmap');
if pixMap = nil then
PixMap := gdk_pixmap_new(pgtkwidget(canvas)^.window, pgtkwidget(child)^.allocation.width,
pgtkwidget(canvas)^.allocation.height,-1);
fWindow := pGtkWidget(canvas)^.window;
gc := gdk_gc_new(PgdkWindow(fWindow));
DrawIt := (canvas as TCanvas)^.FAutoredraw;
PenColor := (canvas as TCanvas)^.BrushColor;
gdk_draw_Line(pixmap,GetPen(pixmap,TColortoTgdkColor(PenColor)),X1,Y1,X2,Y2);
TheStyle := widget^.TheStyle;
//If DrawIt then
gdk_draw_pixmap(fWindow,TheStyle^.fg_gc[GTK_WIDGET_STATE (widget)],pixmap,X1,Y1,X1,Y1,X2+1,Y2+1);
gtk_Object_set_data(pgtkobject(canvas),'PixMap',pixmap);
gtk_Object_set_data(pgtkobject(widget),'PixMap',pixmap);
end;
begin
{ here we create the gtk specific object }
graphint:=tgtkgraphinterface.create;
end.
{
Graphics Unit
Contains :
TGraphicsObject-
TFont
}
unit Graphics;
{$mode objfpc}
interface
uses
SysUtils,classes,vclGlobals,LMessages;
type
TColor = longint; //Also defined in LMessages.pp
const
// The follow colors match the predefined Delphi Colors
clBtnFace = TColor($d5d6d5);
clInactiveCaption = TColor($eeeeee);
clActiveCaption = TColor($00D6FF);
clHighLight = TColor($ACAAAC);
clHighLightText = TColor($ACAAAC);
clWindow = TColor($d5d6d5);
clWindowText = TColor($000000);
clBtnHighLight = TColor($d5d6d5);
clBtnShadow = TColor($d5d6d5);
clBlack = TColor($000000);
clMaroon = TColor($000080);
clGreen = TColor($008000);
clOlive = TColor($008080);
clNavy = TColor($800000);
clPurple = TColor($800080);
clTeal = TColor($808000);
clGray = TColor($808080);
clSilver = TColor($C0C0C0);
clRed = TColor($0000FF);
clLime = TColor($00FF00);
clYellow = TColor($00FFFF);
clBlue = TColor($FF0000);
clFuchsia = TColor($FF00FF);
clAqua = TColor($FFFF00);
clLtGray = TColor($C0C0C0);
clDkGray = TColor($808080);
clWhite = TColor($FFFFFF);
clNone = TColor($1FFFFFFF);
clDefault = TColor($20000000);
type
TFontName = String;
TFontStyle = (fsBold, fsItalic, fsStrikeOut, fsUnderline);
TFontStyles = set of TFontStyle;
TFOntStylesbase = set of TFontStyle;
TPenStyle = (psSolid, psDash, psDot, psDashDot, psDashDotDot, psClear, psInsideframe);
TPenMode = (pmBlack, pmWhite);
TPenData = record
Handle : LongInt;
Color : TColor;
Width : Integer;
Style : TPenStyle;
end;
TBitmap = class; //forward declaration
TBrushStyle = (bsSolid, bsClear, bsHorizantal, bsVertical, bsFDiagonal, bsBDiagonal, bsCross, bsDiagCross);
TBrushData = record
Handle : LongInt;
Color : TColor;
Bitmap : TBitmap;
Style : TBrushStyle;
End;
TGraphicsObject = class(TPersistent)
private
FOnChange: TNotifyEvent;
Procedure DoChange(var msg); message LM_CHANGED;
protected
procedure Changed; dynamic;
Procedure Lock;
Procedure UnLock;
public
property OnChange: TNotifyEvent read FOnChange write FOnChange;
end;
TFont = class(TGraphicsObject)
private
FName : TFontName;
FColor : TColor;
FbColor : TColor;
FWidth : Integer;
FHeight : Integer;
FXBias : Integer;
FYBias : Integer;
FStyle : TFontStyles;
Protected
Procedure SetName(const value : TFontName);
Function GetName : TFontName;
Procedure SetSize(value : Integer);
Function GetSize : Integer;
procedure SetStyle(Value: TFontStyles);
function GetStyle: TFontStyles;
Procedure Changed; override;
public
fComponent : Pointer;
fCompStyle : Integer;
FSize : Integer; //Used to pass on in SendMessage
procedure SetColor(Value : TColor);
procedure SetBColor(Value : TColor);
property Color : TColor read FColor write SetColor;
property Name : TFontName read GetName write SetName;
property Size: Integer read GetSize write SetSize;
property BackGround : TColor read FbColor write SetBColor;
property Width : Integer read FWidth write FWidth;
property Height : Integer read FHeight write FHeight;
property XBias : Integer read FXBias write FXBias;
property YBias : Integer read FYBias write FYBias;
Function GetWidth(Value : String) : Integer;
Function Getheight(Value : String) : Integer;
constructor Create;
destructor destroy; override;
end;
TPen = class(TgraphicsObject)
private
FPenData : TPenData;
FMode : TPenMode;
Procedure GetData(var PenData : TPenData);
Procedure SetData(const PenData: TPenData);
protected
Function GetColor: TColor;
Procedure SetColor(Value : TColor);
Procedure SetMode(Value : TPenMode);
Function GetStyle: TPenStyle;
Procedure SetStyle(Value : TPenStyle);
Function GetWidth : Integer;
Procedure Setwidth(value : Integer);
public
constructor Create;
destructor Destroy; override;
procedure Assign(Source: TPersistent); override;
property Style: TPenStyle read GetStyle write SetStyle;
property Width: Integer read GetWidth write SetWidth;
property Mode: TPenMode read FMode write SetMode;
property Color: TColor read GetColor write SetColor;
end;
TBrush = class(TgraphicsObject)
private
//This is temporary. This should be stored in gtkint.pp?
BrushInfo : TBrushData;
Procedure Getdata(var BrushData: TBrushData);
Procedure SetData(const Brushdata: TBrushdata);
protected
function GetBitmap : TBitmap;
Procedure Setbitmap(value : TBitmap);
Function GetColor: TColor;
Procedure SetColor(Value : TColor);
function GetStyle: TbrushStyle;
Procedure SetStyle(value : TBrushStyle);
public
constructor Create;
destructor Destroy; override;
procedure Assign(Source : Tpersistent); override;
property Bitmap: TBitmap read GetBitmap write SetBitmap;
// published
property color : TColor read GetColor write SetColor ;
property Style: TBrushStyle read GetStyle write SetStyle;
end;
TFillStyle = (fsSurface, fsBorder);
TFillMode = (fmAlternate, fmWinding);
TCopymode = longint;
TCanvasStates = (csHandleValid, csFontValid, csPenvalid, csBrushValid);
TCanvasState = set of TCanvasStates;
TCanvasOrientation = (csLefttoRight, coRighttoLeft);
TGraphic = class(TPersistent)
private
FWidth : Integer;
FHeight : Integer;
public
constructor Create; virtual;
property Height: Integer read FHeight write FHeight;
property Width: Integer read FWidth write FWidth;
end;
TCanvas = class(TPersistent)
private
FAutoReDraw : Boolean;
State: TCanvasState;
FFont : TFont;
FPen: TPen;
FBrush: TBrush;
FPenPos : TPoint;
FCopyMode : TCopyMode;
FOnChange: TNotifyEvent;
FOnChanging: TNotifyEvent;
procedure Createbrush;
procedure CreateFont;
Procedure CreatePen;
Function GetPenPos: TPoint;
Function GetPixel(X,Y : Integer) : TColor;
Function GetColor: TColor;
Procedure SetAutoReDraw(Value : Boolean);
Procedure SetPenPos(Value : TPoint);
Procedure SetBrush(value : TBrush);
Procedure SetFont(value : TFont);
Procedure SetPen(value : TPen);
Procedure SetPixel(X,Y : Integer; Value : TColor);
Procedure SetColor(c: TColor);
public
fComponent : Pointer;
constructor Create;
destructor Destroy; override;
procedure Arc(x,y,width,height,angle1,angle2 : Integer);
Procedure CopyRect(const Dest : TRect; Canvas : TCanvas; const Source : TRect);
Procedure Draw(X,Y: Integer; Graphic : TGraphic);
Procedure FillRect(const Rect : TRect);
Procedure Rectangle(X1,Y1,X2,Y2 : Integer);
Procedure Line(X1,Y1,X2,Y2 : Integer);
Procedure MoveTo(X1,Y1 : Integer);
Procedure LineTo(X1,Y1 : Integer);
Procedure TextOut(X,Y: Integer; const Text: String);
Procedure Polygon(const Points: array of TPoint);
Procedure Polyline(const Points: array of TPoint);
property PenPos: TPoint read GetPenPos write SetPenPos;
property OnChange : TNotifyEvent read FOnChange write FOnChange;
property OnChanging: TNotifyEvent read FOnChanging write FOnChanging;
property Pixels[X, Y: Integer]: TCOlor read GetPixel write SetPixel;
published
property AutoRedraw : Boolean read FAutoReDraw write SetAutoReDraw;
property Brush: TBrush read FBrush write SetBrush;
property Font: TFont read FFont write SetFont;
property Pen: TPen read FPen write SetPen;
// Extra
property Color: TColor read GetColor write SetColor;
end;
TBitmap = class(TGraphic)
private
FCanvas : TCanvas;
FMonochrome: Boolean;
public
constructor Create; override;
destructor Destroy ; Override;
procedure Assign(Source: TPersistent); override;
procedure FreeImage;
procedure LoadFromStream(Stream: TStream); {override; // Uncomment when method is implemented in TGraphic }
procedure LoadFromResourceName(Instance: THandle; const ResName: String);
procedure LoadFromResourceID(Instance: THandle; ResID: Integer);
procedure Mask(TransparentColor: TColor);
procedure SaveToStream(Stream: TStream); {override; // Uncomment when method is implemented in TGraphic }
property Canvas : TCanvas read FCanvas write FCanvas;
property Monochrome: Boolean read FMonochrome write FMonochrome;
end;
TBitmapCanvas = class(TCanvas)
private
FBitmap : TBitMap;
FOldBitMap : HBitmap;
FOldPalette : HPALETTE;
public
constructor Create(ABitMap : TBitmap);
destructor Destroy;
end;
{ TIcon }
{
@abstract()
Introduced by Marc Weustink <weus at quicknet.nl>
Currently maintained by ?
}
TIcon = class(TGraphic)
// Introduced to get TImageList compiled
end;
Implementation
uses Controls;
{$I graphicsobject.inc}
{$I graphic.inc}
{$I bitmap.inc}
{$I bitmapcanvas.inc}
{$I pen.inc}
{$I brush.inc}
{$I font.inc}
{$I canvas.inc}
end.
{
$Log: graphics.pp,v $
Revision 1.22 1999/10/22 21:01:51 lazarus
Removed calls to InterfaceObjects except for controls.pp. Commented
out any gtk depend lines of code. MAH
Revision 1.21 1999/10/19 21:16:23 lazarus
TColor added to graphics.pp
Revision 1.20 1999/10/18 07:32:42 lazarus
Added definitions for Load methods in the TBitmap class. The
methods have not been implemented yet. They need to be implemented. CAW
Revision 1.19 1999/09/26 16:58:01 lazarus
MWE: Added TBitMap.Mask method
Revision 1.18 1999/08/26 23:36:02 peter
+ paintbox
+ generic keydefinitions and gtk conversion
* gtk state -> shiftstate conversion
Revision 1.17 1999/08/25 18:53:02 lazarus
Added Canvas.pixel property which allows
the user to get/set the pixel color. This will be used in the editor
to create the illusion of the cursor by XORing the pixel with black.
Shane
Revision 1.16 1999/08/20 15:44:37 lazarus
TImageList changes added from Marc Weustink
Revision 1.15 1999/08/17 16:46:25 lazarus
Slight modification to Editor.pp
Shane
Revision 1.14 1999/08/16 20:48:03 lazarus
Added a changed event for TFOnt and code to get the average size of the font. Doesn't seem to work very well yet.
The "average size" code is found in gtkobject.inc.
Revision 1.13 1999/08/16 15:48:49 lazarus
Changes by file:
Control: TCOntrol-Function GetRect added
ClientRect property added
TImageList - Added Count
TWinControl- Function Focused added.
Graphics: TCanvas - CopyRect added - nothing finished on it though
Draw added - nothing finiushed on it though
clbtnhighlight and clbtnshadow added. Actual color values not right.
IMGLIST.PP and IMGLIST.INC files added.
A few other minor changes for compatability added.
Shane
Revision 1.12 1999/08/13 19:55:47 lazarus
TCanvas.MoveTo added for compatability.
Revision 1.11 1999/08/13 19:51:07 lazarus
Minor changes for compatability made.
Revision 1.10 1999/08/11 20:41:33 lazarus
Minor changes and additions made. Lazarus may not compile due to these changes
Revision 1.9 1999/08/02 01:13:33 lazarus
Added new colors and corrected BTNFACE
Need the TSCrollbar class to go further with the editor.
Mouse doesn't seem to be working correctly yet when I click on the editor window
Revision 1.8 1999/08/01 21:46:26 lazarus
Modified the GETWIDTH and GETHEIGHT of TFOnt so you can use it to calculate the length in Pixels of a string. This is now used in the editor.
Shane
Revision 1.7 1999/07/31 06:39:26 lazarus
Modified the IntSendMessage3 to include a data variable. It isn't used
yet but will help in merging the Message2 and Message3 features.
Adjusted TColor routines to match Delphi color format
Added a TGdkColorToTColor routine in gtkproc.inc
Finished the TColorDialog added to comDialog example. MAH
}
unit graphint;
interface
uses
messages;
type
tabstractgraphinterface = class
public
procedure line(canvas : tobject;x1,y1,x2,y2 : Integer);virtual;
procedure polygon(canvas : tobject;const Points: array of TPoint);virtual;
end;
var
graphint : tabstractgraphinterface;
implementation
{ this is an example how to avoid destroying existing code }
procedure tabstractgraphinterface.line(canvas : tobject;x1,y1,x2,y2 : integer);
var
msg : TLMCanvasDrawLine;
begin
msg.x1 := X1;
msg.y1 := Y1;
msg.x2 := X2;
msg.y2 := Y2;
msg.PenColor := Brush.Color;
msg.Redraw := FAutoReDraw;
SendMessage(LM_DrawLine, canvas, @msg);
end;
{ here we implement a complex function using simpler/primitive routines }
{ this can be speeded up by using system depended functions }
{ in a descented class }
{ we could do the same with line: implementing it using drawpixel }
procedure tabstractgraphinterface.polygon(canvas : tobject;const Points: array of TPoint);
var
i : integer;
begin
for i:=1 to high(points) do
line(canvas,points[i-1].x,points[i-1].y,points[i].x,points[i].y);
end;
end.
More information about the Lazarus
mailing list