-
Notifications
You must be signed in to change notification settings - Fork 0
/
uPSR_graphics.pas
248 lines (214 loc) · 10.2 KB
/
uPSR_graphics.pas
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
unit uPSR_graphics;
{$I PascalScript.inc}
interface
uses
uPSRuntime, uPSUtils;
procedure RIRegisterTGRAPHICSOBJECT(Cl: TPSRuntimeClassImporter);
procedure RIRegisterTFont(Cl: TPSRuntimeClassImporter);
procedure RIRegisterTPEN(Cl: TPSRuntimeClassImporter);
procedure RIRegisterTBRUSH(Cl: TPSRuntimeClassImporter);
procedure RIRegisterTCanvas(cl: TPSRuntimeClassImporter);
procedure RIRegisterTGraphic(CL: TPSRuntimeClassImporter);
procedure RIRegisterTBitmap(CL: TPSRuntimeClassImporter; Streams: Boolean);
procedure RIRegisterTPicture(CL: TPSRuntimeClassImporter);
procedure RIRegister_Graphics(Cl: TPSRuntimeClassImporter; Streams: Boolean);
implementation
{$IFNDEF FPC}
uses
Classes{$IFDEF CLX}, QGraphics{$ELSE}, Windows, Graphics{$ENDIF};
{$ELSE}
uses
Classes, Graphics,LCLType;
{$ENDIF}
{$IFNDEF CLX}
procedure TFontHandleR(Self: TFont; var T: Longint); begin T := Self.Handle; end;
procedure TFontHandleW(Self: TFont; T: Longint); begin Self.Handle := T; end;
{$ENDIF}
procedure TFontPixelsPerInchR(Self: TFont; var T: Longint); begin T := Self.PixelsPerInch; end;
procedure TFontPixelsPerInchW(Self: TFont; T: Longint); begin {$IFNDEF FPC} Self.PixelsPerInch := T;{$ENDIF} end;
procedure TFontStyleR(Self: TFont; var T: TFontStyles); begin T := Self.Style; end;
procedure TFontStyleW(Self: TFont; T: TFontStyles); begin Self.Style:= T; end;
procedure RIRegisterTFont(Cl: TPSRuntimeClassImporter);
begin
with Cl.Add(TFont) do
begin
RegisterConstructor(@TFont.Create, 'CREATE');
{$IFNDEF CLX}
RegisterPropertyHelper(@TFontHandleR, @TFontHandleW, 'HANDLE');
{$ENDIF}
RegisterPropertyHelper(@TFontPixelsPerInchR, @TFontPixelsPerInchW, 'PIXELSPERINCH');
RegisterPropertyHelper(@TFontStyleR, @TFontStyleW, 'STYLE');
end;
end;
{$IFNDEF CLX}
procedure TCanvasHandleR(Self: TCanvas; var T: Longint); begin T := Self.Handle; end;
procedure TCanvasHandleW(Self: TCanvas; T: Longint); begin Self.Handle:= T; end;
{$ENDIF}
procedure TCanvasPixelsR(Self: TCanvas; var T: Longint; X,Y: Longint); begin T := Self.Pixels[X,Y]; end;
procedure TCanvasPixelsW(Self: TCanvas; T, X, Y: Longint); begin Self.Pixels[X,Y]:= T; end;
procedure TCanvasArc(Self : TCanvas; X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); begin Self.Arc(X1, Y1, X2, Y2, X3, Y3, X4, Y4); end;
procedure TCanvasChord(Self : TCanvas; X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); begin self.Chord(X1, Y1, X2, Y2, X3, Y3, X4, Y4); end;
procedure TCanvasRectangle(Self : TCanvas; X1,Y1,X2,Y2 : integer); begin self.Rectangle(x1,y1,x2,y2); end;
procedure TCanvasRoundRect(Self : TCanvas; X1, Y1, X2, Y2, X3, Y3 : integer); begin self.RoundRect(X1, Y1, X2, Y2, X3, Y3); end;
procedure TCanvasEllipse(Self : TCanvas;X1, Y1, X2, Y2: Integer); begin self.Ellipse(X1, Y1, X2, Y2); end;
procedure TCanvasFillRect(Self : TCanvas; const Rect: TRect); begin self.FillRect(rect); end;
procedure TCanvasFloodFill(Self : TCanvas; X, Y: Integer; Color: TColor; FillStyle: TFillStyle); begin self.FloodFill(x,y,color,fillstyle); end;
procedure RIRegisterTCanvas(cl: TPSRuntimeClassImporter); // requires TPersistent
begin
with Cl.Add(TCanvas) do
begin
RegisterMethod(@TCanvasArc, 'ARC');
RegisterMethod(@TCanvasChord, 'CHORD');
RegisterMethod(@TCanvasRectangle, 'RECTANGLE');
RegisterMethod(@TCanvasRoundRect, 'ROUNDRECT');
RegisterMethod(@TCanvasEllipse, 'ELLIPSE');
RegisterMethod(@TCanvasFillRect, 'FILLRECT');
// RegisterMethod(@TCanvasDraw, 'DRAW');
{$IFNDEF CLX}
RegisterMethod(@TCanvasFloodFill, 'FLOODFILL');
{$ENDIF}
RegisterMethod(@TCanvas.Lineto, 'LINETO');
RegisterMethod(@TCanvas.Moveto, 'MOVETO');
RegisterMethod(@TCanvas.Pie, 'PIE');
RegisterMethod(@TCanvas.Refresh, 'REFRESH');
RegisterMethod(@TCanvas.TextHeight, 'TEXTHEIGHT');
RegisterMethod(@TCanvas.TextOut, 'TEXTOUT');
RegisterMethod(@TCanvas.TextWidth, 'TEXTWIDTH');
{$IFNDEF CLX}
RegisterPropertyHelper(@TCanvasHandleR, @TCanvasHandleW, 'HANDLE');
{$ENDIF}
RegisterPropertyHelper(@TCanvasPixelsR, @TCanvasPixelsW, 'PIXELS');
end;
end;
procedure TGRAPHICSOBJECTONCHANGE_W(Self: TGraphicsObject; T: TNotifyEvent); begin Self.OnChange := t; end;
procedure TGRAPHICSOBJECTONCHANGE_R(Self: TGraphicsObject; var T: TNotifyEvent); begin T :=Self.OnChange; end;
procedure RIRegisterTGRAPHICSOBJECT(Cl: TPSRuntimeClassImporter);
begin
with Cl.Add(TGRAPHICSOBJECT) do
begin
RegisterPropertyHelper(@TGRAPHICSOBJECTONCHANGE_R, @TGRAPHICSOBJECTONCHANGE_W, 'ONCHANGE');
end;
end;
procedure TPenColor_W(Self: TPen; const T: TColor);begin Self.Color := T; end;
procedure TPenColor_R(Self: TPen; var T: TColor);begin T := Self.Color; end;
procedure TPenMode_W(Self: TPen; const T: TPENMODE);begin Self.Mode := T; end;
procedure TPenMode_R(Self: TPen; var T: TPENMODE);begin T := Self.Mode; end;
procedure TPenWidth_W(Self: TPen; const T: Integer);begin Self.Width := T; Writeln(t); end;
procedure TPenWidth_R(Self: TPen; var T: Integer);begin T := Self.Width; Writeln(self.width) end;
procedure TPenStyle_W(Self: TPen; const T: TPenStyle);begin Self.Style := T; end;
procedure TPenStyle_R(Self: TPen; var T: TPenStyle);begin T := Self.Style; end;
procedure RIRegisterTPEN(Cl: TPSRuntimeClassImporter);
begin
with Cl.Add(TPEN) do
begin
RegisterConstructor(@TPEN.CREATE, 'CREATE');
RegisterPropertyHelper(@TPenStyle_R,@TPenStyle_W,'Style');
RegisterPropertyHelper(@TPenWidth_R,@TPenWidth_W,'Width');
RegisterPropertyHelper(@TPenMode_R,@TPenMode_W,'Mode');
RegisterPropertyHelper(@TPenColor_R,@TPenColor_W,'Color');
end;
end;
procedure RIRegisterTBRUSH(Cl: TPSRuntimeClassImporter);
begin
with Cl.Add(TBRUSH) do
begin
RegisterConstructor(@TBRUSH.CREATE, 'CREATE');
end;
end;
procedure TGraphicOnChange_W(Self: TGraphic; const T: TNotifyEvent); begin Self.OnChange := T; end;
procedure TGraphicOnChange_R(Self: TGraphic; var T: TNotifyEvent); begin T := Self.OnChange; end;
procedure TGraphicWidth_W(Self: TGraphic; const T: Integer); begin Self.Width := T; end;
procedure TGraphicWidth_R(Self: TGraphic; var T: Integer); begin T := Self.Width; end;
procedure TGraphicModified_W(Self: TGraphic; const T: Boolean); begin Self.Modified := T; end;
procedure TGraphicModified_R(Self: TGraphic; var T: Boolean); begin T := Self.Modified; end;
procedure TGraphicHeight_W(Self: TGraphic; const T: Integer); begin Self.Height := T; end;
procedure TGraphicHeight_R(Self: TGraphic; var T: Integer); begin T := Self.Height; end;
procedure TGraphicEmpty_R(Self: TGraphic; var T: Boolean); begin T := Self.Empty; end;
procedure RIRegisterTGraphic(CL: TPSRuntimeClassImporter);
begin
with CL.Add(TGraphic) do
begin
RegisterVirtualConstructor(@TGraphic.Create, 'Create');
RegisterVirtualMethod(@TGraphic.LoadFromFile, 'LoadFromFile');
RegisterVirtualMethod(@TGraphic.SaveToFile, 'SaveToFile');
RegisterPropertyHelper(@TGraphicEmpty_R,nil,'Empty');
RegisterPropertyHelper(@TGraphicHeight_R,@TGraphicHeight_W,'Height');
RegisterPropertyHelper(@TGraphicWidth_R,@TGraphicWidth_W,'Width');
RegisterPropertyHelper(@TGraphicOnChange_R,@TGraphicOnChange_W,'OnChange');
{$IFNDEF PS_MINIVCL}
RegisterPropertyHelper(@TGraphicModified_R,@TGraphicModified_W,'Modified');
{$ENDIF}
end;
end;
procedure TBitmapTransparentColor_R(Self: TBitmap; var T: TColor); begin T := Self.TransparentColor; end;
{$IFNDEF CLX}
{$IFNDEF FPC}
procedure TBitmapIgnorePalette_W(Self: TBitmap; const T: Boolean); begin Self.IgnorePalette := T; end;
procedure TBitmapIgnorePalette_R(Self: TBitmap; var T: Boolean); begin T := Self.IgnorePalette; end;
{$ENDIF}
procedure TBitmapPalette_W(Self: TBitmap; const T: HPALETTE); begin Self.Palette := T; end;
procedure TBitmapPalette_R(Self: TBitmap; var T: HPALETTE); begin T := Self.Palette; end;
{$ENDIF}
procedure TBitmapMonochrome_W(Self: TBitmap; const T: Boolean); begin Self.Monochrome := T; end;
procedure TBitmapMonochrome_R(Self: TBitmap; var T: Boolean); begin T := Self.Monochrome; end;
{$IFNDEF CLX}
procedure TBitmapHandle_W(Self: TBitmap; const T: HBITMAP); begin Self.Handle := T; end;
procedure TBitmapHandle_R(Self: TBitmap; var T: HBITMAP); begin T := Self.Handle; end;
{$ENDIF}
procedure TBitmapCanvas_R(Self: TBitmap; var T: TCanvas); begin T := Self.Canvas; end;
procedure RIRegisterTBitmap(CL: TPSRuntimeClassImporter; Streams: Boolean);
begin
with CL.Add(TBitmap) do
begin
if Streams then begin
RegisterMethod(@TBitmap.LoadFromStream, 'LoadFromStream');
RegisterMethod(@TBitmap.SaveToStream, 'SaveToStream');
end;
RegisterPropertyHelper(@TBitmapCanvas_R,nil,'Canvas');
{$IFNDEF CLX}
RegisterPropertyHelper(@TBitmapHandle_R,@TBitmapHandle_W,'Handle');
{$ENDIF}
{$IFNDEF PS_MINIVCL}
{$IFNDEF FPC}
RegisterMethod(@TBitmap.Dormant, 'Dormant');
{$ENDIF}
RegisterMethod(@TBitmap.FreeImage, 'FreeImage');
{$IFNDEF CLX}
RegisterMethod(@TBitmap.LoadFromClipboardFormat, 'LoadFromClipboardFormat');
{$ENDIF}
RegisterMethod(@TBitmap.LoadFromResourceName, 'LoadFromResourceName');
RegisterMethod(@TBitmap.LoadFromResourceID, 'LoadFromResourceID');
{$IFNDEF CLX}
RegisterMethod(@TBitmap.ReleaseHandle, 'ReleaseHandle');
RegisterMethod(@TBitmap.ReleasePalette, 'ReleasePalette');
RegisterMethod(@TBitmap.SaveToClipboardFormat, 'SaveToClipboardFormat');
RegisterPropertyHelper(@TBitmapMonochrome_R,@TBitmapMonochrome_W,'Monochrome');
RegisterPropertyHelper(@TBitmapPalette_R,@TBitmapPalette_W,'Palette');
{$IFNDEF FPC}
RegisterPropertyHelper(@TBitmapIgnorePalette_R,@TBitmapIgnorePalette_W,'IgnorePalette');
{$ENDIF}
{$ENDIF}
RegisterPropertyHelper(@TBitmapTransparentColor_R,nil,'TransparentColor');
{$ENDIF}
end;
end;
procedure TPictureBitmap_W(Self: TPicture; const T: TBitmap); begin Self.Bitmap := T; end;
procedure TPictureBitmap_R(Self: TPicture; var T: TBitmap); begin T := Self.Bitmap; end;
procedure RIRegisterTPicture(CL: TPSRuntimeClassImporter);
begin
with TPSRuntimeClass(CL.Add(TPicture)) do
registerPropertyHelper(@TPictureBitmap_R,@TPictureBitmap_W,'Bitmap');
end;
procedure RIRegister_Graphics(Cl: TPSRuntimeClassImporter; Streams: Boolean);
begin
RIRegisterTGRAPHICSOBJECT(cl);
RIRegisterTFont(Cl);
RIRegisterTCanvas(cl);
RIRegisterTPEN(cl);
RIRegisterTBRUSH(cl);
RIRegisterTGraphic(CL);
RIRegisterTBitmap(CL, Streams);
RIRegisterTPicture(CL);
end;
// PS_MINIVCL changes by Martijn Laan (mlaan at wintax _dot_ nl)
end.