source: trunk/Packages/bgrabitmap/bgracanvasgl.pas

Last change on this file was 2, checked in by chronos, 5 years ago
File size: 65.1 KB
Line 
1unit BGRACanvasGL;
2
3{$mode objfpc}{$H+}
4
5interface
6
7uses
8 Classes, SysUtils, BGRAGraphics, BGRABitmapTypes,
9 BGRAOpenGLType, BGRATransform, BGRAPath,
10 BGRASSE, BGRAMatrix3D;
11
12type
13 TBGLPath = class;
14 TBGLCustomCanvas = class;
15
16 TBGLCustomShader = class
17 protected
18 procedure StartUse; virtual; abstract;
19 procedure EndUse; virtual; abstract;
20 end;
21
22 TBGLCustomArray = class
23 protected
24 FBuffer: DWord;
25 function GetCount: integer; virtual; abstract;
26 function GetRecordSize: integer; virtual; abstract;
27 public
28 constructor Create(ABufferAddress: pointer; ACount: integer; ARecordSize: integer); virtual; abstract;
29 property Count: integer read GetCount;
30 property RecordSize: integer read GetRecordSize;
31 property Handle: DWord read FBuffer;
32 end;
33
34 { TAttributeVariable }
35
36 TAttributeVariable = object
37 protected
38 FOwner: TObject;
39 FAttribute: DWord;
40 FVectorSize: integer;
41 FArray: TBGLCustomArray;
42 FRecordOffset: integer;
43 FFloat: boolean;
44 procedure Init(AOwner: TObject; AAttribute: DWord; AVectorSize: integer;
45 AFloat: boolean);
46 public
47 property Source: TBGLCustomArray read FArray write FArray;
48 property RecordOffset: integer read FRecordOffset write FRecordOffset;
49 property Handle: DWord read FAttribute;
50 property VectorSize: integer read FVectorSize;
51 property IsFloat: boolean read FFloat;
52 property Owner: TObject read FOwner;
53 end;
54
55 TBGLCustomElementArray = class
56 protected
57 function GetCount: integer; virtual; abstract;
58 public
59 constructor Create(const AElements: array of integer); virtual; abstract;
60 procedure Draw(ACanvas: TBGLCustomCanvas; APrimitive: TOpenGLPrimitive; AAttributes: array of TAttributeVariable); virtual; abstract;
61 property Count: integer read GetCount;
62 end;
63
64 { TBGLCustomLighting }
65
66 TBGLCustomLighting = class
67 private
68 FCurrentShader: TBGLCustomShader;
69 function GetActiveShader: TBGLCustomShader;
70 procedure SetActiveShader(AValue: TBGLCustomShader);
71 protected
72 function GetSupportShaders: boolean; virtual;
73 function GetShader(AName: string): TBGLCustomShader;
74 procedure SetShader(AName: string; AValue: TBGLCustomShader);
75 procedure SetAmbiantLightF(AAmbiantLight: TColorF); virtual; abstract;
76 function GetAmbiantLightF: TColorF; virtual; abstract;
77 function GetBuiltInLightingEnabled: boolean; virtual; abstract;
78 procedure SetBuiltInLightingEnabled(AValue: boolean); virtual; abstract;
79 public
80 ShaderList: TStringList;
81 destructor Destroy; override;
82 function AddDirectionalLight(AColor: TColorF; ADirection: TPoint3D): integer; virtual; abstract;
83 function AddPointLight(AColor: TColorF; APosition: TPoint3D; ALinearAttenuation, AQuadraticAttenuation: single): integer; virtual; abstract;
84 procedure ClearLights; virtual; abstract;
85 function RemoveLight(AIndex: integer): boolean; virtual; abstract;
86 procedure SetSpecularIndex(AIndex: integer); virtual; abstract;
87
88 function MakeVertexShader(ASource: string): DWord; virtual; abstract;
89 function MakeFragmentShader(ASource: string): DWord; virtual; abstract;
90 function MakeShaderProgram(AVertexShader, AFragmentShader: DWord): DWord; virtual; abstract;
91 procedure DeleteShaderObject(AShader: DWord); virtual; abstract;
92 procedure DeleteShaderProgram(AProgram: DWord); virtual; abstract;
93 procedure UseProgram(AProgram: DWord); virtual; abstract;
94 function GetUniformVariable(AProgram: DWord; AName: string): DWord; virtual; abstract;
95 function GetAttribVariable(AProgram: DWord; AName: string): DWord; virtual; abstract;
96 procedure SetUniformSingle(AVariable: DWord; const AValue; AElementCount, AComponentCount: integer); virtual; abstract;
97 procedure SetUniformInteger(AVariable: DWord; const AValue; AElementCount, AComponentCount: integer); virtual; abstract;
98 procedure BindAttribute(AAttribute: TAttributeVariable); virtual; abstract;
99 procedure UnbindAttribute(AAttribute: TAttributeVariable); virtual; abstract;
100 procedure FreeShaders;
101 property ActiveShader: TBGLCustomShader read GetActiveShader write SetActiveShader;
102 property Shader[AName: string]: TBGLCustomShader read GetShader write SetShader;
103 property SupportShaders: boolean read GetSupportShaders;
104 property AmbiantLightF: TColorF read GetAmbiantLightF write SetAmbiantLightF;
105 property BuiltInLightingEnabled: boolean read GetBuiltInLightingEnabled write SetBuiltInLightingEnabled;
106 end;
107
108 { TBGLCustomCanvas }
109
110 TBGLCustomCanvas = class
111 private
112 FActiveFrameBuffer: TBGLCustomFrameBuffer;
113 FHeight: integer;
114 FWidth: integer;
115 FNoClip: boolean;
116 FClipRect: TRect;
117 protected
118 procedure SwapRect(var r: TRect); overload;
119 procedure SwapRect(var x1,y1,x2,y2: single); overload;
120 procedure InternalArc(cx,cy,rx,ry: single; const StartPoint,EndPoint: TPointF; ABorderColor,AOuterFillColor,ACenterFillColor: TBGRAPixel; AOptions: TArcOptions; ADrawChord: boolean = false); overload;
121 procedure InternalArc(cx,cy,rx,ry: single; StartAngleRad,EndAngleRad: Single; ABorderColor,AOuterFillColor,ACenterFillColor: TBGRAPixel; AOptions: TArcOptions; ADrawChord: boolean = false); overload;
122 procedure InternalArcInRect(r: TRect; StartAngleRad,EndAngleRad: Single; ABorderColor,AOuterFillColor,ACenterFillColor: TBGRAPixel; AOptions: TArcOptions; ADrawChord: boolean = false); overload;
123 function ComputeEllipseC(r: TRect; AHasBorder: boolean; out cx,cy,rx,ry: single): boolean;
124 function GetHeight: integer; virtual;
125 function GetWidth: integer; virtual;
126 procedure SetWidth(AValue: integer); virtual;
127 procedure SetHeight(AValue: integer); virtual;
128 function GetClipRect: TRect;
129 procedure SetClipRect(AValue: TRect);
130 procedure EnableScissor(AValue: TRect); virtual; abstract;
131 procedure DisableScissor; virtual; abstract;
132 function GetMatrix: TAffineMatrix; virtual; abstract;
133 procedure SetMatrix(const AValue: TAffineMatrix); virtual; abstract;
134 function GetProjectionMatrix: TMatrix4D; virtual;
135 procedure SetProjectionMatrix(const {%H-}AValue: TMatrix4D); virtual;
136 procedure SetBlendMode(AValue: TOpenGLBlendMode); virtual; abstract;
137 function GetBlendMode: TOpenGLBlendMode; virtual; abstract;
138 function GetFaceCulling: TFaceCulling; virtual; abstract;
139 procedure SetFaceCulling(AValue: TFaceCulling); virtual; abstract;
140 procedure SetActiveFrameBuffer(AValue: TBGLCustomFrameBuffer); virtual;
141
142 function GetLighting: TBGLCustomLighting; virtual;
143
144 procedure InternalStartPutPixel(const pt: TPointF); virtual; abstract;
145 procedure InternalStartPolyline(const pt: TPointF); virtual; abstract;
146 procedure InternalStartPolygon(const pt: TPointF); virtual; abstract;
147 procedure InternalStartTriangleFan(const pt: TPointF); virtual; abstract;
148 procedure InternalContinueShape(const pt: TPointF); overload; virtual; abstract;
149
150 procedure InternalContinueShape(const {%H-}pt: TPoint3D); overload; virtual;
151 procedure InternalContinueShape(const {%H-}pt: TPoint3D_128); overload; virtual;
152 procedure InternalContinueShape(const {%H-}pt, {%H-}normal: TPoint3D_128); overload; virtual;
153
154 procedure InternalEndShape; virtual; abstract;
155 procedure InternalSetColor(const AColor: TBGRAPixel); virtual; abstract;
156 procedure InternalSetColorF(const AColor: TColorF); virtual; abstract;
157
158 procedure InternalStartBlend; virtual; abstract;
159 procedure InternalEndBlend; virtual; abstract;
160
161 procedure InternalStartBlendTriangles; virtual; abstract;
162 procedure InternalStartBlendQuads; virtual; abstract;
163 procedure InternalEndBlendTriangles; virtual; abstract;
164 procedure InternalEndBlendQuads; virtual; abstract;
165 public
166 constructor Create;
167 procedure Fill(AColor: TBGRAPixel); virtual; abstract;
168
169 procedure PutPixels(const APoints: array of TPointF; AColor: TBGRAPixel); overload; virtual;
170 procedure PutPixels(const APoints: array of TPointF; const AColors: array of TBGRAPixel); overload; virtual;
171
172 procedure Line(x1,y1,x2,y2: single; AColor: TBGRAPixel; ADrawLastPoint: boolean = true); overload;
173 procedure Line(p1,p2: TPointF; AColor: TBGRAPixel; ADrawLastPoint: boolean = true); overload;
174 procedure Polylines(const APoints: array of TPointF; AColor: TBGRAPixel; ADrawLastPoints: boolean = true); virtual;
175
176 procedure Polygons(const APoints: array of TPointF; AColor: TBGRAPixel); virtual;
177 procedure FillPolyConvex(const APoints: array of TPointF; AColor: TBGRAPixel; APixelCenteredCoordinates: boolean = true);
178
179 procedure FillTriangleLinearColor(pt1,pt2,pt3: TPointF; c1,c2,c3: TBGRAPixel; APixelCenteredCoordinates: boolean = true); overload;
180 procedure FillTriangles(const APoints: array of TPointF; AColor: TBGRAPixel; APixelCenteredCoordinates: boolean = true); overload; virtual;
181 procedure FillTrianglesLinearColor(const APoints: array of TPointF; const AColors: array of TBGRAPixel; APixelCenteredCoordinates: boolean = true); overload; virtual;
182 procedure FillTrianglesLinearColor(const APoints: array of TPoint3D; const AColors: array of TBGRAPixel); overload; virtual;
183 procedure FillTrianglesLinearColor(const APoints: array of TPoint3D_128; const AColors: array of TBGRAPixel); overload; virtual;
184 procedure FillTrianglesLinearColor(const APoints, ANormals: array of TPoint3D_128; const AColors: array of TBGRAPixel); overload; virtual;
185 procedure FillTrianglesFan(const APoints: array of TPointF; ACenterColor, ABorderColor: TBGRAPixel; APixelCenteredCoordinates: boolean = true); overload; virtual;
186
187 procedure FillTriangleLinearColor(pt1,pt2,pt3: TPointF; c1,c2,c3: TColorF; APixelCenteredCoordinates: boolean = true); overload;
188 procedure FillTriangles(const APoints: array of TPointF; AColor: TColorF; APixelCenteredCoordinates: boolean = true); overload; virtual;
189 procedure FillTrianglesLinearColor(const APoints: array of TPointF; const AColors: array of TColorF; APixelCenteredCoordinates: boolean = true); overload; virtual;
190 procedure FillTrianglesLinearColor(const APoints: array of TPoint3D; const AColors: array of TColorF); overload; virtual;
191 procedure FillTrianglesLinearColor(const APoints: array of TPoint3D_128; const AColors: array of TColorF); overload; virtual;
192 procedure FillTrianglesLinearColor(const APoints, ANormals: array of TPoint3D_128; const AColors: array of TColorF); overload; virtual;
193 procedure FillTrianglesFan(const APoints: array of TPointF; ACenterColor, ABorderColor: TColorF; APixelCenteredCoordinates: boolean = true); overload; virtual;
194
195 procedure FillQuadLinearColor(pt1,pt2,pt3,pt4: TPointF; c1,c2,c3,c4: TBGRAPixel; APixelCenteredCoordinates: boolean = true); overload;
196 procedure FillQuads(const APoints: array of TPointF; AColor: TBGRAPixel; APixelCenteredCoordinates: boolean = true); overload; virtual;
197 procedure FillQuadsLinearColor(const APoints: array of TPointF; const AColors: array of TBGRAPixel; APixelCenteredCoordinates: boolean = true); overload; virtual;
198 procedure FillQuadsLinearColor(const APoints: array of TPoint3D; const AColors: array of TBGRAPixel); overload; virtual;
199 procedure FillQuadsLinearColor(const APoints: array of TPoint3D_128; const AColors: array of TBGRAPixel); overload; virtual;
200 procedure FillQuadsLinearColor(const APoints, ANormals: array of TPoint3D_128; const AColors: array of TBGRAPixel); overload; virtual;
201
202 procedure FillQuadLinearColor(pt1,pt2,pt3,pt4: TPointF; c1,c2,c3,c4: TColorF; APixelCenteredCoordinates: boolean = true); overload;
203 procedure FillQuads(const APoints: array of TPointF; AColor: TColorF; APixelCenteredCoordinates: boolean = true); overload; virtual;
204 procedure FillQuadsLinearColor(const APoints: array of TPointF; const AColors: array of TColorF; APixelCenteredCoordinates: boolean = true); overload; virtual;
205 procedure FillQuadsLinearColor(const APoints: array of TPoint3D; const AColors: array of TColorF); overload; virtual;
206 procedure FillQuadsLinearColor(const APoints: array of TPoint3D_128; const AColors: array of TColorF); overload; virtual;
207 procedure FillQuadsLinearColor(const APoints, ANormals: array of TPoint3D_128; const AColors: array of TColorF); overload; virtual;
208
209 procedure DrawPath(APath: TBGLPath; c: TBGRAPixel);
210 procedure FillPathConvex(APath: TBGLPath; c: TBGRAPixel; APixelCenteredCoordinates: boolean = true);
211
212 procedure FillRectLinearColor(r: TRect; ATopLeftColor, ATopRightColor, ABottomRightColor, ABottomLeftColor: TBGRAPixel); overload; virtual;
213 procedure FillRectLinearColor(x1,y1,x2,y2: single;
214 ATopLeftColor, ATopRightColor, ABottomRightColor, ABottomLeftColor: TBGRAPixel;
215 APixelCenteredCoordinates: boolean = true); overload; virtual;
216
217 procedure Ellipse(cx,cy,rx,ry: single; AColor: TBGRAPixel); overload;
218 procedure EllipseInRect(r: TRect; AColor: TBGRAPixel); overload;
219 procedure Ellipse(cx,cy,rx,ry: single; AColor: TBGRAPixel; AFillColor: TBGRAPixel); overload;
220 procedure EllipseInRect(r: TRect; AColor: TBGRAPixel; AFillColor: TBGRAPixel); overload;
221 procedure EllipseLinearColor(cx,cy,rx,ry: single; AColor: TBGRAPixel; AOuterFillColor, AInnerFillColor: TBGRAPixel); overload;
222 procedure EllipseLinearColorInRect(r: TRect; AColor: TBGRAPixel; AOuterFillColor, AInnerFillColor: TBGRAPixel); overload;
223 procedure FillEllipse(cx,cy,rx,ry: single; AColor: TBGRAPixel; APixelCenteredCoordinates: boolean = true);
224 procedure FillEllipseInRect(r: TRect; AColor: TBGRAPixel);
225 procedure FillEllipseLinearColor(cx, cy, rx, ry: single; AOuterColor, AInnerColor: TBGRAPixel; APixelCenteredCoordinates: boolean = true);
226 procedure FillEllipseLinearColorInRect(r: TRect; AOuterColor, AInnerColor: TBGRAPixel);
227
228 procedure Arc(cx,cy,rx,ry: single; const StartPoint,EndPoint: TPointF; AColor: TBGRAPixel; ADrawChord: boolean; AFillColor: TBGRAPixel); overload;
229 procedure Arc(cx,cy,rx,ry: single; StartAngleRad,EndAngleRad: Single; AColor: TBGRAPixel; ADrawChord: boolean; AFillColor: TBGRAPixel); overload;
230 procedure ArcInRect(r: TRect; StartAngleRad,EndAngleRad: Single; AColor: TBGRAPixel; ADrawChord: boolean; AFillColor: TBGRAPixel);
231 procedure ArcLinearColor(cx,cy,rx,ry: single; const StartPoint,EndPoint: TPointF; AColor: TBGRAPixel; ADrawChord: boolean; AOuterFillColor, AInnerFillColor: TBGRAPixel); overload;
232 procedure ArcLinearColor(cx,cy,rx,ry: single; StartAngleRad,EndAngleRad: Single; AColor: TBGRAPixel; ADrawChord: boolean; AOuterFillColor, AInnerFillColor: TBGRAPixel); overload;
233 procedure ArcLinearColorInRect(r: TRect; StartAngleRad,EndAngleRad: Single; AColor: TBGRAPixel; ADrawChord: boolean; AOuterFillColor, AInnerFillColor: TBGRAPixel);
234
235 procedure Pie(cx,cy,rx,ry: single; const StartPoint,EndPoint: TPointF; AColor: TBGRAPixel; AFillColor: TBGRAPixel); overload;
236 procedure Pie(cx,cy,rx,ry: single; StartAngleRad,EndAngleRad: Single; AColor: TBGRAPixel; AFillColor: TBGRAPixel); overload;
237 procedure PieInRect(r: TRect; StartAngleRad,EndAngleRad: Single; AColor: TBGRAPixel; AFillColor: TBGRAPixel);
238 procedure PieLinearColor(cx,cy,rx,ry: single; const StartPoint,EndPoint: TPointF; AColor: TBGRAPixel; AOuterFillColor, AInnerFillColor: TBGRAPixel); overload;
239 procedure PieLinearColor(cx,cy,rx,ry: single; StartAngleRad,EndAngleRad: Single; AColor: TBGRAPixel; AOuterFillColor, AInnerFillColor: TBGRAPixel); overload;
240 procedure PieLinearColorInRect(r: TRect; StartAngleRad,EndAngleRad: Single; AColor: TBGRAPixel; AOuterFillColor, AInnerFillColor: TBGRAPixel);
241
242 procedure Rectangle(r: TRect; AColor: TBGRAPixel); overload;
243 procedure Rectangle(r: TRect; AColor: TBGRAPixel; AFillColor: TBGRAPixel); overload;
244 procedure Rectangle(x1,y1,x2,y2: single; AColor: TBGRAPixel); overload;
245 procedure Rectangle(x1,y1,x2,y2: single; AColor: TBGRAPixel; AFillColor: TBGRAPixel); overload;
246 procedure Rectangle(x1,y1,x2,y2: single; AColor: TBGRAPixel; w: single; APixelCenteredCoordinates: boolean = true); overload;
247 procedure Rectangle(x1,y1,x2,y2: single; AColor: TBGRAPixel; w: single; AFillColor: TBGRAPixel; APixelCenteredCoordinates: boolean = true); overload;
248 procedure RectangleWithin(x1,y1,x2,y2: single; ABorderColor: TBGRAPixel; w: single; AFillColor: TBGRAPixel; APixelCenteredCoordinates: boolean = true); overload;
249 procedure RectangleWithin(r: TRect; ABorderColor: TBGRAPixel; w: single; AFillColor: TBGRAPixel); overload;
250 procedure FillRect(x1,y1,x2,y2: single; AColor: TBGRAPixel; APixelCenteredCoordinates: boolean = true); overload;
251 procedure FillRect(r: TRect; AColor: TBGRAPixel); overload;
252 procedure FillRect(r: TRectF; AColor: TBGRAPixel; APixelCenteredCoordinates: boolean = false); overload;
253 procedure FillRect(r: TRect; AScanner: IBGRAScanner); overload; virtual;
254 procedure RoundRect(x1,y1,x2,y2,rx,ry: single; ABorderColor: TBGRAPixel; options: TRoundRectangleOptions = []); overload;
255 procedure RoundRect(x1,y1,x2,y2,rx,ry: single; ABorderColor,AFillColor: TBGRAPixel; options: TRoundRectangleOptions = []); overload;
256 procedure FillRoundRect(x,y,x2,y2,rx,ry: single; AFillColor: TBGRAPixel; options: TRoundRectangleOptions = []; APixelCenteredCoordinates: boolean = true);
257
258 procedure Frame3D(var bounds: TRect; width: integer; Style: TGraphicsBevelCut); overload;
259 procedure Frame3D(var bounds: TRect; width: integer;
260 Style: TGraphicsBevelCut; LightColor: TBGRAPixel; ShadowColor: TBGRAPixel); overload;
261
262 procedure PutImage(x,y: single; ATexture: IBGLTexture; AAlpha: byte = 255); overload;
263 procedure PutImage(x,y: single; ATexture: IBGLTexture; AColor: TBGRAPixel); overload;
264 procedure StretchPutImage(x,y,w,h: single; ATexture: IBGLTexture; AAlpha: byte = 255); overload;
265 procedure StretchPutImage(x,y,w,h: single; ATexture: IBGLTexture; AColor: TBGRAPixel); overload;
266 procedure StretchPutImage(r: TRect; ATexture: IBGLTexture; AAlpha: byte = 255); overload;
267 procedure StretchPutImage(r: TRect; ATexture: IBGLTexture; AColor: TBGRAPixel); overload;
268 procedure PutImageAngle(x,y: single; ATexture: IBGLTexture; angleDeg: single; AAlpha: byte = 255); overload;
269 procedure PutImageAngle(x,y: single; ATexture: IBGLTexture; angleDeg: single; AColor: TBGRAPixel); overload;
270 procedure PutImageAffine(const Origin, HAxis, VAxis: TPointF; ATexture: IBGLTexture; AAlpha: byte = 255); overload;
271 procedure PutImageAffine(const Origin, HAxis, VAxis: TPointF; ATexture: IBGLTexture; AColor: TBGRAPixel); overload;
272 procedure PutImageAffine(x,y: single; ATexture: IBGLTexture; const AMatrix: TAffineMatrix; AAlpha: byte = 255); overload;
273 procedure PutImageAffine(x,y: single; ATexture: IBGLTexture; const AMatrix: TAffineMatrix; AColor: TBGRAPixel); overload;
274
275 procedure Translate(x,y: single); virtual;
276 procedure Scale(sx,sy: single); virtual;
277 procedure RotateDeg(angleCW: single); virtual;
278 procedure RotateRad(angleCCW: single); virtual;
279 procedure ResetTransform; virtual;
280
281 procedure UseOrthoProjection; overload; virtual;
282 procedure UseOrthoProjection(AMinX,AMinY,AMaxX,AMaxY: single); overload; virtual;
283 procedure StartZBuffer; virtual;
284 procedure EndZBuffer; virtual;
285 procedure WaitForGPU({%H-}AOption: TWaitForGPUOption); virtual;
286
287 function GetImage({%H-}x,{%H-}y,{%H-}w,{%H-}h: integer): TBGRACustomBitmap; virtual;
288 function CreateFrameBuffer({%H-}AWidth,{%H-}AHeight: integer): TBGLCustomFrameBuffer; virtual;
289
290 procedure NoClip;
291 property ActiveFrameBuffer: TBGLCustomFrameBuffer read FActiveFrameBuffer write SetActiveFrameBuffer;
292 property Width: integer read GetWidth write SetWidth;
293 property Height: integer read GetHeight write SetHeight;
294 property ClipRect: TRect read GetClipRect write SetClipRect;
295 property Matrix: TAffineMatrix read GetMatrix write SetMatrix;
296 property ProjectionMatrix: TMatrix4D read GetProjectionMatrix write SetProjectionMatrix;
297 property BlendMode: TOpenGLBlendMode read GetBlendMode write SetBlendMode;
298 property FaceCulling: TFaceCulling read GetFaceCulling write SetFaceCulling;
299 property Lighting: TBGLCustomLighting read GetLighting;
300 end;
301
302 { TBGLPath }
303
304 TBGLPath = class(TBGRAPath)
305 private
306 procedure GLDrawProc(const APoints: array of TPointF; AClosed: boolean; AData: pointer);
307 procedure GLFillProc(const APoints: array of TPointF; AData: pointer);
308 public
309 procedure stroke(ACanvas: TBGLCustomCanvas; AColor: TBGRAPixel; AAcceptedDeviation: single = 0.1); overload;
310 procedure fillConvex(ACanvas: TBGLCustomCanvas; AColor: TBGRAPixel; AAcceptedDeviation: single = 0.1; APixelCenteredCoordinates: boolean = true);
311 end;
312
313implementation
314
315uses Math, Types, BGRAGradientScanner;
316
317type
318 TGLStrokeData = record
319 Color: TBGRAPixel;
320 Canvas: TBGLCustomCanvas;
321 end;
322 TGLFillData = record
323 Color: TBGRAPixel;
324 Canvas: TBGLCustomCanvas;
325 PixelCenteredCoordinates: boolean;
326 end;
327
328{ TAttributeVariable }
329
330procedure TAttributeVariable.Init(AOwner: TObject; AAttribute: DWord;
331 AVectorSize: integer; AFloat: boolean);
332begin
333 FOwner := AOwner;
334 FAttribute:= AAttribute;
335 FVectorSize:= AVectorSize;
336 FFloat := AFloat;
337 FArray := nil;
338 FRecordOffset := 0;
339end;
340
341{ TBGLCustomLighting }
342
343function TBGLCustomLighting.GetActiveShader: TBGLCustomShader;
344begin
345 result := FCurrentShader;
346end;
347
348function TBGLCustomLighting.GetSupportShaders: boolean;
349begin
350 result := false;
351end;
352
353function TBGLCustomLighting.GetShader(AName: string): TBGLCustomShader;
354var index: integer;
355begin
356 if ShaderList = nil then ShaderList := TStringList.Create;
357 index := ShaderList.IndexOf(AName);
358 if index = -1 then
359 result := nil
360 else
361 result := TBGLCustomShader(ShaderList.Objects[index]);
362end;
363
364procedure TBGLCustomLighting.SetShader(AName: string; AValue: TBGLCustomShader);
365var index: integer;
366begin
367 if ShaderList = nil then ShaderList := TStringList.Create;
368 index := ShaderList.IndexOf(AName);
369 if AValue = nil then
370 begin
371 if index <> -1 then
372 ShaderList.Delete(index);
373 end else
374 begin
375 if index = -1 then
376 ShaderList.AddObject(AName,AValue)
377 else
378 ShaderList.Objects[index] := AValue;
379 end;
380end;
381
382destructor TBGLCustomLighting.Destroy;
383begin
384 FreeShaders;
385 FreeAndNil(ShaderList);
386 inherited Destroy;
387end;
388
389procedure TBGLCustomLighting.FreeShaders;
390var i: integer;
391begin
392 if Assigned(ShaderList) then
393 begin
394 for i := 0 to ShaderList.Count-1 do
395 ShaderList.Objects[i].Free;
396 ShaderList.Clear;
397 end;
398end;
399
400procedure TBGLCustomLighting.SetActiveShader(AValue: TBGLCustomShader);
401begin
402 if AValue <> FCurrentShader then
403 begin
404 if Assigned(FCurrentShader) then FCurrentShader.EndUse;
405 FCurrentShader := AValue;
406 if Assigned(FCurrentShader) then FCurrentShader.StartUse;
407 end;
408end;
409
410{ TBGLPath }
411
412procedure TBGLPath.GLDrawProc(const APoints: array of TPointF;
413 AClosed: boolean; AData: pointer);
414begin
415 with TGLStrokeData(AData^) do
416 if AClosed then
417 Canvas.Polygons(APoints, Color)
418 else
419 Canvas.Polylines(APoints, Color);
420end;
421
422procedure TBGLPath.GLFillProc(const APoints: array of TPointF; AData: pointer);
423begin
424 with TGLFillData(AData^) do
425 Canvas.FillPolyConvex(APoints,Color,PixelCenteredCoordinates);
426end;
427
428procedure TBGLPath.stroke(ACanvas: TBGLCustomCanvas; AColor: TBGRAPixel; AAcceptedDeviation: single);
429var data: TGLStrokeData;
430begin
431 data.Color := AColor;
432 data.Canvas := ACanvas;
433 stroke(@GLDrawProc, AffineMatrixIdentity, AAcceptedDeviation, @data);
434end;
435
436procedure TBGLPath.fillConvex(ACanvas: TBGLCustomCanvas; AColor: TBGRAPixel; AAcceptedDeviation: single; APixelCenteredCoordinates: boolean);
437var data: TGLFillData;
438begin
439 data.Color := AColor;
440 data.Canvas := ACanvas;
441 data.PixelCenteredCoordinates := APixelCenteredCoordinates;
442 fill(@GLFillProc, AffineMatrixIdentity, AAcceptedDeviation, @data);
443end;
444
445{ TBGLCustomCanvas }
446
447function TBGLCustomCanvas.ComputeEllipseC(r: TRect; AHasBorder: boolean; out
448 cx, cy, rx, ry: single): boolean;
449begin
450 if (r.right = r.left) or (r.bottom = r.top) then
451 begin
452 cx := r.left;
453 cy := r.top;
454 rx := 0;
455 ry := 0;
456 exit;
457 end;
458 SwapRect(r);
459 cx := (r.left+r.right-1)*0.5;
460 cy := (r.top+r.bottom-1)*0.5;
461 rx := (r.right-r.left)*0.5;
462 ry := (r.bottom-r.top)*0.5;
463 if AHasBorder then
464 begin
465 rx -= 0.5;
466 if rx < 0 then rx := 0;
467 ry -= 0.5;
468 if ry < 0 then ry := 0;
469 end;
470 result := true;
471end;
472
473function TBGLCustomCanvas.GetHeight: integer;
474begin
475 if FActiveFrameBuffer = nil then
476 result := FHeight
477 else
478 result := FActiveFrameBuffer.Height;
479end;
480
481function TBGLCustomCanvas.GetWidth: integer;
482begin
483 if FActiveFrameBuffer = nil then
484 result := FWidth
485 else
486 result := FActiveFrameBuffer.Width;
487end;
488
489procedure TBGLCustomCanvas.SetWidth(AValue: integer);
490begin
491 if FWidth=AValue then Exit;
492 FWidth:=AValue;
493end;
494
495procedure TBGLCustomCanvas.SetHeight(AValue: integer);
496begin
497 if FHeight=AValue then Exit;
498 FHeight:=AValue;
499end;
500
501function TBGLCustomCanvas.GetClipRect: TRect;
502begin
503 if FNoClip then
504 result := rect(0,0,Width,Height)
505 else
506 result := FClipRect;
507end;
508
509procedure TBGLCustomCanvas.SetClipRect(AValue: TRect);
510begin
511 SwapRect(AValue);
512 with ClipRect do
513 if (AValue.left = left) and (AValue.top = top) and (AValue.bottom = bottom)
514 and (AValue.right = right) then exit;
515
516 if (AValue.Left = 0) and (AValue.Top = 0) and
517 (AValue.Right = Width) and (AValue.Bottom = Height) then
518 NoClip
519 else
520 begin
521 FClipRect := AValue;
522 EnableScissor(FClipRect);
523 end;
524end;
525
526function TBGLCustomCanvas.GetProjectionMatrix: TMatrix4D;
527begin
528 result := MatrixIdentity4D;
529end;
530
531procedure TBGLCustomCanvas.SetProjectionMatrix(const AValue: TMatrix4D);
532begin
533 raise exception.Create('Not implemented');
534end;
535
536function TBGLCustomCanvas.GetLighting: TBGLCustomLighting;
537begin
538 result := nil;
539 raise exception.Create('Not implemented');
540end;
541
542procedure TBGLCustomCanvas.InternalContinueShape(const pt: TPoint3D);
543begin
544 raise exception.Create('Not available');
545end;
546
547procedure TBGLCustomCanvas.InternalContinueShape(const pt: TPoint3D_128);
548begin
549 raise exception.Create('Not available');
550end;
551
552procedure TBGLCustomCanvas.InternalContinueShape(const pt, normal: TPoint3D_128);
553begin
554 raise exception.Create('Not available');
555end;
556
557procedure TBGLCustomCanvas.NoClip;
558begin
559 FClipRect := rect(0,0,Width,Height);
560 FNoClip := true;
561 DisableScissor;
562end;
563
564constructor TBGLCustomCanvas.Create;
565begin
566 FNoClip:= true;
567end;
568
569procedure TBGLCustomCanvas.FillTriangles(const APoints: array of TPointF;
570 AColor: TBGRAPixel; APixelCenteredCoordinates: boolean);
571var
572 i: NativeInt;
573 ofs: TPointF;
574begin
575 if (length(APoints) < 3) or (AColor.alpha = 0) then exit;
576 InternalStartBlendTriangles;
577 InternalSetColor(AColor);
578 if APixelCenteredCoordinates then ofs := PointF(0.5,0.5) else ofs := PointF(0,0);
579 for i := 0 to length(APoints) - (length(APoints) mod 3) - 1 do
580 InternalContinueShape(APoints[i]+ofs);
581 InternalEndBlendTriangles;
582end;
583
584procedure TBGLCustomCanvas.FillTrianglesLinearColor(const APoints: array of TPointF;
585 const AColors: array of TBGRAPixel; APixelCenteredCoordinates: boolean);
586var
587 i: NativeInt;
588 ofs: TPointF;
589begin
590 if length(APoints) < 3 then exit;
591 if length(AColors)<>length(APoints) then
592 raise exception.Create('Length of APoints and AColors do not match');
593 InternalStartBlendTriangles;
594 if APixelCenteredCoordinates then ofs := PointF(0.5,0.5) else ofs := PointF(0,0);
595 for i := 0 to length(APoints) - (length(APoints) mod 3) - 1 do
596 begin
597 InternalSetColor(AColors[i]);
598 InternalContinueShape(APoints[i]+ofs);
599 end;
600 InternalEndBlendTriangles;
601end;
602
603procedure TBGLCustomCanvas.FillTrianglesLinearColor(
604 const APoints: array of TPoint3D; const AColors: array of TBGRAPixel);
605var
606 i: NativeInt;
607begin
608 if length(APoints) < 3 then exit;
609 if length(AColors)<>length(APoints) then
610 raise exception.Create('Length of APoints and AColors do not match');
611 InternalStartBlendTriangles;
612 for i := 0 to length(APoints) - (length(APoints) mod 3) - 1 do
613 begin
614 InternalSetColor(AColors[i]);
615 InternalContinueShape(APoints[i]);
616 end;
617 InternalEndBlendTriangles;
618end;
619
620procedure TBGLCustomCanvas.FillTrianglesLinearColor(
621 const APoints: array of TPoint3D_128; const AColors: array of TBGRAPixel);
622var
623 i: NativeInt;
624begin
625 if length(APoints) < 3 then exit;
626 if length(AColors)<>length(APoints) then
627 raise exception.Create('Length of APoints and AColors do not match');
628 InternalStartBlendTriangles;
629 for i := 0 to length(APoints) - (length(APoints) mod 3) - 1 do
630 begin
631 InternalSetColor(AColors[i]);
632 InternalContinueShape(APoints[i]);
633 end;
634 InternalEndBlendTriangles;
635end;
636
637procedure TBGLCustomCanvas.FillTrianglesLinearColor(const APoints,
638 ANormals: array of TPoint3D_128; const AColors: array of TBGRAPixel);
639var
640 i: NativeInt;
641begin
642 if length(APoints) < 3 then exit;
643 if length(AColors)<>length(APoints) then raise exception.Create('Length of APoints and AColors do not match');
644 if length(AColors)<>length(ANormals) then raise exception.Create('Length of APoints and ANormals do not match');
645 InternalStartBlendTriangles;
646 for i := 0 to length(APoints) - (length(APoints) mod 3) - 1 do
647 begin
648 InternalSetColor(AColors[i]);
649 InternalContinueShape(APoints[i], ANormals[i]);
650 end;
651 InternalEndBlendTriangles;
652end;
653
654procedure TBGLCustomCanvas.FillQuads(const APoints: array of TPointF;
655 AColor: TBGRAPixel; APixelCenteredCoordinates: boolean);
656var
657 i: NativeInt;
658 ofs: TPointF;
659begin
660 if (length(APoints) < 4) or (AColor.alpha = 0) then exit;
661 InternalStartBlendQuads;
662 InternalSetColor(AColor);
663 if APixelCenteredCoordinates then ofs := PointF(0.5,0.5) else ofs := PointF(0,0);
664 for i := 0 to length(APoints) - (length(APoints) and 3) - 1 do
665 InternalContinueShape(APoints[i]+ofs);
666 InternalEndBlendQuads;
667end;
668
669procedure TBGLCustomCanvas.FillQuadsLinearColor(const APoints: array of TPointF;
670 const AColors: array of TBGRAPixel; APixelCenteredCoordinates: boolean);
671var
672 i: NativeInt;
673 ofs: TPointF;
674begin
675 if length(APoints) < 4 then exit;
676 if length(AColors)<>length(APoints) then
677 raise exception.Create('Length of APoints and AColors do not match');
678 InternalStartBlendQuads;
679 if APixelCenteredCoordinates then ofs := PointF(0.5,0.5) else ofs := PointF(0,0);
680 for i := 0 to length(APoints) - (length(APoints) and 3) - 1 do
681 begin
682 InternalSetColor(AColors[i]);
683 InternalContinueShape(APoints[i]+ofs);
684 end;
685 InternalEndBlendQuads;
686end;
687
688procedure TBGLCustomCanvas.FillQuadsLinearColor(
689 const APoints: array of TPoint3D; const AColors: array of TBGRAPixel);
690var
691 i: NativeInt;
692begin
693 if length(APoints) < 4 then exit;
694 if length(AColors)<>length(APoints) then
695 raise exception.Create('Length of APoints and AColors do not match');
696 InternalStartBlendQuads;
697 for i := 0 to length(APoints) - (length(APoints) and 3) - 1 do
698 begin
699 InternalSetColor(AColors[i]);
700 InternalContinueShape(APoints[i]);
701 end;
702 InternalEndBlendQuads;
703end;
704
705procedure TBGLCustomCanvas.FillQuadsLinearColor(
706 const APoints: array of TPoint3D_128; const AColors: array of TBGRAPixel);
707var
708 i: NativeInt;
709begin
710 if length(APoints) < 4 then exit;
711 if length(AColors)<>length(APoints) then
712 raise exception.Create('Length of APoints and AColors do not match');
713 InternalStartBlendQuads;
714 for i := 0 to length(APoints) - (length(APoints) and 3) - 1 do
715 begin
716 InternalSetColor(AColors[i]);
717 InternalContinueShape(APoints[i]);
718 end;
719 InternalEndBlendQuads;
720end;
721
722procedure TBGLCustomCanvas.FillQuadsLinearColor(const APoints,
723 ANormals: array of TPoint3D_128; const AColors: array of TBGRAPixel);
724var
725 i: NativeInt;
726begin
727 if length(APoints) < 4 then exit;
728 if length(AColors)<>length(APoints) then raise exception.Create('Length of APoints and AColors do not match');
729 if length(AColors)<>length(ANormals) then raise exception.Create('Length of APoints and ANormals do not match');
730 InternalStartBlendQuads;
731 for i := 0 to length(APoints) - (length(APoints) and 3) - 1 do
732 begin
733 InternalSetColor(AColors[i]);
734 InternalContinueShape(APoints[i], ANormals[i]);
735 end;
736 InternalEndBlendQuads;
737end;
738
739procedure TBGLCustomCanvas.FillQuadLinearColor(pt1, pt2, pt3, pt4: TPointF; c1,
740 c2, c3, c4: TColorF; APixelCenteredCoordinates: boolean);
741begin
742 FillQuadsLinearColor([pt1,pt2,pt3,pt4],[c1,c2,c3,c4],APixelCenteredCoordinates);
743end;
744
745procedure TBGLCustomCanvas.FillQuads(const APoints: array of TPointF;
746 AColor: TColorF; APixelCenteredCoordinates: boolean);
747var
748 i: NativeInt;
749 ofs: TPointF;
750begin
751 if (length(APoints) < 4) or (AColor[4] = 0) then exit;
752 InternalStartBlendQuads;
753 InternalSetColorF(AColor);
754 if APixelCenteredCoordinates then ofs := PointF(0.5,0.5) else ofs := PointF(0,0);
755 for i := 0 to length(APoints) - (length(APoints) and 3) - 1 do
756 InternalContinueShape(APoints[i]+ofs);
757 InternalEndBlendQuads;
758end;
759
760procedure TBGLCustomCanvas.FillQuadsLinearColor(
761 const APoints: array of TPointF; const AColors: array of TColorF;
762 APixelCenteredCoordinates: boolean);
763var
764 i: NativeInt;
765 ofs: TPointF;
766begin
767 if length(APoints) < 4 then exit;
768 if length(AColors)<>length(APoints) then
769 raise exception.Create('Length of APoints and AColors do not match');
770 InternalStartBlendQuads;
771 if APixelCenteredCoordinates then ofs := PointF(0.5,0.5) else ofs := PointF(0,0);
772 for i := 0 to length(APoints) - (length(APoints) and 3) - 1 do
773 begin
774 InternalSetColorF(AColors[i]);
775 InternalContinueShape(APoints[i]+ofs);
776 end;
777 InternalEndBlendQuads;
778end;
779
780procedure TBGLCustomCanvas.FillQuadsLinearColor(
781 const APoints: array of TPoint3D; const AColors: array of TColorF);
782var
783 i: NativeInt;
784begin
785 if length(APoints) < 4 then exit;
786 if length(AColors)<>length(APoints) then
787 raise exception.Create('Length of APoints and AColors do not match');
788 InternalStartBlendQuads;
789 for i := 0 to length(APoints) - (length(APoints) and 3) - 1 do
790 begin
791 InternalSetColorF(AColors[i]);
792 InternalContinueShape(APoints[i]);
793 end;
794 InternalEndBlendQuads;
795end;
796
797procedure TBGLCustomCanvas.FillQuadsLinearColor(
798 const APoints: array of TPoint3D_128; const AColors: array of TColorF);
799var
800 i: NativeInt;
801begin
802 if length(APoints) < 4 then exit;
803 if length(AColors)<>length(APoints) then
804 raise exception.Create('Length of APoints and AColors do not match');
805 InternalStartBlendQuads;
806 for i := 0 to length(APoints) - (length(APoints) and 3) - 1 do
807 begin
808 InternalSetColorF(AColors[i]);
809 InternalContinueShape(APoints[i]);
810 end;
811 InternalEndBlendQuads;
812end;
813
814procedure TBGLCustomCanvas.FillQuadsLinearColor(const APoints,
815 ANormals: array of TPoint3D_128; const AColors: array of TColorF);
816var
817 i: NativeInt;
818begin
819 if length(APoints) < 4 then exit;
820 if length(AColors)<>length(APoints) then raise exception.Create('Length of APoints and AColors do not match');
821 if length(AColors)<>length(ANormals) then raise exception.Create('Length of APoints and ANormals do not match');
822 InternalStartBlendQuads;
823 for i := 0 to length(APoints) - (length(APoints) and 3) - 1 do
824 begin
825 InternalSetColorF(AColors[i]);
826 InternalContinueShape(APoints[i], ANormals[i]);
827 end;
828 InternalEndBlendQuads;
829end;
830
831procedure TBGLCustomCanvas.PutPixels(const APoints: array of TPointF;
832 AColor: TBGRAPixel);
833var
834 i: NativeInt;
835begin
836 if length(APoints) = 0 then exit;
837 InternalStartBlend;
838 InternalSetColor(AColor);
839 InternalStartPutPixel(APoints[0]);
840 for i := 1 to high(APoints) do
841 InternalContinueShape(APoints[i]);
842 InternalEndBlend;
843end;
844
845procedure TBGLCustomCanvas.PutPixels(const APoints: array of TPointF;
846 const AColors: array of TBGRAPixel);
847var
848 i: NativeInt;
849begin
850 if length(APoints) = 0 then exit;
851 InternalStartBlend;
852 InternalSetColor(AColors[0]);
853 InternalStartPutPixel(APoints[0]);
854 for i := 1 to high(APoints) do
855 begin
856 InternalSetColor(AColors[i]);
857 InternalContinueShape(APoints[i]);
858 end;
859 InternalEndBlend;
860end;
861
862procedure TBGLCustomCanvas.FillTrianglesFan(const APoints: array of TPointF;
863 ACenterColor, ABorderColor: TBGRAPixel; APixelCenteredCoordinates: boolean);
864var
865 i: NativeInt;
866 firstPoint: boolean;
867 ofs: TPointF;
868begin
869 if (length(APoints) < 3) or ((ACenterColor.alpha = 0) and (ABorderColor.alpha = 0)) then exit;
870 InternalStartBlend;
871 firstPoint := true;
872 if APixelCenteredCoordinates then ofs := PointF(0.5,0.5) else ofs := PointF(0,0);
873 for i := 0 to high(APoints) do
874 begin
875 if isEmptyPointF(APoints[i]) then
876 begin
877 if not firstPoint then
878 begin
879 InternalEndShape;
880 firstPoint := true;
881 end;
882 end else
883 begin
884 if firstPoint then
885 begin
886 InternalSetColor(ACenterColor);
887 InternalStartTriangleFan(APoints[i]+ofs);
888 InternalSetColor(ABorderColor);
889 firstPoint := false;
890 end else
891 InternalContinueShape(APoints[i]+ofs);
892 end;
893 end;
894 if not firstPoint then InternalEndShape;
895 InternalEndBlend;
896end;
897
898procedure TBGLCustomCanvas.FillTriangleLinearColor(pt1, pt2, pt3: TPointF; c1,
899 c2, c3: TColorF; APixelCenteredCoordinates: boolean);
900begin
901 FillTrianglesLinearColor([pt1,pt2,pt3],[c1,c2,c3],APixelCenteredCoordinates);
902end;
903
904procedure TBGLCustomCanvas.FillTriangles(const APoints: array of TPointF;
905 AColor: TColorF; APixelCenteredCoordinates: boolean);
906var
907 i: NativeInt;
908 ofs: TPointF;
909begin
910 if (length(APoints) < 3) or (AColor[4] = 0) then exit;
911 InternalStartBlendTriangles;
912 InternalSetColorF(AColor);
913 if APixelCenteredCoordinates then ofs := PointF(0.5,0.5) else ofs := PointF(0,0);
914 for i := 0 to length(APoints) - (length(APoints) mod 3) - 1 do
915 InternalContinueShape(APoints[i]+ofs);
916 InternalEndBlendTriangles;
917end;
918
919procedure TBGLCustomCanvas.FillTrianglesLinearColor(
920 const APoints: array of TPointF; const AColors: array of TColorF;
921 APixelCenteredCoordinates: boolean);
922var
923 i: NativeInt;
924 ofs: TPointF;
925begin
926 if length(APoints) < 3 then exit;
927 if length(AColors)<>length(APoints) then
928 raise exception.Create('Length of APoints and AColors do not match');
929 InternalStartBlendTriangles;
930 if APixelCenteredCoordinates then ofs := PointF(0.5,0.5) else ofs := PointF(0,0);
931 for i := 0 to length(APoints) - (length(APoints) mod 3) - 1 do
932 begin
933 InternalSetColorF(AColors[i]);
934 InternalContinueShape(APoints[i]+ofs);
935 end;
936 InternalEndBlendTriangles;
937end;
938
939procedure TBGLCustomCanvas.FillTrianglesLinearColor(
940 const APoints: array of TPoint3D; const AColors: array of TColorF);
941var
942 i: NativeInt;
943begin
944 if length(APoints) < 3 then exit;
945 if length(AColors)<>length(APoints) then
946 raise exception.Create('Length of APoints and AColors do not match');
947 InternalStartBlendTriangles;
948 for i := 0 to length(APoints) - (length(APoints) mod 3) - 1 do
949 begin
950 InternalSetColorF(AColors[i]);
951 InternalContinueShape(APoints[i]);
952 end;
953 InternalEndBlendTriangles;
954end;
955
956procedure TBGLCustomCanvas.FillTrianglesLinearColor(
957 const APoints: array of TPoint3D_128; const AColors: array of TColorF);
958var
959 i: NativeInt;
960begin
961 if length(APoints) < 3 then exit;
962 if length(AColors)<>length(APoints) then
963 raise exception.Create('Length of APoints and AColors do not match');
964 InternalStartBlendTriangles;
965 for i := 0 to length(APoints) - (length(APoints) mod 3) - 1 do
966 begin
967 InternalSetColorF(AColors[i]);
968 InternalContinueShape(APoints[i]);
969 end;
970 InternalEndBlendTriangles;
971end;
972
973procedure TBGLCustomCanvas.FillTrianglesLinearColor(const APoints,
974 ANormals: array of TPoint3D_128; const AColors: array of TColorF);
975var
976 i: NativeInt;
977begin
978 if length(APoints) < 3 then exit;
979 if length(AColors)<>length(APoints) then raise exception.Create('Length of APoints and AColors do not match');
980 if length(AColors)<>length(ANormals) then raise exception.Create('Length of APoints and ANormals do not match');
981 InternalStartBlendTriangles;
982 for i := 0 to length(APoints) - (length(APoints) mod 3) - 1 do
983 begin
984 InternalSetColorF(AColors[i]);
985 InternalContinueShape(APoints[i], ANormals[i]);
986 end;
987 InternalEndBlendTriangles;
988end;
989
990procedure TBGLCustomCanvas.FillTrianglesFan(const APoints: array of TPointF;
991 ACenterColor, ABorderColor: TColorF; APixelCenteredCoordinates: boolean);
992var
993 i: NativeInt;
994 firstPoint: boolean;
995 ofs: TPointF;
996begin
997 if (length(APoints) < 3) or ((ACenterColor[4] = 0) and (ABorderColor[4] = 0)) then exit;
998 InternalStartBlend;
999 firstPoint := true;
1000 if APixelCenteredCoordinates then ofs := PointF(0.5,0.5) else ofs := PointF(0,0);
1001 for i := 0 to high(APoints) do
1002 begin
1003 if isEmptyPointF(APoints[i]) then
1004 begin
1005 if not firstPoint then
1006 begin
1007 InternalEndShape;
1008 firstPoint := true;
1009 end;
1010 end else
1011 begin
1012 if firstPoint then
1013 begin
1014 InternalSetColorF(ACenterColor);
1015 InternalStartTriangleFan(APoints[i]+ofs);
1016 InternalSetColorF(ABorderColor);
1017 firstPoint := false;
1018 end else
1019 InternalContinueShape(APoints[i]+ofs);
1020 end;
1021 end;
1022 if not firstPoint then InternalEndShape;
1023 InternalEndBlend;
1024end;
1025
1026procedure TBGLCustomCanvas.Polylines(const APoints: array of TPointF;
1027 AColor: TBGRAPixel; ADrawLastPoints: boolean);
1028const
1029 STATE_START = 0; //nothing defined
1030 STATE_SECOND = 1; //prevPoint defined and is the first point
1031 STATE_AFTER = 2; //newPoint defined and is the lastest point, prevPoint is the point before that
1032var
1033 i: NativeInt;
1034 state: NativeInt;
1035 prevPoint,newPoint,v,ofs: TPointF;
1036 len: single;
1037
1038 procedure Flush;
1039 begin
1040 case state of
1041 STATE_SECOND: begin
1042 InternalStartPutPixel(prevPoint);
1043 InternalEndShape;
1044 end;
1045 STATE_AFTER:
1046 begin
1047 v := newPoint-prevPoint;
1048 len := VectLen(v);
1049 if len > 0 then
1050 begin
1051 v := v*(1/len);
1052 if ADrawLastPoints then
1053 InternalContinueShape(newPoint + v*0.5 + ofs)
1054 else
1055 InternalContinueShape(newPoint - v*0.5 + ofs);
1056 end;
1057 InternalEndShape;
1058 end;
1059 end;
1060 state := STATE_START;
1061 end;
1062
1063begin
1064 if (length(APoints) = 0) or (AColor.alpha = 0) then exit;
1065 InternalStartBlend;
1066 InternalSetColor(AColor);
1067 prevPoint := PointF(0,0);
1068 newPoint := PointF(0,0);
1069 state := STATE_START;
1070 ofs := PointF(0.5,0.5);
1071 for i := 0 to high(APoints) do
1072 begin
1073 if isEmptyPointF(APoints[i]) then
1074 begin
1075 Flush;
1076 end else
1077 begin
1078 if state = STATE_START then
1079 begin
1080 state := STATE_SECOND;
1081 prevPoint := APoints[i];
1082 end else
1083 if APoints[i] <> prevPoint then
1084 begin
1085 if state = STATE_SECOND then
1086 begin
1087 newPoint := APoints[i];
1088 v := newPoint-prevPoint;
1089 len := VectLen(v);
1090 if len > 0 then
1091 begin
1092 v := v*(1/len);
1093 InternalStartPolyline(prevPoint - v*0.5 + ofs);
1094 state := STATE_AFTER;
1095 end;
1096 end else
1097 begin
1098 InternalContinueShape(newPoint + ofs);
1099 prevPoint := newPoint;
1100 newPoint := APoints[i];
1101 end;
1102 end;
1103 end;
1104 end;
1105 Flush;
1106 InternalEndBlend;
1107end;
1108
1109procedure TBGLCustomCanvas.Polygons(const APoints: array of TPointF;
1110 AColor: TBGRAPixel);
1111const
1112 STATE_START = 0; //nothing defined
1113 STATE_SECOND = 1; //prevPoint defined and is the first point
1114 STATE_AFTER = 2; //newPoint defined and is the lastest point, prevPoint is the point before that
1115var
1116 i: NativeInt;
1117 state: NativeInt;
1118 prevPoint,newPoint: TPointF;
1119 ofs: TPointF;
1120
1121 procedure Flush;
1122 begin
1123 case state of
1124 STATE_SECOND: begin
1125 InternalStartPutPixel(prevPoint);
1126 InternalEndShape;
1127 end;
1128 STATE_AFTER:
1129 begin
1130 InternalContinueShape(newPoint + ofs);
1131 InternalEndShape;
1132 end;
1133 end;
1134 state := STATE_START;
1135 end;
1136
1137begin
1138 if (length(APoints) = 0) or (AColor.alpha = 0) then exit;
1139 InternalStartBlend;
1140 InternalSetColor(AColor);
1141 prevPoint := PointF(0,0);
1142 newPoint := PointF(0,0);
1143 state := STATE_START;
1144 ofs := PointF(0.5,0.5);
1145 for i := 0 to high(APoints) do
1146 begin
1147 if isEmptyPointF(APoints[i]) then
1148 begin
1149 Flush;
1150 end else
1151 begin
1152 if state = STATE_START then
1153 begin
1154 state := STATE_SECOND;
1155 prevPoint := APoints[i];
1156 end else
1157 if APoints[i] <> prevPoint then
1158 begin
1159 if state = STATE_SECOND then
1160 begin
1161 InternalStartPolygon(prevPoint+ofs);
1162 newPoint := APoints[i];
1163 state := STATE_AFTER;
1164 end else
1165 begin
1166 InternalContinueShape(newPoint+ofs);
1167 prevPoint := newPoint;
1168 newPoint := APoints[i];
1169 end;
1170 end;
1171 end;
1172 end;
1173 Flush;
1174 InternalEndBlend;
1175end;
1176
1177procedure TBGLCustomCanvas.FillRect(r: TRect; AScanner: IBGRAScanner);
1178var
1179 bmp: TBGLCustomBitmap;
1180 yb,bandHeight,bandY: NativeInt;
1181 tx: integer;
1182begin
1183 SwapRect(r);
1184 if (r.right = r.left) or (r.bottom = r.top) then exit;
1185 tx := r.right-r.left;
1186 bandHeight := 65536 div tx;
1187 if bandHeight <= 2 then bandHeight := 2;
1188 bandHeight := GetPowerOfTwo(bandHeight);
1189 bmp := BGLBitmapFactory.Create(tx,bandHeight);
1190 bmp.Texture.ResampleFilter := orfBox;
1191 bandY := (r.Bottom-1-r.top) mod bandHeight;
1192 for yb := r.bottom-1 downto r.top do
1193 begin
1194 AScanner.ScanMoveTo(r.left,yb);
1195 AScanner.ScanPutPixels(bmp.ScanLine[bandY],tx,dmSet);
1196 bmp.InvalidateBitmap;
1197 if bandY = 0 then
1198 begin
1199 bmp.Texture.Draw(r.left,yb);
1200 bandY := bandHeight-1;
1201 end else
1202 dec(bandY);
1203 end;
1204 bmp.Free;
1205end;
1206
1207procedure TBGLCustomCanvas.DrawPath(APath: TBGLPath; c: TBGRAPixel);
1208begin
1209 APath.stroke(self, c);
1210end;
1211
1212procedure TBGLCustomCanvas.FillPathConvex(APath: TBGLPath; c: TBGRAPixel; APixelCenteredCoordinates: boolean);
1213begin
1214 APath.fillConvex(self, c, 0.1, APixelCenteredCoordinates);
1215end;
1216
1217procedure TBGLCustomCanvas.SetActiveFrameBuffer(AValue: TBGLCustomFrameBuffer);
1218begin
1219 if FActiveFrameBuffer=AValue then Exit;
1220 if FActiveFrameBuffer <> nil then
1221 FActiveFrameBuffer.SetCanvas(nil);
1222 FActiveFrameBuffer:=AValue;
1223 if FActiveFrameBuffer <> nil then
1224 FActiveFrameBuffer.SetCanvas(self);
1225end;
1226
1227procedure TBGLCustomCanvas.SwapRect(var r: TRect);
1228var
1229 temp: LongInt;
1230begin
1231 if (r.Right < r.left) then
1232 begin
1233 temp := r.Left;
1234 r.left := r.right;
1235 r.right := temp;
1236 end;
1237 if (r.bottom < r.top) then
1238 begin
1239 temp := r.top;
1240 r.top:= r.bottom;
1241 r.bottom:= temp;
1242 end;
1243end;
1244
1245procedure TBGLCustomCanvas.SwapRect(var x1, y1, x2, y2: single);
1246var
1247 temp: single;
1248begin
1249 if (x2 < x1) then
1250 begin
1251 temp := x1;
1252 x1 := x2;
1253 x2 := temp;
1254 end;
1255 if (y2 < y1) then
1256 begin
1257 temp := y1;
1258 y1 := y2;
1259 y2 := temp;
1260 end;
1261end;
1262
1263procedure TBGLCustomCanvas.InternalArc(cx, cy, rx, ry: single; const StartPoint,
1264 EndPoint: TPointF; ABorderColor, AOuterFillColor,ACenterFillColor: TBGRAPixel;
1265 AOptions: TArcOptions; ADrawChord: boolean = false);
1266var angle1,angle2: single;
1267begin
1268 if (rx = 0) or (ry = 0) then exit;
1269 angle1 := arctan2(-(StartPoint.y-cy)/ry,(StartPoint.x-cx)/rx);
1270 angle2 := arctan2(-(EndPoint.y-cy)/ry,(EndPoint.x-cx)/rx);
1271 if angle1 = angle2 then angle2 := angle1+2*Pi;
1272 InternalArc(cx,cy,rx,ry, angle1,angle2,
1273 ABorderColor,AOuterFillColor,ACenterFillColor, AOptions, ADrawChord);
1274end;
1275
1276procedure TBGLCustomCanvas.InternalArc(cx, cy, rx, ry: single;
1277 StartAngleRad, EndAngleRad: Single; ABorderColor,
1278 AOuterFillColor,ACenterFillColor: TBGRAPixel; AOptions: TArcOptions;
1279 ADrawChord: boolean = false);
1280var
1281 pts,ptsFill: array of TPointF;
1282 temp: single;
1283begin
1284 if (rx = 0) or (ry = 0) then exit;
1285 if ADrawChord then AOptions := AOptions+[aoClosePath];
1286 if not (aoFillPath in AOptions) then
1287 begin
1288 AOuterFillColor := BGRAPixelTransparent;
1289 ACenterFillColor := BGRAPixelTransparent;
1290 end;
1291
1292 if (ABorderColor.alpha = 0) and (AOuterFillColor.alpha = 0) and (ACenterFillColor.alpha = 0) then exit;
1293
1294 if abs(StartAngleRad-EndAngleRad) >= 2*PI - 1e-6 then
1295 begin
1296 Ellipse(cx,cy,rx,ry,ABorderColor);
1297 FillEllipseLinearColor(cx,cy,rx,ry,AOuterFillColor,ACenterFillColor);
1298 if aoPie in AOptions then
1299 Line(cx,cy,cx+cos(StartAngleRad)*rx,cy-sin(StartAngleRad)*ry,ABorderColor,False);
1300 exit;
1301 end;
1302
1303 if EndAngleRad < StartAngleRad then
1304 begin
1305 temp := StartAngleRad;
1306 StartAngleRad:= EndAngleRad;
1307 EndAngleRad:= temp;
1308 end;
1309
1310 pts := ComputeArcRad(cx,cy,rx,ry,StartAngleRad,EndAngleRad);
1311 if aoPie in AOptions then
1312 pts := ConcatPointsF([PointsF([PointF(cx,cy)]),pts]);
1313 if (ACenterFillColor.alpha <> 0) or (AOuterFillColor.alpha <> 0) then
1314 begin
1315 if not (aoPie in AOptions) and (length(pts)>=2) then ptsFill := ConcatPointsF([PointsF([(pts[0]+pts[high(pts)])*0.5]),pts])
1316 else ptsFill := pts;
1317 FillTrianglesFan(ptsFill, ACenterFillColor,AOuterFillColor);
1318 end;
1319 if ABorderColor.alpha <> 0 then
1320 begin
1321 if [aoPie,aoClosePath]*AOptions <> [] then
1322 Polygons(pts, ABorderColor)
1323 else
1324 Polylines(pts, ABorderColor, true);
1325 end;
1326end;
1327
1328procedure TBGLCustomCanvas.InternalArcInRect(r: TRect; StartAngleRad,
1329 EndAngleRad: Single; ABorderColor, AOuterFillColor,ACenterFillColor: TBGRAPixel;
1330 AOptions: TArcOptions; ADrawChord: boolean = false);
1331begin
1332 if r.right = r.left then exit;
1333 if r.bottom = r.top then exit;
1334 SwapRect(r);
1335 InternalArc((r.left+r.right-1)/2,(r.top+r.bottom-1)/2,
1336 (r.right-r.left-1)/2,(r.bottom-r.top-1)/2,
1337 StartAngleRad,EndAngleRad,
1338 ABorderColor,AOuterFillColor,ACenterFillColor,
1339 AOptions, ADrawChord);
1340end;
1341
1342procedure TBGLCustomCanvas.FillTriangleLinearColor(pt1, pt2, pt3: TPointF; c1,
1343 c2, c3: TBGRAPixel; APixelCenteredCoordinates: boolean);
1344begin
1345 FillTrianglesLinearColor([pt1,pt2,pt3],[c1,c2,c3],APixelCenteredCoordinates);
1346end;
1347
1348procedure TBGLCustomCanvas.FillQuadLinearColor(pt1, pt2, pt3, pt4: TPointF; c1,
1349 c2, c3, c4: TBGRAPixel; APixelCenteredCoordinates: boolean);
1350begin
1351 FillQuadsLinearColor([pt1,pt2,pt3,pt4],[c1,c2,c3,c4],APixelCenteredCoordinates);
1352end;
1353
1354procedure TBGLCustomCanvas.FillPolyConvex(const APoints: array of TPointF;
1355 AColor: TBGRAPixel; APixelCenteredCoordinates: boolean);
1356begin
1357 FillTrianglesFan(APoints,AColor,AColor,APixelCenteredCoordinates);
1358end;
1359
1360procedure TBGLCustomCanvas.Line(x1, y1, x2, y2: single; AColor: TBGRAPixel; ADrawLastPoint: boolean);
1361var pts: array of TPointF;
1362begin
1363 setlength(pts,2);
1364 pts[0] := PointF(x1,y1);
1365 pts[1] := PointF(x2,y2);
1366 Polylines(pts,AColor,ADrawLastPoint);
1367end;
1368
1369procedure TBGLCustomCanvas.Line(p1, p2: TPointF; AColor: TBGRAPixel; ADrawLastPoint: boolean);
1370var pts: array of TPointF;
1371begin
1372 setlength(pts,2);
1373 pts[0] := p1;
1374 pts[1] := p2;
1375 Polylines(pts,AColor,ADrawLastPoint);
1376end;
1377
1378procedure TBGLCustomCanvas.FillRectLinearColor(r: TRect;
1379 ATopLeftColor, ATopRightColor, ABottomRightColor, ABottomLeftColor: TBGRAPixel);
1380begin
1381 FillRectLinearColor(r.left,r.top,r.right,r.bottom,
1382 ATopLeftColor, ATopRightColor, ABottomRightColor, ABottomLeftColor,
1383 False);
1384end;
1385
1386procedure TBGLCustomCanvas.FillRectLinearColor(x1, y1, x2, y2: single;
1387 ATopLeftColor, ATopRightColor, ABottomRightColor,
1388 ABottomLeftColor: TBGRAPixel; APixelCenteredCoordinates: boolean);
1389begin
1390 FillQuadLinearColor(PointF(x1,y1),PointF(x2,y1),
1391 PointF(x2,y2),PointF(x1,y2),
1392 ATopLeftColor, ATopRightColor, ABottomRightColor, ABottomLeftColor,
1393 APixelCenteredCoordinates);
1394end;
1395
1396procedure TBGLCustomCanvas.Ellipse(cx, cy, rx, ry: single; AColor: TBGRAPixel);
1397begin
1398 if AColor.alpha = 0 then exit;
1399 Polygons(ComputeEllipse(cx,cy,rx,ry),AColor);
1400end;
1401
1402procedure TBGLCustomCanvas.EllipseInRect(r: TRect; AColor: TBGRAPixel);
1403var cx,cy,rx,ry: single;
1404begin
1405 if not ComputeEllipseC(r,True,cx,cy,rx,ry) then exit;
1406 Ellipse(cx,cy,rx,ry, AColor);
1407end;
1408
1409procedure TBGLCustomCanvas.FillEllipse(cx, cy, rx, ry: single; AColor: TBGRAPixel; APixelCenteredCoordinates: boolean);
1410begin
1411 if AColor.alpha = 0 then exit;
1412 FillTrianglesFan(ComputeEllipse(cx,cy,rx,ry),AColor,AColor,APixelCenteredCoordinates);
1413end;
1414
1415procedure TBGLCustomCanvas.FillEllipseInRect(r: TRect; AColor: TBGRAPixel);
1416var cx,cy,rx,ry: single;
1417begin
1418 if not ComputeEllipseC(r,False,cx,cy,rx,ry) then exit;
1419 FillEllipse(cx,cy,rx,ry, AColor);
1420end;
1421
1422procedure TBGLCustomCanvas.FillEllipseLinearColor(cx, cy, rx, ry: single;
1423 AOuterColor, AInnerColor: TBGRAPixel; APixelCenteredCoordinates: boolean);
1424begin
1425 if (AOutercolor.alpha = 0) and (AInnercolor.alpha = 0) then exit;
1426 FillTrianglesFan(ConcatPointsF([PointsF([PointF(cx,cy)]),ComputeEllipse(cx,cy,rx,ry)]),AInnercolor,AOutercolor,APixelCenteredCoordinates);
1427end;
1428
1429procedure TBGLCustomCanvas.FillEllipseLinearColorInRect(r: TRect; AOuterColor,
1430 AInnerColor: TBGRAPixel);
1431var cx,cy,rx,ry: single;
1432begin
1433 if not ComputeEllipseC(r,False,cx,cy,rx,ry) then exit;
1434 FillEllipseLinearColor(cx,cy,rx,ry, AOutercolor,AInnercolor);
1435end;
1436
1437procedure TBGLCustomCanvas.Arc(cx, cy, rx, ry: single; const StartPoint,
1438 EndPoint: TPointF; AColor: TBGRAPixel; ADrawChord: boolean; AFillColor: TBGRAPixel);
1439begin
1440 InternalArc(cx,cy,rx,ry,StartPoint,EndPoint,AColor,AFillColor,AFillColor,[aoFillPath],ADrawChord);
1441end;
1442
1443procedure TBGLCustomCanvas.Arc(cx, cy, rx, ry: single; StartAngleRad,
1444 EndAngleRad: Single; AColor: TBGRAPixel; ADrawChord: boolean; AFillColor: TBGRAPixel);
1445begin
1446 InternalArc(cx,cy,rx,ry,StartAngleRad,EndAngleRad,AColor,AFillColor,AFillColor,[aoFillPath],ADrawChord);
1447end;
1448
1449procedure TBGLCustomCanvas.ArcInRect(r: TRect; StartAngleRad,
1450 EndAngleRad: Single; AColor: TBGRAPixel; ADrawChord: boolean; AFillColor: TBGRAPixel);
1451var cx,cy,rx,ry: single;
1452begin
1453 if not ComputeEllipseC(r,True,cx,cy,rx,ry) then exit;
1454 Arc(cx,cy,rx,ry,StartAngleRad,EndAngleRad, AColor,ADrawChord, AFillColor);
1455end;
1456
1457procedure TBGLCustomCanvas.ArcLinearColor(cx, cy, rx, ry: single;
1458 const StartPoint, EndPoint: TPointF; AColor: TBGRAPixel; ADrawChord: boolean; AOuterFillColor,
1459 AInnerFillColor: TBGRAPixel);
1460begin
1461 InternalArc(cx,cy,rx,ry,StartPoint,EndPoint,AColor,AOuterFillColor,AInnerFillColor,[aoFillPath],ADrawChord);
1462end;
1463
1464procedure TBGLCustomCanvas.ArcLinearColor(cx, cy, rx, ry: single;
1465 StartAngleRad, EndAngleRad: Single; AColor: TBGRAPixel; ADrawChord: boolean; AOuterFillColor,
1466 AInnerFillColor: TBGRAPixel);
1467begin
1468 InternalArc(cx,cy,rx,ry,StartAngleRad,EndAngleRad,AColor,AOuterFillColor,AInnerFillColor,[aoFillPath],ADrawChord);
1469end;
1470
1471procedure TBGLCustomCanvas.ArcLinearColorInRect(r: TRect; StartAngleRad,
1472 EndAngleRad: Single; AColor: TBGRAPixel; ADrawChord: boolean; AOuterFillColor,
1473 AInnerFillColor: TBGRAPixel);
1474var cx,cy,rx,ry: single;
1475begin
1476 if not ComputeEllipseC(r,True,cx,cy,rx,ry) then exit;
1477 ArcLinearColor(cx,cy,rx,ry,StartAngleRad,EndAngleRad, AColor,ADrawChord, AOuterFillColor,AInnerFillColor);
1478end;
1479
1480procedure TBGLCustomCanvas.Pie(cx, cy, rx, ry: single; const StartPoint,
1481 EndPoint: TPointF; AColor: TBGRAPixel; AFillColor: TBGRAPixel);
1482begin
1483 InternalArc(cx,cy,rx,ry,StartPoint,EndPoint,AColor,AFillColor,AFillColor,[aoFillPath,aoPie]);
1484end;
1485
1486procedure TBGLCustomCanvas.Pie(cx, cy, rx, ry: single; StartAngleRad,
1487 EndAngleRad: Single; AColor: TBGRAPixel; AFillColor: TBGRAPixel);
1488begin
1489 InternalArc(cx,cy,rx,ry,StartAngleRad,EndAngleRad,AColor,AFillColor,AFillColor,[aoFillPath,aoPie]);
1490end;
1491
1492procedure TBGLCustomCanvas.PieInRect(r: TRect; StartAngleRad,
1493 EndAngleRad: Single; AColor: TBGRAPixel; AFillColor: TBGRAPixel);
1494var cx,cy,rx,ry: single;
1495begin
1496 if not ComputeEllipseC(r,True,cx,cy,rx,ry) then exit;
1497 Pie(cx,cy,rx,ry,StartAngleRad,EndAngleRad, AColor,AFillColor);
1498end;
1499
1500procedure TBGLCustomCanvas.PieLinearColor(cx, cy, rx, ry: single;
1501 const StartPoint, EndPoint: TPointF; AColor: TBGRAPixel; AOuterFillColor,
1502 AInnerFillColor: TBGRAPixel);
1503begin
1504 InternalArc(cx,cy,rx,ry,StartPoint,EndPoint,AColor,AOuterFillColor,AInnerFillColor,[aoFillPath,aoPie]);
1505end;
1506
1507procedure TBGLCustomCanvas.PieLinearColor(cx, cy, rx, ry: single;
1508 StartAngleRad, EndAngleRad: Single; AColor: TBGRAPixel; AOuterFillColor,
1509 AInnerFillColor: TBGRAPixel);
1510begin
1511 InternalArc(cx,cy,rx,ry,StartAngleRad,EndAngleRad,AColor,AOuterFillColor,AInnerFillColor,[aoFillPath,aoPie]);
1512end;
1513
1514procedure TBGLCustomCanvas.PieLinearColorInRect(r: TRect; StartAngleRad,
1515 EndAngleRad: Single; AColor: TBGRAPixel; AOuterFillColor,
1516 AInnerFillColor: TBGRAPixel);
1517var cx,cy,rx,ry: single;
1518begin
1519 if not ComputeEllipseC(r,True,cx,cy,rx,ry) then exit;
1520 PieLinearColor(cx,cy,rx,ry,StartAngleRad,EndAngleRad, AColor,AOuterFillColor,AInnerFillColor);
1521end;
1522
1523procedure TBGLCustomCanvas.EllipseLinearColor(cx, cy, rx, ry: single; AColor: TBGRAPixel;
1524 AOuterFillColor, AInnerFillColor: TBGRAPixel);
1525begin
1526 if (rx>1) and (ry>1) then
1527 FillEllipseLinearColor(cx,cy,rx-0.5,ry-0.5,AOuterFillColor,AInnerFillColor);
1528 Ellipse(cx,cy,rx,ry,AColor);
1529end;
1530
1531procedure TBGLCustomCanvas.EllipseLinearColorInRect(r: TRect; AColor: TBGRAPixel;
1532 AOuterFillColor, AInnerFillColor: TBGRAPixel);
1533var cx,cy,rx,ry: single;
1534begin
1535 if not ComputeEllipseC(r,True,cx,cy,rx,ry) then exit;
1536 FillEllipseLinearColor(cx,cy,rx,ry, AOuterFillColor,AInnerFillColor);
1537 EllipseInRect(r,AColor);
1538end;
1539
1540procedure TBGLCustomCanvas.Ellipse(cx, cy, rx, ry: single; AColor: TBGRAPixel;
1541 AFillColor: TBGRAPixel);
1542begin
1543 EllipseLinearColor(cx,cy,rx,ry,AColor,AFillColor,AFillColor);
1544end;
1545
1546procedure TBGLCustomCanvas.EllipseInRect(r: TRect; AColor: TBGRAPixel;
1547 AFillColor: TBGRAPixel);
1548begin
1549 EllipseLinearColorInRect(r, AColor, AFillColor, AFillColor);
1550end;
1551
1552procedure TBGLCustomCanvas.Rectangle(r: TRect; AColor: TBGRAPixel);
1553begin
1554 Rectangle(r,AColor,BGRAPixelTransparent);
1555end;
1556
1557procedure TBGLCustomCanvas.Rectangle(r: TRect; AColor: TBGRAPixel;
1558 AFillColor: TBGRAPixel);
1559begin
1560 SwapRect(r);
1561 if r.left=r.right then exit;
1562 if r.top=r.bottom then exit;
1563 Rectangle(r.left,r.top,r.right-1,r.bottom-1,AColor,AFillColor);
1564end;
1565
1566procedure TBGLCustomCanvas.Rectangle(x1, y1, x2, y2: single; AColor: TBGRAPixel);
1567begin
1568 Rectangle(x1,y1,x2,y2,AColor,1);
1569end;
1570
1571procedure TBGLCustomCanvas.Rectangle(x1, y1, x2, y2: single;
1572 AColor: TBGRAPixel; AFillColor: TBGRAPixel);
1573begin
1574 Rectangle(x1,y1,x2,y2,AColor,1,AFillColor);
1575end;
1576
1577procedure TBGLCustomCanvas.Rectangle(x1, y1, x2, y2: single;
1578 AColor: TBGRAPixel; w: single; APixelCenteredCoordinates: boolean);
1579var hw: single;
1580begin
1581 SwapRect(x1,y1,x2,y2);
1582 hw := w*0.5;
1583 if (x2-x1 > w) and (y2-y1 > w) then
1584 FillQuads(PointsF([PointF(x1-hw,y1-hw),PointF(x2+hw,y1-hw),PointF(x2+hw,y1+hw),PointF(x1-hw,y1+hw),
1585 PointF(x1-hw,y2-hw),PointF(x2+hw,y2-hw),PointF(x2+hw,y2+hw),PointF(x1-hw,y2+hw),
1586 PointF(x1-hw,y1+hw),PointF(x1+hw,y1+hw),PointF(x1+hw,y2-hw),PointF(x1-hw,y2-hw),
1587 PointF(x2-hw,y1+hw),PointF(x2+hw,y1+hw),PointF(x2+hw,y2-hw),PointF(x2-hw,y2-hw)]), AColor,
1588 APixelCenteredCoordinates)
1589 else
1590 FillQuads(PointsF([PointF(x1-hw,y1-hw),PointF(x2+hw,y1-hw),PointF(x2+hw,y2+hw),PointF(x1-hw,y2+hw)]),AColor,
1591 APixelCenteredCoordinates);
1592end;
1593
1594procedure TBGLCustomCanvas.Rectangle(x1, y1, x2, y2: single;
1595 AColor: TBGRAPixel; w: single; AFillColor: TBGRAPixel; APixelCenteredCoordinates: boolean);
1596begin
1597 SwapRect(x1,y1,x2,y2);
1598 if (x2-x1 > w) and (y2-y1 > w) then
1599 FillRect(x1+0.5*w,y1+0.5*w,x2-0.5*w,y2-0.5*w,AFillColor,APixelCenteredCoordinates);
1600 Rectangle(x1,y1,x2,y2,AColor,w,APixelCenteredCoordinates);
1601end;
1602
1603procedure TBGLCustomCanvas.RectangleWithin(x1, y1, x2, y2: single;
1604 ABorderColor: TBGRAPixel; w: single; AFillColor: TBGRAPixel;
1605 APixelCenteredCoordinates: boolean);
1606begin
1607 Rectangle(x1+w*0.5,y1+w*0.5,x2-w*0.5,y2-w*0.5, ABorderColor, w, AFillColor,
1608 APixelCenteredCoordinates);
1609end;
1610
1611procedure TBGLCustomCanvas.RectangleWithin(r: TRect; ABorderColor: TBGRAPixel;
1612 w: single; AFillColor: TBGRAPixel);
1613begin
1614 RectangleWithin(r.left,r.top,r.right,r.bottom,ABorderColor,w,AFillColor,false);
1615end;
1616
1617procedure TBGLCustomCanvas.RoundRect(x1, y1, x2, y2, rx, ry: single;
1618 ABorderColor: TBGRAPixel; options: TRoundRectangleOptions);
1619begin
1620 RoundRect(x1,y1,x2,y2,rx,ry,ABorderColor,options);
1621end;
1622
1623procedure TBGLCustomCanvas.RoundRect(x1, y1, x2, y2, rx, ry: single;
1624 ABorderColor, AFillColor: TBGRAPixel; options: TRoundRectangleOptions);
1625const radiusReduction = 1;
1626begin
1627 SwapRect(x1,y1,x2,y2);
1628 rx := abs(rx);
1629 ry := abs(ry);
1630 if (AFillColor.alpha <> 0) and (y2-y1 > 1) and (x2-x1 > 1) then
1631 begin
1632 if (rx <= radiusReduction) or (ry <= radiusReduction) then
1633 FillRect(x1+0.5,y1+0.5,x2-0.5,y2-0.5, AFillColor)
1634 else
1635 FillPolyConvex(ComputeRoundRect(x1+0.5,y1+0.5,x2-0.5,y2-0.5,rx-radiusReduction,ry-radiusReduction,options),AFillColor);
1636 end;
1637 Polygons(ComputeRoundRect(x1,y1,x2,y2,rx,ry,options),ABorderColor);
1638end;
1639
1640procedure TBGLCustomCanvas.FillRoundRect(x, y, x2, y2, rx, ry: single;
1641 AFillColor: TBGRAPixel; options: TRoundRectangleOptions; APixelCenteredCoordinates: boolean);
1642begin
1643 if AFillColor.alpha <> 0 then
1644 FillPolyConvex(ComputeRoundRect(x,y,x2,y2,rx,ry,options),AFillColor,APixelCenteredCoordinates);
1645end;
1646
1647procedure TBGLCustomCanvas.FillRect(x1, y1, x2, y2: single; AColor: TBGRAPixel; APixelCenteredCoordinates: boolean);
1648begin
1649 FillQuads(PointsF([PointF(x1,y1),PointF(x2,y1),PointF(x2,y2),PointF(x1,y2)]), AColor, APixelCenteredCoordinates);
1650end;
1651
1652procedure TBGLCustomCanvas.FillRect(r: TRect; AColor: TBGRAPixel);
1653begin
1654 SwapRect(r);
1655 if r.left=r.right then exit;
1656 if r.top=r.bottom then exit;
1657 FillRect(r.left,r.top,r.Right,r.bottom,AColor,False);
1658end;
1659
1660procedure TBGLCustomCanvas.FillRect(r: TRectF; AColor: TBGRAPixel;
1661 APixelCenteredCoordinates: boolean);
1662begin
1663 if r.left=r.right then exit;
1664 if r.top=r.bottom then exit;
1665 FillRect(r.left,r.top,r.Right,r.bottom,AColor,APixelCenteredCoordinates);
1666end;
1667
1668procedure TBGLCustomCanvas.Frame3D(var bounds: TRect; width: integer;
1669 Style: TGraphicsBevelCut);
1670begin
1671 Frame3D(bounds,width,style,ColorToBGRA(clRgbBtnHighlight),ColorToBGRA(clRgbBtnShadow));
1672end;
1673
1674procedure TBGLCustomCanvas.Frame3D(var bounds: TRect; width: integer;
1675 Style: TGraphicsBevelCut; LightColor: TBGRAPixel; ShadowColor: TBGRAPixel);
1676var temp: TBGRAPixel;
1677 color1,color2: TBGRAPixel;
1678begin
1679 if width <= 0 then exit;
1680 color1 := LightColor;
1681 color2 := ShadowColor;
1682 if Style = bvLowered then
1683 begin
1684 temp := color1;
1685 color1 := color2;
1686 color2 := temp;
1687 end;
1688 if Style in [bvLowered,bvRaised] then
1689 with bounds do
1690 begin
1691 FillTrianglesFan([PointF(Left,Top),PointF(Right,Top),
1692 PointF(Right-width,Top+width),PointF(Left+width,Top+width),
1693 PointF(Left+width,Bottom-width),PointF(Left,Bottom)],color1,color1, False);
1694 FillTrianglesFan([PointF(Right,Bottom),PointF(Left,Bottom),
1695 PointF(Left+width,Bottom-width),PointF(Right-width,Bottom-width),
1696 PointF(Right-width,Top+width),PointF(Right,Top)],color2,color2, false);
1697 end;
1698 InflateRect(bounds,-width,-width);
1699end;
1700
1701procedure TBGLCustomCanvas.PutImage(x, y: single; ATexture: IBGLTexture;
1702 AAlpha: byte);
1703begin
1704 ATexture.Draw(x,y,AAlpha);
1705end;
1706
1707procedure TBGLCustomCanvas.PutImage(x, y: single; ATexture: IBGLTexture;
1708 AColor: TBGRAPixel);
1709begin
1710 ATexture.Draw(x,y,AColor);
1711end;
1712
1713procedure TBGLCustomCanvas.StretchPutImage(x, y, w, h: single;
1714 ATexture: IBGLTexture; AAlpha: byte);
1715begin
1716 ATexture.StretchDraw(x,y,w,h, AAlpha);
1717end;
1718
1719procedure TBGLCustomCanvas.StretchPutImage(x, y, w, h: single;
1720 ATexture: IBGLTexture; AColor: TBGRAPixel);
1721begin
1722 ATexture.StretchDraw(x,y,w,h, AColor);
1723end;
1724
1725procedure TBGLCustomCanvas.StretchPutImage(r: TRect; ATexture: IBGLTexture;
1726 AAlpha: byte);
1727begin
1728 ATexture.StretchDraw(r.left,r.top,r.right-r.left,r.bottom-r.top, AAlpha);
1729end;
1730
1731procedure TBGLCustomCanvas.StretchPutImage(r: TRect; ATexture: IBGLTexture;
1732 AColor: TBGRAPixel);
1733begin
1734 ATexture.StretchDraw(r.left,r.top,r.right-r.left,r.bottom-r.top, AColor);
1735end;
1736
1737procedure TBGLCustomCanvas.PutImageAngle(x, y: single; ATexture: IBGLTexture;
1738 angleDeg: single; AAlpha: byte);
1739begin
1740 ATexture.DrawAngle(x,y,angleDeg,AAlpha);
1741end;
1742
1743procedure TBGLCustomCanvas.PutImageAngle(x, y: single; ATexture: IBGLTexture;
1744 angleDeg: single; AColor: TBGRAPixel);
1745begin
1746 ATexture.DrawAngle(x,y,angleDeg,AColor);
1747end;
1748
1749procedure TBGLCustomCanvas.PutImageAffine(const Origin, HAxis, VAxis: TPointF;
1750 ATexture: IBGLTexture; AAlpha: byte);
1751begin
1752 {$PUSH}{$OPTIMIZATION OFF}
1753 ATexture.DrawAffine(Origin, HAxis, VAxis, AAlpha);
1754 {$POP}
1755end;
1756
1757procedure TBGLCustomCanvas.PutImageAffine(const Origin, HAxis, VAxis: TPointF;
1758 ATexture: IBGLTexture; AColor: TBGRAPixel);
1759begin
1760 {$PUSH}{$OPTIMIZATION OFF}
1761 ATexture.DrawAffine(Origin, HAxis, VAxis, AColor);
1762 {$POP}
1763end;
1764
1765procedure TBGLCustomCanvas.PutImageAffine(x, y: single; ATexture: IBGLTexture;
1766 const AMatrix: TAffineMatrix; AAlpha: byte);
1767begin
1768 ATexture.DrawAffine(x,y,AMatrix,AAlpha);
1769end;
1770
1771procedure TBGLCustomCanvas.PutImageAffine(x, y: single; ATexture: IBGLTexture;
1772 const AMatrix: TAffineMatrix; AColor: TBGRAPixel);
1773begin
1774 ATexture.DrawAffine(x,y,AMatrix,AColor);
1775end;
1776
1777procedure TBGLCustomCanvas.Translate(x, y: single);
1778begin
1779 Matrix := Matrix*AffineMatrixTranslation(x,y);
1780end;
1781
1782procedure TBGLCustomCanvas.Scale(sx, sy: single);
1783begin
1784 Matrix := Matrix*AffineMatrixScale(sx,sy);
1785end;
1786
1787procedure TBGLCustomCanvas.RotateDeg(angleCW: single);
1788begin
1789 Matrix := Matrix*AffineMatrixRotationDeg(angleCW);
1790end;
1791
1792procedure TBGLCustomCanvas.RotateRad(angleCCW: single);
1793begin
1794 Matrix := Matrix*AffineMatrixRotationRad(angleCCW);
1795end;
1796
1797procedure TBGLCustomCanvas.ResetTransform;
1798begin
1799 Matrix := AffineMatrixIdentity;
1800end;
1801
1802procedure TBGLCustomCanvas.UseOrthoProjection;
1803begin
1804 ProjectionMatrix := OrthoProjectionToOpenGL(0,0,Width,Height);
1805end;
1806
1807procedure TBGLCustomCanvas.UseOrthoProjection(AMinX, AMinY, AMaxX, AMaxY: single);
1808begin
1809 ProjectionMatrix := OrthoProjectionToOpenGL(AMinX,AMinY,AMaxX,AMaxY);
1810end;
1811
1812procedure TBGLCustomCanvas.StartZBuffer;
1813begin
1814 raise exception.Create('Not implemented');
1815end;
1816
1817procedure TBGLCustomCanvas.EndZBuffer;
1818begin
1819 raise exception.Create('Not implemented');
1820end;
1821
1822procedure TBGLCustomCanvas.WaitForGPU(AOption: TWaitForGPUOption);
1823begin
1824 raise exception.Create('Not implemented');
1825end;
1826
1827function TBGLCustomCanvas.GetImage(x, y, w, h: integer): TBGRACustomBitmap;
1828begin
1829 result := nil;
1830end;
1831
1832function TBGLCustomCanvas.CreateFrameBuffer(AWidth, AHeight: integer): TBGLCustomFrameBuffer;
1833begin
1834 result := nil;
1835 raise exception.Create('Not implemented');
1836end;
1837
1838end.
1839
Note: See TracBrowser for help on using the repository browser.