开通博客赚积分
发布资源赚积分
分类

源码开发语言/平台
当前位置：首页 > 电子书籍 > Delphi/CppBuilder > 查看源码
UOpenGLCanvas.pas
资源名称：box2DDelphiPackage.zip　[点击查看]
上传用户：zkjn0718
上传日期：2021-01-01
资源大小：776k
文件大小：71k
源码类别：

Delphi/CppBuilder

开发平台：

Delphi

UOpenGLCanvas.pas：源码内容
  1. unit UOpenGLCanvas;
  3. { This unit is written by Qianyuan Wang. One version is contributed to CnPack(www.cnpack.org) and this version
  4.    doens't require you install the component. 
  6.   http://hi.baidu.com/wqyfavor
  7.   wqyfavor@163.com
  8.   QQ: 466798985}
  10. interface
  11. {$I OpenGLCanvas.inc}
  13. uses
  14.    Math,
  15.    Windows,
  16.    Classes,
  17.    Controls,
  18.    Graphics,
  19.    OpenGL,
  20.    ExtCtrls;
  22. const
  23.    TransformStackTop = 10;
  24.    ListNestLevel = 9;
  25.    MaxChar = 128;
  27. type
  28.    ARGB = type Cardinal;
  29.    // Use TARGB(ARGB) to quick access elements of an ARGB color
  30.    TARGB = packed record
  31.       blue, green, red, alpha: Byte;
  32.    end;
  34.    PSingleArray = ^TSingleArray;
  35.    TSingleArray = array of Single;
  36.    TColorVector = array[0..3] of Single;
  37.    TVector4f = array[0..3] of Single;
  38.    PMatrix4f = ^TMatrix4f;
  39.    TMatrix4f = array[0..3] of TVector4f;
  41.    PGLPointF = ^TGLPointF;
  42.    TGLPointF = packed record
  43.       X: Single;
  44.       Y: Single;
  45.    end;
  47.    PGLPointsF = ^TGLPointsF;
  48.    TGLPointsF = array of TGLPointF;
  50.    PGLPointI = ^TGLPointI;
  51.    TGLPointI = TPoint;
  53.    PGLPointsI = ^TGLPointsI;
  54.    TGLPointsI = array of TGLPointI;
  56.    TTransformType = (ttScale, ttTranslate, ttRotate);
  57.    TTransformData = record
  58.       TransformType: TTransformType;
  59.       var1, var2: Single;
  60.    end;
  62.    TLineStippleStyle = (lssSolid, lssDash, lssDashDot, lssDashDotDot, lssDot);
  64.    TGLCanvas = class;
  65.    TAfterRendering = procedure(Sender: TGLCanvas) of object;
  66.    TGetDCFunction = function: HDC of object;
  67.    TGLFontNotify = procedure of object;
  69.    TGLFont = class
  70.    private
  71.       FHFont: HFONT;
  72.       FName: WideString;
  73.       FSize: Integer;
  74.       FStyles: TFontStyles;
  75.       FCharSet: Integer;
  76.       FColor: ARGB;
  77.       FColorVector: TColorVector;
  78.       FNotifyChange: TGLFontNotify;
  80.       function FGetWinColor: TColor;
  81.       procedure FSetWinColor(value: TColor);
  82.       procedure FSetColor(value: ARGB);
  83.    public
  84.       constructor Create(Name: WideString; Size: Integer; Styles: TFontStyles = [];
  85.          CharSet: Integer = DEFAULT_CHARSET; Notify: TGLFontNotify = nil);
  86.       destructor Destroy; override;
  87.       procedure Update; // call Update after modifying Name, Size ...
  89.       property HFont: HFONT read FHFont write FHFont;
  90.       property Name: WideString read FName write FName;
  91.       property Size: Integer read FSize write FSize;
  92.       property Styles: TFontStyles read FStyles write FStyles;
  93.       property CharSet: Integer read FCharSet write FCharSet;
  94.       property Color: ARGB read FColor write FSetColor; // do not need to call Update
  95.       property WinColor: TColor read FGetWinColor write FSetWinColor; // do not need to call Update
  96.       property NotifyChange: TGLFontNotify read FNotifyChange write FNotifyChange;
  97.    end;
  99.    TGLCanvas = class
  100.    private
  101.       FHRC: HGLRC;
  102.       FControl: TControl;
  103.       FAfterRendering: TAfterRendering;
  104.       FGetDCFunction: TGetDCFunction;
  106.       FRenderToBmp: Boolean;
  107.       FBufferHDC: HDC;
  108.       FBufferBitmap: HBITMAP;
  109.       FBufferObject: HGDIOBJ;
  110.       FBufferWidth, FBufferHeight: Integer;
  112.       FInvertY: Boolean;
  113.       FRendering: Boolean;
  114.       FBlend: Boolean;
  115.       FAntialiasing: Boolean;
  116.       FIgnorePenWidthFactor: Boolean;
  118.       FListLevel: Integer;
  119.       FIgnoreColor: Boolean;
  120.       FIgnoreColorStack: array[1..ListNestLevel] of Boolean;
  122.       FPenWidthFactor: Single; // Actually the total scale
  123.       FPenWidth: Single;
  124.       FPenColorARGB, FBrushColorARGB: ARGB;
  125.       FPenColor, FBrushColor: TColorVector;
  127.       FMatrix: TMatrix4f; // For backup
  128.       FTransformationUpdateCount: Integer;
  129.       FUseTransformStack: Boolean;
  130.       FTransformStack: array[0..TransformStackTop] of TTransformData;
  131.       FStackTop: Integer;
  133.       FScaleX, FScaleY: Single;
  134.       FTranslateX, FTranslateY: Single;
  135.       FRotation: Single;
  137.       FDefaultFont: TGLFont;
  138.       FASCIICharList: GLuint;
  139.       FASCIICharListCreated: Boolean;
  141.       procedure InitOpenGL;
  142.       procedure ActivateSelf;
  143.       procedure CreateBufferBMP;
  144.       procedure FreeBufferBMP;
  145.       procedure PresentBufferBMP(DC: HDC);
  147.       procedure ApplyTransformation;
  148.       procedure DefaultFontNotify;
  150.       procedure FSetAntialiasing(value: Boolean);
  151.       procedure FSetScaleX(value: Single);
  152.       procedure FSetScaleY(value: Single);
  153.       procedure FSetTranslateX(value: Single);
  154.       procedure FSetTranslateY(value: Single);
  155.       procedure FSetRotation(value: Single);
  157.       procedure FSetPenColor(Value: ARGB);
  158.       procedure FSetBrushColor(Value: ARGB);
  159.       procedure FSetPenWidth(Value: Single);
  161.       procedure EllipseVertices(const x, y, xRadius, yRadius: Single);
  162.    public
  163.       constructor Create(AControl: TControl; RenderToBmp: Boolean = True;
  164.          Antialiasing: Boolean = True; UseTransformStack: Boolean = False;
  165.          IgnorePenWidthFactor: Boolean = False; InvertY: Boolean = True);
  166.       destructor Destroy; override;
  168.       function RenderingBegin(BackgroundColor: TColor = clWhite): TGLCanvas;
  169.       procedure RenderingEnd;
  171.       { You can either build draw lists in Rendering process or not.
  172.         An example:
  173.            GLCanvas.CreateList(List1, 1).ListBegin(List1).Line(0, 0, 50, 50).ListEnd;
  174.            GLCanvas.RenderingBegin.ListExecute(List1).SetTranslateX(50).ListExecute(box).RenderingEnd;
  175.         If IgnoreColor is true, all color definition in fill-shape processes are
  176.         ignored. When the list is built, you can specify color for all vertices of
  177.         the list.  }
  178.       function CreateList(var ListID: GLuint; Range: GLuint = 1): TGLCanvas;
  179.       function DeleteList(ListID: GLuint; Range: GLuint = 1): TGLCanvas;
  180.       function ListBegin(ListID: GLuint; Offset: GLuint = 0; Execute: Boolean = False;
  181.          IgnoreColor: Boolean = True): TGLCanvas;
  182.       function ListEnd: TGLCanvas;
  183.       function ListExecute(ListID: GLuint; Offset: GLuint = 0): TGLCanvas; overload;
  184.       function ListExecute(ListID: GLuint; Offset: GLuint; Color: ARGB;
  185.          PenWidth: Single): TGLCanvas; overload; // PenWidth <= 0 for no change
  187.       { Call Recreate if you want to manually recreate opengl. Normally if Control
  188.         is resized, GLCanvas will detect this change at the beginning of next
  189.         rendering process. }
  190.       procedure Recreate;
  191.       procedure OnControlPaint;
  192.       procedure DrawTo(DC: HDC);
  193.       procedure StretchDrawTo(DC: HDC; X, Y, W, H: Integer);
  195.       ///////////////////////////////////////////////
  196.       function BeginUpdateTransformation: TGLCanvas;
  197.       function EndUpdateTransformation: TGLCanvas;
  199.       // Use transformation for rendering. Not effective for TextOut.
  200.       function SetTransformation(sx, sy, tx, ty, r: Single): TGLCanvas; // Scale, Translate, Rotation
  201.       function SetMatrix(const m11, m12, m13, m21, m22, m23, m31, m32, m33,
  202.          dx, dy: Single; Backup: Boolean = True): TGLCanvas;
  203.       function ResetBackupMatrix: TGLCanvas;
  205.       function ResetTransformation: TGLCanvas;
  206.       function PopMatrix: TGLCanvas; // Cancel last transformation
  207.       function SetEqualScale(value: Single): TGLCanvas;
  208.       function ScaleMatrix(x, y: Single): TGLCanvas;
  209.       function TranslateMatrix(x, y: Single): TGLCanvas;
  210.       function RotateMatrix(angle: Single): TGLCanvas;
  211.       function SetScaleX(value: Single): TGLCanvas;
  212.       function SetScaleY(value: Single): TGLCanvas;
  213.       function SetTranslateX(value: Single): TGLCanvas;
  214.       function SetTranslateY(value: Single): TGLCanvas;
  215.       function SetRotation(value: Single): TGLCanvas;
  217.       function ConvertScreenToWorld(x, y: Integer): TGLPointF; // GDI coordinate where (0, 0) is Left-Top
  218.       function UpdateTransformation: TGLCanvas; // You can maually force update transformation
  220.       ///////////////////////////////////////////////
  221.       function SetBlendState(value: Boolean): TGLCanvas; // Use this to enable or disable GL_BLEND, GL_BLEND is enabled by default.
  223.       ///////////////////////////////////////////////
  224.       function SetPenColorWin(value: TColor; alpha: Byte = 255; Sync: Boolean = True): TGLCanvas;
  225.       function SetBrushColorWin(value: TColor; alpha: Byte = 255; Sync: Boolean = True): TGLCanvas;
  226.       function SetPenColor(value: ARGB): TGLCanvas; overload; // for linked process
  227.       function SetBrushColor(value: ARGB): TGLCanvas; overload; // for linked process
  228.       // For quick OpenGL color assignment. Sync = True, update FPenColorARGB or FBrushColorARGB
  229.       function SetPenColor(const value: TColorVector; Sync: Boolean = False): TGLCanvas; overload;
  230.       function SetBrushColor(const value: TColorVector; Sync: Boolean = False): TGLCanvas; overload;
  231.       function SetPenWidth(value: Single): TGLCanvas; // for linked process
  233.       function LineStipple(factor: Integer; pattern: word): TGLCanvas; overload;
  234.       function LineStipple(style: TLineStippleStyle; enlarge: Byte = 2): TGLCanvas; overload;
  235.       function LineStippleEnd: TGLCanvas;
  237.       function Line(const x1, y1, x2, y2: Integer): TGLCanvas; overload;
  238.       function Line(const x1, y1, x2, y2: Single): TGLCanvas; overload;
  239.       function BeginLines: TGLCanvas; // Remember to call EndLines
  240.       function Lines(const x1, y1, x2, y2: Integer): TGLCanvas; overload;
  241.       function Lines(const x1, y1, x2, y2: Single): TGLCanvas; overload;
  242.       function EndLines: TGLCanvas;
  243.       function Lines(const points: TGLPointsF; count: Integer): TGLCanvas; overload;
  244.       function Lines(const points: TGLPointsI; count: Integer): TGLCanvas; overload;
  246.       function Polyline(const points: TGLPointsF; count: Integer): TGLCanvas; overload;
  247.       function Polyline(const points: TGLPointsI; count: Integer): TGLCanvas; overload;
  248.       function Polygon(const points: TGLPointsF; count: Integer): TGLCanvas; overload;
  249.       function Polygon(const points: TGLPointsI; count: Integer): TGLCanvas; overload;
  250.       function FillPolygon(const points: TGLPointsF; count: Integer; Border: Boolean = False): TGLCanvas; overload;
  251.       function FillPolygon(const points: TGLPointsI; count: Integer; Border: Boolean = False): TGLCanvas; overload;
  253.       function Curve(const points: TGLPointsF; count: Integer; tension: Single = 0.5): TGLCanvas; overload;
  254.       function Curve(const points: TGLPointsI; count: Integer; tension: Single = 0.5): TGLCanvas; overload;
  255.       function ClosedCurve(const points: TGLPointsF; count: Integer; tension: Single = 0.5): TGLCanvas; overload;
  256.       function ClosedCurve(const points: TGLPointsI; count: Integer; tension: Single = 0.5): TGLCanvas; overload;
  257.       function FillClosedCurve(const points: TGLPointsF; count: Integer;
  258.          Border: Boolean = False; tension: Single = 0.5): TGLCanvas; overload;
  259.       function FillClosedCurve(const points: TGLPointsI; count: Integer;
  260.          Border: Boolean = False; tension: Single = 0.5): TGLCanvas; overload;
  262.       function Bezier(const x1, y1, x2, y2, x3, y3, x4, y4: Integer): TGLCanvas; overload;
  263.       function Bezier(const x1, y1, x2, y2, x3, y3, x4, y4: Single): TGLCanvas; overload;
  264.       function PolyBezier(const points: TGLPointsI; count: Integer): TGLCanvas; overload;
  265.       function PolyBezier(const points: TGLPointsF; count: Integer): TGLCanvas; overload;
  267.       // x, y, xRadius, yRadius specify an ellipse. startAngle and sweepAngle specify the range of curve.
  268.       function Arc(const x, y, xRadius, yRadius: Single; startAngle, sweepAngle: Single): TGLCanvas;
  269.       function FillPie(const x, y, xRadius, yRadius: Single;
  270.          startAngle, sweepAngle: Single; Border: Boolean = False): TGLCanvas;
  272.       // Plots a pixel at given coordinate
  273.       function PlotPixel(const x, y: Integer): TGLCanvas; overload;
  274.       function PlotPixel(const x, y: Single): TGLCanvas; overload;
  275.       function BeginPixels: TGLCanvas; // Remember to call EndLines
  276.       function Pixels(const x, y: Integer): TGLCanvas; overload;
  277.       function Pixels(const x, y: Single): TGLCanvas; overload;
  278.       function EndPixels: TGLCanvas;
  280.       // Draw the (x1,y1)-(x2, y2) rectangle's frame (border). }
  281.       function FrameRect(const x1, y1, x2, y2: Integer): TGLCanvas; overload;
  282.       function FrameRect(const x1, y1, x2, y2: Single): TGLCanvas; overload;
  283.       // Draw the (x1,y1)-(x2, y2) rectangle (filled with BrushColor)
  284.       function FillRect(const x1, y1, x2, y2: Integer; Border: Boolean = False): TGLCanvas; overload;
  285.       function FillRect(const x1, y1, x2, y2: Single; Border: Boolean = False): TGLCanvas; overload;
  287.       function Triangle(const x1, y1, x2, y2, x3, y3: Integer): TGLCanvas; overload;
  288.       function Triangle(const x1, y1, x2, y2, x3, y3: Single): TGLCanvas; overload;
  289.       function FillTriangle(const x1, y1, x2, y2, x3, y3: Integer; Border: Boolean = False): TGLCanvas; overload;
  290.       function FillTriangle(const x1, y1, x2, y2, x3, y3: Single; Border: Boolean = False): TGLCanvas; overload;
  292.       // Draws an ellipse with (x1,y1)-(x2, y2) bounding rectangle.
  293.       function EllipseRect(const x1, y1, x2, y2 : Single): TGLCanvas; overload;
  294.       // Draws and ellipse centered at (x, y) with given radiuses.
  295.       function Ellipse(const x, y, xRadius, yRadius: Single): TGLCanvas; overload;
  296.       function FillEllipseRect(const x1, y1, x2, y2: Single; Border: Boolean = False): TGLCanvas; overload;
  297.       function FillEllipse(const x, y, xRadius, yRadius: Single; Border: Boolean = False): TGLCanvas; overload;
  299.       procedure RecreateDefaultFont;
  300.       // Output only ASCII chars, other chars will be ignored automatically
  301.       function TextOutASCII(const text: string; x, y: Integer; Font: TGLFont = nil): TGLCanvas; // Use this for ASCII chars for efficiency
  302.       // Output any string but slow
  303.       function TextOut(const text: WideString; x, y: Integer; Font: TGLFont = nil): TGLCanvas;
  305.       function BuildTexture(bmp: TBitmap; var texId: GLuint): TGLCanvas;
  306.       function DeleteTexture(texId: GLuint): TGLCanvas;
  308.       //The difference between DrawBitmap and DrawBitmapTex is that DrawBitmapTex supports transformation}
  309.       function DrawBitmap(bmp: TBitmap; x, y: Integer; xZoom: Single = 1.0; yZoom: Single = 1.0): TGLCanvas; overload;
  310.       function DrawBitmapTex(bmp: TBitmap; x, y, w, h: Integer): TGLCanvas; overload;
  311.       function DrawBitmapTex(texId: GLuint; x, y, w, h: Integer): TGLCanvas; overload;
  313.       // Transformation
  314.       property UseTransformStack: Boolean read FUseTransformStack write FUseTransformStack;
  316.       property AfterRendering: TAfterRendering read FAfterRendering write FAfterRendering;
  317.       property GetDCFunction: TGetDCFunction read FGetDCFunction write FGetDCFunction;
  319.       // Turn off UseTransformStack to use these parameters
  320.       property ScaleX: Single read FScaleX write FSetScaleX;
  321.       property ScaleY: Single read FScaleY write FSetScaleY;
  322.       property TranslateX: Single read FTranslateX write FSetTranslateX;
  323.       property TranslateY: Single read FTranslateY write FSetTranslateY;
  324.       property Rotation: Single read FRotation write FSetRotation;
  326.       property RenderToBMP: Boolean read FRenderToBmp;
  327.       property BufferHDC: HDC read FBufferHDC write FBufferHDC;
  328.       property Rendering: Boolean read FRendering;
  329.       property PenColor: ARGB read FPenColorARGB write FSetPenColor;
  330.       property BrushColor: ARGB read FBrushColorARGB write FSetBrushColor;
  331.       property Control: TControl read FControl;
  333.       property InvertY: Boolean read FInvertY;
  334.       property Antialiasing: Boolean read FAntialiasing write FSetAntialiasing;
  335.       property PenWidth: Single read FPenWidth write FSetPenWidth;
  336.       property DefaultFont: TGLFont read FDefaultFont;
  337.    end;
  339. const
  340.    IdentityHmgMatrix: TMatrix4f = ((1, 0, 0, 0), (0, 1, 0, 0), (0, 0, 1, 0), (0, 0, 0, 1));
  342.    AlphaShift = 24;
  343.    RedShift = 16;
  344.    GreenShift = 8;
  345.    BlueShift = 0;
  347. function MakeColor(r, g, b: Byte): ARGB; overload; {$IFDEF INLINE_AVAIL}inline;{$ENDIF}
  348. function MakeColor(a, r, g, b: Byte): ARGB; overload; {$IFDEF INLINE_AVAIL}inline;{$ENDIF}
  349. function GetAlpha(color: ARGB): BYTE; {$IFDEF INLINE_AVAIL}inline;{$ENDIF}
  350. function GetRed(color: ARGB): BYTE; {$IFDEF INLINE_AVAIL}inline;{$ENDIF}
  351. function GetGreen(color: ARGB): BYTE; {$IFDEF INLINE_AVAIL}inline;{$ENDIF}
  352. function GetBlue(color: ARGB): BYTE; {$IFDEF INLINE_AVAIL}inline;{$ENDIF}
  354. // TColor = COLORREF
  355. function TColorToARGB(rgb: TColor; alpha: Byte = 255): ARGB; {$IFDEF INLINE_AVAIL}inline;{$ENDIF}
  356. function ARGBToTColor(Color: ARGB): TColor; {$IFDEF INLINE_AVAIL}inline;{$ENDIF}
  358. function GLColorToARGB(const glcolor: TColorVector): ARGB;  {$IFDEF INLINE_AVAIL}inline;{$ENDIF}
  359. function ARGBToGLColor(color: ARGB): TColorVector; {$IFDEF INLINE_AVAIL}inline;{$ENDIF}
  361. function GLColorToTColor(const glcolor: TColorVector): TColor; {$IFDEF INLINE_AVAIL}inline;{$ENDIF}
  362. function TColorToGLColor(color: TColor; alpha: Byte = 255): TColorVector; {$IFDEF INLINE_AVAIL}inline;{$ENDIF}
  364. implementation
  365. var
  366.    GLOBAL_ANTIALIASING_STATE: Boolean;
  368. const
  369.    // Almost all video cards now support these extensions. Even not, no error will be raised.
  370.    GL_TEXTURE_3D = $806F;
  371.    GL_TEXTURE_CUBE_MAP_ARB = $8513;
  372.    GL_BGR = $80E0;
  374.    cNoPrimitive = MaxInt;
  376.    PiDiv180 = Pi / 180;
  377.    _2Pi = Pi * 2;
  378.    PiDiv2 = Pi / 2;
  380.    opengl32 = 'OpenGL32.dll';
  382. procedure glGenTextures(n: GLsizei; textures: PGLuint); {$IFDEF MSWINDOWS} stdcall; {$ENDIF} {$IFDEF UNIX} cdecl; {$ENDIF} external opengl32;
  383. procedure glBindTexture(target: GLEnum; texture: GLuint); {$IFDEF MSWINDOWS} stdcall; {$ENDIF} {$IFDEF UNIX} cdecl; {$ENDIF} external opengl32;
  384. procedure glDeleteTextures(n: GLsizei; textures: PGLuint); {$IFDEF MSWINDOWS} stdcall; {$ENDIF} {$IFDEF UNIX} cdecl; {$ENDIF} external opengl32;
  386. procedure SinCos(const Theta: Single; var Sin, Cos: Single);
  387. asm
  388.    FLD  Theta
  389.    FSINCOS
  390.    FSTP DWORD PTR [EDX]    // cosine
  391.    FSTP DWORD PTR [EAX]    // sine
  392. end;
  394. function MakeColor(r, g, b: Byte): ARGB; overload;
  395. begin
  396.    with TARGB(Result) do
  397.    begin
  398.       alpha := 255;
  399.       red := r;
  400.       green := g;
  401.       blue := b;
  402.    end;
  403. end;
  405. function MakeColor(a, r, g, b: Byte): ARGB; overload;
  406. begin
  407.    with TARGB(Result) do
  408.    begin
  409.       alpha := a;
  410.       red := r;
  411.       green := g;
  412.       blue := b;
  413.    end;
  414. end;
  416. function GetAlpha(color: ARGB): BYTE;
  417. begin
  418.    Result := BYTE(color shr AlphaShift);
  419. end;
  421. function GetRed(color: ARGB): BYTE;
  422. begin
  423.    Result := BYTE(color shr RedShift);
  424. end;
  426. function GetGreen(color: ARGB): BYTE;
  427. begin
  428.    Result := BYTE(color shr GreenShift);
  429. end;
  431. function GetBlue(color: ARGB): BYTE;
  432. begin
  433.    Result := BYTE(color shr BlueShift);
  434. end;
  436. function TColorToARGB(rgb: TColor; alpha: Byte = 255): ARGB;
  437. begin
  438.    Result := MakeColor(alpha, GetRValue(rgb), GetGValue(rgb), GetBValue(rgb));
  439. end;
  441. function ARGBToTColor(Color: ARGB): TColor;
  442. begin
  443.    with TARGB(Color) do
  444.       Result := RGB(red, green, blue);
  445. end;
  447. function GLColorToARGB(const glcolor: TColorVector): ARGB;
  448. begin
  449.    Result := MakeColor(Trunc(255 * glcolor[3]), Trunc(255 * glcolor[0]),
  450.       Trunc(255 * glcolor[1]), Trunc(255 * glcolor[2]));
  451. end;
  453. function ARGBToGLColor(color: ARGB): TColorVector;
  454. begin
  455.    with TARGB(color) do
  456.    begin
  457.       Result[0] := red / 255;
  458.       Result[1] := green / 255;
  459.       Result[2] := blue / 255;
  460.       Result[3] := alpha / 255;
  461.    end;
  462. end;
  464. function GLColorToTColor(const glcolor: TColorVector): TColor;
  465. begin
  466.    Result := RGB(Trunc(255 * glcolor[0]), Trunc(255 * glcolor[1]), Trunc(255 * glcolor[2]));
  467. end;
  469. function TColorToGLColor(color: TColor; alpha: Byte = 255): TColorVector;
  470. begin
  471.    Result[0] := GetRValue(color) / 255;
  472.    Result[1] := GetGValue(color) / 255;
  473.    Result[2] := GetBValue(color) / 255;
  474.    Result[3] := alpha / 255;
  475. end;
  477. { TGLFont }
  479. constructor TGLFont.Create(Name: WideString; Size: Integer; Styles: TFontStyles = [];
  480.    CharSet: Integer = DEFAULT_CHARSET; Notify: TGLFontNotify = nil);
  481. begin
  482.    FHFont := 0;
  483.    FName := Name;
  484.    FSize := Size;
  485.    FStyles := Styles;
  486.    FCharSet := CharSet;
  487.    FColor := TColorToARGB(clBlack);
  488.    FNotifyChange := Notify;
  489.    Update;
  490. end;
  492. destructor TGLFont.Destroy;
  493. begin
  494.    DeleteObject(FHFont);
  495.    inherited;
  496. end;
  498. function TGLFont.FGetWinColor: TColor;
  499. begin
  500.    Result := ARGBToTColor(FColor);
  501. end;
  503. procedure TGLFont.FSetWinColor(value: TColor);
  504. begin
  505.    Color := TColorToARGB(value);
  506. end;
  508. procedure TGLFont.FSetColor(value: ARGB);
  509. begin
  510.    FColor := value;
  511.    FColorVector := ARGBToGLColor(FColor);
  512. end;
  514. procedure TGLFont.Update;
  515. var
  516.    bold, italic, underline, strikeout: Integer;
  517. begin
  518.    if FHFont <> 0 then
  519.       DeleteObject(FHFont);
  521.    if fsBold in FStyles then
  522.       bold := FW_BOLD
  523.    else
  524.       bold := FW_NORMAL;
  526.    if fsItalic in FStyles then
  527.       italic := 1
  528.    else
  529.       italic := 0;
  531.    if fsUnderline in FStyles then
  532.       underline := 1
  533.    else
  534.       underline := 0;
  536.    if fsStrikeOut in FStyles then
  537.       strikeout := 1
  538.    else
  539.       strikeout := 0;
  541.    FHFont := CreateFontW(FSize, 0, 0, 0, bold, italic, underline, strikeout,
  542.         FCharSet, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS,
  543.         DEFAULT_QUALITY, DEFAULT_PITCH or FF_SWISS, PWideChar(FName));
  545.    FColorVector := ARGBToGLColor(FColor);
  547.    if Assigned(FNotifyChange) then
  548.       FNotifyChange;
  549. end;
  551. { TGLCanvas }
  553. constructor TGLCanvas.Create(AControl: TControl; RenderToBmp: Boolean = True;
  554.    Antialiasing: Boolean = True; UseTransformStack: Boolean = False;
  555.    IgnorePenWidthFactor: Boolean = False; InvertY: Boolean = True);
  556. begin
  557.    FControl := AControl;
  558.    FRenderToBmp := RenderToBmp;
  559.    if not FRenderToBmp then // Require that FControl is TWinControl
  560.       if not (FControl is TWinControl) then
  561.          FRenderToBmp := True;
  563.    FUseTransformStack := UseTransformStack;
  564.    FInvertY := InvertY;
  565.    FRendering := False;
  566.    FAntialiasing := Antialiasing;
  567.    FIgnorePenWidthFactor := IgnorePenWidthFactor;
  568.    FListLevel := 0;
  569.    FIgnoreColor := False;
  570.    FPenWidth := 1.0;
  571.    FStackTop := -1;
  572.    FTranslateX := 0.0;
  573.    FTranslateY := 0.0;
  574.    FScaleX := 1.0;
  575.    FScaleY := 1.0;
  576.    FRotation := 0.0;
  577.    FTransformationUpdateCount := 0;
  578.    SetPenColorWin(clBlack);
  579.    SetBrushColorWin(clRed);
  581.    FASCIICharListCreated := False;
  582.    FDefaultFont := TGLFont.Create('Tahoma', 14);
  583.    FDefaultFont.NotifyChange := DefaultFontNotify; // Mustn't assign NotifyChange by TGLFont.Create
  585.    FBufferWidth := -1;
  586.    Recreate;
  587. end;
  589. destructor TGLCanvas.Destroy;
  590. begin
  591.    FreeBufferBMP;
  592.    wglDeleteContext(FHRC);
  593.    FDefaultFont.Free;
  594.    inherited;
  595. end;
  597. procedure TGLCanvas.CreateBufferBMP;
  598. var
  599.    bmi: BITMAPINFO;
  600.    pbits: ^DWORD;
  601. begin
  602.    if FBufferWidth <> -1 then
  603.       FreeBufferBMP;
  605.    FBufferWidth := FControl.ClientWidth;
  606.    FBufferHeight := FControl.ClientHeight;
  607.    // Create a memory DC compatible with the screen
  608.    FBufferHDC := CreateCompatibleDC(0);
  610.    FillChar(bmi, SizeOf(bmi), 0);
  611.    with bmi.bmiHeader do
  612.    begin
  613.       biSize := SizeOf(BITMAPINFOHEADER);
  614.       biWidth := FBufferWidth;
  615.       biHeight := FBufferHeight;
  616.       biPlanes := 1;
  617.       biBitCount := 32;
  618.       biCompression := BI_RGB;
  619.    end;
  621.    FBufferBitmap := CreateDIBSection(FBufferHDC, bmi, DIB_RGB_COLORS, Pointer(pbits), 0, 0);
  623.    // Select the bitmap into the DC
  624.    FBufferObject := SelectObject(FBufferHDC, FBufferBitmap);
  625. end;
  627. procedure TGLCanvas.FreeBufferBMP;
  628. begin
  629.    SelectObject(FBufferHDC, FBufferObject); // Remove bitmap from DC
  630.    DeleteObject(FBufferBitmap); // Delete bitmap
  631.    DeleteDC(FBufferHDC); // Delete DC
  632. end;
  634. procedure TGLCanvas.PresentBufferBMP(DC: HDC);
  635. begin
  636.    StretchBlt(DC, 0, 0, FControl.ClientWidth,
  637.       FControl.ClientHeight, FBufferHDC, 0, 0, FBufferWidth,
  638.       FBufferHeight, SRCCOPY);
  639. end;
  641. procedure TGLCanvas.FSetPenColor(Value: ARGB);
  642. begin
  643.    if FPenColorARGB <> Value then
  644.    begin
  645.       FPenColorARGB := Value;
  646.       FPenColor := ARGBToGLColor(Value);
  647.    end;
  648.    glColor4fv(@FPenColor);
  649. end;
  651. procedure TGLCanvas.FSetBrushColor(Value: ARGB);
  652. begin
  653.    if FBrushColorARGB <> Value then
  654.    begin
  655.       FBrushColorARGB := Value;
  656.       FBrushColor := ARGBToGLColor(Value);
  657.    end;
  658. end;
  660. procedure TGLCanvas.FSetPenWidth(Value: Single);
  661. begin
  662.    FPenWidth := Value;
  663.    glLineWidth(Value * FPenWidthFactor);
  664.    glPointSize(Value * FPenWidthFactor);
  665. end;
  667. procedure TGLCanvas.InitOpenGL;
  668. var
  669.    pfd: TPIXELFORMATDESCRIPTOR;
  670.    pixelFormat: Integer;
  671. begin
  672.    FillChar(pfd, SizeOf(pfd), 0);
  673.    with pfd do
  674.    begin
  675.       nSize := SizeOf(TPIXELFORMATDESCRIPTOR); // 此结构尺寸
  676.       nVersion := 1;
  677.       if FRenderToBmp then
  678.          dwFlags := PFD_SUPPORT_OPENGL or PFD_DRAW_TO_BITMAP
  679.       else
  680.          dwFlags := PFD_SUPPORT_OPENGL or PFD_DOUBLEBUFFER or PFD_DRAW_TO_WINDOW;
  681.       iPixelType := PFD_TYPE_RGBA; //使用RGBA颜色空间
  682.       cColorBits := 32;
  683.       cDepthBits := 16;
  684.       iLayerType := PFD_MAIN_PLANE;
  685.    end;
  687.    pixelFormat := ChoosePixelFormat(FBufferHDC, @pfd);
  688.    SetPixelFormat(FBufferHDC, pixelFormat, @pfd);
  689.    FHRC := wglCreateContext(FBufferHDC);
  690.    wglMakeCurrent(FBufferHDC, FHRC);
  691.    GdiFlush();
  693.    glPushAttrib(GL_ENABLE_BIT);
  694.    glDisable(GL_CULL_FACE);
  695.    glDisable(GL_LIGHTING);
  696.    glDisable(GL_FOG);
  697.    glDisable(GL_COLOR_MATERIAL);
  698.    glDisable(GL_DEPTH_TEST);
  699.    glDisable(GL_TEXTURE_1D);
  700.    glDisable(GL_TEXTURE_2D);
  701.    glDisable(GL_TEXTURE_3D);
  702.    glDisable(GL_TEXTURE_CUBE_MAP_ARB);
  704.    FBlend := True;
  705.    glEnable(GL_BLEND);
  706.    glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA);
  708.    Antialiasing := FAntialiasing; // Apply antialiasing mode
  710.    glViewPort(0, 0, FBufferWidth, FBufferHeight); //指定OpenGL在此区域内绘图。
  711.    glMatrixMode(GL_PROJECTION);
  712.    if FInvertY then
  713.       gluOrtho2D(0, FBufferWidth, 0, FBufferHeight)
  714.    else
  715.       gluOrtho2D(0, FBufferWidth, FBufferHeight, 0);
  716.    glMatrixMode(GL_MODELVIEW);
  718.    // Recreate ASCII char lists
  719.    DefaultFontNotify;
  720. end;
  722. procedure TGLCanvas.ActivateSelf;
  723. begin
  724.    wglMakeCurrent(FBufferHDC, FHRC);
  725.    if GLOBAL_ANTIALIASING_STATE <> FAntialiasing then
  726.       FSetAntialiasing(FAntialiasing);
  727.    if FBlend then
  728.       glEnable(GL_BLEND)
  729.    else
  730.       glDisable(GL_BLEND);
  731. end;
  733. procedure TGLCanvas.ApplyTransformation;
  734.    function ComputeCompoundPenWidthFactor(sx, sy: Single): Single;
  735.    begin
  736.       Result := Sqrt((sx * sx + sy * sy) / 2);
  737.    end;
  738. var
  739.    i: Integer;
  740.    tx, ty: Single;
  741. begin
  742.    if not FRendering then
  743.       Exit;
  744.    if FUseTransformStack then
  745.    begin
  746.       glLoadIdentity;
  747.       tx := 1.0;
  748.       ty := 1.0;
  749.       for i := 0 to FStackTop do
  750.          with FTransformStack[i] do
  751.          begin
  752.             case TransformType of
  753.                ttScale:
  754.                   begin
  755.                      glScale(var1, var2, 1.0);
  756.                      tx := tx * var1;
  757.                      ty := ty * var2;
  758.                   end;
  759.                ttTranslate: glTranslate(var1, var2, 0.0);
  760.                ttRotate: glRotatef(var1, 0.0, 0.0, 1.0);
  761.             end;
  762.          end;
  763.       if FIgnorePenWidthFactor then
  764.          FPenWidthFactor := 1
  765.       else
  766.          FPenWidthFactor := ComputeCompoundPenWidthFactor(tx, ty);
  767.    end
  768.    else
  769.    begin
  770.       glLoadIdentity;
  771.       glTranslate(FTranslateX, FTranslateY, 0.0);
  772.       glScale(FScaleX, FScaleY, 1.0);
  773.       glRotatef(FRotation, 0.0, 0.0, 1.0);
  774.       if FIgnorePenWidthFactor then
  775.          FPenWidthFactor := 1
  776.       else
  777.          FPenWidthFactor := ComputeCompoundPenWidthFactor(FScaleX, FScaleY);
  778.    end;
  779. end;
  781. procedure TGLCanvas.DefaultFontNotify;
  782. var
  783.    i: Integer;
  784. begin
  785.    for i := 0 to 1 do // very odd, must call twice
  786.    begin
  787.       if FASCIICharListCreated then
  788.          glDeleteLists(FASCIICharList, MaxChar);
  789.       SelectObject(FBufferHDC, FDefaultFont.HFont);
  790.       FASCIICharList := glGenLists(MaxChar);
  791.       wglUseFontBitmaps(FBufferHDC, 0, MaxChar, FASCIICharList);
  792.       FASCIICharListCreated := True;
  793.    end;
  794. end;
  796. procedure TGLCanvas.FSetAntialiasing(value: Boolean);
  797. begin
  798.    if value then
  799.    begin
  800.       glEnable(GL_SMOOTH);
  801.       glEnable(GL_LINE_SMOOTH);
  802.       glEnable(GL_POINT_SMOOTH);
  803.       glEnable(GL_POLYGON_SMOOTH);
  804.       glHint(GL_POINT_SMOOTH_HINT, GL_NICEST);
  805.       glHint(GL_LINE_SMOOTH_HINT, GL_NICEST);
  806.       glHint(GL_POLYGON_SMOOTH_HINT, GL_NICEST);
  807.    end
  808.    else
  809.    begin
  810.       glDisable(GL_SMOOTH);
  811.       glDisable(GL_LINE_SMOOTH);
  812.       glDisable(GL_POINT_SMOOTH);
  813.       glDisable(GL_POLYGON_SMOOTH);
  814.       glHint(GL_POINT_SMOOTH_HINT, GL_FASTEST);
  815.       glHint(GL_LINE_SMOOTH_HINT, GL_FASTEST);
  816.       glHint(GL_POLYGON_SMOOTH_HINT, GL_FASTEST);
  817.    end;
  818.    FAntialiasing := value;
  819.    GLOBAL_ANTIALIASING_STATE := FAntialiasing;
  820. end;
  822. procedure TGLCanvas.FSetScaleX(value: Single);
  823. begin
  824.    FScaleX := value;
  825.    if FTransformationUpdateCount = 0 then
  826.       ApplyTransformation;
  827. end;
  829. procedure TGLCanvas.FSetScaleY(value: Single);
  830. begin
  831.    FScaleY := value;
  832.    if FTransformationUpdateCount = 0 then
  833.       ApplyTransformation;
  834. end;
  836. procedure TGLCanvas.FSetTranslateX(value: Single);
  837. begin
  838.    FTranslateX := value;
  839.    if FTransformationUpdateCount = 0 then
  840.       ApplyTransformation;
  841. end;
  843. procedure TGLCanvas.FSetTranslateY(value: Single);
  844. begin
  845.    FTranslateY := value;
  846.    if FTransformationUpdateCount = 0 then
  847.       ApplyTransformation;
  848. end;
  850. procedure TGLCanvas.FSetRotation(value: Single);
  851. begin
  852.    FRotation := value;
  853.    if FTransformationUpdateCount = 0 then
  854.       ApplyTransformation;
  855. end;
  857. function TGLCanvas.RenderingBegin(BackgroundColor: TColor = clWhite): TGLCanvas;
  858. var
  859.    bkCol: TColorVector;
  860. begin
  861.    Result := Self;
  862.    if FRendering then
  863.       Exit;
  864.    FRendering := True;
  865.    if (FBufferWidth <> FControl.ClientWidth) or (FBufferHeight <> FControl.ClientHeight) then
  866.       Recreate
  867.    {$IFDEF MultiCanvases}
  868.    else
  869.       ActivateSelf{$ENDIF}; // get active
  871.    bkCol := TColorToGLColor(BackgroundColor);
  872.    glClearColor(bkCol[0], bkCol[1], bkCol[2], bkCol[3]);
  873.    glClear(GL_COLOR_BUFFER_BIT);
  875.    ApplyTransformation;
  877.    // User must keep in mind that Matrix Mode mustn't be changed during rendering.
  878.    glColor4fv(@FPenColor);
  879. end;
  881. procedure TGLCanvas.RenderingEnd;
  882. begin
  883.    if FRenderToBMP then
  884.    begin
  885.       glFinish;
  886.       // User may draw other objects using Gdi, GdiP after OpenGL process.
  887.       if Assigned(FAfterRendering) then
  888.          FAfterRendering(Self);
  889.       // Present the image
  890.       if FControl is TImage then // TImage has the ability to keep its image
  891.          PresentBufferBMP(TImage(FControl).Canvas.Handle);
  892.       FControl.Repaint; // Other controls must repaint whenever they are repainted by Windows.
  893.    end
  894.    else
  895.       SwapBuffers(FBufferHDC);
  897.    FRendering := False;
  898. end;
  900. function TGLCanvas.CreateList(var ListID: GLuint; Range: GLuint = 1): TGLCanvas;
  901. begin
  902.    if Range >= 1 then
  903.    begin
  904.       {$IFDEF MultiCanvases}
  905.       ActivateSelf;
  906.       {$ENDIF}
  907.       ListID := glGenLists(Range);
  908.    end;
  909.    Result := Self;
  910. end;
  912. function TGLCanvas.DeleteList(ListID: GLuint; Range: GLuint = 1): TGLCanvas;
  913. begin
  914.    glDeleteLists(ListID, Range);
  915.    Result := Self;
  916. end;
  918. function TGLCanvas.ListBegin(ListID: GLuint; Offset: GLuint = 0;
  919.    Execute: Boolean = False; IgnoreColor: Boolean = True): TGLCanvas;
  920. begin
  921.    Result := Self;
  922.    if FListLevel = ListNestLevel then
  923.       Exit;
  924.       
  925.    if Execute then
  926.       glNewList(ListID + Offset, GL_COMPILE_AND_EXECUTE)
  927.    else
  928.       glNewList(ListID + Offset, GL_COMPILE);
  929.    Inc(FListLevel);
  930.    FIgnoreColorStack[FListLevel] := IgnoreColor;       
  931.    FIgnoreColor := IgnoreColor;
  932. end;
  934. function TGLCanvas.ListEnd: TGLCanvas;
  935. begin
  936.    glEndList;
  937.    Dec(FListLevel);
  938.    if FListLevel > 0 then
  939.       FIgnoreColor := FIgnoreColorStack[FListLevel]
  940.    else  
  941.       FIgnoreColor := False;    
  942.    Result := Self;      
  943. end;
  945. function TGLCanvas.ListExecute(ListID: GLuint; Offset: GLuint = 0): TGLCanvas;
  946. begin
  947.    if FRendering then
  948.       glCallList(ListID + Offset);
  949.    Result := Self;
  950. end;
  952. function TGLCanvas.ListExecute(ListID: GLuint; Offset: GLuint; Color: ARGB;
  953.    PenWidth: Single): TGLCanvas;
  954. var
  955.    ColorVec: TColorVector;
  956. begin
  957.    if FRendering then
  958.    begin
  959.       ColorVec := ARGBToGLColor(Color);
  960.       glColor4fv(@ColorVec);
  961.       if PenWidth > 0 then
  962.       begin
  963.          glLineWidth(PenWidth * FPenWidthFactor);
  964.          glPointSize(PenWidth * FPenWidthFactor);
  965.       end;
  966.       glCallList(ListID + Offset);
  968.       // Restore color and pen width
  969.       glColor4fv(@FPenColor);
  970.       if PenWidth > 0 then
  971.       begin
  972.          glLineWidth(FPenWidth * FPenWidthFactor);
  973.          glPointSize(FPenWidth * FPenWidthFactor);
  974.       end;
  975.    end;
  976.    Result := Self;
  977. end;
  979. procedure TGLCanvas.Recreate;
  980. begin
  981.    // Reinitialize opengl
  982.    if FRenderToBmp then
  983.       CreateBufferBMP
  984.    else
  985.    begin
  986.       FBufferHDC := GetDC(TWinControl(FControl).Handle);
  987.       FBufferWidth := FControl.ClientWidth;
  988.       FBufferHeight := FControl.ClientHeight;
  989.    end;
  990.    wglDeleteContext(FHRC);
  991.    InitOpenGL;
  992. end;
  994. procedure TGLCanvas.OnControlPaint;
  995. var
  996.    DC: HDC;
  997. begin
  998.    if FRenderToBmp then
  999.    begin
  1000.       if FControl is TWinControl then
  1001.          DC := GetDC(TWinControl(FControl).Handle)
  1002.       else if Assigned(FGetDCFunction) then
  1003.          DC := FGetDCFunction()
  1004.       else
  1005.          DC := 0;
  1007.       if DC <> 0 then
  1008.          PresentBufferBMP(DC);
  1009.    end;
  1010. end;
  1012. procedure TGLCanvas.DrawTo(DC: HDC);
  1013. begin
  1014.    if FRenderToBmp then
  1015.       StretchBlt(DC, 0, 0, FBufferWidth, FBufferHeight,
  1016.          FBufferHDC, 0, 0, FBufferWidth, FBufferHeight, SRCCOPY);
  1017. end;
  1019. procedure TGLCanvas.StretchDrawTo(DC: HDC; X, Y, W, H: Integer);
  1020. begin
  1021.    if FRenderToBmp then
  1022.       StretchBlt(DC, X, Y, W, H, FBufferHDC, 0, 0, FBufferWidth, FBufferHeight, SRCCOPY);
  1023. end;
  1025. function TGLCanvas.BeginUpdateTransformation: TGLCanvas;
  1026. begin
  1027.    Inc(FTransformationUpdateCount);
  1028.    Result := Self;
  1029. end;
  1031. function TGLCanvas.EndUpdateTransformation: TGLCanvas;
  1032. begin
  1033.    Dec(FTransformationUpdateCount);
  1034.    if FTransformationUpdateCount <= 0 then
  1035.    begin
  1036.       UpdateTransformation;
  1037.       FTransformationUpdateCount := 0;
  1038.    end;
  1039.    Result := Self;
  1040. end;
  1042. function TGLCanvas.SetTransformation(sx, sy, tx, ty, r: Single): TGLCanvas;
  1043. begin
  1044.    FUseTransformStack := False;
  1045.    FScaleX := sx;
  1046.    FScaleY := sy;
  1047.    FTranslateX := tx;
  1048.    FTranslateY := ty;
  1049.    FRotation := r;
  1050.    if FTransformationUpdateCount = 0 then
  1051.       ApplyTransformation;
  1052.    Result := Self;
  1053. end;
  1055. function TGLCanvas.SetMatrix(const m11, m12, m13, m21, m22, m23, m31, m32, m33,
  1056.    dx, dy: Single; Backup: Boolean = True): TGLCanvas;
  1057. var
  1058.    AMatrix: TMatrix4f;
  1059. begin
  1060.    Result := Self;
  1061.    if not Rendering then
  1062.       Exit;
  1064.    AMatrix := IdentityHmgMatrix;
  1065.    AMatrix[0][0] := m11;
  1066.    AMatrix[0][1] := m12;
  1067.    AMatrix[0][2] := m13;
  1068.    AMatrix[1][0] := m21;
  1069.    AMatrix[1][1] := m22;
  1070.    AMatrix[1][2] := m23;
  1071.    AMatrix[2][0] := m31;
  1072.    AMatrix[2][1] := m32;
  1073.    AMatrix[2][2] := m33;
  1074.    AMatrix[3][0] := dx;
  1075.    AMatrix[3][1] := dy;
  1076.    glLoadMatrixf(@AMatrix);
  1078.    if Backup then
  1079.       FMatrix := AMatrix;
  1081.    // Assume that X axis and Y axis are equally scaled.
  1082.    if FIgnorePenWidthFactor then
  1083.       FPenWidthFactor := 1
  1084.    else
  1085.       FPenWidthFactor := Sqrt((m11 * m11 + m22 * m22) / 2);
  1086. end;
  1088. function TGLCanvas.ResetBackupMatrix: TGLCanvas;
  1089. begin
  1090.    Result := Self;
  1091.    if not Rendering then
  1092.       Exit;
  1094.    glLoadMatrixf(@FMatrix);
  1095.    // Assume that X axis and Y axis are equally scaled.
  1096.    if FIgnorePenWidthFactor then
  1097.       FPenWidthFactor := 1
  1098.    else
  1099.       FPenWidthFactor := Sqrt((Sqr(FMatrix[0][0]) + Sqr(FMatrix[1][1])) / 2);
  1100. end;
  1102. function TGLCanvas.ResetTransformation: TGLCanvas;
  1103. begin
  1104.    FStackTop := -1;
  1105.    FScaleX := 1.0;
  1106.    FScaleY := 1.0;
  1107.    FTranslateX := 0.0;
  1108.    FTranslateY := 0.0;
  1109.    FRotation := 0.0;
  1110.    if FTransformationUpdateCount = 0 then
  1111.       ApplyTransformation;
  1112.    Result := Self;
  1113. end;
  1115. function TGLCanvas.PopMatrix: TGLCanvas;
  1116. begin
  1117.    if FStackTop >= 0 then
  1118.       Dec(FStackTop);
  1119.    if FTransformationUpdateCount = 0 then
  1120.       ApplyTransformation;
  1121.    Result := Self;
  1122. end;
  1124. function TGLCanvas.SetEqualScale(value: Single): TGLCanvas;
  1125. begin
  1126.    if not FUseTransformStack then
  1127.    begin
  1128.       FScaleX := value;
  1129.       FScaleY := value;
  1130.    end;
  1131.    if FTransformationUpdateCount = 0 then
  1132.       ApplyTransformation;
  1133.    Result := Self;
  1134. end;
  1136. function TGLCanvas.ScaleMatrix(x, y: Single): TGLCanvas;
  1137. begin
  1138.    if FStackTop < TransformStackTop then
  1139.    begin
  1140.       Inc(FStackTop);
  1141.       with FTransformStack[FStackTop] do
  1142.       begin
  1143.          TransformType := ttScale;
  1144.          var1 := x;
  1145.          var2 := y;
  1146.       end;
  1147.    end;
  1148.    if FTransformationUpdateCount = 0 then
  1149.       ApplyTransformation;
  1150.    Result := Self;
  1151. end;
  1153. function TGLCanvas.TranslateMatrix(x, y: Single): TGLCanvas;
  1154. begin
  1155.    if FStackTop < TransformStackTop then
  1156.    begin
  1157.       Inc(FStackTop);
  1158.       with FTransformStack[FStackTop] do
  1159.       begin
  1160.          TransformType := ttTranslate;
  1161.          var1 := x;
  1162.          var2 := y;
  1163.       end;
  1164.    end;
  1165.    if FTransformationUpdateCount = 0 then
  1166.       ApplyTransformation;
  1167.    Result := Self;
  1168. end;
  1170. function TGLCanvas.RotateMatrix(angle: Single): TGLCanvas;
  1171. begin
  1172.    if FStackTop < TransformStackTop then
  1173.    begin
  1174.       Inc(FStackTop);
  1175.       with FTransformStack[FStackTop] do
  1176.       begin
  1177.          TransformType := ttRotate;
  1178.          var1 := angle;
  1179.       end;
  1180.    end;
  1181.    if FTransformationUpdateCount = 0 then
  1182.       ApplyTransformation;
  1183.    Result := Self;
  1184. end;
  1186. function TGLCanvas.SetScaleX(value: Single): TGLCanvas;
  1187. begin
  1188.    ScaleX := value;
  1189.    Result := Self;
  1190. end;
  1192. function TGLCanvas.SetScaleY(value: Single): TGLCanvas;
  1193. begin
  1194.    ScaleY := value;
  1195.    Result := Self;
  1196. end;
  1198. function TGLCanvas.SetTranslateX(value: Single): TGLCanvas;
  1199. begin
  1200.    TranslateX := value;
  1201.    Result := Self;
  1202. end;
  1204. function TGLCanvas.SetTranslateY(value: Single): TGLCanvas;
  1205. begin
  1206.    TranslateY := value;
  1207.    Result := Self;
  1208. end;
  1210. function TGLCanvas.SetRotation(value: Single): TGLCanvas;
  1211. begin
  1212.    Rotation := value;
  1213.    Result := Self;
  1214. end;
  1216. function TGLCanvas.ConvertScreenToWorld(x, y: Integer): TGLPointF;
  1217. var
  1218.    Viewport: array[0..3] of GLuint;
  1219.    ModelMatrix: array[0..15] of GLdouble;
  1220.    ProjMatrix: array[0..15] of GLdouble;
  1221.    ox, oy, oz: GLdouble;
  1222. begin
  1223.    glGetIntegerv(GL_VIEWPORT, @Viewport[0]);
  1224.    glGetDoublev(GL_MODELVIEW_MATRIX, @ModelMatrix[0]);
  1225.    glGetDoublev(GL_PROJECTION_MATRIX, @ProjMatrix[0]);
  1226.    gluUnProject(x, Viewport[3] - y, 0, @ModelMatrix[0],
  1227.       @ProjMatrix[0], @Viewport[0], ox, oy, oz);
  1228.    Result.X := ox;
  1229.    Result.Y := oy;
  1230. end;
  1232. function TGLCanvas.UpdateTransformation: TGLCanvas;
  1233. begin
  1234.    ApplyTransformation;
  1235.    PenWidth := FPenWidth;
  1236.    Result := Self;
  1237. end;
  1239. function TGLCanvas.SetBlendState(value: Boolean): TGLCanvas;
  1240. begin
  1241.    if value then
  1242.       glEnable(GL_BLEND)
  1243.    else
  1244.       glDisable(GL_BLEND);
  1245.    FBlend := value;
  1246.    Result := Self;
  1247. end;
  1249. function TGLCanvas.SetPenColorWin(value: TColor; alpha: Byte = 255; Sync: Boolean = True): TGLCanvas;
  1250. begin
  1251.    if Sync then
  1252.       FPenColorARGB := TColorToARGB(value);
  1253.    FPenColor := TColorToGLColor(value, alpha);
  1254.    glColor4fv(@FPenColor);
  1255.    Result := Self;
  1256. end;
  1258. function TGLCanvas.SetBrushColorWin(value: TColor; alpha: Byte = 255; Sync: Boolean = True): TGLCanvas;
  1259. begin
  1260.    if Sync then
  1261.       FBrushColorARGB := TColorToARGB(value);
  1262.    FBrushColor := TColorToGLColor(value, alpha);
  1263.    Result := Self;
  1264. end;
  1266. function TGLCanvas.SetPenColor(value: ARGB): TGLCanvas;
  1267. begin
  1268.    FSetPenColor(value);
  1269.    Result := Self;
  1270. end;
  1272. function TGLCanvas.SetBrushColor(value: ARGB): TGLCanvas;
  1273. begin
  1274.    FSetBrushColor(value);
  1275.    Result := Self;
  1276. end;
  1278. function TGLCanvas.SetPenColor(const value: TColorVector; Sync: Boolean = False): TGLCanvas;
  1279. begin
  1280.    glColor4fv(@value);
  1281.    FPenColor := value;
  1282.    if Sync then
  1283.       FPenColorARGB := GLColorToARGB(value);
  1284.    Result := Self;
  1285. end;
  1287. function TGLCanvas.SetBrushColor(const value: TColorVector; Sync: Boolean = False): TGLCanvas;
  1288. begin
  1289.    FBrushColor := value;
  1290.    if Sync then
  1291.       FBrushColorARGB := GLColorToARGB(value);
  1292.    Result := Self;
  1293. end;
  1295. function TGLCanvas.SetPenWidth(value: Single): TGLCanvas; // for linked process
  1296. begin
  1297.    FSetPenWidth(value);
  1298.    Result := Self;
  1299. end;
  1301. function TGLCanvas.LineStipple(factor: Integer; pattern: word): TGLCanvas;
  1302. begin
  1303.    glEnable(GL_LINE_STIPPLE);
  1304.    glLineStipple(factor, pattern);
  1305.    Result := Self;
  1306. end;
  1308. function TGLCanvas.LineStipple(style: TLineStippleStyle; enlarge: Byte = 2): TGLCanvas;
  1309. begin
  1310.    case style of
  1311.       lssSolid: LineStippleEnd;
  1312.       lssDash: LineStipple(3 * enlarge, $AAAA);
  1313.       lssDashDot: LineStipple(1 * enlarge, $6F6F);
  1314.       lssDashDotDot: LineStipple(2 * enlarge, $EAEA);
  1315.       lssDot: LineStipple(1 * enlarge, $AAAA);
  1316.    end;
  1317.    Result := Self;
  1318. end;
  1320. function TGLCanvas.LineStippleEnd: TGLCanvas;
  1321. begin
  1322.    glDisable(GL_LINE_STIPPLE);
  1323.    Result := Self;
  1324. end;
  1326. function TGLCanvas.Line(const x1, y1, x2, y2: Integer): TGLCanvas;
  1327. begin
  1328.    glBegin(GL_LINES);
  1329.    glVertex2i(x1, y1);
  1330.    glVertex2i(x2, y2);
  1331.    glEnd;
  1332.    Result := Self;
  1333. end;
  1335. function TGLCanvas.Line(const x1, y1, x2, y2: Single): TGLCanvas;
  1336. begin
  1337.    glBegin(GL_LINES);
  1338.    glVertex2f(x1, y1);
  1339.    glVertex2f(x2, y2);
  1340.    glEnd;
  1341.    Result := Self;
  1342. end;
  1344. function TGLCanvas.BeginLines: TGLCanvas;
  1345. begin
  1346.    glBegin(GL_LINES);
  1347.    Result := Self;
  1348. end;
  1350. function TGLCanvas.Lines(const x1, y1, x2, y2: Integer): TGLCanvas;
  1351. begin
  1352.    glVertex2i(x1, y1);
  1353.    glVertex2i(x2, y2);
  1354.    Result := Self;
  1355. end;
  1357. function TGLCanvas.Lines(const x1, y1, x2, y2: Single): TGLCanvas;
  1358. begin
  1359.    glVertex2f(x1, y1);
  1360.    glVertex2f(x2, y2);
  1361.    Result := Self;
  1362. end;
  1364. function TGLCanvas.EndLines: TGLCanvas;
  1365. begin
  1366.    glEnd;
  1367.    Result := Self;
  1368. end;
  1370. function TGLCanvas.Lines(const points: TGLPointsF; count: Integer): TGLCanvas;
  1371. var
  1372.    i: Integer;
  1373. begin
  1374.    glBegin(GL_LINES);
  1375.    i := 0;
  1376.    while (i <= count - 2) do
  1377.    begin
  1378.       glVertex2f(points[i].X, points[i].Y);
  1379.       glVertex2f(points[i + 1].X, points[i + 1].Y);
  1380.       Inc(i, 2);
  1381.    end;
  1382.    glEnd;
  1383.    Result := Self;
  1384. end;
  1386. function TGLCanvas.Lines(const points: TGLPointsI; count: Integer): TGLCanvas;
  1387. var
  1388.    i: Integer;
  1389. begin
  1390.    glBegin(GL_LINES);
  1391.    i := 0;
  1392.    while (i <= count - 2) do
  1393.    begin
  1394.       glVertex2i(points[i].X, points[i].Y);
  1395.       glVertex2i(points[i + 1].X, points[i + 1].Y);
  1396.       Inc(i, 2);
  1397.    end;
  1398.    glEnd;
  1399.    Result := Self;
  1400. end;
  1402. function TGLCanvas.Polyline(const points: TGLPointsF; count: Integer): TGLCanvas;
  1403. var
  1404.    i: Integer;
  1405. begin
  1406.    if count > 1 then
  1407.    begin
  1408.       glBegin(GL_LINE_STRIP);
  1409.       for i := 0 to count - 1 do
  1410.          glVertex2f(points[i].X, points[i].Y);
  1411.       glEnd;
  1412.    end;
  1413.    Result := Self;
  1414. end;
  1416. function TGLCanvas.Polygon(const points: TGLPointsF; count: Integer): TGLCanvas;
  1417. var
  1418.    i: Integer;
  1419. begin
  1420.    if count > 1 then
  1421.    begin
  1422.       glBegin(GL_LINE_LOOP);
  1423.       for i := 0 to count - 1 do
  1424.          glVertex2f(points[i].X, points[i].Y);
  1425.       glEnd;
  1426.    end;
  1427.    Result := Self;
  1428. end;
  1430. function TGLCanvas.Polyline(const points: TGLPointsI; count: Integer): TGLCanvas;
  1431. var
  1432.    i: Integer;
  1433. begin
  1434.    if count > 1 then
  1435.    begin
  1436.       glBegin(GL_LINE_STRIP);
  1437.       for i := 0 to count - 1 do
  1438.          glVertex2i(points[i].X, points[i].Y);
  1439.       glEnd;
  1440.    end;
  1441.    Result := Self;
  1442. end;
  1444. function TGLCanvas.Polygon(const points: TGLPointsI; count: Integer): TGLCanvas;
  1445. var
  1446.    i: Integer;
  1447. begin
  1448.    if count > 1 then
  1449.    begin
  1450.       glBegin(GL_LINE_LOOP);
  1451.       for i := 0 to count - 1 do
  1452.          glVertex2i(points[i].X, points[i].Y);
  1453.       glEnd;
  1454.    end;
  1455.    Result := Self;
  1456. end;
  1458. function TGLCanvas.FillPolygon(const points: TGLPointsF; count: Integer;
  1459.    Border: Boolean = False): TGLCanvas;
  1460. var
  1461.    i: Integer;
  1462. begin
  1463.    if count > 1 then
  1464.    begin
  1465.       if not FIgnoreColor then
  1466.          glColor4fv(@FBrushColor);
  1467.       glBegin(GL_POLYGON);
  1468.       for i := 0 to count - 1 do
  1469.          glVertex2f(points[i].X, points[i].Y);
  1470.       glEnd;
  1471.       if not FIgnoreColor then 
  1472.          glColor4fv(@FPenColor);
  1474.       if Border then
  1475.          Polygon(points, count);
  1476.    end;
  1477.    Result := Self;
  1478. end;
  1480. function TGLCanvas.FillPolygon(const points: TGLPointsI; count: Integer;
  1481.    Border: Boolean = False): TGLCanvas;
  1482. var
  1483.    i: Integer;
  1484. begin
  1485.    if count > 1 then
  1486.    begin
  1487.       if not FIgnoreColor then 
  1488.          glColor4fv(@FBrushColor);
  1489.       glBegin(GL_POLYGON);
  1490.       for i := 0 to count - 1 do
  1491.          glVertex2i(points[i].X, points[i].Y);
  1492.       glEnd;   
  1493.       if not FIgnoreColor then 
  1494.          glColor4fv(@FPenColor);
  1496.       if Border then
  1497.          Polygon(points, count);
  1498.    end;
  1499.    Result := Self;
  1500. end;
  1502. { The following methods are translated into Pascal from ReactOS source.
  1503.     calc_curve_bezier_endp
  1504.     calc_curve_bezier
  1505.     BEZIERMIDDLE
  1506.     BezierCheck
  1507.     GDI_InternalBezier
  1508.     GDI_Bezier
  1509.     GenCurvePoints  }
  1510. // Calculates Bezier points from cardinal spline endpoints.
  1511. procedure calc_curve_bezier_endp(xend, yend, xadj, yadj, tension: Single;
  1512.    var x, y: Single);
  1513. begin
  1514.    // tangent at endpoints is the line from the endpoint to the adjacent point
  1515.    x := tension * (xadj - xend) + xend;
  1516.    y := tension * (yadj - yend) + yend;
  1517. end;
  1519. // Calculates Bezier points from cardinal spline points.
  1520. procedure calc_curve_bezier(const pts: TGLPointsF; tension: Single;
  1521.    var x1, y1, x2, y2: Single);
  1522. var
  1523.    xdiff, ydiff: Single;
  1524. begin
  1525.    // calculate tangent
  1526.    xdiff := pts[2].X - pts[0].X;
  1527.    ydiff := pts[2].Y - pts[0].Y;
  1529.    // apply tangent to get control points
  1530.    x1 := pts[1].X - tension * xdiff;
  1531.    y1 := pts[1].Y - tension * ydiff;
  1532.    x2 := pts[1].X + tension * xdiff;
  1533.    y2 := pts[1].Y + tension * ydiff;
  1534. end;
  1536. procedure BEZIERMIDDLE(var Mid: TGLPointF; const P1, P2: TGLPointF);
  1537. begin
  1538.    Mid.x := (P1.x + P2.x) / 2;
  1539.    Mid.y := (P1.y + P2.y) / 2;
  1540. end;
  1542. type
  1543.    TGDIBezierPoints = array[0..3] of TGLPointF;
  1545. {
  1546. * BezierCheck helper function to check
  1547. * that recursion can be terminated
  1548. *       Points[0] and Points[3] are begin and endpoint
  1549. *       Points[1] and Points[2] are control points
  1550. *       level is the recursion depth
  1551. *       returns true if the recusion can be terminated
  1552. }
  1553. function BezierCheck(level: Integer; const Points: TGDIBezierPoints): Boolean;
  1554. const
  1555.    BEZIERPIXEL = 1;
  1556. var
  1557.    dx, dy: Single;
  1558. begin
  1559.    dx := Points[3].x - Points[0].x;
  1560.    dy := Points[3].y - Points[0].y;
  1561.    if Abs(dy) <= Abs(dx) then // shallow line
  1562.    begin
  1563.       // check that control points are between begin and end
  1564.       if Points[1].x < Points[0].x then
  1565.       begin
  1566.          if Points[1].x < Points[3].x then
  1567.          begin
  1568.             Result := False;
  1569.             Exit;
  1570.          end;
  1571.       end
  1572.       else if Points[1].x > Points[3].x then
  1573.       begin
  1574.          Result := False;
  1575.          Exit;
  1576.       end;
  1578.       if Points[2].x < Points[0].x then
  1579.       begin
  1580.          if Points[2].x < Points[3].x then
  1581.          begin
  1582.             Result := False;
  1583.             Exit;
  1584.          end;
  1585.       end
  1586.       else if Points[2].x > Points[3].x then
  1587.       begin
  1588.          Result := False;
  1589.          Exit;
  1590.       end;
  1592.       if IsZero(dx) then
  1593.       begin
  1594.          Result := True;
  1595.          Exit;
  1596.       end;
  1598.       if (Abs(Points[1].y - Points[0].y - (dy / dx) * (Points[1].x - Points[0].x)) > BEZIERPIXEL) or
  1599.          (Abs(Points[2].y - Points[0].y - (dy / dx) * (Points[2].x - Points[0].x)) > BEZIERPIXEL) then
  1600.       begin
  1601.          Result := False;
  1602.          Exit;
  1603.       end
  1604.       else
  1605.       begin
  1606.          Result := True;
  1607.          Exit;
  1608.       end;
  1609.    end
  1610.    else
  1611.    begin // steep line
  1612.       // check that control points are between begin and end
  1613.       if Points[1].y < Points[0].y then
  1614.       begin
  1615.          if Points[1].y < Points[3].y then
  1616.          begin
  1617.             Result := False;
  1618.             Exit;
  1619.          end;
  1620.       end
  1621.       else if Points[1].y > Points[3].y then
  1622.       begin
  1623.          Result := False;
  1624.          Exit;
  1625.       end;
  1627.       if Points[2].y < Points[0].y then
  1628.       begin
  1629.          if Points[2].y < Points[3].y then
  1630.          begin
  1631.             Result := False;
  1632.             Exit;
  1633.          end;
  1634.       end
  1635.       else if Points[2].y > Points[3].y then
  1636.       begin
  1637.          Result := False;
  1638.          Exit;
  1639.       end;
  1641.       if IsZero(dy) then
  1642.       begin
  1643.          Result := True;
  1644.          Exit;
  1645.       end;
  1647.       if (Abs(Points[1].x - Points[0].x - (dx / dy) * (Points[1].y - Points[0].y)) > BEZIERPIXEL) or
  1648.         (Abs(Points[2].x - Points[0].x - (dx / dy) * (Points[2].y - Points[0].y)) > BEZIERPIXEL) then
  1649.       begin
  1650.          Result := False;
  1651.          Exit;
  1652.       end
  1653.       else
  1654.       begin
  1655.          Result := True;
  1656.          Exit;
  1657.       end;
  1658.    end;
  1659. end;
  1661. procedure GDI_InternalBezier(var Points: TGDIBezierPoints; var PtsOut: TGLPointsF;
  1662.    var dwOut, nPtsOut: Integer; level: Integer);
  1663. var
  1664.    Points2: TGDIBezierPoints; // for the second recursive call
  1665. begin
  1666.   if nPtsOut = dwOut then
  1667.   begin
  1668.      dwOut := dwOut * 2;
  1669.      SetLength(PtsOut, dwOut);
  1670.   end;
  1672.   if (level = 0) or BezierCheck(level, Points) then // Recursion can be terminated
  1673.   begin
  1674.      if nPtsOut = 0 then
  1675.      begin
  1676.         PtsOut[0] := Points[0];
  1677.         nPtsOut := 1;
  1678.      end;
  1679.      PtsOut[nPtsOut] := Points[3];
  1680.      Inc(nPtsOut);
  1681.   end
  1682.   else
  1683.   begin
  1684.      Points2[3] := Points[3];
  1685.      BEZIERMIDDLE(Points2[2], Points[2], Points[3]);
  1686.      BEZIERMIDDLE(Points2[0], Points[1], Points[2]);
  1687.      BEZIERMIDDLE(Points2[1],Points2[0],Points2[2]);
  1689.      BEZIERMIDDLE(Points[1], Points[0],  Points[1]);
  1690.      BEZIERMIDDLE(Points[2], Points[1], Points2[0]);
  1691.      BEZIERMIDDLE(Points[3], Points[2], Points2[1]);
  1693.      Points2[0] := Points[3];
  1695.      // do the two halves
  1696.      GDI_InternalBezier(Points, PtsOut, dwOut, nPtsOut, level - 1);
  1697.      GDI_InternalBezier(Points2, PtsOut, dwOut, nPtsOut, level - 1);
  1698.   end;
  1699. end;
  1701. procedure GDI_Bezier(const Points: TGLPointsF; count: Integer;
  1702.    var PtsOut: TGLPointsF; var nPtsOut:Integer);
  1703. var
  1704.    Bezier, dwOut: Integer;
  1705.    ptBuf: TGDIBezierPoints;
  1706. begin
  1707.    dwOut := 150;
  1708.    nPtsOut := 0;
  1710.    if (count - 1) mod 3 <> 0 then
  1711.       Exit;
  1713.    SetLength(PtsOut, dwOut);
  1714.    for Bezier := 0 to (count - 1) div 3 - 1 do
  1715.    begin
  1716.       Move(Points[Bezier * 3], ptBuf[0], SizeOf(ptBuf));
  1717.       GDI_InternalBezier(ptBuf, PtsOut, dwOut, nPtsOut, 8);
  1718.    end;
  1719. end;
  1721. procedure GenCurvePoints(const points: TGLPointsF; count: Integer;
  1722.    var outPoints: TGLPointsF; var outCount: Integer; tension: Single = 0.5);
  1723. var
  1724.    i, len_pt: Integer;
  1725.    x1, x2, y1, y2: Single;
  1726.    pt: TGLPointsF;
  1727. begin
  1728.    outCount := 0;
  1729.    if count <= 1 then
  1730.       Exit;
  1732.    // PolyBezier expects count*3-2 points.
  1733.    len_pt := count * 3 - 2;
  1734.    SetLength(pt, len_pt);
  1735.    tension := tension * 0.3;
  1737.    calc_curve_bezier_endp(points[0].X, points[0].Y, points[1].X, points[1].Y,
  1738.       tension, x1, y1);
  1740.    pt[0] := points[0];
  1741.    pt[1].X := x1;
  1742.    pt[1].Y := y1;
  1744.    for i := 0 to count - 3 do
  1745.    begin
  1746.       calc_curve_bezier(TGLPointsF(@(points[i])), tension, x1, y1, x2, y2);
  1747.       pt[3 * i + 2].X := x1;
  1748.       pt[3 * i + 2].Y := y1;
  1749.       pt[3 * i + 3] := points[i + 1];
  1750.       pt[3 * i + 4].X := x2;
  1751.       pt[3 * i + 4].Y := y2;
  1752.    end;
  1754.    calc_curve_bezier_endp(points[count - 1].X, points[count - 1].Y,
  1755.        points[count - 2].X, points[count - 2].Y, tension, x1, y1);
  1756.    pt[len_pt - 2].X := x1;
  1757.    pt[len_pt - 2].Y := y1;
  1758.    pt[len_pt - 1] := points[count - 1];
  1760.    GDI_Bezier(pt, len_pt, outPoints, outCount);
  1761. end;
  1763. function TGLCanvas.Curve(const points: TGLPointsF; count: Integer;
  1764.    tension: Single = 0.5): TGLCanvas;
  1765. var
  1766.    pt2: TGLPointsF;
  1767.    pt2Count: Integer;
  1768. begin
  1769.    Result := Self;
  1770.    if count <= 1 then
  1771.       Exit;
  1773.    GenCurvePoints(points, count, pt2, pt2Count, tension);
  1774.    Polyline(pt2, pt2Count);
  1775. end;
  1777. function TGLCanvas.Curve(const points: TGLPointsI; count: Integer;
  1778.    tension: Single = 0.5): TGLCanvas;
  1779. var
  1780.    i: Integer;
  1781.    pfs: TGLPointsF;
  1782. begin
  1783.    Result := Self;
  1784.    if count <= 1 then
  1785.       Exit;
  1787.    SetLength(pfs, count);
  1788.    for i := 0 to count - 1 do
  1789.    begin
  1790.       pfs[i].X := points[i].X;
  1791.       pfs[i].Y := points[i].Y;
  1792.    end;
  1793.    Curve(pfs, count, tension);
  1794. end;
  1796. function TGLCanvas.ClosedCurve(const points: TGLPointsF; count: Integer;
  1797.    tension: Single = 0.5): TGLCanvas;
  1798. var
  1799.    ps: TGLPointsF;
  1800. begin
  1801.    Result := Self;
  1802.    if count <= 2 then
  1803.       Exit;
  1805.    SetLength(ps, count + 1);
  1806.    Move(points[0], ps[0], SizeOf(TGLPointF) * count);
  1807.    ps[count] := ps[0]; // Close the curve
  1808.    Curve(ps, count + 1, tension);
  1809. end;
  1811. function TGLCanvas.ClosedCurve(const points: TGLPointsI; count: Integer;
  1812.    tension: Single = 0.5): TGLCanvas;
  1813. var
  1814.    i: Integer;
  1815.    ps: TGLPointsF;
  1816. begin
  1817.    Result := Self;
  1818.    if count <= 2 then
  1819.       Exit;
  1821.    SetLength(ps, count + 1);
  1822.    for i := 0 to count - 1 do
  1823.    begin
  1824.       ps[i].X := points[i].X;
  1825.       ps[i].Y := points[i].Y;
  1826.    end;
  1827.    ps[count] := ps[0]; // Close the curve
  1828.    Curve(ps, count + 1, tension);
  1829. end;
  1831. function TGLCanvas.FillClosedCurve(const points: TGLPointsF; count: Integer;
  1832.    Border: Boolean = False; tension: Single = 0.5): TGLCanvas;
  1833. var
  1834.    ps, pt2: TGLPointsF;
  1835.    pt2Count: Integer;
  1836. begin
  1837.    Result := Self;
  1838.    if count <= 2 then
  1839.       Exit;
  1841.    SetLength(ps, count + 1);
  1842.    Move(points[0], ps[0], SizeOf(TGLPointF) * count);
  1843.    ps[count] := ps[0]; // Close the curve
  1845.    GenCurvePoints(ps, count + 1, pt2, pt2Count, tension);
  1846.    FillPolygon(pt2, pt2Count, Border);
  1847. end;
  1849. function TGLCanvas.FillClosedCurve(const points: TGLPointsI; count: Integer;
  1850.    Border: Boolean = False; tension: Single = 0.5): TGLCanvas;
  1851. var
  1852.    i: Integer;
  1853.    ps, pt2: TGLPointsF;
  1854.    pt2Count: Integer;
  1855. begin
  1856.    Result := Self;
  1857.    if count <= 2 then
  1858.       Exit;
  1860.    SetLength(ps, count + 1);
  1861.    for i := 0 to count - 1 do
  1862.    begin
  1863.       ps[i].X := points[i].X;
  1864.       ps[i].Y := points[i].Y;
  1865.    end;
  1866.    ps[count] := ps[0]; // Close the curve
  1868.    GenCurvePoints(ps, count + 1, pt2, pt2Count, tension);
  1869.    FillPolygon(pt2, pt2Count, Border);
  1870. end;
  1872. function TGLCanvas.Bezier(const x1, y1, x2, y2, x3, y3, x4, y4: Integer): TGLCanvas;
  1873. var
  1874.    pt: TGDIBezierPoints;
  1875.    pt2: TGLPointsF;
  1876.    ptOut: Integer;
  1877. begin
  1878.    pt[0].X := x1;
  1879.    pt[0].Y := y1;
  1880.    pt[1].X := x2;
  1881.    pt[1].Y := y2;
  1882.    pt[2].X := x3;
  1883.    pt[2].Y := y3;
  1884.    pt[3].X := x4;
  1885.    pt[3].Y := y4;
  1887.    GDI_Bezier(TGLPointsF(@pt[0]), 4, pt2, ptOut);
  1888.    Polyline(pt2, ptOut);
  1889.    Result := Self;
  1890. end;
  1892. function TGLCanvas.Bezier(const x1, y1, x2, y2, x3, y3, x4, y4: Single): TGLCanvas;
  1893. var
  1894.    pt: TGDIBezierPoints;
  1895.    pt2: TGLPointsF;
  1896.    ptOut: Integer;
  1897. begin
  1898.    pt[0].X := x1;
  1899.    pt[0].Y := y1;
  1900.    pt[1].X := x2;
  1901.    pt[1].Y := y2;
  1902.    pt[2].X := x3;
  1903.    pt[2].Y := y3;
  1904.    pt[3].X := x4;
  1905.    pt[3].Y := y4;
  1907.    GDI_Bezier(TGLPointsF(@pt[0]), 4, pt2, ptOut);
  1908.    Polyline(pt2, ptOut);
  1909.    Result := Self;
  1910. end;
  1912. function TGLCanvas.PolyBezier(const points: TGLPointsI; count: Integer): TGLCanvas;
  1913. var
  1914.    i: Integer;
  1915.    ps, pt2: TGLPointsF;
  1916.    pt2Count: Integer;
  1917. begin
  1918.    SetLength(ps, count);
  1919.    for i := 0 to count - 1 do
  1920.    begin
  1921.       ps[i].X := points[i].X;
  1922.       ps[i].Y := points[i].Y;
  1923.    end;
  1925.    GDI_Bezier(ps, count, pt2, pt2Count);
  1926.    Polyline(pt2, pt2Count);
  1927.    Result := Self;
  1928. end;
  1930. function TGLCanvas.PolyBezier(const points: TGLPointsF; count: Integer): TGLCanvas;
  1931. var
  1932.    ps2Count: Integer;
  1933.    ps2: TGLPointsF;
  1934. begin
  1935.    GDI_Bezier(points, count, ps2, ps2Count);
  1936.    Polyline(ps2, ps2Count);
  1937.    Result := Self;
  1938. end;
  1940. const
  1941.    MAX_ARC_PTS = 13;
  1942. type
  1943.    TGdiArcPoints = array[0..MAX_ARC_PTS - 1] of TGLPointF;
  1945.    PGdiArcPointsSegment = ^TGdiArcPointsSegment;
  1946.    TGdiArcPointsSegment = array[0..3] of TGLPointF;
  1948. { We plot the curve as if it is on a circle then stretch the points.  This
  1949.   adjusts the angles so that when we stretch the points they will end in the
  1950.   right place. This is only complicated because atan and atan2 do not behave
  1951.   conveniently. }
  1952. procedure unstretch_angle(var angle: Single; rad_x, rad_y: Single);
  1953. var
  1954.    stretched: Single;
  1955.    revs_off: Integer;
  1956. begin
  1957.     angle := DegToRad(angle);
  1959.     if(Abs(Cos(angle)) < 0.00001) or (Abs(Sin(angle)) < 0.00001) then
  1960.        Exit;
  1962.     stretched := ArcTan2(Sin(angle) / Abs(rad_y), Cos(angle) / Abs(rad_x));
  1963.     revs_off := Round(angle / _2Pi) - Round(stretched / _2Pi);
  1964.     angle := stretched + revs_off * _2Pi;
  1965. end;
  1967. { Calculates the bezier points needed to fill in the arc portion starting at
  1968.   angle start and ending at end.  These two angles should be no more than 90
  1969.   degrees from each other.  x1, y1, x2, y2 describes the bounding box (upper
  1970.   left and width and height).  Angles must be in radians. write_first indicates
  1971.   that the first bezier point should be written out (usually this is false).
  1972.   pt is the array of GpPointFs that gets written to. }
  1973. procedure add_arc_part(pt: PGdiArcPointsSegment; const x1, y1, x2, y2: Single;
  1974.    startangle, endangle: Single; write_first: Boolean);
  1975. var
  1976.    i: Integer;
  1977.    center_x, center_y, rad_x, rad_y, cos_start, cos_end,
  1978.       sin_start, sin_end, a, half: Single;
  1979. begin
  1980.     rad_x := x2 / 2.0;
  1981.     rad_y := y2 / 2.0;
  1982.     center_x := x1 + rad_x;
  1983.     center_y := y1 + rad_y;
  1985.     SinCos(startangle, sin_start, cos_start);
  1986.     SinCos(endangle, sin_end, cos_end);
  1988.     half := (endangle - startangle) / 2.0;
  1989.     a := 4.0 / 3.0 * (1 - Cos(half)) / Sin(half);
  1991.     if write_first then
  1992.     begin
  1993.        pt^[0].X := cos_start;
  1994.        pt^[0].Y := sin_start;
  1995.     end;
  1996.     pt^[1].X := cos_start - a * sin_start;
  1997.     pt^[1].Y := sin_start + a * cos_start;
  1999.     pt^[3].X := cos_end;
  2000.     pt^[3].Y := sin_end;
  2001.     pt^[2].X := cos_end + a * sin_end;
  2002.     pt^[2].Y := sin_end - a * cos_end;
  2004.     // expand the points back from the unit circle to the ellipse
  2005.     if write_first then
  2006.     begin
  2007.        for i := 0 to 3 do
  2008.        begin
  2009.           pt^[i].X := pt^[i].X * rad_x + center_x;
  2010.           pt^[i].Y := pt^[i].Y * rad_y + center_y;
  2011.        end;
  2012.     end
  2013.     else
  2014.     begin
  2015.        for i := 1 to 3 do
  2016.        begin
  2017.           pt^[i].X := pt^[i].X * rad_x + center_x;
  2018.           pt^[i].Y := pt^[i].Y * rad_y + center_y;
  2019.        end;
  2020.     end;
  2021. end;
  2023. { Stores the bezier points that correspond to the arc in points. If points is
  2024.   null, just return the number of points needed to represent the arc. }
  2025. function arc2polybezier(var points: TGdiArcPoints; const x1, y1, x2, y2: Single;
  2026.    var startAngle, sweepAngle: Single): Integer;
  2027. var
  2028.    i, count: Integer;
  2029.    end_angle, start_angle, endAngle: Single;
  2030. begin
  2031.     endAngle := startAngle + sweepAngle;
  2032.     unstretch_angle(startAngle, x2 / 2.0, y2 / 2.0);
  2033.     unstretch_angle(endAngle, x2 / 2.0, y2 / 2.0);
  2035.     count := Ceil(Abs(endAngle - startAngle) / PiDiv2) * 3 + 1;
  2036.     count := Min(MAX_ARC_PTS, count); // don't make more than a full circle
  2038.     if count = 1 then
  2039.     begin
  2040.        Result := 0;
  2041.        Exit;
  2042.     end;
  2044.     // start_angle and end_angle are the iterative variables
  2045.     start_angle := startAngle;
  2046.     i := 0;
  2047.     while (i < count - 1) do
  2048.     begin
  2049.        // check if we've overshot the end angle
  2050.        if sweepAngle > 0.0 then
  2051.           end_angle := Min(start_angle + PiDiv2, endAngle)
  2052.        else
  2053.           end_angle := Max(start_angle - PiDiv2, endAngle);
  2055.        if SameValue(start_angle, end_angle) then
  2056.        begin
  2057.           count := i + 1;
  2058.           Break;
  2059.        end;
  2061.        add_arc_part(PGdiArcPointsSegment(@points[i]), x1, y1, x2, y2,
  2062.           start_angle, end_angle, i = 0);
  2064.        if sweepAngle < 0.0 then
  2065.           start_angle := start_angle - PiDiv2
  2066.        else
  2067.           start_angle := start_angle + PiDiv2;
  2068.        i := i + 3;
  2069.     end;
  2071.     Result := count;
  2072. end;
  2074. function TGLCanvas.Arc(const x, y, xRadius, yRadius: Single;
  2075.    startAngle, sweepAngle: Single): TGLCanvas;
  2076. var
  2077.    num_pts: Integer;
  2078.    points: TGdiArcPoints;
  2079. begin
  2080.    num_pts := arc2polybezier(points, x - xRadius, y - yRadius,
  2081.       xRadius * 2, yRadius * 2, startAngle, sweepAngle);
  2082.    PolyBezier(TGLPointsF(@points[0]), num_pts);
  2083.    Result := Self;
  2084. end;
  2086. function TGLCanvas.FillPie(const x, y, xRadius, yRadius: Single;
  2087.    startAngle, sweepAngle: Single; Border: Boolean = False): TGLCanvas;
  2088. var
  2089.    i, num_pts: Integer;
  2090.    points: TGdiArcPoints;
  2091.    ps2Count: Integer;
  2092.    ps2: TGLPointsF;
  2093. begin
  2094.    if not FIgnoreColor then
  2095.       glColor4fv(@FBrushColor);
  2096.    glBegin(GL_TRIANGLE_FAN);
  2097.    glVertex2f(x, y); // not really necessary, but may help with memory stride
  2099.    num_pts := arc2polybezier(points, x - xRadius, y - yRadius,
  2100.       xRadius * 2, yRadius * 2, startAngle, sweepAngle);
  2101.    GDI_Bezier(TGLPointsF(@points[0]), num_pts, ps2, ps2Count);
  2102.    for i := 0 to ps2Count - 1 do
  2103.       glVertex2f(ps2[i].X, ps2[i].Y);
  2105.    glEnd;
  2106.    if not FIgnoreColor then
  2107.       glColor4fv(@FPenColor);
  2109.    if Border then
  2110.    begin
  2111.       glBegin(GL_LINE_STRIP);
  2112.       glVertex2f(x, y);
  2113.       for i := 0 to ps2Count - 1 do
  2114.          glVertex2f(ps2[i].X, ps2[i].Y);
  2115.       glVertex2f(x, y);
  2116.       glEnd;
  2117.    end;
  2119.    Result := Self;
  2120. end;
  2122. function TGLCanvas.PlotPixel(const x, y: Integer): TGLCanvas;
  2123. begin
  2124.    glBegin(GL_POINTS);
  2125.    glVertex2i(x, y);
  2126.    glEnd;
  2127.    Result := Self;
  2128. end;
  2130. function TGLCanvas.PlotPixel(const x, y: Single): TGLCanvas;
  2131. begin
  2132.    glBegin(GL_POINTS);
  2133.    glVertex2f(x, y);
  2134.    glEnd;
  2135.    Result := Self;
  2136. end;
  2138. function TGLCanvas.BeginPixels: TGLCanvas;
  2139. begin
  2140.    glBegin(GL_POINTS);
  2141.    Result := Self;
  2142. end;
  2144. function TGLCanvas.Pixels(const x, y: Integer): TGLCanvas;
  2145. begin
  2146.    glVertex2i(x, y);
  2147.    Result := Self;
  2148. end;
  2150. function TGLCanvas.Pixels(const x, y: Single): TGLCanvas;
  2151. begin
  2152.    glVertex2f(x, y);
  2153.    Result := Self;
  2154. end;
  2156. function TGLCanvas.EndPixels: TGLCanvas;
  2157. begin
  2158.    glEnd;
  2159.    Result := Self;
  2160. end;
  2162. function TGLCanvas.FrameRect(const x1, y1, x2, y2: Integer): TGLCanvas;
  2163. begin
  2164.    glBegin(GL_LINE_LOOP);
  2165.    glVertex2i(x1, y1);
  2166.    glVertex2i(x2, y1);
  2167.    glVertex2i(x2, y2);
  2168.    glVertex2i(x1, y2);
  2169.    glEnd;
  2170.    Result := Self;
  2171. end;
  2173. function TGLCanvas.FrameRect(const x1, y1, x2, y2: Single): TGLCanvas;
  2174. begin
  2175.    glBegin(GL_LINE_LOOP);
  2176.    glVertex2f(x1, y1);
  2177.    glVertex2f(x2, y1);
  2178.    glVertex2f(x2, y2);
  2179.    glVertex2f(x1, y2);
  2180.    glEnd;
  2181.    Result := Self;
  2182. end;
  2184. function TGLCanvas.FillRect(const x1, y1, x2, y2: Integer; Border: Boolean = False): TGLCanvas;
  2185. begin
  2186.    if not FIgnoreColor then 
  2187.       glColor4fv(@FBrushColor);
  2188.    glRecti(x1, y1, x2, y2);
  2189.    if not FIgnoreColor then 
  2190.       glColor4fv(@FPenColor);
  2191.    if Border then
  2192.       FrameRect(x1, y1, x2, y2);
  2193.    Result := Self;
  2194. end;
  2196. function TGLCanvas.FillRect(const x1, y1, x2, y2: Single; Border: Boolean = False): TGLCanvas;
  2197. begin
  2198.    if not FIgnoreColor then 
  2199.       glColor4fv(@FBrushColor);
  2200.    glRectf(x1, y1, x2, y2);
  2201.    if not FIgnoreColor then 
  2202.       glColor4fv(@FPenColor);
  2203.    if Border then
  2204.       FrameRect(x1, y1, x2, y2);
  2205.    Result := Self;
  2206. end;
  2208. function TGLCanvas.Triangle(const x1, y1, x2, y2, x3, y3: Integer): TGLCanvas;
  2209. begin
  2210.    glBegin(GL_LINE_LOOP);
  2211.    glVertex2i(x1, y1);
  2212.    glVertex2i(x2, y2);
  2213.    glVertex2i(x3, y3);
  2214.    glEnd;
  2215.    Result := Self;
  2216. end;
  2218. function TGLCanvas.Triangle(const x1, y1, x2, y2, x3, y3: Single): TGLCanvas;
  2219. begin
  2220.    glBegin(GL_LINE_LOOP);
  2221.    glVertex2f(x1, y1);
  2222.    glVertex2f(x2, y2);
  2223.    glVertex2f(x3, y3);
  2224.    glEnd;
  2225.    Result := Self;
  2226. end;
  2228. function TGLCanvas.FillTriangle(const x1, y1, x2, y2, x3, y3: Integer;
  2229.    Border: Boolean = False): TGLCanvas;
  2230. begin
  2231.    if not FIgnoreColor then 
  2232.       glColor4fv(@FBrushColor);
  2233.    glBegin(GL_TRIANGLE_FAN);
  2234.    glVertex2i(x1, y1);
  2235.    glVertex2i(x2, y2);
  2236.    glVertex2i(x3, y3);
  2237.    glEnd;
  2238.    if not FIgnoreColor then 
  2239.       glColor4fv(@FPenColor);
  2240.    if Border then
  2241.       Triangle(x1, y1, x2, y2, x3, y3);
  2242.    Result := Self;
  2243. end;
  2245. function TGLCanvas.FillTriangle(const x1, y1, x2, y2, x3, y3: Single;
  2246.    Border: Boolean = False): TGLCanvas;
  2247. begin
  2248.    if not FIgnoreColor then 
  2249.       glColor4fv(@FBrushColor);
  2250.    glBegin(GL_TRIANGLE_FAN);
  2251.    glVertex2f(x1, y1);
  2252.    glVertex2f(x2, y2);
  2253.    glVertex2f(x3, y3);
  2254.    glEnd;
  2255.    if not FIgnoreColor then 
  2256.       glColor4fv(@FPenColor);
  2257.    if Border then
  2258.       Triangle(x1, y1, x2, y2, x3, y3);
  2259.    Result := Self;
  2260. end;
  2262. // Ellipse drawing methods are borrowed from GLScene.GLCanvas unit
  2264. procedure PrepareSinCosCache(var s, c: array of Single;
  2265.    startAngle, stopAngle: Single);
  2266. var
  2267.    i: Integer;
  2268.    d, alpha, beta: Single;
  2269. begin
  2270.    stopAngle := stopAngle + 1E-5;
  2271.    if High(s) > Low(s) then
  2272.       d := PiDiv180 * (stopAngle - startAngle) / (High(s) - Low(s))
  2273.    else
  2274.       d := 0;
  2276.    if High(s) - Low(s) < 1000 then
  2277.    begin
  2278.       // Fast computation (approx 5.5x)
  2279.       alpha := 2 * Sqr(Sin(d * 0.5));
  2280.       beta := Sin(d);
  2281.       SinCos(startAngle * PiDiv180, s[Low(s)], c[Low(s)]);
  2282.       for i := Low(s) to High(s) - 1 do
  2283.       begin
  2284.          // Make use of the incremental formulae:
  2285.          // cos (theta+delta) = cos(theta) - [alpha*cos(theta) + beta*sin(theta)]
  2286.          // sin (theta+delta) = sin(theta) - [alpha*sin(theta) - beta*cos(theta)]
  2287.          c[i + 1] := c[i] - alpha * c[i] - beta * s[i];
  2288.          s[i + 1] := s[i] - alpha * s[i] + beta * c[i];
  2289.       end;
  2290.    end
  2291.    else
  2292.    begin
  2293.       // Slower, but maintains precision when steps are small
  2294.       startAngle := startAngle * PiDiv180;
  2295.       for i := Low(s) to High(s) do
  2296.          SinCos((i - Low(s)) * d + startAngle, s[i], c[i]);
  2297.    end;
  2298. end;
  2300. procedure TGLCanvas.EllipseVertices(const x, y, xRadius, yRadius: Single);
  2301. var
  2302.    i, n: Integer;
  2303.    s, c: TSingleArray;
  2304. begin
  2305.    if xRadius > yRadius then
  2306.       n := Round(xRadius * 0.1) + 10
  2307.    else
  2308.       n := Round(yRadius * 0.1) + 10;
  2309.    SetLength(s, n);
  2310.    SetLength(c, n);
  2311.    Dec(n);
  2312.    PrepareSinCosCache(s, c, 0, 90);
  2313.    // first quadrant (top right)
  2314.    for i := 0 to n do
  2315.    begin
  2316.       s[i] := s[i] * yRadius;
  2317.       c[i] := c[i] * xRadius;
  2318.       glVertex2f(x + c[i], y - s[i]);
  2319.    end;
  2320.    // second quadrant (top left)
  2321.    for i := n - 1 downto 0 do
  2322.       glVertex2f(x - c[i], y - s[i]);
  2323.    // third quadrant (bottom left)
  2324.    for i := 1 to n do
  2325.       glVertex2f(x - c[i], y + s[i]);
  2326.    // fourth quadrant (bottom right)
  2327.    for i := n - 1 downto 0 do
  2328.       glVertex2f(x + c[i], y + s[i]);
  2329. end;
  2331. function TGLCanvas.EllipseRect(const x1, y1, x2, y2: Single): TGLCanvas;
  2332. begin
  2333.    Ellipse((x1 + x2) * 0.5, (y1 + y2) * 0.5, Abs(x2 - x1) * 0.5, Abs(y2 - y1) * 0.5);
  2334.    Result := Self;
  2335. end;
  2337. function TGLCanvas.Ellipse(const x, y, xRadius, yRadius: Single): TGLCanvas;
  2338. begin
  2339.    glBegin(GL_LINE_STRIP);
  2340.    EllipseVertices(x, y, xRadius, yRadius);
  2341.    glEnd;
  2342.    Result := Self;
  2343. end;
  2345. function TGLCanvas.FillEllipseRect(const x1, y1, x2, y2: Single;
  2346.    Border: Boolean = False): TGLCanvas;
  2347. begin
  2348.    FillEllipse((x1 + x2) * 0.5, (y1 + y2) * 0.5, Abs(x2 - x1) * 0.5, Abs(y2 - y1) * 0.5, Border);
  2349.    Result := Self;
  2350. end;
  2352. function TGLCanvas.FillEllipse(const x, y, xRadius, yRadius: Single;
  2353.    Border: Boolean = False): TGLCanvas;
  2354. begin
  2355.    if not FIgnoreColor then
  2356.       glColor4fv(@FBrushColor);
  2357.    glBegin(GL_TRIANGLE_FAN);
  2358.    glVertex2f(x, y); // not really necessary, but may help with memory stride
  2359.    EllipseVertices(x, y, xRadius, yRadius);
  2360.    glEnd;
  2361.    if not FIgnoreColor then 
  2362.       glColor4fv(@FPenColor);
  2363.    if Border then
  2364.       Ellipse(x, y, xRadius, yRadius);
  2365.    Result := Self;
  2366. end;
  2368. procedure TGLCanvas.RecreateDefaultFont;
  2369. begin
  2370.    if Assigned(FDefaultFont) then
  2371.       FDefaultFont.Free;
  2372.    FDefaultFont := TGLFont.Create('Tahoma', 14);
  2373.    FDefaultFont.NotifyChange := DefaultFontNotify; // Mustn't assign NotifyChange by TCnGLFont.Create
  2374. end;
  2376. function TGLCanvas.TextOutASCII(const text: string; x, y: Integer;
  2377.    Font: TGLFont = nil): TGLCanvas;
  2378. var
  2379.    i: Integer;
  2380.    GLList: GLuint;
  2381.    NeedFreeList: Boolean;
  2382. begin
  2383.    if Assigned(Font) then
  2384.    begin
  2385.       SelectObject(FBufferHDC, Font.HFont);
  2386.       GLList := glGenLists(MaxChar);
  2387.       wglUseFontBitmaps(FBufferHDC, 0, MaxChar, GLList);
  2388.       NeedFreeList := True;
  2389.    end
  2390.    else
  2391.    begin
  2392.       Font := FDefaultFont;
  2393.       GLList := FASCIICharList;
  2394.       NeedFreeList := False;
  2395.    end;
  2397.    glPushMatrix;
  2398.    glLoadIdentity;
  2399.    glColor4fv(@Font.FColorVector);
  2400.    glRasterPos2i(x, y);
  2401.    for i := 1 to Length(text) do
  2402.       glCallList(GLList + Ord(text[i]));
  2403.    glPopMatrix;
  2405.    if NeedFreeList then
  2406.       glDeleteLists(GLList, MaxChar);
  2407.    glColor4fv(@FPenColor);
  2408.    Result := Self;
  2409. end;
  2411. function TGLCanvas.TextOut(const text: WideString; x, y: Integer;
  2412.    Font: TGLFont = nil): TGLCanvas;
  2413. var
  2414.    i: Integer;
  2415.    list: GLuint;
  2416. begin
  2417.    if not Assigned(Font) then
  2418.       Font := FDefaultFont;
  2419.    SelectObject(FBufferHDC, Font.HFont);
  2420.    glColor4fv(@Font.FColorVector);
  2422.    glPushMatrix;
  2423.    glLoadIdentity;
  2424.    glRasterPos2i(x, y);
  2425.    for i := 1 to Length(text) do
  2426.    begin
  2427.       wglUseFontBitmapsW(FBufferHDC, Ord(text[i]), 1, list);
  2428.       glCallList(list);
  2429.    end;
  2430.    glDeleteLists(list, 1);
  2431.    glColor4fv(@FPenColor);
  2432.    glPopMatrix;
  2433.    Result := Self;
  2434. end;
  2436. function TGLCanvas.BuildTexture(bmp: TBitmap; var texId: GLuint): TGLCanvas; // Creates Texture From A Bitmap File
  2437. var
  2438.    bmpInfo: BITMAP;
  2439. begin
  2440.    GetObject(bmp.Handle, SizeOf(bmpInfo), @bmpInfo);
  2441.    glGenTextures(1, @texId);          // Create The Texture
  2442.    glPixelStorei(GL_PACK_ALIGNMENT, 1);
  2443.    // Typical Texture Generation Using Data From The Bitmap
  2444.    glBindTexture(GL_TEXTURE_2D, texId);        // Bind To The Texture ID
  2445.    glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR); // Linear Min Filter
  2446.    glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR); // Linear Mag Filter
  2447.    glTexImage2D(GL_TEXTURE_2D, 0, 3, bmpInfo.bmWidth, bmpInfo.bmHeight, 0, GL_BGR, GL_UNSIGNED_BYTE, bmpInfo.bmBits);
  2448.    Result := Self;
  2449. end;
  2451. function TGLCanvas.DeleteTexture(texId: GLuint): TGLCanvas;
  2452. begin
  2453.    glDeleteTextures(1, @texId);
  2454.    Result := Self;
  2455. end;
  2457. function TGLCanvas.DrawBitmap(bmp: TBitmap; x, y: Integer;
  2458.    xZoom: Single = 1.0; yZoom: Single = 1.0): TGLCanvas;
  2459. var
  2460.    bmpInfo: BITMAP;
  2461. begin
  2462.    GetObject(bmp.Handle, SizeOf(bmpInfo), @bmpInfo);
  2463.    glPixelZoom(xZoom, yZoom);
  2464.    glPushMatrix;
  2465.    glLoadIdentity;
  2466.    glRasterPos2i(x, y);
  2467.    glDrawPixels(bmp.Width, bmp.Height, GL_BGR, GL_UNSIGNED_BYTE, bmpInfo.bmBits);
  2468.    glPopMatrix;
  2469.    Result := Self;
  2470. end;
  2472. function TGLCanvas.DrawBitmapTex(bmp: TBitmap; x, y, w, h: Integer): TGLCanvas; var    tex: GLuint;
  2473. begin
  2474.    glColor3f(1.0, 1.0, 1.0);
  2475.    glDisable(GL_BLEND);
  2476.    glEnable(GL_TEXTURE_2D);
  2477.    BuildTexture(bmp, tex);
  2479.    glBegin(GL_QUADS);
  2480.    glTexCoord2f(0.0, 0.0); glVertex3i(x, y, 0);
  2481.    glTexCoord2f(1.0, 0.0); glVertex3f(x + w, y, 0);
  2482.    glTexCoord2f(1.0, 1.0); glVertex3f(x + w, y + h, 0);
  2483.    glTexCoord2f(0.0, 1.0); glVertex3f(x, y + h, 0);
  2484.    glEnd;
  2486.    glDeleteTextures(1, @tex);
  2487.    glDisable(GL_TEXTURE_2D);
  2488.    SetBlendState(FBlend);
  2489.    glColor4fv(@FPenColor); // Restore color
  2490.    Result := Self;
  2491. end;
  2493. function TGLCanvas.DrawBitmapTex(texId: GLuint; x, y, w, h: Integer): TGLCanvas;
  2494. begin
  2495.    glColor3f(1.0, 1.0, 1.0);
  2496.    glDisable(GL_BLEND);
  2497.    glEnable(GL_TEXTURE_2D);
  2499.    glBindTexture(GL_TEXTURE_2D, texid);        // Bind To The Texture ID
  2500.    glBegin(GL_QUADS);
  2501.    glTexCoord2f(0.0, 0.0); glVertex3i(x, y, 0);
  2502.    glTexCoord2f(1.0, 0.0); glVertex3f(x + w, y, 0);
  2503.    glTexCoord2f(1.0, 1.0); glVertex3f(x + w, y + h, 0);
  2504.    glTexCoord2f(0.0, 1.0); glVertex3f(x, y + h, 0);
  2505.    glEnd;
  2507.    glDisable(GL_TEXTURE_2D);
  2508.    SetBlendState(FBlend);
  2509.    glColor4fv(@FPenColor); // Restore color
  2510.    Result := Self;
  2511. end;
  2513. end.