{$WARN DUPLICATE_CTOR_DTOR OFF}
{$WARN PRIVATE_PROPACCESSOR OFF}

unit rgl;

interface

uses
  Windows, SysUtils, OpenGL, OpenGLext, Generics.Defaults, Generics.Collections,
  Messages, Graphics, Types, UITypes, Classes, Controls, Forms, ASObjects, ASNum,
  Dialogs, Menus, ExtCtrls, AppEvnts, TableDialog, VisCtl, VisCtl2D;

const
  // Note: programs sorted alphabetically; programs for transparent overlays start with "z"
  P_Default = 'default';
  P_UniformColorDefault = 'ucdef';
  P_Lighting = 'light';
  P_UniformColorLighting = 'uclight';
  P_UniformColorLightingUnisided = 'uclightus';
  P_UniformColorInfinity = 'ucinf';
  P_Tex = 'tex';
  P_Scatter = 'scatter';
  P_AdvScatter = 'advsca';
  P_VectorField = 'vf';
  P_Image = 'zimage';
  P_Text = 'ztext';

type
  TPPE = (ppIdentity, ppGreyscale, ppInvert, ppFlipH, ppFlipV, ppBinary,
    ppSpectra, ppEdgeDetect, ppBlur, ppSharpen, ppUnderwater);
  TPPEHelper = record helper for TPPE
    function ID: Integer;
    function Name: string;
    class function FromString(const S: string): TPPE; static;
  end;
  TPPEs = set of TPPE;

const
  AnimatedEffects: TPPEs = [ppUnderwater];

type
  TStockSurfaceIndex = (
    STOCKSURF_SPHERE   = 1,
    STOCKSURF_CYLINDER = 2,
    STOCKSURF_PLANE    = 3,
    STOCKSURF_DISK     = 4,
    STOCKSURF_SPHERELET= 5,
    STOCKSURF_ARROW    = 6
  );

type
  GLfloat2 = array[0..1] of GLfloat;
  GLfloat3 = array[0..2] of GLfloat;
  GLfloat4 = array[0..3] of GLfloat;
  GLfloat5 = array[0..4] of GLfloat;
  GLfloat6 = array[0..5] of GLfloat;
  GLfloat7 = array[0..6] of GLfloat;
  GLfloat9 = array[0..8] of GLfloat;
  GLfloat15 = array[0..14] of GLfloat;

  ERglError = class(Exception);

  rglv2 = record
    class operator Add(const Left, Right: rglv2): rglv2;
    class operator Subtract(const Left, Right: rglv2): rglv2;
    class operator Multiply(const Left: Single; const Right: rglv2): rglv2;
    class operator Multiply(const Left: rglv2; const Right: Single): rglv2;
    class operator Multiply(const Left, Right: rglv2): Single;
    class operator Divide(const Left: rglv2; const Right: Single): rglv2;
    class operator Equal(const Left, Right: rglv2): Boolean;
    class operator NotEqual(const Left, Right: rglv2): Boolean;
    class operator Implicit(const arr: GLfloat2): rglv2;
    class operator Implicit(const v: rglv2): GLfloat2;
    class operator Implicit(const v: TRealVector): rglv2;
    function Norm: Single;
    function Normalized: rglv2;
    function NormSquare: Single;
    constructor Create(const x, y: Single);
    function ptr: PGLfloat;
    class function Zero: rglv2; static;
    case Byte of
      0:
        (elem: GLfloat2);
      1:
        (x, y: GLfloat);
      2:
        (u, v: GLfloat);
      3:
        (s, t: GLfloat);
  end;

  rglv = record
    class operator Add(const Left, Right: rglv): rglv;
    class operator Subtract(const Left, Right: rglv): rglv;
    class operator Multiply(const Left: Single; const Right: rglv): rglv;
    class operator Multiply(const Left: rglv; const Right: Single): rglv;
    class operator Multiply(const Left, Right: rglv): Single;
    class operator Divide(const Left: rglv; const Right: Single): rglv;
    class operator Equal(const Left, Right: rglv): Boolean;
    class operator NotEqual(const Left, Right: rglv): Boolean;
    class operator LogicalXor(const Left, Right: rglv): rglv;
    class operator Implicit(const arr: GLfloat3): rglv;
    class operator Implicit(const v: rglv): GLfloat3;
    class operator Implicit(const c: TColor): rglv;
    class operator Implicit(const v: TRealVector): rglv;
    function xy: rglv2;
    function Norm: Single;
    function Normalized: rglv;
    function NormSquare: Single; inline;
    constructor Create(const x, y, z: Single);
    function ptr: PGLfloat;
    class function Zero: rglv; static;
    case Byte of
      0:
        (elem: GLfloat3);
      1:
        (x, y, z: GLfloat);
      2:
        (r, g, b: GLfloat);
      3:
        (s, t, p: GLfloat);
  end;

  TCartesianCoordinates = rglv;

  TSphericalCoordinates = record
    r, θ, φ: Single;
    class operator Implicit(const ACoords: TSphericalCoordinates): TCartesianCoordinates;
    class operator Implicit(const ACoords: TCartesianCoordinates): TSphericalCoordinates;
    class operator Equal(const Left, Right: TSphericalCoordinates): Boolean;
    class operator NotEqual(const Left, Right: TSphericalCoordinates): Boolean;
    class operator Add(const Left, Right: TSphericalCoordinates): TSphericalCoordinates;
    class operator Multiply(const Left: Single; Right: TSphericalCoordinates): TSphericalCoordinates;
    class function RealVectorAsSphericalCoordinates(const ARealVector: TRealVector): TSphericalCoordinates; static;
  end;

  rθφ = TSphericalCoordinates;

  rglv4 = record
    class operator Add(const Left, Right: rglv4): rglv4;
    class operator Subtract(const Left, Right: rglv4): rglv4;
    class operator Multiply(const Left: Single; const Right: rglv4): rglv4;
    class operator Multiply(const Left, Right: rglv4): Single;
    class operator Divide(const Left: rglv4; const Right: Single): rglv4;
    class operator Equal(const Left, Right: rglv4): Boolean;
    class operator NotEqual(const Left, Right: rglv4): Boolean;
    function Norm: Single;
    function Normalized: rglv4;
    function NormSquare: Single;
    constructor Create(const x, y, z, w: Single);
    function ptr: PGLfloat;
    class function Zero: rglv4; static;
    case Byte of
      0:
        (elem: GLfloat4);
      1:
        (x, y, z, w: GLfloat);
      2:
        (r, g, b, a: GLfloat);
      3:
        (s, t, p, q: GLfloat);
  end;

  rglm = record
  private const
    _dim = 3;
    _dimh = _dim - 1;
    _elemc = _dim * _dim;
    _elemh = _elemc - 1;
  public
    class operator Add(const Left, Right: rglm): rglm;
    class operator Subtract(const Left, Right: rglm): rglm;
    class operator Multiply(const Left: Single; const Right: rglm): rglm;
    class operator Multiply(const Left: rglm; const Right: rglv): rglv;
    class operator Multiply(const Left, Right: rglm): rglm;
    class operator Divide(const Left: rglm; const Right: Single): rglm;
    class operator Equal(const Left, Right: rglm): Boolean;
    class operator NotEqual(const Left, Right: rglm): Boolean;
    constructor Create(const m11, m12, m13, m21, m22, m23, m31, m32, m33: Single);
    constructor CreateFromColumns(const u, v, w: rglv);
    function ptr: PGLfloat;
    function Transpose: rglm;
    function Inverse: rglm;
    function ToString: string;
    class function Zero: rglm; static;
    class function Identity: rglm; static;
    case Boolean of
      False:
        (elem: array[0.._elemh] of GLfloat);
      True:
        (m: array[0.._dimh] of array [0.._dimh] of GLfloat);
  end;

  rglm4 = record
  private const
    _dim = 4;
    _dimh = _dim - 1;
    _elemc = _dim * _dim;
    _elemh = _elemc - 1;
  public
    class operator Add(const Left, Right: rglm4): rglm4;
    class operator Subtract(const Left, Right: rglm4): rglm4;
    class operator Multiply(const Left: Single; const Right: rglm4): rglm4;
    class operator Multiply(const Left: rglm4; const Right: rglv4): rglv4;
    class operator Multiply(const Left, Right: rglm4): rglm4;
    class operator Divide(const Left: rglm4; const Right: Single): rglm4;
    class operator Equal(const Left, Right: rglm4): Boolean;
    class operator NotEqual(const Left, Right: rglm4): Boolean;
    class operator Explicit(const Mat4: rglm4): rglm;
    class operator Explicit(const Mat: rglm): rglm4;
    constructor Create(const m11, m12, m13, m14, m21, m22, m23, m24, m31, m32, m33, m34,
      m41, m42, m43, m44: Single);
    function ptr: PGLfloat;
    function Transpose: rglm4;
    class function Identity: rglm4; static;
    case Boolean of
      False:
        (elem: array[0.._elemh] of GLfloat);
      True:
        (m: array[0.._dimh] of array [0.._dimh] of GLfloat);
  end;

  GLr3c3 = packed record // position, colour
    x, y, z,
    r, g, b: GLfloat
  end;

  GLr3c3v = packed record
    r, c: rglv;
  end;

  GLr3u3 = packed record // position, texture coords
    x, y, z,
    u, v: GLfloat
  end;

  GLr3u3v = packed record
    r: rglv;
    u: rglv2;
  end;

  GLr3c4 = packed record // position, alpha colour
    x, y, z,
    r, g, b, a: GLfloat
  end;

  GLr3c4v = packed record
    r: rglv;
    c: rglv4
  end;

  GLr3c3f1 = packed record // position, colour, float parameter
    x, y, z,
    r, g, b,
    q: GLfloat
  end;

  GLr3c3f1v = packed record
    r, c: rglv;
    q: GLfloat;
  end;

  GLr3n3 = packed record // position, normal
    x, y, z,
    u, v, w: GLfloat
  end;

  GLr3n3v = packed record
    r, n: rglv;
  end;

  GLr3v3 = packed record // position, vector
    x, y, z,
    u, v, w: GLfloat
  end;

  GLr3v3v = packed record
    r, v: rglv;
  end;

  GLr3c3n3 = packed record // position, colour, normal
    x, y, z,
    r, g, b,
    u, v, w: GLfloat
  end;

  GLr3c3n3v = packed record
    r, c, n: rglv;
  end;

  GLr3v3c3 = packed record // position, vector, colour
    x, y, z,
    u, v, w,
    r, g, b: GLfloat
  end;

  GLr3v3c3v = packed record
    r, v, c: rglv;
  end;

  GLr3m9c3v = packed record // position, 3×3 matrix, colour
    r: rglv;
    m: rglm;
    c: rglv;
  end;

function vec(const x, y, z: Single): rglv;
function vec2(const x, y: Single): rglv2;
function vec4(const x, y, z, w: Single): rglv4;
function mat(const m11, m12, m13, m21, m22, m23, m31, m32, m33: Single): rglm;
function mat4(const m11, m12, m13, m14, m21, m22, m23, m24, m31, m32, m33, m34,
  m41, m42, m43, m44: Single): rglm4;

function mat_transpose(const m11, m12, m13, m21, m22, m23, m31, m32, m33: Single): rglm;

const
  rglv_red:   rglv = (r: 1.0; g: 0.0; b: 0.0);
  rglv_green: rglv = (r: 0.0; g: 1.0; b: 0.0);
  rglv_blue:  rglv = (r: 0.0; g: 0.0; b: 1.0);
  rglv_black: rglv = (r: 0.0; g: 0.0; b: 0.0);
  rglv_white: rglv = (r: 1.0; g: 1.0; b: 1.0);

function rglLookAt(const eyeX, eyeY, eyeZ: Single;
  const centerX, centerY, centerZ: Single; const upX, upY, upZ: Single): rglm4; overload;
function rglLookAt(const eye, center, up: rglv): rglm4; overload;

function rglPerspective(const fovy, aspect, &near, &far: Double): rglm4;
function rglOrtho(const left, right, bottom, top, &near, &far: Double): rglm4;
function rglOrtho2D(const left, right, bottom, top: Double): rglm4;

function rglScale(const x, y, z: Single): rglm4;
function rglTranslate(const x, y, z: Single): rglm4; overload;
function rglTranslate(const v: rglv): rglm4; overload;
function rglRotate(const a, x, y, z: Single): rglm4; overload;
function rglRotate(const a: Single; const v: rglv): rglm4; overload;

function rglGetString(name: GLenum): string;

type
  TSurfParamFcn = function(const u, v: Double): rglv;
  TSurfParamColorFcn = function(const u, v: Double): rglv;
  TSurfParamNormalFcn = function(const u, v: Double): rglv;

  TCurveParamFcn = function(const t: Double): rglv;
  TCurveParamColorFcn = function(const t: Double): rglv;
  TCurveParamNormalFcn = function(const t: Double): rglv;

procedure TriangulateSurface(F: TSurfParamFcn;
  N: TSurfParamNormalFcn; const umin, umax, vmin, vmax: Double;
  A, B, pccx, pccy: Integer; Normalize: Boolean; out Vertices: TArray<GLfloat6>;
  out Indices, PCIs: TArray<GLuint>; PCOnly: Boolean; ListData: TArray<rglv>);

procedure TriangulateColoredSurface(F: TSurfParamFcn; C: TSurfParamColorFcn;
  N: TSurfParamNormalFcn; const umin, umax, vmin, vmax: Double;
  A, B, pccx, pccy: Integer; Normalize: Boolean; out Vertices: TArray<GLfloat9>;
  out Indices, PCIs: TArray<GLuint>; PCOnly: Boolean; ListData: TArray<GLr3c3v>);

type
  TParamSurfProc<vtype> = procedure(out Vertices: TArray<vtype>;
    out Indices, PCIs: TArray<GLuint>; A, B, pccx, pccy: Integer;
    PCOnly: Boolean; Data: Pointer);

  TSimpleParamSurfProc = TParamSurfProc<GLfloat6>;
  TColoredParamSurfProc = TParamSurfProc<GLfloat9>;

  TrglSphereMapType = (rglSphereMapPolar, rglSphereMapConstantArea);

procedure rglSpherePolar(out Vertices: TArray<GLfloat6>;
  out Indices, PCIs: TArray<GLuint>; A, B, pccx, pccy: Integer; PCOnly: Boolean;
  Data: Pointer);

procedure rglSphereConstArea(out Vertices: TArray<GLfloat6>;
  out Indices, PCIs: TArray<GLuint>; A, B, pccx, pccy: Integer; PCOnly: Boolean;
  Data: Pointer);

procedure rglCylinder(out Vertices: TArray<GLfloat6>;
  out Indices, PCIs: TArray<GLuint>; A, B, pccx, pccy: Integer; PCOnly: Boolean;
  Data: Pointer);

procedure rglCone(out Vertices: TArray<GLfloat6>;
  out Indices, PCIs: TArray<GLuint>; A, B, pccx, pccy: Integer; PCOnly: Boolean;
  Data: Pointer);

procedure rglPlane(out Vertices: TArray<GLfloat6>;
  out Indices, PCIs: TArray<GLuint>; A, B, pccx, pccy: Integer; PCOnly: Boolean;
  Data: Pointer);

procedure rglDisk(out Vertices: TArray<GLfloat6>;
  out Indices, PCIs: TArray<GLuint>; A, B, pccx, pccy: Integer; PCOnly: Boolean;
  Data: Pointer);

type
  TRglContext = class;

  TRglShader = class;
  TRglShaderClass = class of TRglShader;

  TShaderKind = (Vertex, Geometry, Fragment);

  TShaderKindHelper = record helper for TShaderKind
    function ToString: string;
    function RglClass: TRglShaderClass;
  end;

  TRglShader = class abstract
  private
    FContext: TRglContext;
    FKind: Cardinal;
    FHandle: Cardinal;
    FSource: AnsiString;
  public
    constructor Create(AContext: TRglContext; const ASource: string); virtual;
    destructor Destroy; override;
    procedure Compile;
    property Handle: Cardinal read FHandle;
    property Kind: Cardinal read FKind;
    property Source: AnsiString read FSource;
  end;

  TRglVertexShader = class(TRglShader)
    constructor Create(AContext: TRglContext; const ASource: string); override;
  end;

  TRglFragmentShader = class(TRglShader)
    constructor Create(AContext: TRglContext; const ASource: string); override;
  end;

  TRglGeometryShader = class(TRglShader)
    constructor Create(AContext: TRglContext; const ASource: string); override;
  end;

  TRglUniform = class abstract
  strict private
    FContext: TRglContext;
    FName: string;
    FHandle: Integer;
  private
    constructor Create; overload;
    constructor Create(AContext: TRglContext; AProgram: Cardinal;
      const AName: string); overload;
    class function TryCreate(AContext: TRglContext; AProgram: Cardinal;
      const AName: string): TRglUniform;
  public
    destructor Destroy; override;
    property Context: TRglContext read FContext;
    property Name: string read FName;
    property Handle: Integer read FHandle;
  end;

  TRglUniformClass = class of TRglUniform;

  TRglUniformFloat = class(TRglUniform)
    procedure SetValue(const AValue: GLfloat);
  end;

  TRglUniformFloatVec2 = class(TRglUniform)
    procedure SetValue(const AValue: rglv2); overload;
    procedure SetValue(const a0, a1: GLfloat); overload;
  end;

  TRglUniformFloatVec3 = class(TRglUniform)
    procedure SetValue(const AValue: rglv); overload;
    procedure SetValue(const a0, a1, a2: GLfloat); overload;
  end;

  TRglUniformFloatVec4 = class(TRglUniform)
    procedure SetValue(const AValue: rglv4); overload;
    procedure SetValue(const a0, a1, a2, a3: GLfloat); overload;
  end;

  TRglUniformFloatMat3 = class(TRglUniform)
    procedure SetValue(const AValue: rglm);
  end;

  TRglUniformFloatMat4 = class(TRglUniform)
    procedure SetValue(const AValue: rglm4);
  end;

  TRglUniformInt = class(TRglUniform)
    procedure SetValue(const AValue: GLint);
  end;

  TRglUniformUInt = class(TRglUniform)
    procedure SetValue(const AValue: GLuint);
  end;

  TRglUniformDouble = class(TRglUniform)
    procedure SetValue(const AValue: Double);
  end;

  TRglUniformBool = class(TRglUniform)
    procedure SetValue(const AValue: Boolean);
  end;

  TRglProgram = class
  strict private
    FContext: TRglContext;
    FShaders: TDictionary<Integer, AnsiString>;
    FHandle: Cardinal;
    FUniforms: TObjectList<TRglUniform>;
  public
    constructor Create(AContext: TRglContext);
    destructor Destroy; override;
    procedure AttachShader(AShader: TRglShader);
    procedure Link;
    function AddAttribute(const AName: string): Integer;
    function AddUniform<T: TRglUniform>(const AName: string): T;
    function TryAddUniform<T: TRglUniform>(const AName: string): T;
    procedure Use;
    procedure Unuse;
  end;

// Because the Delphi IDE doesn't understand the Delphi language.
//  TGLImplInfo = record
//    Version: record
//      Major, Minor: Integer
//    end;
//    VersionString: string;
//    Vendor: string;
//    Renderer: string;
//    GLSL: string;
//    ContextProfileMask: Integer;
//    ContextFlags: Integer;
//    LineWidths: record
//      Aliased, Smooth: packed record
//        Min, Max: Integer
//      end
//    end;
//    MaxSamples: Integer;
//    MaxTextureSize: Integer;
//    MaxTextureAnisotropy: GLfloat;
//  end;

  __version = record
    Major, Minor: Integer
  end;

  __range = packed record
    Min, Max: Integer
  end;

  __linewidths = record
    Aliased, Smooth: __range
  end;

  TGLImplInfo = record
    Version: __version;
    VersionString: string;
    Vendor: string;
    Renderer: string;
    GLSL: string;
    ContextProfileMask: Integer;
    ContextFlags: Integer;
    LineWidths: __linewidths;
    MaxSamples: Integer;
    MaxTextureSize: Integer;
    MaxTextureAnisotropy: GLfloat;
  end;

  TStockSurfaceData = record
    VertexData: GLuint;
    IndexData: GLuint;
    IndexCount: GLuint;
  end;

  TSolidModel = class;
  TSolidModelClass = class of TSolidModel;

  TSolidStoreRec = record
    VertexData: GLuint;
    Count: Integer;
    RefCnt: Integer;
  end;

  TDrawable3D = class;
  TDrawable3DClass = class of TDrawable3D;

  TRglContext = class
  strict private
    FWnd: HWND;
    FDC: HDC;
    FRC: HGLRC;
    class var FInstances: TList<TRglContext>;
    class constructor ClassCreate;
    class destructor ClassDestroy;
    class procedure DoMakeCurrent(DC: HDC; RC: HGLRC; const ACaller: string); static;
  private
    FStockSurfaces: TDictionary<TStockSurfaceIndex, TStockSurfaceData>;
    FStoredSolids: TDictionary<TDrawable3DClass, TSolidStoreRec>;
    FCustomBuffers: TObjectDictionary<TDrawable3DClass, TObject>;
    class var FCurrentDC: HDC;
    class var FCurrentRC: HGLRC;
  public
    constructor Create(AWnd: HWND);
    destructor Destroy; override;
    procedure SwapBuffers;
    function GetExtensionNames: TArray<string>;
    function GetImplInfo: TGLImplInfo;
    procedure MakeCurrent(const ACaller: string); overload; inline;
    class procedure MakeCurrent(DC: HDC; RC: HGLRC; const ACaller: string); overload; static; inline;
    function TryMakeCurrent: Boolean; overload;
    class function TryMakeCurrent(DC: HDC; RC: HGLRC): Boolean; overload; static; inline;
    class function GlobalCount: Integer;
  end;

  TRglControl = class(TVisCtl)
  strict private
    FContext: TRglContext;
    FClearMask: Cardinal;
    FGlCtlColor: rglv;
    FPrevTick: Int64;
    FFPS: Double;
    function GetAspectRatio: Double;
  private
    FPerfFreq: Int64;
  protected
    procedure ApplyClearColor;
    procedure Resize; override;
    procedure CreateWnd; override;
    procedure DestroyWnd; override;
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
    procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;
    procedure WMDestroy(var Message: TWMDestroy); message WM_DESTROY;
    procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
    procedure GLInit; virtual;
    procedure CreateParams(var Params: TCreateParams); override;
    property ClearMask: Cardinal read FClearMask write FClearMask;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Context: TRglContext read FContext;
    property FPS: Double read FFPS;
    property AspectRatio: Double read GetAspectRatio;
  published
    property Color;
  end;

  TDrawableOptionsFrm3D = class(TForm)
  protected
    FInitialized: Boolean;
    FDrawable: TDrawable3D;
    FOnChange: TNotifyEvent;
    procedure DrawableDestroyed(Sender: TObject);
  public
    constructor Create(AOwner: TComponent; ADrawable: TDrawable3D); reintroduce; virtual;
    procedure Reassign(ADrawable: TDrawable3D);
    procedure Initialize; virtual;
    property Initialized: Boolean read FInitialized;
    procedure UpdateDrawable; virtual;
    property Drawable: TDrawable3D read FDrawable;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
  end;

  TDrawableOptionsFrmClass3D = class of TDrawableOptionsFrm3D;

  TVisCtl3D = class;

  TDrawable3D = class(TVisObj)
  strict private
    class var FInstances: TDictionary<TGUID, TDrawable3D>;
    class var FModalLevel: Integer;
    class procedure InstanceListChanged(Sender: TObject; const Item: TGUID;
      Action: TCollectionNotification);
    class constructor ClassCreate;
    class destructor ClassDestroy;
  public
    class function TryGetDrawableByGUID(const AGUID: TGUID;
      out ADrawable: TDrawable3D): Boolean; static;
    class property ModalLevel: Integer read FModalLevel;
    class function Verify(ADrawable: TDrawable3D): Boolean; static;
    class property Instances: TDictionary<TGUID, TDrawable3D> read FInstances;
    class function GetRealm: string; override; final;
  protected
    FTag: NativeInt;
    FVisible: Boolean;
    FCtl: TVisCtl3D;
    FDefaultProgram: string;
    FLineWidth: Single;
    FAnimationSpeed: Double;
    FOnChange: TNotifyEvent;
    FOptionsFrmClass: TDrawableOptionsFrmClass3D;
    FParent: TDrawable3D;
    FChildren: TList<TDrawable3D>;
    FParentTag: NativeUInt;
    function TryContextCurrent: Boolean;
  private
    FProtected: Boolean;
    procedure SetVisible(const Value: Boolean);
    procedure Draw(const AGlobalTime: Double); virtual;
    procedure Setup; virtual;
    procedure Recreate; virtual;
    procedure ProjectionChanged; virtual;
    function GetChild(Index: Integer): TDrawable3D;
    function GetChildCount: Integer;
    property DefaultProgram: string read FDefaultProgram;
    procedure SetAnimationSpeed(const Value: Double);
    function GetDisplayed: Boolean;
  protected
    procedure Changed; overload; inline;
    procedure Changed(Sender: TObject); overload; inline;
    procedure FreeGLResources; virtual;
    procedure GLRelease; virtual;
    function GetLineWidth: Single; virtual;
    procedure SetLineWidth(const Value: Single); virtual;
  public
    constructor Create(ACtl: TVisCtl3D); virtual;
    destructor Destroy; override;
    procedure ShowOptionsForm(AParent: TCustomForm = nil); override;
    procedure Configure(ASettings: TAlgosimStructure); virtual;
    function CreateChild<T: TDrawable3D>: T;
    procedure DeleteChild(AChild: TDrawable3D);
    procedure DeleteChildren(ATagMask: NativeUInt);
    function CreateReference: TAlgosimReference; virtual;
    property AnimationSpeed: Double read FAnimationSpeed write SetAnimationSpeed;
    property ChildCount: Integer read GetChildCount;
    property Children[Index: Integer]: TDrawable3D read GetChild;
    property Control: TVisCtl3D read FCtl;
    property Visible: Boolean read FVisible write SetVisible;
    property Displayed: Boolean read GetDisplayed;
    property LineWidth: Single read GetLineWidth write SetLineWidth;
    property Parent: TDrawable3D read FParent;
    property Tag: NativeInt read FTag write FTag;
    property OptionsFormClass: TDrawableOptionsFrmClass3D read FOptionsFrmClass write FOptionsFrmClass;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
  end;

  TDrawableList3D = class(TDrawable3D)
  strict private
    FList: TObjectList<TDrawable3D>;
    FSortedList: TList<TDrawable3D>;
    FTimeDependent: Boolean;
    FAlphaBlending: Boolean;
    FPrevCameraPos: rglv;
    FStencilIDs: array[Byte] of Pointer;
    FSortOrderDirty: Boolean;
    function GetItem(Index: Integer): TDrawable3D;
    procedure SetItem(Index: Integer; const Value: TDrawable3D);
    function GetItemCount: Integer;
    procedure ObjsNotify(Sender: TObject; const Item: TDrawable3D;
      Action: TCollectionNotification);
    procedure Resort;
  private
    procedure Draw(const AGlobalTime: Double); override;
    function GetObjFromStencilID(AStencilID: Byte): TDrawable3D;
  protected
    procedure FreeGLResources; override;
    procedure GLRelease; override;
  public
    constructor Create(ACtl: TVisCtl3D); override;
    destructor Destroy; override;
    procedure MoveUp(ADrawable: TDrawable3D);
    procedure MoveDown(ADrawable: TDrawable3D);
    property List: TObjectList<TDrawable3D> read FList;
    property Items[Index: Integer]: TDrawable3D read GetItem write SetItem; default;
    property ItemCount: Integer read GetItemCount;
    property TimeDependent: Boolean read FTimeDependent;
  end;

  TScene = class(TDrawable3D)
  public
    constructor Create(ACtl: TVisCtl3D); override;
    function CreateReference: TAlgosimReference; override;
    procedure Configure(ASettings: TAlgosimStructure); override;
  end;

  TRefAxes = class(TDrawable3D)
  strict private
    const N = 64;
    var FVertexData: GLuint;
    var FVAO: GLuint;
  private
    procedure Draw(const AGlobalTime: Double); override;
    procedure Setup; override;
  protected
    procedure FreeGLResources; override;
    procedure GLRelease; override;
  public
    constructor Create(ACtl: TVisCtl3D); override;
    destructor Destroy; override;
  end;

  TGeometricObject3D = class(TDrawable3D)
  private
    FColor: TColor;
    FPosition: rglv;
    FDirection: rglv;
    FScale: rglv;
    FRotation: Single;
    FObjectMatrix: rglm4;
    FNormalMatrix: rglm;
    FManualMatrix: rglm4;
    FUseManualMatrix: Boolean;
    FColorNotApplicable: Boolean;
    function GetColor: TColor; virtual;
    procedure SetColor(const Value: TColor); virtual;
    procedure SetPosition(const Value: rglv);
    procedure SetDirection(const Value: rglv);
    procedure SetScale(const Value: rglv);
    procedure SetRotation(const Value: Single);
  private
    procedure ComputeOM; virtual;
    procedure Draw(const AGlobalTime: Double); override;
    procedure SetManualMatrix(const Value: rglm4); overload;
    procedure SetUseManualMatrix(const Value: Boolean);
  public
    constructor Create(ACtl: TVisCtl3D); override;
    procedure Assign(Source: TPersistent); override;
    procedure Configure(ASettings: TAlgosimStructure); override;
    procedure SetManualMatrix; overload;
    property Color: TColor read GetColor write SetColor;
    property Position: rglv read FPosition write SetPosition;
    property Direction: rglv read FDirection write SetDirection;
    property Scale: rglv read FScale write SetScale;
    property Rotation: Single read FRotation write SetRotation;
    property ManualMatrix: rglm4 read FManualMatrix write SetManualMatrix;
    property UseManualMatrix: Boolean read FUseManualMatrix write SetUseManualMatrix;
    property ColorNotApplicable: Boolean read FColorNotApplicable;
  end;

  TParamCurveFamilySize = record
    nx, ny: Integer;
    class operator Equal(const Left, Right: TParamCurveFamilySize): Boolean;
    class operator NotEqual(const Left, Right: TParamCurveFamilySize): Boolean;
    class operator Implicit(const AValue: Integer): TParamCurveFamilySize;
    class operator Implicit(const AValue: TSize): TParamCurveFamilySize;
    class operator Implicit(const AValue: rglv2): TParamCurveFamilySize;
    constructor Create(X, Y: Integer);
  end;

  TAbstractSurface3D = class abstract(TGeometricObject3D)
  private
    FShowSurface: Boolean;
    FShowParameterCurves: Boolean;
    FLineColor: TColor;
    FParamCurveCounts: TParamCurveFamilySize;
    FUnisided: Boolean;
  private
    procedure RecreateParamCurves; virtual;
    procedure SetShowParameterCurves(const Value: Boolean);
    procedure SetShowSurface(const Value: Boolean);
    procedure UpdateDefProgram; virtual;
    procedure SetLineColor(const Value: TColor);
    procedure SetParamCurveCounts(const Value: TParamCurveFamilySize);
    procedure SetUnisided(const Value: Boolean);
  public
    constructor Create(ACtl: TVisCtl3D); override;
    procedure Assign(Source: TPersistent); override;
    procedure Configure(ASettings: TAlgosimStructure); override;
    property LineColor: TColor read FLineColor write SetLineColor;
    property ShowSurface: Boolean read FShowSurface write SetShowSurface;
    property ShowParameterCurves: Boolean read FShowParameterCurves write SetShowParameterCurves;
    property Unisided: Boolean read FUnisided write SetUnisided;
    property ParamCurveCounts: TParamCurveFamilySize read FParamCurveCounts write SetParamCurveCounts;
  end;

  TSurface3D<vtype> = class abstract(TAbstractSurface3D)
  private
    FVertexData: GLuint;
    FIndexData: GLuint;
    FPCIData: GLuint;
    FIndexCount: Integer;
    FPCICount: Integer;
    FVAO: GLuint;
    FSurfProgram: string;
    FSurfProgramUnisided: string;
    FCurveProgram: string;
  var
    FStockSurface: Boolean;
    FStockID: TStockSurfaceIndex;
  private
    procedure Setup; override;
    procedure Draw(const AGlobalTime: Double); override;
    procedure RecreateParamCurves; override;
    procedure UpdateDefProgram; override;
  protected
    FSurfProc: TParamSurfProc<vtype>;
  protected
    procedure FreeGLResources; override;
    procedure GLRelease; override;
  public
    destructor Destroy; override;
  end;

  TBasicSurface3D = class abstract(TSurface3D<GLfloat6>)
    constructor Create(ACtl: TVisCtl3D); override;
  end;

  TColoredSurface3D = class abstract(TSurface3D<GLfloat9>)
    constructor Create(ACtl: TVisCtl3D); override;
  end;

  TRectDom = record
    umin, umax,
    vmin, vmax: Double;
    class operator Equal(const Left, Right: TRectDom): Boolean;
    class operator NotEqual(const Left, Right: TRectDom): Boolean;
    constructor Create(const umin, umax, vmin, vmax: Double);
  end;

  TCustomSurface = class(TBasicSurface3D)
  strict private
    FSurfaceFunction: TSurfParamFcn;
    FData: TArray<rglv>;
    FDomain: TRectDom;
    procedure SetDomain(const Value: TRectDom);
    procedure SetSurfaceFunction(const Value: TSurfParamFcn);
    procedure SetData(const Value: TArray<rglv>);
    class procedure SurfProc(out Vertices: TArray<GLfloat6>;
      out Indices, PCIs: TArray<GLuint>; A, B, pccx, pccy: Integer;
      PCOnly: Boolean; Data: Pointer); static;
  private
    procedure Recreate; override;
  public
    Nx, Ny: Integer;
    constructor Create(ACtl: TVisCtl3D); override;
    property SurfaceFunction: TSurfParamFcn read FSurfaceFunction write SetSurfaceFunction;
    property Data: TArray<rglv> read FData write SetData;
    property Domain: TRectDom read FDomain write SetDomain;
  end;

  TCustomColoredSurface = class(TColoredSurface3D)
  strict private
    FSurfaceFunction: TSurfParamFcn;
    FSurfaceColorFunction: TSurfParamColorFcn;
    FData: TArray<glr3c3v>;
    FDomain: TRectDom;
    procedure SetDomain(const Value: TRectDom);
    procedure SetSurfaceFunction(const Value: TSurfParamFcn);
    procedure SetSurfaceColorFunction(const Value: TSurfParamColorFcn);
    procedure SetData(const Value: TArray<GLr3c3v>);
    class procedure SurfProc(out Vertices: TArray<GLfloat9>;
      out Indices, PCIs: TArray<GLuint>; A, B, pccx, pccy: Integer;
      PCOnly: Boolean; Data: Pointer); static;
  private
    procedure Recreate; override;
  public
    Nx, Ny: Integer;
    constructor Create(ACtl: TVisCtl3D); override;
    property SurfaceFunction: TSurfParamFcn read FSurfaceFunction
      write SetSurfaceFunction;
    property SurfaceColorFunction: TSurfParamColorFcn read FSurfaceColorFunction
      write SetSurfaceColorFunction;
    property Data: TArray<GLr3c3v> read FData write SetData;
    property Domain: TRectDom read FDomain write SetDomain;
  end;

  TEllipsoid = class(TBasicSurface3D)
  private
    FScale: rglv;
    procedure SetScale(const Value: rglv);
  public
    constructor Create(ACtl: TVisCtl3D); override;
    procedure Configure(ASettings: TAlgosimStructure); override;
    property AxisLengths: rglv read FScale write SetScale;
  end;

  TSphere = class(TEllipsoid)
  private
    function GetRadius: Single;
    procedure SetRadius(const Value: Single);
  public
    constructor Create(ACtl: TVisCtl3D); override;
    property Radius: Single read GetRadius write SetRadius;
  end;

  TCylinder = class(TBasicSurface3D)
  private
    function GetAxisLengths: rglv2;
    function GetHeight: Single;
    procedure SetAxisLengths(const Value: rglv2);
    procedure SetHeight(const Value: Single);
    function GetRadius: Single;
    procedure SetRadius(const Value: Single);
  public
    constructor Create(ACtl: TVisCtl3D); override;
    procedure Configure(ASettings: TAlgosimStructure); override;
    property AxisLengths: rglv2 read GetAxisLengths write SetAxisLengths;
    property Height: Single read GetHeight write SetHeight;
    property Radius: Single read GetRadius write SetRadius;
  end;

  TCone = class(TBasicSurface3D)
  private
    function GetAxisLengths: rglv2;
    function GetHeight: Single;
    procedure SetAxisLengths(const Value: rglv2);
    procedure SetHeight(const Value: Single);
  public
    constructor Create(ACtl: TVisCtl3D); override;
    procedure Configure(ASettings: TAlgosimStructure); override;
    property AxisLengths: rglv2 read GetAxisLengths write SetAxisLengths;
    property Height: Single read GetHeight write SetHeight;
  end;

  TPlane = class(TBasicSurface3D)
  public
    constructor Create(ACtl: TVisCtl3D); override;
  end;

  TInfinitePlane = class(TAbstractSurface3D)
  private
    FVertexData: GLuint;
    FIndexData: GLuint;
    FPCIData: GLuint;
    FIndexCount: Integer;
    FPCICount: Integer;
    FVAO: GLuint;
  private
    procedure Setup; override;
    procedure Recreate; override;
    procedure Draw(const AGlobalTime: Double); override;
  protected
    procedure FreeGLResources; override;
    procedure GLRelease; override;
  public
    constructor Create(ACtl: TVisCtl3D); override;
    destructor Destroy; override;
  end;

  TDisk = class(TBasicSurface3D)
  private
    function GetRadius: Single;
    procedure SetRadius(const Value: Single);
  public
    constructor Create(ACtl: TVisCtl3D); override;
    procedure Configure(ASettings: TAlgosimStructure); override;
    property Radius: Single read GetRadius write SetRadius;
  end;

  TInterval = record
    a, b: Double;
    class operator Equal(const Left, Right: TInterval): Boolean;
    class operator NotEqual(const Left, Right: TInterval): Boolean;
    constructor Create(const a, b: Double);
  end;

  TCurve3D = class(TGeometricObject3D)
  strict private
    FVertexData: GLuint;
    FCount: Integer;
    FCurveFunction: TCurveParamFcn;
    FData: TArray<rglv>;
    FDomain: TInterval;
    FVAO: GLuint;
    procedure SetDomain(const Value: TInterval);
    procedure SetCurveFunction(const Value: TCurveParamFcn);
    procedure SetData(const Value: TArray<rglv>);
    procedure Sample(out Vertices: TArray<rglv>);
  private
    procedure Recreate; override;
  private
    procedure Setup; override;
    procedure Draw(const AGlobalTime: Double); override;
  protected
    procedure FreeGLResources; override;
    procedure GLRelease; override;
  public
    constructor Create(ACtl: TVisCtl3D); override;
    destructor Destroy; override;
    property CurveFunction: TCurveParamFcn read FCurveFunction write SetCurveFunction;
    property Data: TArray<rglv> read FData write SetData;
    property Domain: TInterval read FDomain write SetDomain;
  end;

  TColoredCurve3D = class(TGeometricObject3D)
  strict private
    FVertexData: GLuint;
    FCount: Integer;
    FCurveFunction: TCurveParamFcn;
    FCurveColorFunction: TCurveParamColorFcn;
    FData: TArray<GLr3c3v>;
    FDomain: TInterval;
    FVAO: GLuint;
    procedure SetDomain(const Value: TInterval);
    procedure SetCurveFunction(const Value: TCurveParamFcn);
    procedure SetCurveColorFunction(const Value: TCurveParamColorFcn);
    procedure SetData(const Value: TArray<GLr3c3v>);
    procedure Sample(out Vertices: TArray<GLr3c3v>);
  private
    procedure Recreate; override;
  private
    procedure Setup; override;
    procedure Draw(const AGlobalTime: Double); override;
  protected
    procedure FreeGLResources; override;
    procedure GLRelease; override;
  public
    constructor Create(ACtl: TVisCtl3D); override;
    destructor Destroy; override;
    property CurveFunction: TCurveParamFcn read FCurveFunction write SetCurveFunction;
    property CurveColorFunction: TCurveParamColorFcn read FCurveColorFunction
      write SetCurveColorFunction;
    property Data: TArray<GLr3c3v> read FData write SetData;
    property Domain: TInterval read FDomain write SetDomain;
  end;

  TScatterPlot = class abstract(TGeometricObject3D)
  private
    FVertexData: GLuint;
    FIndexData: GLuint;
    FIndexCount: Integer;
    FVAO: GLuint;
    FInstanceData: GLuint;
    FSize: Single;
    procedure MakeBaseMarker;
    procedure SetSize(const Value: Single);
    procedure Recreate; override;
    procedure Draw(const AGlobalTime: Double); override;
  protected
    procedure FreeGLResources; override;
    procedure GLRelease; override;
  public
    constructor Create(ACtl: TVisCtl3D); override;
    destructor Destroy; override;
    procedure Configure(ASettings: TAlgosimStructure); override;
    property Size: Single read FSize write SetSize;
  end;

  TSimpleScatterPlot = class(TScatterPlot)
  private
    FPoints: TArray<GLfloat3>;
  private
    procedure Setup; override;
    procedure Draw(const AGlobalTime: Double); override;
    procedure SetPoints(const Value: TArray<GLfloat3>); overload;
    procedure SetPoints(const Value: TArray<TASR3>); overload;
  public
    constructor Create(ACtl: TVisCtl3D); override;
    property Data: TArray<GLfloat3> write SetPoints;
    property DataAsDoubles: TArray<TASR3> write SetPoints;
  end;

  TAdvScatterPlot = class(TScatterPlot)
  private
    FPoints: TArray<GLfloat7>;
  private
    procedure Setup; override;
    procedure Draw(const AGlobalTime: Double); override;
    procedure SetPoints(const Value: TArray<GLfloat7>); overload;
    procedure SetPoints(const Value: TArray<Double>); overload;
  public
    constructor Create(ACtl: TVisCtl3D); override;
    property Data: TArray<GLfloat7> write SetPoints;
    property DataAsDoubles: TArray<Double> write SetPoints;
  end;

  TVectorField = class(TGeometricObject3D)
  private class var
    FVertexCount: Integer;
  var
    FVertexData: GLuint;
    FVAO: GLuint;
    FInstanceData: GLuint;
    FSize: Single;
    FVectors: TArray<GLr3v3c3v>;
    FMaxNorm: Single;
    FAttribColors: Boolean;
    FAnchorPoint: Single;
    procedure MakeBaseArrow;
    class function MakeMatrix(const AVector: rglv): rglm; static;
    class function Prepare(const AVectors: TArray<GLr3v3c3v>;
      out AMaxNorm: Single): TArray<GLfloat15>; static;
    procedure SetSize(const Value: Single);
    procedure SetVectors(const Value: TArray<GLr3v3c3v>);
    procedure SetAttribColors(const Value: Boolean);
    procedure SetAnchorPoint(const Value: Single);
  private
    procedure Setup; override;
    procedure Draw(const AGlobalTime: Double); override;
    procedure Recreate; override;
  protected
    procedure FreeGLResources; override;
    procedure GLRelease; override;
  public
    constructor Create(ACtl: TVisCtl3D); override;
    destructor Destroy; override;
    procedure Configure(ASettings: TAlgosimStructure); override;
    property Size: Single read FSize write SetSize;
    property Data: TArray<GLr3v3c3v> write SetVectors;
    property PerVertexColors: Boolean read FAttribColors write SetAttribColors;
    property AnchorPoint: Single read FAnchorPoint write SetAnchorPoint;
  end;

  TTransparentColorMode = (tcmOff, tcmEqual, tcmDistance, tcmBipolar);

  TTransparentColorModeHelper = record helper for TTransparentColorMode
    function ToString: string;
    class function FromString(const S: string): TTransparentColorMode; static;
  end;

  TImageRect = class(TGeometricObject3D)
  private
    FTexture: GLuint;
    FVertexData: GLuint;
    FVAO: GLuint;
    FBitmap: TBitmap;
    FTransparentColor: TColor;
    FOpaqueColor: TColor;
    FTransparentColorMode: TTransparentColorMode;
  private
    procedure Setup; override;
    procedure Draw(const AGlobalTime: Double); override;
    procedure Recreate; override;
    procedure BitmapChanged(Sender: TObject);
    procedure SetBitmap(const Value: TBitmap);
    procedure SetTransparentColor(const Value: TColor);
    procedure SetOpaqueColor(const Value: TColor);
    procedure SetTransparentColorMode(const Value: TTransparentColorMode);
  protected
    procedure FreeGLResources; override;
    procedure GLRelease; override;
  public
    constructor Create(ACtl: TVisCtl3D); override;
    destructor Destroy; override;
    procedure Configure(ASettings: TAlgosimStructure); override;
    property Bitmap: TBitmap read FBitmap write SetBitmap;
    property TransparentColor: TColor read FTransparentColor write SetTransparentColor;
    property OpaqueColor: TColor read FOpaqueColor write SetOpaqueColor;
    property TransparentColorMode: TTransparentColorMode read FTransparentColorMode
      write SetTransparentColorMode;
  end;

  TTextRect = class(TGeometricObject3D)
  private
    FTexture: GLuint;
    FVertexData: GLuint;
    FVAO: GLuint;
    FText: string;
    FFont: TFont;
    FAspect: Double;
    FTextResFactor: Double;
    FHighQuality: Boolean;
    FOpacity: Double;
    FAnchorPoint: TAnchorPoint;
    FDisplacement: rglv2;
    FFaceScreen: Boolean;
    procedure SetAnchorPoint(const Value: TAnchorPoint);
    procedure SetText(const Value: string);
    procedure SetFont(const Value: TFont);
    procedure SetOpacity(const Value: Double);
    procedure SetDisplacement(const Value: rglv2);
    procedure SetFaceScreen(const Value: Boolean);
    procedure FontChanged(Sender: TObject);
    procedure SetTextResFactor(const Value: Double);
    procedure SetHighQuality(const Value: Boolean);
    function MakeBitmap: TBitmap;
  private
    procedure Setup; override;
    procedure Draw(const AGlobalTime: Double); override;
    procedure Recreate; override;
  protected
    procedure FreeGLResources; override;
    procedure GLRelease; override;
  public
    constructor Create(ACtl: TVisCtl3D); override;
    destructor Destroy; override;
    procedure Configure(ASettings: TAlgosimStructure); override;
    property AnchorPoint: TAnchorPoint read FAnchorPoint write SetAnchorPoint;
    property Font: TFont read FFont write SetFont;
    property Text: string read FText write SetText;
    property Aspect: Double read FAspect;
    property TextResFactor: Double read FTextResFactor write SetTextResFactor;
    property HighQuality: Boolean read FHighQuality write SetHighQuality;
    property Opacity: Double read FOpacity write SetOpacity;
    property FaceScreen: Boolean read FFaceScreen write SetFaceScreen;
    property Displacement: rglv2 read FDisplacement write SetDisplacement;
  end;

  TAxis = class(TGeometricObject3D)
  private
  const
    PTAG_AXISLABEL = 1;
  var
    FCylinder: TCylinder;
    FLabels: Boolean;
    FLabelFont: TFont;
    FLabelDelta: Double;
    FNegativeLength: Double;
    FLength: Double;
    FRadius: Double;
    FLabelFormat: string;
    procedure FontChange(Sender: TObject);
    procedure SetLabelDelta(const Value: Double);
    procedure SetLabelFont(const Value: TFont);
    procedure SetLabels(const Value: Boolean);
    procedure SetLength(const Value: Double);
    procedure SetNegativeLength(const Value: Double);
    procedure SetRadius(const Value: Double);
    procedure SetLabelFormat(const Value: string);
    procedure SetupLabels;
    function GetColor: TColor; override;
    procedure SetColor(const Value: TColor); override;
  private
    FIndex: Integer;
    function AxisName: string;
    procedure Setup; override;
    procedure Recreate; override;
    procedure ProjectionChanged; override;
  public
    constructor Create(ACtl: TVisCtl3D); override;
    function CreateReference: TAlgosimReference; override;
    procedure Configure(ASettings: TAlgosimStructure); override;
    destructor Destroy; override;
    function FormatAxisLabel(const AFormat: string; const AValue: Double): string;
    property Labels: Boolean read FLabels write SetLabels;
    property LabelFont: TFont read FLabelFont write SetLabelFont;
    property LabelFormat: string read FLabelFormat write SetLabelFormat;
    property LabelDelta: Double read FLabelDelta write SetLabelDelta;
    property Length: Double read FLength write SetLength;
    property NegativeLength: Double read FNegativeLength write SetNegativeLength;
    property Radius: Double read FRadius write SetRadius;
  end;

  TGrid = class(TGeometricObject3D)
  private
  const
    PTAG_GRIDLABEL = 2;
  var
    FVertexData: GLuint;
    FCount: Integer;
    FVAO: GLuint;
    FXMin, FXMax, FXDelta: Double;
    FYMin, FYMax, FYDelta: Double;
  private
    FIndex: Integer;
    procedure Setup; override;
    procedure Draw(const AGlobalTime: Double); override;
    procedure Recreate; override;
    procedure SetXDelta(const Value: Double);
    procedure SetXMax(const Value: Double);
    procedure SetXMin(const Value: Double);
    procedure SetYDelta(const Value: Double);
    procedure SetYMax(const Value: Double);
    procedure SetYMin(const Value: Double);
  protected
    procedure FreeGLResources; override;
    procedure GLRelease; override;
  public
    constructor Create(ACtl: TVisCtl3D); override;
    destructor Destroy; override;
    procedure Configure(ASettings: TAlgosimStructure); override;
    property XMin: Double read FXMin write SetXMin;
    property XMax: Double read FXMax write SetXMax;
    property XDelta: Double read FXDelta write SetXDelta;
    property YMin: Double read FYMin write SetYMin;
    property YMax: Double read FYMax write SetYMax;
    property YDelta: Double read FYDelta write SetYDelta;
  end;

  TAxes = class(TGeometricObject3D)
  private
    FXAxis,
    FYAxis,
    FZAxis: TAxis;
  private
    procedure AxisChanged(Sender: TObject);
    procedure GridChanged(Sender: TObject);
  private
    procedure SetXAxis(const Value: TAxis);
    procedure SetYAxis(const Value: TAxis);
    procedure SetZAxis(const Value: TAxis);
    function GetGridCount: Integer;
    procedure SetGridCount(const Value: Integer);
  public
    constructor Create(ACtl: TVisCtl3D); override;
    function CreateReference: TAlgosimReference; override;
    procedure Configure(ASettings: TAlgosimStructure); override;
    property X: TAxis read FXAxis write SetXAxis;
    property Y: TAxis read FYAxis write SetYAxis;
    property Z: TAxis read FZAxis write SetZAxis;
    property GridCount: Integer read GetGridCount write SetGridCount;
  end;

  TSolidModel = class abstract(TGeometricObject3D)
  private
    FVertexData: GLuint;
    FCount: Integer;
    FVAO: GLuint;
    class var FSolidClasses: TDictionary<string, TDrawable3DClass>;
    class procedure RegisterClass(const AClass: TDrawable3DClass;
      const AName: string); static;
    class constructor ClassCreate;
    class destructor ClassDestroy;
  private
    procedure Setup; override;
    procedure Recreate; override;
    procedure Draw(const AGlobalTime: Double); override;
    procedure MakeBaseBuffer; virtual;
  protected
    Stored: Boolean;
    function ModelClass: TSolidModelClass;
  protected
    procedure FreeGLResources; override;
    procedure GLRelease; override;
  public
    constructor Create(ACtl: TVisCtl3D); override;
    destructor Destroy; override;
    class function FromString(const S: string): TDrawable3DClass; static;
    class function TryFromString(const S: string;
      out AClass: TDrawable3DClass): Boolean; static;
  end;

  TObjModel = class(TSolidModel)
  private
    FSource: string;
    FBuf: TArray<GLfloat6>;
    procedure MakeBaseBuffer; override;
  public
    constructor Create(ACtl: TVisCtl3D); override;
    procedure Configure(ASettings: TAlgosimStructure); override;
    procedure LoadModel(const AData: string); overload;
    procedure LoadModel(const AData: TArray<string>); overload;
    procedure LoadModelFromFile(const AFileName: TFileName); overload;
    procedure LoadModelFromFile(const AFileName: TFileName;
      const Encoding: TEncoding); overload;
    property Source: string read FSource write LoadModel;
  end;

  TRawModel = class abstract(TSolidModel)
  private
    procedure MakeBaseBuffer; override; final;
  protected
    function GetRawData: TArray<GLfloat6>; virtual;
  end;

  TSolidCube = class(TRawModel)
  protected
    function GetRawData: TArray<GLfloat6>; override;
  public
    constructor Create(ACtl: TVisCtl3D); override;
  end;

  TSolidCylinder = class(TGeometricObject3D)
  private
  type
    TBufferStoreKey = packed record
      InnerRadius: Double;
      Angle: Double;
    end;
    TBufferStoreItem = record
      InnerRadius: Double;
      Angle: Double;
      VertexData: GLuint;
      Counts: TArray<Integer>;
      TwoSides: Boolean;
      RefCnt: Integer;
    end;
  var
    FBSK: TBufferStoreKey;
    FVertexData: GLuint;
    FCounts: TArray<Integer>;
    FTwoSides: Boolean;
    FVAO: GLuint;
    FAngle: Double;
    FInnerRadius: Double;
    function GetAxisLengths: rglv2;
    function GetHeight: Single;
    procedure SetAxisLengths(const Value: rglv2);
    procedure SetHeight(const Value: Single);
    function GetRadius: Single;
    procedure SetRadius(const Value: Single);
    procedure SetAngle(const Value: Double);
    procedure SetInnerRadiusFraction(const Value: Double);
    procedure ConstructBufferSinHole;
    procedure ConstructBufferConHole;
    procedure GetBufferData;
    procedure ReleaseBuffer;
  private
    procedure Setup; override;
    procedure Recreate; override;
    procedure Draw(const AGlobalTime: Double); override;
  protected
    procedure FreeGLResources; override;
    procedure GLRelease; override;
  public
    constructor Create(ACtl: TVisCtl3D); override;
    destructor Destroy; override;
    procedure Configure(ASettings: TAlgosimStructure); override;
    property Angle: Double read FAngle write SetAngle;
    property AxisLengths: rglv2 read GetAxisLengths write SetAxisLengths;
    property Height: Single read GetHeight write SetHeight;
    property Radius: Single read GetRadius write SetRadius;
    property InnerRadiusFraction: Double read FInnerRadius write SetInnerRadiusFraction;
  end;

  TSolidCone = class(TGeometricObject3D)
  private
    FVertexData: GLuint;
    FCount: Integer;
    FVAO: GLuint;
    function GetAxisLengths: rglv2;
    function GetHeight: Single;
    procedure SetAxisLengths(const Value: rglv2);
    procedure SetHeight(const Value: Single);
    function GetRadius: Single;
    procedure SetRadius(const Value: Single);
    procedure MakeBaseBuffer;
  private
    procedure Setup; override;
    procedure Recreate; override;
    procedure Draw(const AGlobalTime: Double); override;
  protected
    procedure FreeGLResources; override;
    procedure GLRelease; override;
  public
    constructor Create(ACtl: TVisCtl3D); override;
    destructor Destroy; override;
    procedure Configure(ASettings: TAlgosimStructure); override;
    property AxisLengths: rglv2 read GetAxisLengths write SetAxisLengths;
    property Height: Single read GetHeight write SetHeight;
    property Radius: Single read GetRadius write SetRadius;
  end;

  TSolidTetrahedron = class(TRawModel)
  protected
    function GetRawData: TArray<GLfloat6>; override;
  public
    constructor Create(ACtl: TVisCtl3D); override;
  end;

  TSolidOctahedron = class(TRawModel)
  protected
    function GetRawData: TArray<GLfloat6>; override;
  public
    constructor Create(ACtl: TVisCtl3D); override;
  end;

  TSolidDodecahedron = class(TRawModel)
  protected
    function GetRawData: TArray<GLfloat6>; override;
  public
    constructor Create(ACtl: TVisCtl3D); override;
  end;

  TSolidIcosahedron = class(TRawModel)
  protected
    function GetRawData: TArray<GLfloat6>; override;
  public
    constructor Create(ACtl: TVisCtl3D); override;
  end;

  TSolidPyramid = class(TRawModel)
  protected
    function GetRawData: TArray<GLfloat6>; override;
  public
    constructor Create(ACtl: TVisCtl3D); override;
  end;

  TArrow = class(TGeometricObject3D)
  private
    v: rglv;
    FLine: TSolidCylinder;
    FHead: TSolidCone;
    Q: Single;
    FHeadSize: Single;
    FSetup: Boolean;
    function GetColor: TColor; override;
    procedure SetColor(const Value: TColor); override;
    procedure SetVector(const Value: rglv);
    procedure SetHeadSize(const Value: Single);
    procedure SetAspect(const Value: Single);
  protected
    function GetLineWidth: Single; override;
    procedure SetLineWidth(const Value: Single); override;
    procedure Setup; override;
    procedure Recreate; override;
  public
    constructor Create(ACtl: TVisCtl3D); override;
    procedure Configure(ASettings: TAlgosimStructure); override;
    function CreateReference: TAlgosimReference; override;
    property Aspect: Single read Q write SetAspect;
    property HeadSize: Single read FHeadSize write SetHeadSize;
    property Vector: rglv read v write SetVector;
  end;

  TLightSourceDummy = class(TSphere)
  public
    constructor Create(ACtl: TVisCtl3D); override;
  end;

  TProjection = (Orthographic, Perspective);

  TProjectionHelper = record helper for TProjection
    function ToString: string;
    class function FromString(const S: string): TProjection; static;
  end;

  TAnimationTimer = class(TTimer)
  private
    FControl: TVisCtl3D;
    class var FAppEvents: TApplicationEvents;
    class var FInstances: TList<TAnimationTimer>;
    class procedure AppIdle(Sender: TObject; var Done: Boolean);
    class constructor ClassCreate;
    class destructor ClassDestroy;
    class var FPrioritize: Boolean;
    class procedure SetPrioritize(const Value: Boolean); static;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Control: TVisCtl3D read FControl write FControl;
    class property Prioritize: Boolean read FPrioritize write SetPrioritize;
  end;

  TView3D = class(TDrawable3D)
  strict private
  const
    AnimationDurationSec = 1.0;
    AnimationFramerateFPS = 30;
    AnimationFrameCount =
      Round(AnimationDurationSec * AnimationFramerateFPS);
    AFC = AnimationFrameCount;
  var
    FAnimationTimer: TAnimationTimer;
    FAnimationBegin: TDateTime;
    FAnimationEnd: TDateTime;
    FAnimation: array[0..AFC - 1] of TSphericalCoordinates;
    procedure AnimationTimerTimer(Sender: TObject);
  private
    function GetCameraPosition: rglv;
    function GetCameraPositionSp: TSphericalCoordinates;
    function GetPhi: Double;
    function GetR: Double;
    function GetTheta: Double;
    procedure SetCameraPosition(const Value: rglv);
    procedure SetCameraPositionSp(const Value: TSphericalCoordinates);
    procedure SetPhi(const Value: Double);
    procedure SetR(const Value: Double);
    procedure SetTheta(const Value: Double);
  public
    constructor Create(ACtl: TVisCtl3D); override;
    destructor Destroy; override;
    procedure Configure(ASettings: TAlgosimStructure); override;
    property r: Double read GetR write SetR;
    property Theta: Double read GetTheta write SetTheta;
    property Phi: Double read GetPhi write SetPhi;
    property CameraPosition: rglv read GetCameraPosition write SetCameraPosition;
    property CameraPositionSp: TSphericalCoordinates read GetCameraPositionSp write SetCameraPositionSp;
    procedure AnimateTo(const ATarget: rglv);
  end;

  TManagedProgram = class
  strict private
    FName: string;
    FProgram: TRglProgram;
    FUMVP: TRglUniformFloatMat4;
    FUEye: TRglUniformFloatVec3;
    FULightPos: TRglUniformFloatVec3;
    FUColor: TRglUniformFloatVec3;
    FUSize: TRglUniformFloat;
    FUAnchorPoint: TRglUniformInt;
    FUFaceScreen: TRglUniformBool;
    FUAttribColors: TRglUniformBool;
    FUAspect: TRglUniformFloat;
    FUDisplacement: TRglUniformFloatVec2;
    FUObjectMatrix: TRglUniformFloatMat4;
    FUNormalMatrix: TRglUniformFloatMat3;
    FUt: TRglUniformFloat;
    FUTranspColor: TRglUniformFloatVec3;
    FUOpaqueColor: TRglUniformFloatVec3;
    FUTranspColorMode: TRglUniformInt;
    FUOpacity: TRglUniformFloat;
    FUPP_Greyscale: TRglUniformBool;
    FUPP_Invert: TRglUniformBool;
    FUPP_FlipV: TRglUniformBool;
    FUPP_FlipH: TRglUniformBool;
    FUPP_Binary: TRglUniformBool;
    FUPP_Spectra: TRglUniformBool;
    FUPP_EdgeDetect: TRglUniformBool;
    FUPP_Sharpen: TRglUniformBool;
    FUPP_Blur: TRglUniformBool;
    FUPP_Underwater: TRglUniformBool;
  public
    constructor Create(const AName: string; AProgram: TRglProgram);
    destructor Destroy; override;
    property Name: string read FName;
    property &Program: TRglProgram read FProgram;
    property UMVP: TRglUniformFloatMat4 read FUMVP;
    property UEye: TRglUniformFloatVec3 read FUEye;
    property ULightPos: TRglUniformFloatVec3 read FULightPos;
    property UColor: TRglUniformFloatVec3 read FUColor;
    property USize: TRglUniformFloat read FUSize;
    property UAnchorPoint: TRglUniformInt read FUAnchorPoint;
    property UFaceScreen: TRglUniformBool read FUFaceScreen;
    property UAttribColors: TRglUniformBool read FUAttribColors;
    property UAspect: TRglUniformFloat read FUAspect;
    property UDisplacement: TRglUniformFloatVec2 read FUDisplacement;
    property UObjectMatrix: TRglUniformFloatMat4 read FUObjectMatrix;
    property UNormalMatrix: TRglUniformFloatMat3 read FUNormalMatrix;
    property Ut: TRglUniformFloat read FUt;
    property UTranspColor: TRglUniformFloatVec3 read FUTranspColor;
    property UOpaqueColor: TRglUniformFloatVec3 read FUOpaqueColor;
    property UTranspColorMode: TRglUniformInt read FUTranspColorMode;
    property UOpacity: TRglUniformFloat read FUOpacity;
    property UPP_Greyscale: TRglUniformBool read FUPP_Greyscale;
    property UPP_Invert: TRglUniformBool read FUPP_Invert;
    property UPP_FlipV: TRglUniformBool read FUPP_FlipV;
    property UPP_FlipH: TRglUniformBool read FUPP_FlipH;
    property UPP_Binary: TRglUniformBool read FUPP_Binary;
    property UPP_Spectra: TRglUniformBool read FUPP_Spectra;
    property UPP_EdgeDetect: TRglUniformBool read FUPP_EdgeDetect;
    property UPP_Sharpen: TRglUniformBool read FUPP_Sharpen;
    property UPP_Blur: TRglUniformBool read FUPP_Blur;
    property UPP_Underwater: TRglUniformBool read FUPP_Underwater;
  end;

  TProgramMgr = class
  strict private
    FControl: TVisCtl3D;
    FPrograms: TObjectList<TManagedProgram>;
    FCurrentProgram: TManagedProgram;
    FTimeDependent: Boolean;
    function LoadProgramResource(const AName: string; AData: TStringList): TManagedProgram;
  public
    constructor Create(AControl: TVisCtl3D);
    destructor Destroy; override;
    function GetProgram(const AName: string): TManagedProgram;
    procedure UseProgram(const AName: string);
    procedure BeginMonitorTime;
    function EndMonitorTime: Boolean;
    property CurrentProgram: TManagedProgram read FCurrentProgram;
  end;

  TMSAAValue = (msaa0 = 0, msaa2 = 2, msaa4 = 4, msaa8 = 8, msaa16 = 16,
    msaa32 = 32, msaa64 = 64, msaa128 = 128);

  TVisCtlObjectMenuItem = class(TMenuItem)
  private
    FObjRef: TGUID;
  public
    property ObjRef: TGUID read FObjRef;
  end;

  TVisCtl3D = class(TRglControl)
  strict private
  type
    TRenderOutputData = record
      Width, Height: Integer;
      MSAA: TMSAAValue;
      PostProc: Boolean;
      Offscreen: Boolean;
      function Aspect: Double;
      class operator Equal(const Left, Right: TRenderOutputData): Boolean; static;
      class operator NotEqual(const Left, Right: TRenderOutputData): Boolean; static;
    end;
  var
    FRenderOutputData: TRenderOutputData;
    FPrevRenderOutputData: TRenderOutputData;
    FRenderToBitmap: Boolean;
    FRenderToClipboard: Boolean;
    FRenderFileName: string;
    FFOV: Double;
    FProjection: TProjection;
    M, V, P: rglm4;
    MVP: rglm4;
    Eye: rglv;
    FObjs: TDrawableList3D;
    FCustomMenuItems: TList<TMenuItem>;
    FOnBeforeContextPopup: TNotifyEvent;
    FBackgroundPaintLevel: Integer;
    FInvalidationTimer: TTimer;
    FAnimationTimer: TAnimationTimer;
    FProgramMgr: TProgramMgr;
    FNewObjects: TList<TDrawable3D>;
    FPrevMousePoint: TPoint;
    FLightPos: rglv;
    FMSAAbuf: GLuint;
    FMSAAbuf_coloratt: GLuint;
    FMSAAbuf_dsatt: GLuint;
    Fauxbuf: GLuint;
    Fauxbuf_coloratt: GLuint;
    Fauxbuf_dsatt: GLuint;
    Fosbuf: GLuint;
    Fosbuf_coloratt: GLuint;
    FScreenVAO: GLuint;
    FScreenQuad: GLuint;
    FMSAAValue: TMSAAValue;
    FPostProcessing: Boolean;
    FPopupMenu: TPopupMenu;
    FToggleAxesMnuItem: TMenuItem;
    FRemoveMnuItem: TVisCtlObjectMenuItem;
    FProjSubmenu: TMenuItem;
    FOrthogonalMnuItem,
    FPerspectiveMnuItem: TMenuItem;
    FMSAASubmenu: TMenuItem;
    FPPSubmenu: TMenuItem;
    FImplInfoMnuItem: TMenuItem;
    FExtInfoMnuItem: TMenuItem;
    FEffects: TPPEs;
    FMaxSamples: Integer;
    FPrevTick: Int64;
    FGlobalTime: Double;
    FImplData: TGLImplInfo;
    FExts: TArray<string>;
    FStencil: Boolean;
    FScene: TScene;
    FView: TView3D;
    FAxes: TAxes;
    procedure SetFov(const Value: Double);
    procedure SetProjection(const Value: TProjection);
    procedure ViewChanged(Sender: TObject);
    procedure ComputeM;
    procedure ComputeV;
    procedure ComputeP(const ARenderOutputData: TRenderOutputData);
    procedure ObjChanged(Sender: TObject);
    procedure LowPriorityInvalidate;
    procedure InvalidationTimerTimer(Sender: TObject);
    procedure AnimationTimerTimer(Sender: TObject);
    function GetObjectCount: Integer;
    function GetObject(Index: Integer): TDrawable3D;
    procedure SetupNewObjects;
    procedure SetLightPos(const Value: rglv);
    procedure MakeContextMenu;
    procedure PopupMenuPopup(Sender: TObject);
    procedure UpdateContextMenuStates(ASelObj: TDrawable3D);
    procedure MnuSceneSettings(Sender: TObject);
    procedure MnuObjectSettings(Sender: TObject);
    procedure MnuToggleAxes(Sender: TObject);
    procedure MnuRemoveObject(Sender: TObject);
    procedure MnuSaveSceneToFile(Sender: TObject);
    procedure MnuCopySceneToClipboard(Sender: TObject);
    procedure MnuSetProj(Sender: TObject);
    procedure MnuSetMSAA(Sender: TObject);
    procedure MnuSetPP(Sender: TObject);
    procedure MnuImplInfo(Sender: TObject);
    procedure MnuExtInfo(Sender: TObject);
    procedure SaveSceneToBitmap(const ARenderOutputData: TRenderOutputData;
      ACleanUp, ARenderToClipboard: Boolean; const AFileName: string);
    procedure SetMSAAValue(const Value: TMSAAValue);
    procedure SetEffects(const Value: TPPEs);
    function GetShowAxes: Boolean;
    procedure SetShowAxes(const Value: Boolean);
    procedure CustomizeMenu(AMenu: TMenu);
    procedure FreeGLResources;
  private
    r, φ, θ: Double;
    procedure RemoveObjectOrChild(AObject: TDrawable3D);
  protected
    procedure GLInit; override;
    procedure FramebufferSetup(const ARenderOutputData: TRenderOutputData);
    procedure Paint; override;
    procedure Resize; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X: Integer; Y: Integer); override;
    function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean; override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure KeyPress(var Key: Char); override;
    procedure CreateWnd; override;
    procedure DestroyWnd; override;
    procedure WMContextMenu(var Message: TWMContextMenu); message WM_CONTEXTMENU;
    procedure WMDestroy(var Message: TWMDestroy); message WM_DESTROY;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Scene: TScene read FScene;
    function NewObject<T: TDrawable3D>: T;
    procedure AddObject(AObject: TDrawable3D);
    property ObjectCount: Integer read GetObjectCount;
    property Objects[Index: Integer]: TDrawable3D read GetObject;
    procedure RemoveObject(AObject: TDrawable3D);
    function HitTest(X, Y: Integer): TDrawable3D;
    procedure ZoomIn(const Delta: Double; Shift: TShiftState);
    procedure ZoomOut(const Delta: Double; Shift: TShiftState);
    procedure Zoom(const Delta: Double; Shift: TShiftState);
    /// <summary>Adds a custom menu item to the control's main context menu.
    ///  The control doesn't take ownership of the item, and the item must not
    ///  be freed by the caller while the control has a reference to it. The
    ///  caller is allowed to change other properties of the item, except its
    ///  parent. After the item has been added to the control, the control takes
    ///  control of its parent property. Hence, if the item previously belonged
    ///  to a menu, it might be removed from that menu.</summary>
    procedure AddMenuItem(AMenuItem: TMenuItem);
    procedure AddMenuItems(AMenu: TMenuItem);
    procedure RemoveMenuItem(AMenuItem: TMenuItem);
    procedure BeginBackgroundPaint;
    procedure EndBackgroundPaint;
    procedure SaveToBitmap(const AFileName: string; AWidth, AHeight: Integer);
    procedure ClearScene;
    property FOV: Double read FFOV write SetFov;
    property Projection: TProjection read FProjection write SetProjection default Perspective;
    property ObjectMgr: TDrawableList3D read FObjs;
    property ProgramMgr: TProgramMgr read FProgramMgr;
    property CurrentMatrix: rglm4 read MVP;
    property CameraPos: rglv read Eye;
    property LightPos: rglv read FLightPos write SetLightPos;
    property GlobalTime: Double read FGlobalTime write FGlobalTime;
    property ImplData: TGLImplInfo read FImplData;
    property Stencil: Boolean read FStencil;
    property Mat_M: rglm4 read M;
    property Mat_V: rglm4 read V;
    property Mat_P: rglm4 read P;
    property Mat_MVP: rglm4 read MVP;
    property View: TView3D read FView;
    property Axes: TAxes read FAxes;
    property _ContextMenu: TPopupMenu read FPopupMenu;
  published
    property Anchors;
    property Align;
    property AlignWithMargins;
    property Color;
    property Cursor;
    property Effects: TPPEs read FEffects write SetEffects;
    property Enabled;
    property Font;
    property MSAA: TMSAAValue read FMSAAValue write SetMSAAValue;
    property ShowAxes: Boolean read GetShowAxes write SetShowAxes;
    property TabStop default True;
    property Visible;
    property OnBeforeContextPopup: TNotifyEvent read FOnBeforeContextPopup
      write FOnBeforeContextPopup;
    property OnClick;
    property OnDblClick;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnMouseEnter;
    property OnMouseLeave;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
  end;

procedure rglEnableDebugLog;
procedure rglLog(const S: string); overload; {noexcept}
procedure rglLog(const S: string; const AArgs: array of const); overload; {noexcept}

implementation

uses
  StrUtils, Math, DateUtils, ASKernelDefs, ASPixmap, ImageSizeForm, IOUtils,
  ObjFile, TDMB, Clipbrd, Vis3D_GeoObjSettings, ASColors, Vis3D_DrawableSettings,
  Vis3D_SurfaceSettings, Vis3D_DrawableListSettings, Vis3D_ScatterPlotSettings,
  Vis3D_VectorFieldSettings, Vis3D_ImageRectSettings, Vis3D_TextRectSettings,
  Vis3D_AxisSettings, Vis3D_AxesSettings, Vis3D_GridSettings,
  Vis3D_ModelSettings, Vis3D_CylinderSettings, Vis3D_SceneSettings,
  Vis3D_ViewSettings, Vis3D_ArrowSettings;

var
  InvFS: TFormatSettings;
  RglDebugLog: Boolean;

{ rglv }

procedure rglEnableDebugLog;
begin
  RglDebugLog := RglDebugLog or AllocConsole;
end;

procedure rglLog(const S: string); {noexcept}
begin
  {$IFDEF DEBUG}
  if IsDebuggerPresent then
    OutputDebugString(PChar(S));
  {$ENDIF}
  if RglDebugLog then
    try
      Writeln(S);
    except
      RglDebugLog := False;
    end;
end;

procedure rglLog(const S: string; const AArgs: array of const); {noexcept}
begin
  try
    rglLog(Format(S, Aargs));
  except
    var ArgsStr := '';
    try
      for var LArg in AArgs do
        case LArg.VType of
          vtInteger:
            ArgsStr := ArgsStr + IfThen(not ArgsStr.IsEmpty, ', ') + LArg.VInteger.ToString;
          vtInt64:
            ArgsStr := ArgsStr + IfThen(not ArgsStr.IsEmpty, ', ') + LArg.VInt64^.ToString;
          vtBoolean:
            ArgsStr := ArgsStr + IfThen(not ArgsStr.IsEmpty, ', ') + LArg.VBoolean.ToString(TUseBoolStrs.True);
          vtExtended:
            ArgsStr := ArgsStr + IfThen(not ArgsStr.IsEmpty, ', ') + LArg.VExtended^.ToString;
          vtString:
            ArgsStr := ArgsStr + IfThen(not ArgsStr.IsEmpty, ', ') + QuotedStr(string(LArg.VString^));
          vtAnsiString:
            ArgsStr := ArgsStr + IfThen(not ArgsStr.IsEmpty, ', ') + QuotedStr(string(AnsiString(LArg.VAnsiString)));
          vtUnicodeString:
            ArgsStr := ArgsStr + IfThen(not ArgsStr.IsEmpty, ', ') + QuotedStr(string(UnicodeString(LArg.VUnicodeString)));
          vtWideString:
            ArgsStr := ArgsStr + IfThen(not ArgsStr.IsEmpty, ', ') + QuotedStr(string(WideString(LArg.VWideString)));
          vtChar:
            ArgsStr := ArgsStr + IfThen(not ArgsStr.IsEmpty, ', ') + QuotedStr(string(LArg.VChar));
          vtWideChar:
            ArgsStr := ArgsStr + IfThen(not ArgsStr.IsEmpty, ', ') + QuotedStr(string(LArg.VWideChar));
          vtPointer:
            ArgsStr := ArgsStr + IfThen(not ArgsStr.IsEmpty, ', ') + NativeUInt(LArg.VPointer).ToHexString;
          vtObject:
            ArgsStr := ArgsStr + IfThen(not ArgsStr.IsEmpty, ', ') + NativeUInt(LArg.VObject).ToHexString;
          vtClass:
            ArgsStr := ArgsStr + IfThen(not ArgsStr.IsEmpty, ', ') + NativeUInt(LArg.VClass).ToHexString;
        else
          ArgsStr := ArgsStr + IfThen(not ArgsStr.IsEmpty, ', ') + '?';
        end;
    except
      ArgsStr := '<argument error>';
    end;
    rglLog('rglLog: Format failed on ' + QuotedStr(S) + ' with arguments ' + ArgsStr + '.');
  end;
end;

class operator rglv.Add(const Left, Right: rglv): rglv;
begin
  Result.x := Left.x + Right.x;
  Result.y := Left.y + Right.y;
  Result.z := Left.z + Right.z;
end;

constructor rglv.Create(const x, y, z: Single);
begin
  Self.x := x;
  Self.y := y;
  Self.z := z;
end;

class operator rglv.Divide(const Left: rglv; const Right: Single): rglv;
begin
  Result.x := Left.x / Right;
  Result.y := Left.y / Right;
  Result.z := Left.z / Right;
end;

class operator rglv.Equal(const Left, Right: rglv): Boolean;
begin
  Result := (Left.x = Right.x) and (Left.y = Right.y) and (Left.z = Right.z);
end;

class operator rglv.Implicit(const v: TRealVector): rglv;
begin
  if v.Dimension <> 3 then
    raise Exception.Create('Vector must be three-dimensional.');
  Result.x := v[0];
  Result.y := v[1];
  Result.z := v[2];
end;

class operator rglv.Implicit(const c: TColor): rglv;
begin
  const rgb = ColorToRGB(c);
  Result.r := GetRValue(rgb) / 255;
  Result.g := GetGValue(rgb) / 255;
  Result.b := GetBValue(rgb) / 255;
end;

class operator rglv.Implicit(const v: rglv): GLfloat3;
begin
  Result := v.elem;
end;

class operator rglv.Implicit(const arr: GLfloat3): rglv;
begin
  Result.elem := arr;
end;

class operator rglv.LogicalXor(const Left, Right: rglv): rglv;
begin
  Result.x := Left.y * Right.z - Left.z * Right.y;
  Result.y := Left.z * Right.x - Left.x * Right.z;
  Result.z := Left.x * Right.y - Left.y * Right.x;
end;

class operator rglv.Multiply(const Left: Single; const Right: rglv): rglv;
begin
  Result.x := Left * Right.x;
  Result.y := Left * Right.y;
  Result.z := Left * Right.z;
end;

class operator rglv.Multiply(const Left: rglv; const Right: Single): rglv;
begin
  Result.x := Left.x * Right;
  Result.y := Left.y * Right;
  Result.z := Left.z * Right;
end;

class operator rglv.Multiply(const Left, Right: rglv): Single;
begin
  Result := Left.x * Right.x + Left.y * Right.y + Left.z * Right.z;
end;

function rglv.Norm: Single;
begin
  Result := Sqrt(Self * Self);
end;

function rglv.Normalized: rglv;
begin
  Result := (1 / Norm) * Self;
end;

function rglv.NormSquare: Single;
begin
  Result := Self * Self;
end;

class operator rglv.NotEqual(const Left, Right: rglv): Boolean;
begin
  Result := not (Left = Right);
end;

function rglv.ptr: PGLfloat;
begin
  Result := PGLfloat(@Self);
end;

class operator rglv.Subtract(const Left, Right: rglv): rglv;
begin
  Result.x := Left.x - Right.x;
  Result.y := Left.y - Right.y;
  Result.z := Left.z - Right.z;
end;

function rglv.xy: rglv2;
begin
  Result := vec2(x, y);
end;

class function rglv.Zero: rglv;
const Z: rglv =
  (
    elem:
      (
        0, 0, 0
      )
    );
begin
  Result := Z;
end;

function vec(const x, y, z: Single): rglv;
begin
  Result.x := x;
  Result.y := y;
  Result.z := z;
end;

{ rglm }

class operator rglm.Add(const Left, Right: rglm): rglm;
begin
  for var i := 0 to _elemh do
    Result.elem[i] := Left.elem[i] + Right.elem[i];
end;

constructor rglm.Create(const m11, m12, m13, m21, m22, m23, m31, m32,
  m33: Single);
begin
  elem[0] := m11;
  elem[1] := m12;
  elem[2] := m13;
  elem[3] := m21;
  elem[4] := m22;
  elem[5] := m23;
  elem[6] := m31;
  elem[7] := m32;
  elem[8] := m33;
end;

constructor rglm.CreateFromColumns(const u, v, w: rglv);
begin
  elem[0] := u.x;
  elem[1] := v.x;
  elem[2] := w.x;
  elem[3] := u.y;
  elem[4] := v.y;
  elem[5] := w.y;
  elem[6] := u.z;
  elem[7] := v.z;
  elem[8] := w.z;
end;

class operator rglm.Divide(const Left: rglm; const Right: Single): rglm;
begin
  for var i := 0 to _elemh do
    Result.elem[i] := Left.elem[i] / Right;
end;

class operator rglm.Equal(const Left, Right: rglm): Boolean;
begin
  for var i := 0 to _elemh do
    if Left.elem[i] <> Right.elem[i] then
      Exit(False);
  Result := True;
end;

class function rglm.Identity: rglm;
const I: rglm =
  (
    elem:
      (
        1, 0, 0,
        0, 1, 0,
        0, 0, 1
      )
    );
begin
  Result := I;
end;

function rglm.Inverse: rglm;
begin
  Result :=
    mat(
      elem[4] * elem[8] - elem[5] * elem[7],
      elem[2] * elem[7] - elem[1] * elem[8],
      elem[1] * elem[5] - elem[2] * elem[4],
      elem[5] * elem[6] - elem[3] * elem[8],
      elem[0] * elem[8] - elem[2] * elem[6],
      elem[2] * elem[3] - elem[0] * elem[5],
      elem[3] * elem[7] - elem[4] * elem[6],
      elem[1] * elem[6] - elem[0] * elem[7],
      elem[0] * elem[4] - elem[1] * elem[3]
    )
      /
    (
      elem[0] * (elem[4] * elem[8] - elem[5] * elem[7])
        +
      elem[1] * (elem[5] * elem[6] - elem[3] * elem[8])
        +
      elem[2] * (elem[3] * elem[7] - elem[4] * elem[6])
    )
end;

class operator rglm.Multiply(const Left: rglm; const Right: rglv): rglv;
begin
  Result := Default(rglv);
  for var i := 0 to _dimh do
    for var j := 0 to _dimh do
      Result.elem[i] := Result.elem[i] + Left.m[i, j] * Right.elem[j];
end;

class operator rglm.Multiply(const Left: Single; const Right: rglm): rglm;
begin
  for var i := 0 to _elemh do
    Result.elem[i] := Left * Right.elem[i];
end;

class operator rglm.Multiply(const Left, Right: rglm): rglm;
begin
  Result := Default(rglm);
  for var i := 0 to _dimh do
    for var j := 0 to _dimh do
      for var k := 0 to _dimh do
        Result.m[i, j] := Result.m[i, j] + Left.m[i, k] * Right.m[k, j];
end;

class operator rglm.NotEqual(const Left, Right: rglm): Boolean;
begin
  Result := not (Left = Right);
end;

function rglm.ptr: PGLfloat;
begin
  Result := PGLFloat(@Self);
end;

class operator rglm.Subtract(const Left, Right: rglm): rglm;
begin
  for var i := 0 to _elemh do
    Result.elem[i] := Left.elem[i] - Right.elem[i];
end;

function rglm.ToString: string;
begin
  Result := '';
  for var y := 0 to _dimh do
  begin
    for var x := 0 to _dimh do
    begin
      Result := Result + FloatToStrF(m[y, x], ffFixed, 10, 4, InvFS);
      if x < _dimh then
        Result := Result + #32;
    end;
    if y < _dimh then
      Result := Result + #13#10
  end;
end;

function rglm.Transpose: rglm;
begin
  for var i := 0 to _dimh do
    for var j := 0 to _dimh do
      Result.m[j, i] := Self.m[i, j];
end;

class function rglm.Zero: rglm;
const Z: rglm =
  (
    elem:
      (
        0, 0, 0,
        0, 0, 0,
        0, 0, 0
      )
    );
begin
  Result := Z;
end;

function mat(const m11, m12, m13, m21, m22, m23, m31, m32, m33: Single): rglm;
begin
  Result.elem[0] := m11;
  Result.elem[1] := m12;
  Result.elem[2] := m13;
  Result.elem[3] := m21;
  Result.elem[4] := m22;
  Result.elem[5] := m23;
  Result.elem[6] := m31;
  Result.elem[7] := m32;
  Result.elem[8] := m33;
end;

function mat_transpose(const m11, m12, m13, m21, m22, m23, m31, m32, m33: Single): rglm;
begin
  Result.elem[0] := m11;
  Result.elem[3] := m12;
  Result.elem[6] := m13;
  Result.elem[1] := m21;
  Result.elem[4] := m22;
  Result.elem[7] := m23;
  Result.elem[2] := m31;
  Result.elem[5] := m32;
  Result.elem[8] := m33;
end;

{ rglv2 }

class operator rglv2.Add(const Left, Right: rglv2): rglv2;
begin
  Result.x := Left.x + Right.x;
  Result.y := Left.y + Right.y;
end;

constructor rglv2.Create(const x, y: Single);
begin
  Self.x := x;
  Self.y := y;
end;

class operator rglv2.Divide(const Left: rglv2; const Right: Single): rglv2;
begin
  Result.x := Left.x / Right;
  Result.y := Left.y / Right;
end;

class operator rglv2.Equal(const Left, Right: rglv2): Boolean;
begin
  Result := (Left.x = Right.x) and (Left.y = Right.y);
end;

class operator rglv2.Implicit(const v: rglv2): GLfloat2;
begin
  Result := v.elem;
end;

class operator rglv2.Implicit(const arr: GLfloat2): rglv2;
begin
  Result.elem := arr;
end;

class operator rglv2.Multiply(const Left: Single; const Right: rglv2): rglv2;
begin
  Result.x := Left * Right.x;
  Result.y := Left * Right.y;
end;

class operator rglv2.Multiply(const Left: rglv2; const Right: Single): rglv2;
begin
  Result.x := Left.x * Right;
  Result.y := Left.y * Right;
end;

class operator rglv2.Multiply(const Left, Right: rglv2): Single;
begin
  Result := Left.x * Right.x + Left.y * Right.y;
end;

function rglv2.Norm: Single;
begin
  Result := Sqrt(Self * Self);
end;

function rglv2.Normalized: rglv2;
begin
  Result := (1 / Norm) * Self;
end;

function rglv2.NormSquare: Single;
begin
  Result := Self * Self;
end;

class operator rglv2.NotEqual(const Left, Right: rglv2): Boolean;
begin
  Result := not (Left = Right);
end;

function rglv2.ptr: PGLfloat;
begin
  Result := PGLfloat(@Self);
end;

class operator rglv2.Subtract(const Left, Right: rglv2): rglv2;
begin
  Result.x := Left.x - Right.x;
  Result.y := Left.y - Right.y;
end;

class function rglv2.Zero: rglv2;
const Z: rglv2 =
  (
    elem:
      (
        0, 0
      )
    );
begin
  Result := Z;
end;

function vec2(const x, y: Single): rglv2;
begin
  Result.x := x;
  Result.y := y;
end;

class operator rglv2.Implicit(const v: TRealVector): rglv2;
begin
  if v.Dimension <> 2 then
    raise Exception.Create('Vector must be two-dimensional.');
  Result.x := v[0];
  Result.y := v[1];
end;

{ rglv4 }

class operator rglv4.Add(const Left, Right: rglv4): rglv4;
begin
  Result.x := Left.x + Right.x;
  Result.y := Left.y + Right.y;
  Result.z := Left.z + Right.z;
  Result.w := Left.w + Right.w;
end;

constructor rglv4.Create(const x, y, z, w: Single);
begin
  Self.x := x;
  Self.y := y;
  Self.z := z;
  Self.w := w;
end;

class operator rglv4.Divide(const Left: rglv4; const Right: Single): rglv4;
begin
  Result.x := Left.x / Right;
  Result.y := Left.y / Right;
  Result.z := Left.z / Right;
  Result.w := Left.w / Right;
end;

class operator rglv4.Equal(const Left, Right: rglv4): Boolean;
begin
  Result := (Left.x = Right.x) and (Left.y = Right.y) and (Left.z = Right.z)
    and (Left.w = Right.w);
end;

class operator rglv4.Multiply(const Left: Single; const Right: rglv4): rglv4;
begin
  Result.x := Left * Right.x;
  Result.y := Left * Right.y;
  Result.z := Left * Right.z;
  Result.w := Left * Right.w;
end;

class operator rglv4.Multiply(const Left, Right: rglv4): Single;
begin
  Result := Left.x * Right.x + Left.y * Right.y + Left.z * Right.z + Left.w * Right.w;
end;

function rglv4.Norm: Single;
begin
  Result := Sqrt(Self * Self);
end;

function rglv4.Normalized: rglv4;
begin
  Result := (1 / Norm) * Self;
end;

function rglv4.NormSquare: Single;
begin
  Result := Self * Self;
end;

class operator rglv4.NotEqual(const Left, Right: rglv4): Boolean;
begin
  Result := not (Left = Right);
end;

function rglv4.ptr: PGLfloat;
begin
  Result := PGLfloat(@Self);
end;

class operator rglv4.Subtract(const Left, Right: rglv4): rglv4;
begin
  Result.x := Left.x - Right.x;
  Result.y := Left.y - Right.y;
  Result.z := Left.z - Right.z;
  Result.w := Left.w - Right.w;
end;

class function rglv4.Zero: rglv4;
const Z: rglv4 =
  (
    elem:
      (
        0, 0, 0, 0
      )
    );
begin
  Result := Z;
end;

function vec4(const x, y, z, w: Single): rglv4;
begin
  Result.x := x;
  Result.y := y;
  Result.z := z;
  Result.w := w;
end;

{ rglm4 }

class operator rglm4.Add(const Left, Right: rglm4): rglm4;
begin
  for var i := 0 to _elemh do
    Result.elem[i] := Left.elem[i] + Right.elem[i];
end;

constructor rglm4.Create(const m11, m12, m13, m14, m21, m22, m23, m24,
  m31, m32, m33, m34, m41, m42, m43, m44: Single);
begin
  elem[0] := m11;
  elem[1] := m12;
  elem[2] := m13;
  elem[3] := m14;
  elem[4] := m21;
  elem[5] := m22;
  elem[6] := m23;
  elem[7] := m24;
  elem[8] := m31;
  elem[9] := m32;
  elem[10] := m33;
  elem[11] := m34;
  elem[12] := m41;
  elem[13] := m42;
  elem[14] := m43;
  elem[15] := m44;
end;

class operator rglm4.Divide(const Left: rglm4; const Right: Single): rglm4;
begin
  for var i := 0 to _elemh do
    Result.elem[i] := Left.elem[i] / Right;
end;

class operator rglm4.Equal(const Left, Right: rglm4): Boolean;
begin
  for var i := 0 to _elemh do
    if Left.elem[i] <> Right.elem[i] then
      Exit(False);
  Result := True;
end;

class operator rglm4.Explicit(const Mat: rglm): rglm4;
begin
  Result := rglm4.Identity;
  for var i := 0 to Mat._dimh do
    for var j := 0 to Mat._dimh do
      Result.m[i, j] := Mat.m[i, j];
end;

class operator rglm4.Explicit(const Mat4: rglm4): rglm;
begin
  for var i := 0 to Result._dimh do
    for var j := 0 to Result._dimh do
      Result.m[i, j] := Mat4.m[i, j];
end;

class function rglm4.Identity: rglm4;
const I: rglm4 =
  (
    elem:
      (
        1, 0, 0, 0,
        0, 1, 0, 0,
        0, 0, 1, 0,
        0, 0, 0, 1
      )
    );
begin
  Result := I;
end;

class operator rglm4.Multiply(const Left: Single; const Right: rglm4): rglm4;
begin
  for var i := 0 to _elemh do
    Result.elem[i] := Left * Right.elem[i];
end;

class operator rglm4.Multiply(const Left: rglm4; const Right: rglv4): rglv4;
begin
  Result := Default(rglv4);
  for var i := 0 to _dimh do
    for var j := 0 to _dimh do
      Result.elem[i] := Result.elem[i] + Left.m[i, j] * Right.elem[j];
end;

class operator rglm4.Multiply(const Left, Right: rglm4): rglm4;
begin
  Result := Default(rglm4);
  for var i := 0 to _dimh do
    for var j := 0 to _dimh do
      for var k := 0 to _dimh do
        Result.m[i, j] := Result.m[i, j] + Left.m[i, k] * Right.m[k, j];
end;

class operator rglm4.NotEqual(const Left, Right: rglm4): Boolean;
begin
  Result := not (Left = Right);
end;

function rglm4.ptr: PGLfloat;
begin
  Result := PGLFloat(@Self);
end;

class operator rglm4.Subtract(const Left, Right: rglm4): rglm4;
begin
  for var i := 0 to _elemh do
    Result.elem[i] := Left.elem[i] - Right.elem[i];
end;

function rglm4.Transpose: rglm4;
begin
  for var i := 0 to _dimh do
    for var j := 0 to _dimh do
      Result.m[j, i] := Self.m[i, j];
end;

function mat4(const m11, m12, m13, m14, m21, m22, m23, m24, m31, m32, m33, m34,
  m41, m42, m43, m44: Single): rglm4;
begin
  Result.elem[0] := m11;
  Result.elem[1] := m12;
  Result.elem[2] := m13;
  Result.elem[3] := m14;
  Result.elem[4] := m21;
  Result.elem[5] := m22;
  Result.elem[6] := m23;
  Result.elem[7] := m24;
  Result.elem[8] := m31;
  Result.elem[9] := m32;
  Result.elem[10] := m33;
  Result.elem[11] := m34;
  Result.elem[12] := m41;
  Result.elem[13] := m42;
  Result.elem[14] := m43;
  Result.elem[15] := m44;
end;

function rglLookAt(const eyeX, eyeY, eyeZ: Single;
  const centerX, centerY, centerZ: Single; const upX, upY, upZ: Single): rglm4;
begin
  Result := rglLookAt(vec(eyeX, eyeY, eyeZ), vec(centerX, centerY, centerZ),
    vec(upX, upY, upZ));
end;

function rglLookAt(const eye, center, up: rglv): rglm4;
begin

  var f := (center - eye).Normalized;
  var u := up.Normalized;

  var s := (f xor u).Normalized;
  var v := S xor f;

  Result := mat4(
    s.x, s.y, s.z, 0,
    v.x, v.y, v.z, 0,
    -f.x, -f.y, -f.z, 0,
    0, 0, 0, 1
  )
  *
  rglTranslate(-eye.x, -eye.y, -eye.z);

end;

function rglPerspective(const fovy, aspect, &near, &far: Double): rglm4;
begin

  var f := Cot(DegToRad(fovy / 2));

  Result := mat4(
    f / aspect, 0, 0, 0,
    0, f, 0, 0,
    0, 0, (&far + &near) / (&near - &far), 2 * &far * &near / (&near - &far),
    0, 0, -1, 0
  );

end;

function rglOrtho(const left, right, bottom, top, &near, &far: Double): rglm4;
begin

  var tx := (left + right) / (left - right);
  var ty := (bottom + top) / (bottom - top);
  var tz := (&near + &far) / (&near - &far);

  Result := mat4(
    2 / (right - left), 0, 0, tx,
    0, 2 / (top - bottom), 0, ty,
    0, 0, 2 / (&near - &far), tz,
    0, 0, 0, 1
  );

end;

function rglOrtho2D(const left, right, bottom, top: Double): rglm4;
begin

  Result := rglOrtho(left, right, bottom, top, -1.0, 1.0);

end;

function rglScale(const x, y, z: Single): rglm4;
begin

  Result := mat4(
    x, 0, 0, 0,
    0, y, 0, 0,
    0, 0, z, 0,
    0, 0, 0, 1
  );

end;

function rglTranslate(const x, y, z: Single): rglm4;
begin

  Result := mat4(
    1, 0, 0, x,
    0, 1, 0, y,
    0, 0, 1, z,
    0, 0, 0, 1
  );

end;

function rglTranslate(const v: rglv): rglm4;
begin
  Result := rglTranslate(v.x, v.y, v.z);
end;

function rglRotate(const a, x, y, z: Single): rglm4;
begin

  var s, c: Single;
  SinCos(DegToRad(a), s, c);
  var cc := 1 - c;

  Result := mat4(
    x*x*cc+c, x*y*cc-z*s, x*z*cc+y*s, 0,
    y*x*cc+z*s, y*y*cc+c, y*z*cc-x*s, 0,
    x*z*cc-y*s, y*z*cc+x*s, z*z*cc+c, 0,
    0, 0, 0, 1
  );

end;

function rglRotate(const a: Single; const v: rglv): rglm4;
begin
  if IsZero(a) then
    Exit(rglm4.Identity);
  with v.Normalized do
    Result := rglRotate(a, x, y, z);
end;

function rglGetString(name: GLenum): string;
begin
  Result := string(glGetString(name));
end;

procedure TriangulateSurface(F: TSurfParamFcn;
  N: TSurfParamNormalFcn; const umin, umax, vmin, vmax: Double;
  A, B, pccx, pccy: Integer; Normalize: Boolean; out Vertices: TArray<GLfloat6>;
  out Indices, PCIs: TArray<GLuint>; PCOnly: Boolean; ListData: TArray<rglv>);
const
  RevDir: array[Boolean] of Integer = (+1, -1);
begin

  if
    not ((@F = nil) xor (ListData = nil))
      or
    (umin >= umax)
      or
    (vmin >= vmax)
      or
    (A < 2)
      or
    (B < 2)
      or
    Assigned(ListData) and (Length(ListData) <> A*B)
  then
    raise Exception.Create('TriangulateSurface: Invalid parameters.');

  pccx := EnsureRange(pccx, 1, A);
  pccy := EnsureRange(pccy, 1, B);

  if not PCOnly then
  begin

    SetLength(Vertices, A*B);
    SetLength(Indices, 3 * 2 * (A - 1) * (B - 1));

    var ∆u := (umax - umin) / (A - 1);
    var ∆v := (vmax - vmin) / (B - 1);

    var idx := 0;
    for var j := 0 to B - 1 do
    begin
      var v := vmin + j*∆v;
      for var i := 0 to A - 1 do
      begin
        var u := umin + i*∆u;
        if Assigned(F) then
          GLr3n3v(Vertices[idx]).r := F(u, v)
        else
          GLr3n3v(Vertices[idx]).r := ListData[idx];
        if Assigned(N) then
        begin
          if Normalize then
            GLr3n3v(Vertices[idx]).n := N(u, v).Normalized
          else
            GLr3n3v(Vertices[idx]).n := N(u, v);
        end;
        Inc(idx);
      end;
    end;

    if not Assigned(N) then
    begin
      idx := 0;
      for var j := 0 to B - 1 do
      begin
        for var i := 0 to A - 1 do
        begin
          var k, l: Integer;
          if i > 0 then
            k := i - 1
          else
            k := i + 1;
          if j > 0 then
            l := j - 1
          else
            l := j + 1;
          GLr3n3v(Vertices[idx]).n :=
            (
              (GLr3n3v(Vertices[j * A + i]).r - GLr3n3v(Vertices[j * A + k]).r) * RevDir[i = 0]
                xor
              (GLr3n3v(Vertices[j * A + i]).r - GLr3n3v(Vertices[l * A + i]).r) * RevDir[j = 0]
            ).Normalized;
          Inc(idx);
        end;
      end;
    end;

    idx := 0;
    for var j := 0 to B - 2 do
      for var i := 0 to A - 2 do
      begin
        var BaseIndex := j * A + i;
        Indices[idx] := BaseIndex;
        Inc(idx);
        Indices[idx] := BaseIndex + A;
        Inc(idx);
        Indices[idx] := BaseIndex + 1;
        Inc(idx);
        Indices[idx] := BaseIndex + 1;
        Inc(idx);
        Indices[idx] := BaseIndex + A;
        Inc(idx);
        Indices[idx] := BaseIndex + A + 1;
        Inc(idx);
      end;

  end;

  SetLength(PCIs, 2 * A * (B - 1) + 2 * B * (A - 1));

  var pccsx := Round(A / pccx);
  var pccsy := Round(B / pccy);

  var idx := 0;
  for var i := 0 to A - 1 do
  begin
    if i mod pccsx <> 0 then
      Continue;
    for var j := 0 to B - 2 do
    begin
      PCIs[idx] := i + j * A;
      Inc(idx);
      PCIs[idx] := i + (j + 1) * A;
      Inc(idx);
    end;
  end;

  for var j := 0 to B - 1 do
  begin
    if j mod pccsy <> 0 then
      Continue;
    for var i := 0 to A - 2 do
    begin
      PCIs[idx] := j * A + i;
      Inc(idx);
      PCIs[idx] := j * A + (i + 1);
      Inc(idx);
    end;
  end;

end;

procedure TriangulateColoredSurface(F: TSurfParamFcn; C: TSurfParamColorFcn;
  N: TSurfParamNormalFcn; const umin, umax, vmin, vmax: Double;
  A, B, pccx, pccy: Integer; Normalize: Boolean; out Vertices: TArray<GLfloat9>;
  out Indices, PCIs: TArray<GLuint>; PCOnly: Boolean; ListData: TArray<GLr3c3v>);
const
  RevDir: array[Boolean] of Integer = (+1, -1);
begin

  if
    not ((@F = nil) xor (ListData = nil))
      or
    (umin >= umax)
      or
    (vmin >= vmax)
      or
    (A < 2)
      or
    (B < 2)
      or
    Assigned(ListData) and (Length(ListData) <> A*B)
  then
    raise Exception.Create('TriangulateColoredSurface: Invalid parameters.');

  pccx := EnsureRange(pccx, 1, A);
  pccy := EnsureRange(pccy, 1, B);

  if not PCOnly then
  begin

    SetLength(Vertices, A*B);
    SetLength(Indices, 3 * 2 * (A - 1) * (B - 1));

    var ∆u := (umax - umin) / (A - 1);
    var ∆v := (vmax - vmin) / (B - 1);

    var idx := 0;
    for var j := 0 to B - 1 do
    begin
      var v := vmin + j*∆v;
      for var i := 0 to A - 1 do
      begin
        var u := umin + i*∆u;
        if Assigned(F) then
        begin
          GLr3c3n3v(Vertices[idx]).r := F(u, v);
          if Assigned(C) then
            GLr3c3n3v(Vertices[idx]).c := C(u, v);
        end
        else
        begin
          GLr3c3n3v(Vertices[idx]).r := ListData[idx].r;
          GLr3c3n3v(Vertices[idx]).c := ListData[idx].c;
        end;
        if Assigned(N) then
        begin
          if Normalize then
            GLr3c3n3v(Vertices[idx]).n := N(u, v).Normalized
          else
            GLr3c3n3v(Vertices[idx]).n := N(u, v);
        end;
        Inc(idx);
      end;
    end;

    if not Assigned(N) then
    begin
      idx := 0;
      for var j := 0 to B - 1 do
      begin
        for var i := 0 to A - 1 do
        begin
          var k, l: Integer;
          if i > 0 then
            k := i - 1
          else
            k := i + 1;
          if j > 0 then
            l := j - 1
          else
            l := j + 1;
          GLr3c3n3v(Vertices[idx]).n :=
            (
              (GLr3c3n3v(Vertices[j * A + i]).r - GLr3c3n3v(Vertices[j * A + k]).r) * RevDir[i = 0]
                xor
              (GLr3c3n3v(Vertices[j * A + i]).r - GLr3c3n3v(Vertices[l * A + i]).r) * RevDir[j = 0]
            ).Normalized;
          Inc(idx);
        end;
      end;
    end;

    idx := 0;
    for var j := 0 to B - 2 do
      for var i := 0 to A - 2 do
      begin
        var BaseIndex := j * A + i;
        Indices[idx] := BaseIndex;
        Inc(idx);
        Indices[idx] := BaseIndex + A;
        Inc(idx);
        Indices[idx] := BaseIndex + 1;
        Inc(idx);
        Indices[idx] := BaseIndex + 1;
        Inc(idx);
        Indices[idx] := BaseIndex + A;
        Inc(idx);
        Indices[idx] := BaseIndex + A + 1;
        Inc(idx);
      end;

  end;

  SetLength(PCIs, 2 * A * (B - 1) + 2 * B * (A - 1));

  var pccsx := Round(A / pccx);
  var pccsy := Round(B / pccy);

  var idx := 0;
  for var i := 0 to A - 1 do
  begin
    if i mod pccsx <> 0 then
      Continue;
    for var j := 0 to B - 2 do
    begin
      PCIs[idx] := i + j * A;
      Inc(idx);
      PCIs[idx] := i + (j + 1) * A;
      Inc(idx);
    end;
  end;

  for var j := 0 to B - 1 do
  begin
    if j mod pccsy <> 0 then
      Continue;
    for var i := 0 to A - 2 do
    begin
      PCIs[idx] := j * A + i;
      Inc(idx);
      PCIs[idx] := j * A + (i + 1);
      Inc(idx);
    end;
  end;

end;

procedure zdef(const vars: array of PInteger; const vals: array of Integer);
begin
  if Length(vars) <> Length(vals) then
    raise Exception.Create('zdef: Invalid parameters.');
  for var i := Low(vars) to High(vars) do
    if vars[i]^ = 0 then
      vars[i]^ := vals[i];
end;

function __spherefcn(const u, v: Double): rglv;
begin
  var s, c: Single;
  SinCos(Single(u), s, c);
  var rt: Single := Sqrt(1 - v*v);
  Result.x := Cos(u) * rt;
  Result.y := Sin(u) * rt;
  Result.z := v;
end;

function __spherenormalfcn(const u, v: Double): rglv;
begin
  var s, c: Single;
  SinCos(Single(u), s, c);
  var rt: Single := Sqrt(1 - v*v);
  Result.x := c * rt;
  Result.y := s * rt;
  Result.z := v;
end;

function __polarspherefcn(const θ, φ: Double): rglv;
begin
  Result.x := Sin(θ) * Cos(φ);
  Result.y := Sin(θ) * Sin(φ);
  Result.z := Cos(θ);
end;

function __polarspherenormalfcn(const θ, φ: Double): rglv;
begin
  Result.x := Sin(θ) * Cos(φ);
  Result.y := Sin(θ) * Sin(φ);
  Result.z := Cos(θ);
end;

procedure rglSpherePolar(out Vertices: TArray<GLfloat6>;
  out Indices, PCIs: TArray<GLuint>; A, B, pccx, pccy: Integer; PCOnly: Boolean;
  Data: Pointer);
begin
  zdef([@A, @B, @pccx, @pccy], [129, 129, 64, 64]);
  TriangulateSurface(__polarspherefcn, __polarspherenormalfcn, 0, Pi, 0, 2*Pi,
    A, B, pccx, pccy, False, Vertices, Indices, PCIs, PCOnly, nil);
end;

procedure rglSphereConstArea(out Vertices: TArray<GLfloat6>;
  out Indices, PCIs: TArray<GLuint>; A, B, pccx, pccy: Integer; PCOnly: Boolean;
  Data: Pointer);
begin
  zdef([@A, @B, @pccx, @pccy], [129, 129, 64, 64]);
  TriangulateSurface(__spherefcn, __spherenormalfcn, 0, 2*Pi, -1, 1,
    A, B, pccx, pccy, False, Vertices, Indices, PCIs, PCOnly, nil)
end;

function __cylinderfcn(const φ, z: Double): rglv;
begin
  var s, c: Single;
  SinCos(Single(φ), s, c);
  Result.x := c;
  Result.y := s;
  Result.z := z;
end;

function __cylindernormalfcn(const φ, z: Double): rglv;
begin
  var s, c: Single;
  SinCos(Single(φ), s, c);
  Result.x := c;
  Result.y := s;
  Result.z := 0;
end;

procedure rglCylinder(out Vertices: TArray<GLfloat6>;
  out Indices, PCIs: TArray<GLuint>; A, B, pccx, pccy: Integer; PCOnly: Boolean;
  Data: Pointer);
begin
  zdef([@A, @B, @pccx, @pccy], [129, 129, 64, 64]);
  TriangulateSurface(__cylinderfcn, __cylindernormalfcn, 0, 2*Pi, 0, 1, A, B,
    pccx, pccy, False, Vertices, Indices, PCIs, PCOnly, nil);
end;

function __conefcn(const φ, z: Double): rglv;
begin
  var s, c: Single;
  SinCos(Single(φ), s, c);
  Result.x := z*c;
  Result.y := z*s;
  Result.z := z;
end;

function __conenormalfcn(const φ, z: Double): rglv;
begin
  var s, c: Single;
  SinCos(Single(φ), s, c);
  Result.x := c / Sqrt(2);
  Result.y := s / Sqrt(2);
  Result.z := -1 / Sqrt(2);
end;

procedure rglCone(out Vertices: TArray<GLfloat6>;
  out Indices, PCIs: TArray<GLuint>; A, B, pccx, pccy: Integer; PCOnly: Boolean;
  Data: Pointer);
begin
  zdef([@A, @B, @pccx, @pccy], [129, 129, 64, 64]);
  TriangulateSurface(__conefcn, __conenormalfcn, 0, 2*Pi, 0, 1, A, B, pccx, pccy,
    False, Vertices, Indices, PCIs, PCOnly, nil);
end;

function __planefcn(const x, y: Double): rglv;
begin
  Result.x := x;
  Result.y := y;
  Result.z := 0;
end;

function __planenormalfcn(const x, y: Double): rglv;
begin
  Result.x := 0;
  Result.y := 0;
  Result.z := 1;
end;

procedure rglPlane(out Vertices: TArray<GLfloat6>;
  out Indices, PCIs: TArray<GLuint>; A, B, pccx, pccy: Integer; PCOnly: Boolean;
  Data: Pointer);
begin
  zdef([@A, @B, @pccx, @pccy], [129, 129, 64, 64]);
  TriangulateSurface(__planefcn, __planenormalfcn, -1, +1, -1, +1, A, B,
    pccx, pccy, False, Vertices, Indices, PCIs, PCOnly, nil);
end;

function __diskfcn(const ρ, φ: Double): rglv;
begin
  var s, c: Single;
  SinCos(Single(φ), s, c);
  Result.x := ρ*s;
  Result.y := ρ*c;
  Result.z := 0;
end;

function __disknormalfcn(const ρ, φ: Double): rglv;
begin
  Result.x := 0;
  Result.y := 0;
  Result.z := 1;
end;

procedure rglDisk(out Vertices: TArray<GLfloat6>;
  out Indices, PCIs: TArray<GLuint>; A, B, pccx, pccy: Integer; PCOnly: Boolean;
  Data: Pointer);
begin
  zdef([@A, @B, @pccx, @pccy], [129, 129, 64, 64]);
  TriangulateSurface(__diskfcn, __disknormalfcn, 0, +1, 0, 2*Pi, A, B,
    pccx, pccy, False, Vertices, Indices, PCIs, PCOnly, nil);
end;

{ TPPEHelper }

class function TPPEHelper.FromString(const S: string): TPPE;
begin
  for var e := Low(TPPE) to High(TPPE) do
    if SameText(e.Name, S) then
      Exit(e);
  raise ERglError.CreateFmt('Unknown effect: "%s".', [S]);
end;

function TPPEHelper.ID: Integer;
begin
  Result := 1 shl Ord(Self);
end;

function TPPEHelper.Name: string;
begin
  case Self of
    ppIdentity:
      Result := 'Identity';
    ppGreyscale:
      Result := 'Greyscale';
    ppInvert:
      Result := 'Invert';
    ppFlipH:
      Result := 'Horizontal flip';
    ppFlipV:
      Result := 'Vertical flip';
    ppBinary:
      Result := 'Binarize';
    ppSpectra:
      Result := 'Spectra';
    ppEdgeDetect:
      Result := 'Edge detection';
    ppBlur:
      Result := 'Blur';
    ppSharpen:
      Result := 'Sharpen';
    ppUnderwater:
      Result := 'Underwater';
  else
    Result := '';
  end;
end;

{ TRglShader }

procedure TRglShader.Compile;
begin

  if FHandle = 0 then
    raise ERglError.Create('Shader handle empty.');

  FContext.MakeCurrent('TRglShader.Compile');

  glCompileShader(FHandle);

  var i: GLInt := 0;
  glGetShaderiv(FHandle, GL_COMPILE_STATUS, @i);

  if i <> GL_TRUE then
  begin
    var maxlen: GLint;
    glGetShaderiv(FHandle, GL_INFO_LOG_LENGTH, @maxlen);
    var S: AnsiString;
    SetLength(S, maxlen);
    glGetShaderInfoLog(FHandle, maxlen, @maxlen, PAnsiChar(S));
    SetLength(S, maxlen);
    raise ERglError.Create('Shader not successfully compiled: ' + string(S));
  end;

end;

constructor TRglShader.Create(AContext: TRglContext; const ASource: string);
begin

  FContext := AContext;

  FContext.MakeCurrent('TRglShader.Create');

  FHandle := glCreateShader(FKind);

  if FHandle = 0 then
    raise ERglError.Create('Couldn''t create shader.');

  FSource := AnsiString(ASource);
  glShaderSource(FHandle, 1, @FSource, nil);

end;

destructor TRglShader.Destroy; // TRglShader objects are destroyed immediately
begin
  if Assigned(FContext) and FContext.TryMakeCurrent then
  begin
    glDeleteShader(FHandle);
    FHandle := 0;
  end
  else
    rglLog('TRglShader.Destroy error');
  inherited;
end;

{ TRglVertexShader }

constructor TRglVertexShader.Create(AContext: TRglContext; const ASource: string);
begin
  FKind := GL_VERTEX_SHADER;
  inherited;
end;

{ TRglFragmentShader }

constructor TRglFragmentShader.Create(AContext: TRglContext; const ASource: string);
begin
  FKind := GL_FRAGMENT_SHADER;
  inherited;
end;

{ TRglGeometryShader }

constructor TRglGeometryShader.Create(AContext: TRglContext; const ASource: string);
begin
  FKind := GL_GEOMETRY_SHADER;
  inherited;
end;

{ TRglProgram }

function TRglProgram.AddAttribute(const AName: string): Integer;
begin
  FContext.MakeCurrent('TRglProgram.AddAttribute');
  Result := glGetAttribLocation(FHandle, PAnsiChar(AnsiString(AName)));
  if Result = -1 then
    raise ERglError.Create('Couldn''t bind attribute.');
end;

function TRglProgram.AddUniform<T>(const AName: string): T;
begin
  Result := T(TRglUniformClass(T).Create(FContext, FHandle, AName));
  FUniforms.Add(Result);
end;

procedure TRglProgram.AttachShader(AShader: TRglShader);
begin
  FContext.MakeCurrent('TRglProgram.AttachShader');
  if not FShaders.TryAdd(AShader.Handle, AShader.Source) then
    raise ERglError.Create('A shader of this kind has already been attached to the program.');
  glAttachShader(FHandle, AShader.Handle);
end;

constructor TRglProgram.Create(AContext: TRglContext);
begin
  FContext := AContext;
  FContext.MakeCurrent('TRglProgram.Create');
  FShaders := TDictionary<Integer, AnsiString>.Create;
  FUniforms := TObjectList<TRglUniform>.Create;
  FHandle := glCreateProgram;
end;

destructor TRglProgram.Destroy;
begin
  if Assigned(FContext) and FContext.TryMakeCurrent then
  begin
    glDeleteProgram(FHandle);
    FHandle := 0;
  end
  else
    rglLog('TRglProgram.Destroy error');
  FreeAndNil(FUniforms);
  FreeAndNil(FShaders);
  inherited;
end;

procedure TRglProgram.Link;
begin

  if FHandle = 0 then
    raise ERglError.Create('Program handle empty.');

  FContext.MakeCurrent('TRglProgram.Link');

  glLinkProgram(FHandle);

  var i: GLint := 0;
  glGetProgramiv(FHandle, GL_LINK_STATUS, @i);

  if i <> GL_TRUE then
  begin
    var maxlen: GLint;
    glGetProgramiv(FHandle, GL_INFO_LOG_LENGTH, @maxlen);
    var S: AnsiString;
    SetLength(S, maxlen);
    glGetProgramInfoLog(FHandle, maxlen, @maxlen, PAnsiChar(S));
    SetLength(S, maxlen);
    raise ERglError.Create('Program not successfully linked: ' + string(S));
  end;

  for var S in FShaders do
    glDetachShader(FHandle, S.Key);

  FShaders.Clear;

end;

function TRglProgram.TryAddUniform<T>(const AName: string): T;
begin
  Result := T(TRglUniformClass(T).TryCreate(FContext, FHandle, AName));
  if Assigned(Result) then
    FUniforms.Add(Result);
end;

procedure TRglProgram.Unuse;
begin
  FContext.MakeCurrent('TRglProgram.Unuse');
  glUseProgram(0);
end;

procedure TRglProgram.Use;
begin
  FContext.MakeCurrent('TRglProgram.Use');
  glUseProgram(FHandle);
end;

{ TRglUniformFloat }

procedure TRglUniformFloat.SetValue(const AValue: GLfloat);
begin
  if Self <> nil then
  begin
    Context.MakeCurrent('TRglUniformFloat.SetValue');
    glUniform1f(Handle, AValue);
  end;
end;

{ TRglUniformFloatVec2 }

procedure TRglUniformFloatVec2.SetValue(const AValue: rglv2);
begin
  if Self <> nil then
  begin
    Context.MakeCurrent('TRglUniformFloatVec2.SetValue');
    glUniform2fv(Handle, 1, AValue.ptr);
  end;
end;

procedure TRglUniformFloatVec2.SetValue(const a0, a1: GLfloat);
begin
  if Self <> nil then
  begin
    Context.MakeCurrent('TRglUniformFloatVec2.SetValue');
    glUniform2f(Handle, a0, a1);
  end;
end;

{ TRglUniformFloatVec3 }

procedure TRglUniformFloatVec3.SetValue(const AValue: rglv);
begin
  if Self <> nil then
  begin
    Context.MakeCurrent('TRglUniformFloatVec3.SetValue');
    glUniform3fv(Handle, 1, AValue.ptr);
  end;
end;

procedure TRglUniformFloatVec3.SetValue(const a0, a1, a2: GLfloat);
begin
  if Self <> nil then
  begin
    Context.MakeCurrent('TRglUniformFloatVec3.SetValue');
    glUniform3f(Handle, a0, a1, a2);
  end;
end;

{ TRglUniformFloatVec4 }

procedure TRglUniformFloatVec4.SetValue(const AValue: rglv4);
begin
  if Self <> nil then
  begin
    Context.MakeCurrent('TRglUniformFloatVec4.SetValue');
    glUniform4fv(Handle, 1, AValue.ptr);
  end;
end;

procedure TRglUniformFloatVec4.SetValue(const a0, a1, a2, a3: GLfloat);
begin
  if Self <> nil then
  begin
    Context.MakeCurrent('TRglUniformFloatVec4.SetValue');
    glUniform4f(Handle, a0, a1, a2, a3);
  end;
end;

{ TRglUniformFloatMat3 }

procedure TRglUniformFloatMat3.SetValue(const AValue: rglm);
begin
  if Self <> nil then
  begin
    Context.MakeCurrent('TRglUniformFloatMat3.SetValue');
    glUniformMatrix3fv(Handle, 1, GL_TRUE, AValue.ptr);
  end;
end;

{ TRglUniformFloatMat4 }

procedure TRglUniformFloatMat4.SetValue(const AValue: rglm4);
begin
  if Self <> nil then
  begin
    Context.MakeCurrent('TRglUniformFloatMat4.SetValue');
    glUniformMatrix4fv(Handle, 1, GL_TRUE, AValue.ptr);
  end;
end;

{ TRglUniformInt }

procedure TRglUniformInt.SetValue(const AValue: GLint);
begin
  if Self <> nil then
  begin
    Context.MakeCurrent('TRglUniformInt.SetValue');
    glUniform1i(Handle, AValue);
  end;
end;

{ TRglUniformUInt }

procedure TRglUniformUInt.SetValue(const AValue: GLuint);
begin
  if Self <> nil then
  begin
    Context.MakeCurrent('TRglUniformUInt.SetValue');
    glUniform1ui(Handle, AValue);
  end;
end;

{ TRglUniformDouble }

procedure TRglUniformDouble.SetValue(const AValue: Double);
begin
  if Self <> nil then
  begin
    Context.MakeCurrent('TRglUniformDouble.SetValue');
    glUniform1d(Handle, AValue);
  end;
end;

{ TRglUniformBool }

procedure TRglUniformBool.SetValue(const AValue: Boolean);
begin
  if Self <> nil then
  begin
    Context.MakeCurrent('TRglUniformBool.SetValue');
    glUniform1i(Handle, Ord(AValue <> False));
  end;
end;

{ TRglUniform }

constructor TRglUniform.Create;
begin

end;

constructor TRglUniform.Create(AContext: TRglContext;
  AProgram: Cardinal; const AName: string);
begin
  FContext := AContext;
  FContext.MakeCurrent('TRglUniform.Create');
  FName := AName;
  FHandle := glGetUniformLocation(AProgram, PAnsiChar(AnsiString(AName)));
  if FHandle = -1 then
    raise ERglError.Create('Couldn''t bind uniform.');
end;

destructor TRglUniform.Destroy;
begin
  FHandle := 0;
  inherited;
end;

class function TRglUniform.TryCreate(AContext: TRglContext; AProgram: Cardinal;
  const AName: string): TRglUniform;
begin
  AContext.MakeCurrent('TRglUniform.TryCreate');
  var LName := AName;
  var LHandle := glGetUniformLocation(AProgram, PAnsiChar(AnsiString(AName)));
  if LHandle <> -1 then
  begin
    Result := TRglUniform.Create;
    Result.FContext := AContext;
    Result.FName := LName;
    Result.FHandle := LHandle;
  end
  else
    Result := nil;
end;

{ TRglContext }

type
  wglCreateContextAttribsARB = function(DC: HDC; hShareContext: HGLRC; attribList: PInteger): HGLRC; stdcall;

class constructor TRglContext.ClassCreate;
begin
  FInstances := TList<TRglContext>.Create;
end;

class destructor TRglContext.ClassDestroy;
begin
  FreeAndNil(FInstances);
end;

constructor TRglContext.Create(AWnd: HWND);
const
  pfd: TPixelFormatDescriptor = (
    nSize: SizeOf(TPixelFormatDescriptor);
    nVersion: 1;
    dwFlags: PFD_SUPPORT_OPENGL or PFD_DRAW_TO_WINDOW or PFD_DOUBLEBUFFER;
    iPixelType: PFD_TYPE_RGBA;
    cColorBits: 32;
    cRedBits: 0; cRedShift: 0;
    cGreenBits: 0;  cGreenShift: 0;
    cBlueBits: 0; cBlueShift: 0;
    cAlphaBits: 0;  cAlphaShift: 0;
    cAccumBits: 0;
    cAccumRedBits: 0;
    cAccumGreenBits: 0;
    cAccumBlueBits: 0;
    cAccumAlphaBits: 0;
    cDepthBits: 24;
    cStencilBits: 0;
    cAuxBuffers: 0;
    iLayerType: PFD_MAIN_PLANE;
    bReserved: 0;
    dwLayerMask: 0;
    dwVisibleMask: 0;
    dwDamageMask: 0;
  );

  WGL_CONTEXT_MAJOR_VERSION_ARB           = $2091;
  WGL_CONTEXT_MINOR_VERSION_ARB           = $2092;
  WGL_CONTEXT_LAYER_PLANE_ARB             = $2093;
  WGL_CONTEXT_FLAGS_ARB                   = $2094;
  WGL_CONTEXT_PROFILE_MASK_ARB            = $9126;
  WGL_CONTEXT_DEBUG_BIT_ARB               = $0001;
  WGL_CONTEXT_FORWARD_COMPATIBLE_BIT_ARB  = $0002;
  WGL_CONTEXT_CORE_PROFILE_BIT_ARB        = $00000001;
  WGL_CONTEXT_COMPATIBILITY_PROFILE_BIT_ARB = $00000002;

  attribs: array[0..6] of Integer =
    (
      WGL_CONTEXT_MAJOR_VERSION_ARB,
        3,
      WGL_CONTEXT_MINOR_VERSION_ARB,
        3,
      WGL_CONTEXT_FLAGS_ARB,
        {$IFDEF DEBUG}
          WGL_CONTEXT_DEBUG_BIT_ARB
        {$ELSE}
          0
        {$ENDIF},
      0
    );

begin

  rglLog('TRglContext.Create');

  if Assigned(FInstances) then
  begin
    FInstances.Add(Self);
    rglLog('RGL context count: ' + FInstances.Count.ToString);
  end;

  FStockSurfaces := TDictionary<TStockSurfaceIndex, TStockSurfaceData>.Create;
  FStoredSolids := TDictionary<TDrawable3DClass, TSolidStoreRec>.Create;
  FCustomBuffers := TObjectDictionary<TDrawable3DClass, TObject>.Create([doOwnsValues]);

  FWnd := AWnd;
  FDC := GetDC(AWnd);

  if FDC = 0 then
    raise ERglError.Create('Couldn''t obtain device context during GL context creation.');

  var PixelFormat := ChoosePixelFormat(FDC, @pfd);

  if PixelFormat = 0 then
    RaiseLastOSError;

  if not SetPixelFormat(FDC, PixelFormat, @pfd) then
    RaiseLastOSError;

  FRC := wglCreateContext(FDC);

  if FRC = 0 then
    RaiseLastOSError;

  TRglContext.MakeCurrent(FDC, FRC, 'TRglContext.Create[1]');

  InitOpenGLext;

  var LwglCreateContextAttribsARB: wglCreateContextAttribsARB := wglGetProcAddress('wglCreateContextAttribsARB');

  if Assigned(LwglCreateContextAttribsARB) then
  begin
    TRglContext.MakeCurrent(0, 0, 'TRglContext.Create[2]');
    wglDeleteContext(FRC);
    FRC := LwglCreateContextAttribsARB(FDC, 0, @attribs);
    if FRC = 0 then
      RaiseLastOSError;
    TRglContext.MakeCurrent(FDC, FRC, 'TRglContext.Create[3]');
  end;

end;

destructor TRglContext.Destroy;
begin
  rglLog('TRglContext.Destroy');
  if wglGetCurrentContext = FRC then
  begin
    if not TRglContext.TryMakeCurrent(0, 0) then
      rglLog('TRglContext.Destroy: TryMakeCurrent failed');
  end;
  if FDC <> 0 then
  begin
    ReleaseDC(FWnd, FDC);
    FDC := 0;
  end;
  if FRC <> 0 then
  begin
    if not wglDeleteContext(FRC) then
      rglLog('TRglContext.Destroy: wglDeleteContext failed');
    FRC := 0; // yes, in any case
  end;
  FWnd := 0;
  FreeAndNil(FCustomBuffers);
  FreeAndNil(FStoredSolids);
  FreeAndNil(FStockSurfaces);
  if Assigned(FInstances) then
  begin
    FInstances.Remove(Self);
    rglLog('RGL context count: ' + FInstances.Count.ToString);
  end;
  inherited;
end;

function TRglContext.GetExtensionNames: TArray<string>;
begin

  MakeCurrent('TRglContext.GetExtensionNames');

  var c: GLInt := 0;
  glGetIntegerv(GL_NUM_EXTENSIONS, @c);

  SetLength(Result, c);
  for var i := 0 to c - 1 do
    Result[i] := string(PAnsiChar(glGetStringi(GL_EXTENSIONS, i)));

end;

function TRglContext.GetImplInfo: TGLImplInfo;
const
  MAX_TEXTURE_MAX_ANISOTROPY_EXT: GLenum = 34047;
begin

  MakeCurrent('TRglContext.GetImplInfo');

  Result := Default(TGLImplInfo);

  glGetIntegerv(GL_MAJOR_VERSION, @Result.Version.Major);
  glGetIntegerv(GL_MINOR_VERSION, @Result.Version.Minor);
  Result.VersionString := rglGetString(GL_VERSION);
  Result.Vendor := rglGetString(GL_VENDOR);
  Result.Renderer := rglGetString(GL_RENDERER);
  Result.GLSL := rglGetString(GL_SHADING_LANGUAGE_VERSION);
  glGetIntegerv(GL_CONTEXT_PROFILE_MASK, @Result.ContextProfileMask);
  glGetIntegerv(GL_CONTEXT_FLAGS, @Result.ContextFlags);
  glGetIntegerv(GL_ALIASED_LINE_WIDTH_RANGE, @Result.LineWidths.Aliased);
  glGetIntegerv(GL_SMOOTH_LINE_WIDTH_RANGE, @Result.LineWidths.Smooth);
  glGetIntegerv(GL_MAX_SAMPLES, @Result.MaxSamples);
  glGetIntegerv(GL_MAX_TEXTURE_SIZE, @Result.MaxTextureSize);
  glGetFloatv(MAX_TEXTURE_MAX_ANISOTROPY_EXT, @Result.MaxTextureAnisotropy)

end;

class function TRglContext.GlobalCount: Integer;
begin
  if Assigned(FInstances) then
    Result := FInstances.Count
  else
    Result := -1;
end;

class procedure TRglContext.MakeCurrent(DC: HDC; RC: HGLRC; const ACaller: string);
begin
  if (FCurrentDC <> DC) or (FCurrentRC <> RC) then
    DoMakeCurrent(DC, RC, ACaller);
end;

procedure TRglContext.MakeCurrent(const ACaller: string);
begin
  if (FCurrentDC <> FDC) or (FCurrentRC <> FRC) then
    DoMakeCurrent(FDC, FRC, ACaller);
end;

procedure TRglContext.SwapBuffers;
begin
  Windows.SwapBuffers(FDC);
end;

class function TRglContext.TryMakeCurrent(DC: HDC; RC: HGLRC): Boolean;
begin
  Result := (FCurrentDC = DC) and (FCurrentRC = RC) or wglMakeCurrent(DC, RC);
  if Result then
  begin
    FCurrentDC := DC;
    FCurrentRC := RC;
  end;
end;

function TRglContext.TryMakeCurrent: Boolean;
begin
  Result := (FCurrentDC = FDC) and (FCurrentRC = FRC) or wglMakeCurrent(FDC, FRC);
  if Result then
  begin
    FCurrentDC := FDC;
    FCurrentRC := FRC;
  end;
end;

class procedure TRglContext.DoMakeCurrent(DC: HDC; RC: HGLRC; const ACaller: string);
begin
  if wglMakeCurrent(DC, RC) then
  begin
    FCurrentDC := DC;
    FCurrentRC := RC
  end
  else
  begin
    rglLog(
      'TRglContext.DoMakeCurrent failed when invoked by %s for DC %x and RC %x.',
      [ACaller, NativeUInt(DC), NativeUInt(RC)]
    );
    RaiseLastOSError;
  end;
end;

{ TRglControl }

procedure TRglControl.ApplyClearColor;
begin
  if Assigned(FContext) then
  begin
    FContext.MakeCurrent('TRglControl.ApplyClearColor');
    glClearColor(FGlCtlColor.r, FGlCtlColor.g, FGlCtlColor.b, 1.0);
  end;
end;

procedure TRglControl.CMColorChanged(var Message: TMessage);
begin
  var C := ColorToRGB(Color);
  FGlCtlColor := vec(GetRValue(C) / $FF, GetGValue(C) / $FF, GetBValue(C) / $FF);
  ApplyClearColor;
  Invalidate;
end;

constructor TRglControl.Create(AOwner: TComponent);
begin
  inherited;
  QueryPerformanceFrequency(FPerfFreq);
  Color := clWhite;
  FGlCtlColor := vec(1.0, 1.0, 1.0);
  FClearMask := GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT;
end;

procedure TRglControl.CreateParams(var Params: TCreateParams);
begin
  inherited;
  Params.WindowClass.Style := Params.WindowClass.Style or CS_OWNDC;
end;

procedure TRglControl.CreateWnd;
begin
  inherited;
  FreeAndNil(FContext);
  FContext := TRglContext.Create(Handle);
  ApplyClearColor;
  GlInit;
end;

destructor TRglControl.Destroy;
begin
  inherited;
end;

procedure TRglControl.DestroyWnd;
begin
  FreeAndNil(FContext);
  inherited;
end;

function TRglControl.GetAspectRatio: Double;
begin
  var W := ClientWidth;
  var H := ClientHeight;
  if (W <> 0) and (H <> 0) then
    Result := W/H
  else
    Result := 1.0;
end;

procedure TRglControl.GLInit;
begin

end;

procedure TRglControl.Resize;
begin
  if Assigned(FContext) then
  begin
    FContext.MakeCurrent('TRglControl.Resize');
    glViewport(0, 0, ClientWidth, ClientHeight);
  end;
  Invalidate;
  inherited;
end;

procedure TRglControl.WMDestroy(var Message: TWMDestroy);
begin
  FreeAndNil(FContext);
  inherited;
end;

procedure TRglControl.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
  Message.Result := 1;
end;

procedure TRglControl.WMGetDlgCode(var Message: TWMGetDlgCode);
begin
  inherited;
  Message.Result := Message.Result or DLGC_WANTARROWS;
end;

procedure TRglControl.WMPaint(var Message: TWMPaint);
var
  PaintStruct: TPaintStruct;
begin
  var LThisTick: Int64;
  QueryPerformanceCounter(LThisTick);
  if (FPrevTick <> 0) and (LThisTick > FPrevTick) then
    FFPS := FPerfFreq / (LThisTick - FPrevTick);
  FPrevTick := LThisTick;
  BeginPaint(Handle, PaintStruct);
  try
    if Assigned(FContext) then
    begin
      FContext.MakeCurrent('TRglControl.WMPaint');
      if FClearMask <> 0 then
        glClear(FClearMask);
      Paint;
      if not ((Self is TVisCtl3D) and TVisCtl3D(Self).Stencil) then
        FContext.SwapBuffers;
    end
    else
    begin
      Canvas.Brush.Color := clWhite;
      Canvas.Font.Assign(Font);
      Canvas.Font.Color := clBlack;
      var R := ClientRect;
      var S := 'OpenGL context not set up.';
      Canvas.TextRect(R, S, [tfSingleLine, tfCenter, tfVerticalCenter, tfEndEllipsis]);
    end;
  finally
    EndPaint(Handle, PaintStruct);
  end;
end;

{ TVisCtl3D.TRenderOutputData }

function TVisCtl3D.TRenderOutputData.Aspect: Double;
begin
  if Height <> 0 then
    Result := Width / Height
  else
    Result := 1.0;
end;

class operator TVisCtl3D.TRenderOutputData.Equal(const Left,
  Right: TRenderOutputData): Boolean;
begin
  Result := (Left.Width = Right.Width) and (Left.Height = Right.Height) and
    (Left.Offscreen = Right.Offscreen) and (Left.MSAA = Right.MSAA) and
    (Left.PostProc = Right.PostProc);
end;

class operator TVisCtl3D.TRenderOutputData.NotEqual(const Left,
  Right: TRenderOutputData): Boolean;
begin
  Result := not (Left = Right);
end;

{ TVisCtl3D }

var LVisCtl3DSSTB_Level: Cardinal = 0;

procedure TVisCtl3D.SaveSceneToBitmap(const ARenderOutputData: TRenderOutputData;
  ACleanUp, ARenderToClipboard: Boolean; const AFileName: string);
begin

  Inc(LVisCtl3DSSTB_Level);
  try

    try

      var bm := TBitmap.Create(ARenderOutputData.Width, ARenderOutputData.Height);
      try
        bm.PixelFormat := pf24bit;
        var p := bm.ScanLine[bm.Height - 1]; // bm is bottom-up
        glReadPixels(0, 0, ARenderOutputData.Width, ARenderOutputData.Height, GL_BGR,
          GL_UNSIGNED_BYTE, p);
        if ARenderToClipboard then
          Clipboard.Assign(bm)
        else if not AFileName.IsEmpty then
          SaveGraphicToFile(bm, AFileName, ifFromExtension)
        else
          SaveGraphicToFile(bm, Parent);
      finally
        bm.Free;
      end;

    finally

      if ACleanUp and ARenderOutputData.Offscreen then
      begin
        if Fosbuf_coloratt <> 0 then
        begin
          glDeleteTextures(1, @Fosbuf_coloratt);
          Fosbuf_coloratt := 0;
        end;
        if Fosbuf <> 0 then
        begin
          glDeleteRenderbuffers(1, @Fosbuf);
          Fosbuf := 0;
        end;
      end;

    end;

  finally
    Dec(LVisCtl3DSSTB_Level);
  end;

end;

procedure TVisCtl3D.SaveToBitmap(const AFileName: string; AWidth,
  AHeight: Integer);
begin
  FRenderToBitmap := True;
  FRenderToClipboard := False;
  FRenderFileName := AFileName;
  FRenderOutputData.Offscreen := (AWidth <> ClientWidth) or (AHeight <> ClientHeight);
  FRenderOutputData.Width := AWidth;
  FRenderOutputData.Height := AHeight;
  Invalidate;
end;

procedure TVisCtl3D.SetEffects(const Value: TPPEs);
begin
  if FEffects <> Value then
  begin
    FEffects := Value;
    FPostProcessing := FEffects <> [];
    Invalidate;
  end;
end;

procedure TVisCtl3D.SetFov(const Value: Double);
begin
  if FFov <> Value then
  begin
    FFov := Value;
    if FProjection = Perspective then
    begin
      ComputeP(FRenderOutputData);
      Invalidate;
    end;
  end;
end;

procedure TVisCtl3D.SetLightPos(const Value: rglv);
begin
  if FLightPos <> Value then
  begin
    FLightPos := Value;
    Invalidate;
  end;
end;

procedure TVisCtl3D.SetMSAAValue(const Value: TMSAAValue);
begin

  if FMSAAValue <> Value then
  begin
    FMSAAValue := Value;
    Invalidate;
  end;

end;

procedure TVisCtl3D.SetProjection(const Value: TProjection);
begin
  if FProjection <> Value then
  begin
    FProjection := Value;
    ComputeP(FRenderOutputData);
    for var obj in FObjs.List do
      obj.ProjectionChanged;      
    Invalidate;
  end;
end;

procedure TVisCtl3D.SetShowAxes(const Value: Boolean);
begin
  if Assigned(FAxes) then
    FAxes.Visible := Value;
end;

procedure TVisCtl3D.SetupNewObjects;
begin
  if Assigned(FNewObjects) and (FNewObjects.Count > 0) then
  begin
    Screen.Cursor := crHourGlass;
    try
      for var NewObject in FNewObjects do
        try
          NewObject.Setup;
        except
          NewObject.FVisible := False;
        end;
      FNewObjects.Clear;
    finally
      Screen.Cursor := crDefault;
    end;
  end;
end;

procedure TVisCtl3D.UpdateContextMenuStates(ASelObj: TDrawable3D);
begin
  if Assigned(FPopupMenu) then
  begin
    if Assigned(FToggleAxesMnuItem) then
      FToggleAxesMnuItem.Checked := ShowAxes;
    if Assigned(FMSAASubmenu) then
      for var i := 0 to FMSAASubmenu.Count - 1 do
      begin
        FMSAASubmenu.Items[i].Checked := FMSAASubmenu.Items[i].Tag = Ord(FMSAAValue);
        FMSAASubmenu.Items[i].Visible := FMSAASubmenu.Items[i].Tag <= FMaxSamples;
      end;
    if Assigned(FPPSubmenu) then
      for var i := 0 to FPPSubmenu.Count - 1 do
        FPPSubmenu.Items[i].Checked := TPPE(FPPSubmenu.Items[i].Tag) in FEffects;
    if Assigned(FOrthogonalMnuItem) then
      FOrthogonalMnuItem.Checked := Projection = Orthographic;
    if Assigned(FPerspectiveMnuItem) then
      FPerspectiveMnuItem.Checked := Projection = Perspective;
    if Assigned(FRemoveMnuItem) then
    begin
      FRemoveMnuItem.Visible := Assigned(ASelObj);
      if Assigned(ASelObj) then
        FRemoveMnuItem.FObjRef := ASelObj.GUID
      else
        FRemoveMnuItem.FObjRef := TGUID.Empty;
    end;
    for var i := FPopupMenu.Items.Count - 1 downto 0 do
      if (FPopupMenu.Items[i] is TVisCtlObjectMenuItem) and (FPopupMenu.Items[i] <> FRemoveMnuItem) then
        FPopupMenu.Items.Delete(i);
    if Assigned(ASelObj) then
    begin
      var i := 0;
      var LCurObj := ASelObj;
      repeat
        var MI := TVisCtlObjectMenuItem.Create(FPopupMenu);
        MI.Caption := Format('%s settings', [LCurObj.Name]);
        MI.Hint := Format('Displays the settings dialog for this %s object.', [LCurObj.Name]);
        MI.FObjRef := LCurObj.GUID;
        MI.OnClick := MnuObjectSettings;
        FPopupMenu.Items.Insert(i, MI);
        LCurObj := LCurObj.FParent;
        Inc(i);
     until LCurObj = nil;
    end;
    var ShiftKeyDown := GetKeyState(VK_SHIFT) < 0;
    if Assigned(FImplInfoMnuItem) then
      FImplInfoMnuItem.Visible := ShiftKeyDown;
    if Assigned(FExtInfoMnuItem) then
      FExtInfoMnuItem.Visible := ShiftKeyDown;
  end;
end;

procedure TVisCtl3D.ViewChanged(Sender: TObject);
begin
  ComputeV;
  if FProjection = Orthographic then
    ComputeP(FRenderOutputData);
  Invalidate;
end;

procedure TVisCtl3D.WMContextMenu(var Message: TWMContextMenu);
var
  P: TPoint;
begin
  if Assigned(FPopupMenu) then
  begin
    var LObj := TDrawable3D(nil);
    if Message.Pos = Point(-1, -1) then
      P := ClientToScreen(BoundsRect.CenterPoint)
    else
    begin
      P := Message.Pos;
      with ScreenToClient(P) do
        LObj := HitTest(X, Y);
    end;
    UpdateContextMenuStates(LObj);
    CustomizeMenu(FPopupMenu);
    if Assigned(FOnBeforeContextPopup) then
      FOnBeforeContextPopup(Self);
    FPopupMenu.OnPopup := nil;
    try
      FPopupMenu.Popup(P.X, P.Y);
    finally
      if Assigned(Self) and Assigned(FPopupMenu) then
        FPopupMenu.OnPopup := PopupMenuPopup;
    end;
  end
  else
    inherited;
end;

procedure TVisCtl3D.WMDestroy(var Message: TWMDestroy);
begin
  FreeGLResources;
  inherited;
end;

procedure TVisCtl3D.Zoom(const Delta: Double; Shift: TShiftState);
begin
  var F := 1.0;
  if ssCtrl in Shift then
    F := 10
  else if ssShift in Shift then
    F := 0.1;
  var q: Double := Pow(1.1, -F * Delta);
  r := q * r;
  r := EnsureRange(r, 0.01, 900);
  ComputeV;
  if FProjection = Orthographic then
    ComputeP(FRenderOutputData);
  Invalidate;
end;

procedure TVisCtl3D.ZoomIn(const Delta: Double; Shift: TShiftState);
begin
  Zoom(Abs(Delta), Shift);
end;

procedure TVisCtl3D.ZoomOut(const Delta: Double; Shift: TShiftState);
begin
  Zoom(-Abs(Delta), Shift);
end;

procedure TVisCtl3D.ClearScene;
begin
  var LObjects := TList<TDrawable3D>.Create;
  try
    for var i := 0 to FObjs.ItemCount - 1 do
    begin
      var LObj := FObjs.Items[i];
      if Assigned(LObj) and (LObj.Parent = nil) and not LObj.FProtected and (LObj <> FAxes) then
        LObjects.Add(LObj);
    end;
    for var LObj in LObjects do
      RemoveObject(LObj);
  finally
    LObjects.Free;
  end;
end;

procedure TVisCtl3D.ComputeM;
begin
  M :=
    rglRotate(-90, 0, 0, 1)
      *
    rglRotate(-90, 0, 1, 0);
end;

procedure TVisCtl3D.ComputeP(const ARenderOutputData: TRenderOutputData);
begin
  var AR: Single;
  if
    ((ARenderOutputData.Width = 0) or (ARenderOutputData.Height = 0)) and not ARenderOutputData.Offscreen
  then
  begin
    if (ClientWidth <> 0) and (ClientHeight <> 0) then
      AR := ClientWidth / ClientHeight
    else
      AR := 1.0;
  end
  else
    AR := ARenderOutputData.Aspect;
  case FProjection of
    Orthographic:
      P := rglOrtho(-r, r, -r / AR, r / AR, 0.1, 1000);
    Perspective:
      P := rglPerspective(FFOV, AR, 0.1, 1000)
  else
    P := rglm4.Identity;
  end;
end;

procedure TVisCtl3D.ComputeV;
begin
  eye.x := r*Sin(θ)*Cos(φ);
  eye.y := r*Sin(θ)*Sin(φ);
  eye.z := r*Cos(θ);
  var z := eye.x;
  var x := eye.y;
  var y := eye.z;
  var u: rglv;
  if IsZero(θ, 1E-7) then
    u := vec(-Sin(φ), 0, -Cos(φ))
  else if IsZero(θ - Pi, 1E-7) then
    u := vec(Sin(φ), 0, Cos(φ))
  else
    u := vec(0, 1, 0);
  V := rglLookAt(x, y, z, 0.0, 0.0, 0.0, u.x, u.y, u.z);
end;

constructor TVisCtl3D.Create(AOwner: TComponent);
begin
  inherited;
  FMSAAValue := msaa8;
  ClearMask := 0;
  r := 25;
  θ := Pi/4;
  φ := Pi/4;
  ComputeM;
  ComputeV;
  FFOV := 45;
  FLightPos := vec(10.0, 12.0, 8.0);
  FProjection := Perspective;
  FNewObjects := TList<TDrawable3D>.Create;
  FScene := TScene.Create(Self);
  FView := TView3D.Create(Self);
  FView.OnChange := ViewChanged;
  FObjs := TDrawableList3D.Create(Self);
  FObjs.OnChange := ObjChanged;
  FAxes := NewObject<TAxes>;
  FAxes.FProtected := True;
  FInvalidationTimer := TTimer.Create(Self);
  FInvalidationTimer.Interval := 50;
  FInvalidationTimer.OnTimer := InvalidationTimerTimer;
  FInvalidationTimer.Enabled := False;
  FAnimationTimer := TAnimationTimer.Create(Self);
  FAnimationTimer.Control := Self;
  FAnimationTimer.OnTimer := AnimationTimerTimer;
  FAnimationTimer.Enabled := False;
  TabStop := True;
  FCustomMenuItems := TList<TMenuItem>.Create;
  MakeContextMenu;
  {$IFDEF DEBUG}
  var DBG := TTextRect.Create(Self);
  Self.AddObject(DBG);
  DBG.Text := 'debugging mode';
  DBG.Opacity := 0.25;
  DBG.Position := vec(-0.001, 0.1, 0.1);
  DBG.Direction := vec(1, 0, 0);
  DBG.Scale := DBG.Scale * 0.2;
  DBG.AnchorPoint := apBottomLeft;
  DBG.TextResFactor := 0.4;
  DBG.FProtected := True;
  {$ENDIF}
end;

procedure TVisCtl3D.CreateWnd;
begin
  inherited;
end;

procedure TVisCtl3D.CustomizeMenu(AMenu: TMenu);
begin

  if FCustomMenuItems = nil then
    Exit;

  if AMenu = nil then
    Exit;

  for var i := 0 to FCustomMenuItems.Count - 1 do
  begin
    if Assigned(FCustomMenuItems[i].Parent) then
      FCustomMenuItems[i].Parent.Remove(FCustomMenuItems[i]);
    AMenu.Items.Add(FCustomMenuItems[i]);
  end;

end;

procedure TVisCtl3D.ObjChanged(Sender: TObject);
begin
  LowPriorityInvalidate;
end;

procedure TVisCtl3D.AnimationTimerTimer(Sender: TObject);
begin
  Invalidate;
end;

procedure TVisCtl3D.BeginBackgroundPaint;
begin
  Inc(FBackgroundPaintLevel);
end;

procedure TVisCtl3D.EndBackgroundPaint;
begin
  Dec(FBackgroundPaintLevel);
end;

procedure TVisCtl3D.FramebufferSetup(const ARenderOutputData: TRenderOutputData);

const
  ScreenQuad: array[0..2*2*2*3-1] of GLfloat =
    (
      -1.0, +1.0,      0.0, 1.0,
      -1.0, -1.0,      0.0, 0.0,
      +1.0, -1.0,      1.0, 0.0,
      -1.0, +1.0,      0.0, 1.0,
      +1.0, -1.0,      1.0, 0.0,
      +1.0, +1.0,      1.0, 1.0
    );

begin

  if Context = nil then
    Exit;

  Context.MakeCurrent('TVisCtl3D.FramebufferSetup');

  var LMaxSamples: GLint;
  glGetIntegerv(GL_MAX_SAMPLES, @LMaxSamples);
  if Ord(FMSAAValue) > LMaxSamples then
    FMSAAValue := TMSAAValue(LMaxSamples);

  FMaxSamples := LMaxSamples;

  // 1: Multi-sample buffer for MSAA

  if FMSAAValue <> msaa0 then
  begin

    if FMSAAbuf = 0 then
      glGenFramebuffers(1, @FMSAAbuf);

    glBindFramebuffer(GL_FRAMEBUFFER, FMSAAbuf);

    if FMSAAbuf_coloratt = 0 then
      glGenTextures(1, @FMSAAbuf_coloratt);

    glBindTexture(GL_TEXTURE_2D_MULTISAMPLE, FMSAAbuf_coloratt);
    glTexImage2DMultisample(GL_TEXTURE_2D_MULTISAMPLE, Ord(FMSAAValue), GL_RGB,
      ARenderOutputData.Width, ARenderOutputData.Height, GL_TRUE);
    glFramebufferTexture2D(GL_FRAMEBUFFER, GL_COLOR_ATTACHMENT0,
      GL_TEXTURE_2D_MULTISAMPLE, FMSAAbuf_coloratt, 0);

    if FMSAAbuf_dsatt = 0 then
      glGenRenderbuffers(1, @FMSAAbuf_dsatt);

    glBindRenderbuffer(GL_RENDERBUFFER, FMSAAbuf_dsatt);
    glRenderbufferStorageMultisample(GL_RENDERBUFFER, Ord(FMSAAValue),
      GL_DEPTH24_STENCIL8, ARenderOutputData.Width, ARenderOutputData.Height);
    glFramebufferRenderbuffer(GL_FRAMEBUFFER, GL_DEPTH_STENCIL_ATTACHMENT,
      GL_RENDERBUFFER, FMSAAbuf_dsatt);

    if glCheckFramebufferStatus(GL_FRAMEBUFFER) <> GL_FRAMEBUFFER_COMPLETE then
      DebugBreak;

  end
  else
  begin
    if FMSAAbuf_dsatt <> 0 then
    begin
      glDeleteRenderbuffers(1, @FMSAAbuf_dsatt);
      FMSAAbuf_dsatt := 0;
    end;
    if FMSAAbuf_coloratt <> 0 then
    begin
      glDeleteTextures(1, @FMSAAbuf_coloratt);
      FMSAAbuf_coloratt := 0;
    end;
    if FMSAAbuf <> 0 then
    begin
      glDeleteFramebuffers(1, @FMSAAbuf);
      FMSAAbuf := 0;
    end;
  end;


  // 2: Off-screen buffer for post-processing

  if FPostProcessing then
  begin

    if Fauxbuf = 0 then
      glGenFramebuffers(1, @Fauxbuf);

    glBindFramebuffer(GL_FRAMEBUFFER, Fauxbuf);

    if Fauxbuf_coloratt = 0 then
      glGenTextures(1, @Fauxbuf_coloratt);

    glBindTexture(GL_TEXTURE_2D, Fauxbuf_coloratt);
    glTexImage2D(GL_TEXTURE_2D, 0, GL_RGB, ARenderOutputData.Width, ARenderOutputData.Height,
      0, GL_RGB, GL_UNSIGNED_BYTE, nil);
    glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR);
    glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR);
    glFramebufferTexture2D(GL_FRAMEBUFFER, GL_COLOR_ATTACHMENT0, GL_TEXTURE_2D,
      Fauxbuf_coloratt, 0);

    if FMSAAValue = msaa0 then
    begin

      if Fauxbuf_dsatt = 0 then
        glGenRenderbuffers(1, @Fauxbuf_dsatt);

      glBindRenderbuffer(GL_RENDERBUFFER, Fauxbuf_dsatt);
      glRenderbufferStorage(GL_RENDERBUFFER, GL_DEPTH24_STENCIL8,
        ARenderOutputData.Width, ARenderOutputData.Height);
      glFramebufferRenderbuffer(GL_FRAMEBUFFER, GL_DEPTH_STENCIL_ATTACHMENT,
        GL_RENDERBUFFER, Fauxbuf_dsatt);

    end;

    if glCheckFramebufferStatus(GL_FRAMEBUFFER) <> GL_FRAMEBUFFER_COMPLETE then
      DebugBreak;

  end
  else
  begin
    if Fauxbuf_dsatt <> 0 then
    begin
      glDeleteRenderbuffers(1, @Fauxbuf_dsatt);
      Fauxbuf_dsatt := 0;
    end;
    if Fauxbuf_coloratt <> 0 then
    begin
      glDeleteTextures(1, @Fauxbuf_coloratt);
      Fauxbuf_coloratt := 0;
    end;
    if Fauxbuf <> 0 then
    begin
      glDeleteFramebuffers(1, @Fauxbuf);
      Fauxbuf := 0;
    end;
  end;


  // 3: Screen quad

  if FScreenVAO = 0 then
  begin
    glGenVertexArrays(1, @FScreenVAO);
    glBindVertexArray(FScreenVAO);
    glGenBuffers(1, @FScreenQuad);
    glBindBuffer(GL_ARRAY_BUFFER, FScreenVAO);
    glBufferData(GL_ARRAY_BUFFER, SizeOf(ScreenQuad), @ScreenQuad, GL_STATIC_DRAW);
    glEnableVertexAttribArray(0);
    glEnableVertexAttribArray(1);
    glVertexAttribPointer(0, 2, GL_FLOAT, GL_FALSE, 4*SizeOf(GLfloat), nil);
    glVertexAttribPointer(1, 2, GL_FLOAT, GL_FALSE, 4*SizeOf(GLfloat), Pointer(2*SizeOf(GLfloat)));
    glBindVertexArray(0);
  end;


  // 4: Off-screen output buffer

  if ARenderOutputData.Offscreen then
  begin

    if Fosbuf = 0 then
      glGenFramebuffers(1, @Fosbuf);

    glBindFramebuffer(GL_FRAMEBUFFER, Fosbuf);

    if Fosbuf_coloratt = 0 then
      glGenTextures(1, @Fosbuf_coloratt);

    glBindTexture(GL_TEXTURE_2D, Fosbuf_coloratt);
    glTexImage2D(GL_TEXTURE_2D, 0, GL_RGB, ARenderOutputData.Width, ARenderOutputData.Height,
      0, GL_RGB, GL_UNSIGNED_BYTE, nil);
    glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR);
    glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR);
    glFramebufferTexture2D(GL_FRAMEBUFFER, GL_COLOR_ATTACHMENT0, GL_TEXTURE_2D,
      Fosbuf_coloratt, 0);

    if glCheckFramebufferStatus(GL_FRAMEBUFFER) <> GL_FRAMEBUFFER_COMPLETE then
      DebugBreak;

  end
  else
  begin
    if Fosbuf_coloratt <> 0 then
    begin
      glDeleteTextures(1, @Fosbuf_coloratt);
      Fosbuf_coloratt := 0;
    end;
    if Fosbuf <> 0 then
    begin
      glDeleteFramebuffers(1, @Fosbuf);
      Fosbuf := 0;
    end;
  end;

end;

procedure TVisCtl3D.FreeGLResources;
begin
  if HandleAllocated and Assigned(Context) then
  begin
    if Context.TryMakeCurrent then
    begin
      if Assigned(FObjs) then
        FObjs.FreeGLResources;
      glDeleteBuffers        (1, @FScreenQuad);        FScreenQuad := 0;
      glDeleteTextures       (1, @Fosbuf_coloratt);    Fosbuf_coloratt := 0;
      glDeleteFramebuffers   (1, @Fosbuf);             Fosbuf := 0;
      glDeleteRenderbuffers  (1, @Fauxbuf_dsatt);      Fauxbuf_dsatt := 0;
      glDeleteTextures       (1, @Fauxbuf_coloratt);   Fauxbuf_coloratt := 0;
      glDeleteFramebuffers   (1, @Fauxbuf);            Fauxbuf := 0;
      glDeleteVertexArrays   (1, @FScreenVAO);         FScreenVAO := 0;
      glDeleteRenderbuffers  (1, @FMSAAbuf_dsatt);     FMSAAbuf_dsatt := 0;
      glDeleteTextures       (1, @FMSAAbuf_coloratt);  FMSAAbuf_coloratt := 0;
      glDeleteFramebuffers   (1, @FMSAAbuf);           FMSAAbuf := 0;
    end
    else
      rglLog('TVisCtl3D.FreeGLResources: TryMakeCurrent failed');
    FreeAndNil(FProgramMgr);
  end;
end;

procedure TVisCtl3D.InvalidationTimerTimer(Sender: TObject);
begin
  FInvalidationTimer.Enabled := False;
  Invalidate;
end;

procedure TVisCtl3D.KeyDown(var Key: Word; Shift: TShiftState);
begin
  inherited;
  case Key of
    VK_LEFT:
      begin
        φ := rmod(φ - Pi/50, 2*Pi);
        ComputeV;
        Invalidate;
      end;
    VK_RIGHT:
      begin
        φ := rmod(φ + Pi/50, 2*Pi);
        ComputeV;
        Invalidate;
      end;
    VK_UP:
      begin
        θ := EnsureRange(θ - Pi/50, 0, Pi);
        ComputeV;
        Invalidate;
      end;
    VK_DOWN:
      begin
        θ := EnsureRange(θ + Pi/50, 0, Pi);
        ComputeV;
        Invalidate;
      end;
    VK_OEM_MINUS, VK_SUBTRACT:
      ZoomOut(1, Shift);
    VK_OEM_PLUS, VK_ADD:
      ZoomIn(1, Shift);
  end;
end;

procedure TVisCtl3D.KeyPress(var Key: Char);
begin
  inherited;
  case Key of
    ^A:
      MnuToggleAxes(Self);
    ^C:
      MnuCopySceneToClipboard(Self);
    ^S:
      MnuSaveSceneToFile(Self);
  end;
end;

procedure TVisCtl3D.LowPriorityInvalidate;
begin
  if FBackgroundPaintLevel <= 0 then
    Invalidate
  else
    FInvalidationTimer.Enabled := True;
end;

procedure TVisCtl3D.MakeContextMenu;
begin

  if Assigned(FPopupMenu) then
    Exit;

  FPopupMenu := TPopupMenu.Create(Self);
  FPopupMenu.OnPopup := PopupMenuPopup;

  var mi := TMenuItem.Create(FPopupMenu);
  mi.Caption := 'Scene settings';
  mi.Hint := 'Opens the scene''s settings dialog.';
  mi.OnClick := MnuSceneSettings;
  FPopupMenu.Items.Add(mi);

  FPopupMenu.Items.NewBottomLine;

  mi := TVisCtlObjectMenuItem.Create(FPopupMenu);
  mi.Caption := 'Remove this object';
  mi.Hint := 'Removes the selected object.';
  mi.OnClick := MnuRemoveObject;
  FPopupMenu.Items.Add(mi);
  FRemoveMnuItem := mi as TVisCtlObjectMenuItem;

  FPopupMenu.Items.NewBottomLine;

  mi := TMenuItem.Create(FPopupMenu);
  mi.Caption := 'Show axes'#9'Ctrl+A';
  mi.Hint := 'Shows or hides the coordinate axes.';
  mi.OnClick := MnuToggleAxes;
  FPopupMenu.Items.Add(mi);
  FToggleAxesMnuItem := mi;

  FPopupMenu.Items.NewBottomLine;

  mi := TMenuItem.Create(FPopupMenu);
  mi.Caption := 'Save image to file...'#9'Ctrl+S';
  mi.Hint := 'Saves the current scene to a bitmap picture file.';
  mi.OnClick := MnuSaveSceneToFile;
  FPopupMenu.Items.Add(mi);

  mi := TMenuItem.Create(FPopupMenu);
  mi.Caption := 'Copy image to clipboard...'#9'Ctrl+C';
  mi.Hint := 'Copies the current scene to the clipboard.';
  mi.OnClick := MnuCopySceneToClipboard;
  FPopupMenu.Items.Add(mi);

  FPopupMenu.Items.NewBottomLine;

  mi := TMenuItem.Create(FPopupMenu);
  mi.Caption := 'Projection';
  mi.Hint := 'Contains the available projections.';
  FPopupMenu.Items.Add(mi);
  FProjSubmenu := mi;

  var smi := TMenuItem.Create(mi);
  smi.Caption := 'Orthographic';
  smi.Hint := 'Displays the scene using orthographic projection.';
  smi.Tag := 0;
  smi.OnClick := MnuSetProj;
  smi.RadioItem := True;
  mi.Add(smi);
  FOrthogonalMnuItem := smi;
  
  smi := TMenuItem.Create(mi);
  smi.Caption := 'Perspective';
  smi.Hint := 'Displays the scene using perspective projection.';
  smi.Tag := 1;
  smi.OnClick := MnuSetProj;
  smi.RadioItem := True;
  mi.Add(smi);
  FPerspectiveMnuItem := smi;  
  
  mi := TMenuItem.Create(FPopupMenu);
  mi.Caption := 'Anti-aliasing';
  mi.Hint := 'Contains the anti-aliasing options.';
  FPopupMenu.Items.Add(mi);
  FMSAASubmenu := mi;

  smi := TMenuItem.Create(mi);
  smi.Caption := 'No anti-aliasing';
  smi.Hint := 'Disables all anti-aliasing.';
  smi.Tag := Ord(msaa0);
  smi.OnClick := MnuSetMSAA;
  smi.RadioItem := True;
  mi.Add(smi);

  var LMSAAValue := 2;
  while LMSAAValue <= Ord(High(TMSAAValue)) do
  begin
    smi := TMenuItem.Create(mi);
    smi.Caption := Format('%d× MSAA', [LMSAAValue]);
    smi.Hint := Format('Enables %d× MSAA.', [LMSAAValue]);
    smi.Tag := LMSAAValue;
    smi.OnClick := MnuSetMSAA;
    smi.RadioItem := True;
    mi.Add(smi);
    LMSAAValue := 2 * LMSAAValue;
  end;

  mi := TMenuItem.Create(FPopupMenu);
  mi.Caption := 'Effects';
  mi.Hint := 'Contains available post-processing effects.';
  FPopupMenu.Items.Add(mi);
  FPPSubmenu := mi;

  for var ppe := Low(TPPE) to High(TPPE) do
  begin
    smi := TMenuItem.Create(mi);
    smi.Caption := ppe.Name;
    smi.Hint := Format('Enables or disables the %s post-processing effect.', [ppe.Name]);
    smi.Tag := Ord(ppe);
    smi.OnClick := MnuSetPP;
    mi.Add(smi);
  end;

  FPopupMenu.Items.NewBottomLine;

  mi := TMenuItem.Create(FPopupMenu);
  mi.Caption := 'OpenGL info';
  mi.Hint := 'Displays information about your system''s OpenGL implementation.';
  mi.OnClick := MnuImplInfo;
  FPopupMenu.Items.Add(mi);
  FImplInfoMnuItem := mi;

  mi := TMenuItem.Create(FPopupMenu);
  mi.Caption := 'OpenGL extensions';
  mi.Hint := 'Displays information about your system''s OpenGL extensions.';
  mi.OnClick := MnuExtInfo;
  FPopupMenu.Items.Add(mi);
  FExtInfoMnuItem := mi;

  mi := TMenuItem.Create(FPopupMenu);
  mi.Caption := '-';
  FPopupMenu.Items.Add(mi);

end;

procedure TVisCtl3D.MnuCopySceneToClipboard(Sender: TObject);
begin

  var W: Integer := Max(ClientWidth, 1);
  var H: Integer := Max(ClientHeight, 1);
  var Aspect: Double := 0.0;
  if ImageSizeDialog(GetParentForm(Self), W, H, Aspect) then
  begin
    FRenderToBitmap := True;
    FRenderToClipboard := True;
    FRenderOutputData.Offscreen := (W <> ClientWidth) or (H <> ClientHeight);
    FRenderOutputData.Width := W;
    FRenderOutputData.Height := H;
    Invalidate;
  end;

end;

procedure TVisCtl3D.MnuImplInfo(Sender: TObject);
begin

  TTableDialog.ShowTable(
    GetParentForm(Self),
    'OpenGL Info',
    'OpenGL implementation data',
    [
      'Version',
      'Vendor',
      'Renderer',
      'GLSL version',
      'Context profile mask',
      'Context flags',
      'Line widths (aliased)',
      'Line widths (smooth)',
      'Max MSAA samples',
      'Max texture size',
      'Max texture anisotropy'
    ],
    [
      FImplData.VersionString + #32'(' + FImplData.Version.Major.ToString + '.' + FImplData.Version.Minor.ToString + ')',
      FImplData.Vendor,
      FImplData.Renderer,
      FImplData.GLSL,
      FImplData.ContextProfileMask.ToHexString,
      FImplData.ContextFlags.ToHexString,
      FImplData.LineWidths.Aliased.Min.ToString + '..' + FImplData.LineWidths.Aliased.Max.ToString,
      FImplData.LineWidths.Smooth.Min.ToString + '..' + FImplData.LineWidths.Smooth.Max.ToString,
      FImplData.MaxSamples.ToString,
      FImplData.MaxTextureSize.ToString,
      FImplData.MaxTextureAnisotropy.ToString
    ],
    TMsgDlgType.mtCustom
  );

end;

procedure TVisCtl3D.MnuExtInfo(Sender: TObject);
begin

  if
    TD
      .Text('Do you want to copy the list of OpenGL extensions to clipboard?')
      .YesNoCancel
      .Execute = mrYes
  then
    Clipboard.AsText := string.Join(#13#10, FExts);

end;

procedure TVisCtl3D.MnuObjectSettings(Sender: TObject);
begin

  if Sender is TVisCtlObjectMenuItem then
  begin
    var MI := TVisCtlObjectMenuItem(Sender);
    var Obj := TDrawable3D(nil);
    if
      Assigned(FObjs) and not MI.ObjRef.IsEmpty
      and FObjs.TryGetDrawableByGUID(MI.ObjRef, Obj) and Assigned(Obj)
    then
      Obj.ShowOptionsForm
  end;

end;

procedure TVisCtl3D.MnuRemoveObject(Sender: TObject);
begin

  if Sender is TVisCtlObjectMenuItem then
  begin
    var MI := TVisCtlObjectMenuItem(Sender);
    var Obj := TDrawable3D(nil);
    if
      Assigned(FObjs) and not MI.ObjRef.IsEmpty
      and FObjs.TryGetDrawableByGUID(MI.ObjRef, Obj) and Assigned(Obj)
    then
    begin
      var LParent := Obj;
      while Assigned(LParent.Parent) do
        LParent := LParent.Parent;
      if
        TD
          .TextFmt('Do you want to remove this %s object?', [LParent.Name])
          .YesNoCancel
          .Execute = mrYes
      then
      begin
        if LParent = FAxes then
          ShowAxes := False
        else
          RemoveObject(LParent);
      end;
    end;
  end;

end;

procedure TVisCtl3D.MnuSaveSceneToFile(Sender: TObject);
begin

  var W: Integer := Max(ClientWidth, 1);
  var H: Integer := Max(ClientHeight, 1);
  var Aspect: Double := 0.0;
  if ImageSizeDialog(GetParentForm(Self), W, H, Aspect) then
    SaveToBitmap('', W, H);

end;

procedure TVisCtl3D.MnuSceneSettings(Sender: TObject);
begin
  if Assigned(FScene) then
    FScene.ShowOptionsForm;
end;

procedure TVisCtl3D.MnuSetMSAA(Sender: TObject);
begin
  if Sender is TMenuItem then
    MSAA := TMSAAValue(TMenuItem(Sender).Tag);
end;

procedure TVisCtl3D.MnuSetPP(Sender: TObject);
begin
  if Sender is TMenuItem then
  begin
    var PPE := TPPE(TMenuItem(Sender).Tag);
    if PPE in FEffects then
      Effects := FEffects - [PPE]
    else
      Effects := FEffects + [PPE];
  end;
end;

procedure TVisCtl3D.MnuSetProj(Sender: TObject);
begin
  if Sender is TMenuItem then
    case TMenuItem(Sender).Tag of
      0:
        Projection := Orthographic;
      1:
        Projection := Perspective;
    end;
end;

procedure TVisCtl3D.MnuToggleAxes(Sender: TObject);
begin
  ShowAxes := not ShowAxes;
end;

procedure TVisCtl3D.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
  inherited;
  FPrevMousePoint := Point(X, Y);
  if CanFocus then
    SetFocus;
end;

procedure TVisCtl3D.MouseMove(Shift: TShiftState; X, Y: Integer);
  function rmod(const x, y: Double): Double;
  begin
    Result := x - Floor64(x / y) * y;
  end;
begin
  inherited;
  if csLButtonDown in ControlState then
  begin
    var ∆X := X - FPrevMousePoint.X;
    var ∆Y := Y - FPrevMousePoint.Y;
    θ := EnsureRange(θ - ∆Y / 1000, 0, Pi);
    φ := rmod(φ - ∆X / 2000, 2*Pi);
    FPrevMousePoint := Point(X, Y);
    ComputeV;
    Invalidate;
  end;
end;

function TVisCtl3D.NewObject<T>: T;
begin
  Result := T.Create(Self);
  AddObject(Result);
end;

destructor TVisCtl3D.Destroy;
begin
  FreeGLResources;
  FreeAndNil(FObjs);
  FreeAndNil(FProgramMgr);
  FreeAndNil(FView);
  FreeAndNil(FScene);
  FreeAndNil(FNewObjects);
  if Assigned(FPopupMenu) then
    FPopupMenu.CloseMenu;
  FreeAndNil(FPopupMenu);
  FreeAndNil(FCustomMenuItems);
  inherited;
end;

procedure TVisCtl3D.DestroyWnd;
begin
  FreeGLResources;
  inherited;
end;

function TVisCtl3D.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
  MousePos: TPoint): Boolean;
begin
  Zoom(WheelDelta / 120, Shift);
  Result := True;
end;

function TVisCtl3D.GetObject(Index: Integer): TDrawable3D;
begin
  if FObjs = nil then
    Result := nil
  else
    Result := FObjs[Index];
end;

function TVisCtl3D.GetObjectCount: Integer;
begin
  if FObjs = nil then
    Result := 0
  else
    Result := FObjs.ItemCount;
end;

function TVisCtl3D.GetShowAxes: Boolean;
begin
  Result := Assigned(FAxes) and FAxes.Visible;
end;

procedure debugproc(source: GLenum; _type: GLenum; id: GLuint; severity: GLenum;
  length: GLsizei; const _message: PGLchar; userParam: Pointer); stdcall;
begin
  OutputDebugStringA(_message);
  if severity = GL_DEBUG_SEVERITY_HIGH then
    DebugBreak;
end;

procedure TVisCtl3D.GLInit;
begin

  inherited;

  Context.MakeCurrent('TVisCtl3D.GLInit');

  {$IFDEF DEBUG}
  glEnable(GL_DEBUG_OUTPUT);
  glEnable(GL_DEBUG_OUTPUT_SYNCHRONOUS_ARB);
  glDebugMessageCallback(debugproc, nil);
  {$ENDIF}

  glEnable(GL_DEPTH_TEST);
  glEnable(GL_BLEND);
  glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA);
  glPolygonOffset(1, 1);
  glEnable(GL_POLYGON_OFFSET_FILL);

  FImplData := Context.GetImplInfo;
  FExts := Context.GetExtensionNames;

  FreeAndNil(FProgramMgr);
  FProgramMgr := TProgramMgr.Create(Self);

  if Assigned(FObjs) then
  begin
    FObjs.GLRelease;
    if Assigned(FNewObjects) then
      for var obj in FObjs.List do
        if Assigned(obj) then
          FNewObjects.Add(obj);
  end;

end;

procedure TVisCtl3D.Paint;
begin

  if (Context = nil) or (FProgramMgr = nil) then
    Exit;

  Context.MakeCurrent('TVisCtl3D.Paint');

  var LRenderToBitmap := FRenderToBitmap;
  FRenderToBitmap := False;

  var LRenderToClipboard := FRenderToClipboard;
  FRenderToClipboard := False;

  var LRenderFileName := FRenderFileName;
  FRenderFileName := '';

  var LRenderOutputData := FRenderOutputData;
  FRenderOutputData := Default(TRenderOutputData);

  LRenderOutputData.MSAA := FMSAAValue;
  LRenderOutputData.PostProc := FPostProcessing;
  if not LRenderOutputData.Offscreen then
  begin
    LRenderOutputData.Width := ClientWidth;
    LRenderOutputData.Height := ClientHeight;
  end;

  if (FScreenVAO = 0) or (LRenderOutputData <> FPrevRenderOutputData) then
  begin
    FramebufferSetup(LRenderOutputData);
    ComputeP(LRenderOutputData);
  end;

  FPrevRenderOutputData := LRenderOutputData;

  //

  glViewport(0, 0, LRenderOutputData.Width, LRenderOutputData.Height);

  if FMSAAValue <> msaa0 then
    glBindFramebuffer(GL_FRAMEBUFFER, FMSAAbuf)
  else if FPostProcessing then
    glBindFramebuffer(GL_FRAMEBUFFER, Fauxbuf)
  else
    glBindFramebuffer(GL_FRAMEBUFFER, 0);

  ApplyClearColor;
  if FStencil then
    glClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT or GL_STENCIL_BUFFER_BIT)
  else
    glClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT);
  glEnable(GL_DEPTH_TEST);
  if FStencil then
  begin
    glEnable(GL_STENCIL_TEST);
    glStencilFunc(GL_ALWAYS, 0, 0);
    glStencilOp(GL_KEEP, GL_KEEP, GL_REPLACE);
  end
  else
    glDisable(GL_STENCIL_TEST);

  SetupNewObjects;
  MVP := P*V*M;
  ProgramMgr.BeginMonitorTime;
  FObjs.Draw(FGlobalTime);
  var LTimeDependent := ProgramMgr.EndMonitorTime or FObjs.TimeDependent;

  var LOutputFramebuffer: GLuint;
  if LRenderOutputData.Offscreen then
    LOutputFramebuffer := Fosbuf
  else
    LOutputFramebuffer := 0;

  if FMSAAValue <> msaa0 then
  begin

    glBindFramebuffer(GL_READ_FRAMEBUFFER, FMSAAbuf);

    if FPostProcessing then
      glBindFramebuffer(GL_DRAW_FRAMEBUFFER, Fauxbuf)
    else
      glBindFramebuffer(GL_DRAW_FRAMEBUFFER, LOutputFramebuffer);

    glBlitFramebuffer(0, 0, LRenderOutputData.Width, LRenderOutputData.Height,
      0, 0, LRenderOutputData.Width, LRenderOutputData.Height, GL_COLOR_BUFFER_BIT,
      GL_NEAREST);

  end;

  if FPostProcessing then
  begin

    glBindFramebuffer(GL_FRAMEBUFFER, LOutputFramebuffer);
    ProgramMgr.UseProgram(P_Tex);
    ProgramMgr.CurrentProgram.UPP_Greyscale.SetValue(ppGreyscale in FEffects);
    ProgramMgr.CurrentProgram.UPP_Invert.SetValue(ppInvert in FEffects);
    ProgramMgr.CurrentProgram.UPP_FlipV.SetValue(ppFlipV in FEffects);
    ProgramMgr.CurrentProgram.UPP_FlipH.SetValue(ppFlipH in FEffects);
    ProgramMgr.CurrentProgram.UPP_Binary.SetValue(ppBinary in FEffects);
    ProgramMgr.CurrentProgram.UPP_Spectra.SetValue(ppSpectra in FEffects);
    ProgramMgr.CurrentProgram.UPP_EdgeDetect.SetValue(ppEdgeDetect in FEffects);
    ProgramMgr.CurrentProgram.UPP_Sharpen.SetValue(ppSharpen in FEffects);
    ProgramMgr.CurrentProgram.UPP_Blur.SetValue(ppBlur in FEffects);
    ProgramMgr.CurrentProgram.UPP_Underwater.SetValue(ppUnderwater in FEffects);
    ProgramMgr.CurrentProgram.Ut.SetValue(FGlobalTime);
    glClear(GL_COLOR_BUFFER_BIT);
    glDisable(GL_DEPTH_TEST);
    glBindTexture(GL_TEXTURE_2D, Fauxbuf_coloratt);
    glBindVertexArray(FScreenVAO);
    glDrawArrays(GL_TRIANGLES, 0, 6);
    glBindVertexArray(0);

    LTimeDependent := LTimeDependent or (FEffects * AnimatedEffects <> []);

  end;

  if LRenderToBitmap then
  begin
    glBindFramebuffer(GL_FRAMEBUFFER, LOutputFramebuffer);
    SaveSceneToBitmap(LRenderOutputData, True, LRenderToClipboard, LRenderFileName);
  end;

  if not LRenderToBitmap and LTimeDependent then
  begin
    var LTick: Int64;
    if QueryPerformanceCounter(LTick) and (FPerfFreq <> 0) then
    begin
      if FPrevTick <> 0 then
        FGlobalTime := FGlobalTime + (LTick - FPrevTick) / FPerfFreq;
      FPrevTick := LTick;
      FAnimationTimer.Enabled := True;
    end;
  end
  else
  begin
    FPrevTick := 0;
    FAnimationTimer.Enabled := False;
  end;

end;

procedure TVisCtl3D.PopupMenuPopup(Sender: TObject);
begin
  UpdateContextMenuStates(nil);
end;

procedure TVisCtl3D.Resize;
begin
  if Assigned(OnResize) then
    OnResize(Self);
end;

procedure TVisCtl3D.AddMenuItem(AMenuItem: TMenuItem);
begin

  if FCustomMenuItems = nil then
    Exit;

  if AMenuItem = nil then
    Exit;

  FCustomMenuItems.Add(AMenuItem);

end;

procedure TVisCtl3D.AddMenuItems(AMenu: TMenuItem);
begin

  if FCustomMenuItems = nil then
    Exit;

  if AMenu = nil then
    Exit;

  for var i := 0 to AMenu.Count - 1 do
    AddMenuItem(AMenu[i]);

end;

procedure TVisCtl3D.AddObject(AObject: TDrawable3D);
begin
  if Assigned(FObjs) and Assigned(FObjs.List) and Assigned(AObject) then
  begin
    FObjs.List.Add(AObject);
    AObject.OnChange := ObjChanged;
    FNewObjects.Add(AObject);
  end;
end;

procedure TVisCtl3D.RemoveMenuItem(AMenuItem: TMenuItem);
begin

  if FCustomMenuItems = nil then
    Exit;

  if AMenuItem = nil then
    Exit;

  FCustomMenuItems.Remove(AMenuItem);

end;

procedure TVisCtl3D.RemoveObject(AObject: TDrawable3D);
begin
  if (Self = nil) or (FObjs = nil) or (FObjs.List = nil) then
    Exit;
  if AObject = nil then
    Exit;
  if AObject.FProtected then
    raise ERglError.Create('Cannot remove protected object.');
  if Assigned(AObject.FParent) then          // We are only allowed to remove a child
    raise ERglError.Create('Cannot remove child object.'); // if we are also removing its parent.
  for var Child in AObject.FChildren do      // Otherwise the parent may find itself having
    Self.RemoveObjectOrChild(Child);         // a dangling ptr.
  FObjs.List.Remove(AObject);                // Also, the TVisCtl3D user shoud only request
  if Assigned(FNewObjects) then              // to remove top-level objects, so RemoveObject
    FNewObjects.Remove(AObject);             // is public, while RemoveObjectOrChild isn't.
end;

procedure TVisCtl3D.RemoveObjectOrChild(AObject: TDrawable3D);
begin
  if (FObjs = nil) or (FObjs.List = nil) then
    Exit;
  if AObject = nil then
    Exit;
  if AObject.FProtected then
    raise ERglError.Create('Cannot remove protected object.');
  for var Child in AObject.FChildren do
    Self.RemoveObjectOrChild(Child);
  FObjs.List.Remove(AObject);
  if Assigned(FNewObjects) then
    FNewObjects.Remove(AObject);
end;

function TVisCtl3D.HitTest(X: Integer; Y: Integer): TDrawable3D;
begin
  Context.MakeCurrent('TVisCtl3D.HitTest');
  var LOldMSAA := Self.MSAA;
  var LOldEffects := Self.Effects;
  try
    FStencil := True;
    Self.MSAA := msaa0;
    Self.Effects := [ppIdentity];
    Repaint;
    glBindFramebuffer(GL_FRAMEBUFFER, Fauxbuf);
    var b: Byte := 0;
    glReadPixels(X, ClientHeight - Y, 1, 1, GL_STENCIL_INDEX, GL_UNSIGNED_BYTE, @b);
    glBindFramebuffer(GL_FRAMEBUFFER, 0);
    Result := FObjs.GetObjFromStencilID(b);
  finally
    FStencil := False;
    Self.MSAA := LOldMSAA;
    Self.Effects := LOldEffects;
  end
end;

{ TDrawableOptionsFrm3D }

constructor TDrawableOptionsFrm3D.Create(AOwner: TComponent;
  ADrawable: TDrawable3D);
begin
  FDrawable := ADrawable;
  inherited Create(AOwner);
  Initialize;
  FInitialized := True;
end;

procedure TDrawableOptionsFrm3D.DrawableDestroyed(Sender: TObject);
begin

end;

procedure TDrawableOptionsFrm3D.Initialize;
begin

end;

procedure TDrawableOptionsFrm3D.Reassign(ADrawable: TDrawable3D);
begin
  if Assigned(FDrawable) and Initialized then
    UpdateDrawable;
  FDrawable := ADrawable;
  FInitialized := False;
  Initialize;
  FInitialized := True;
end;

procedure TDrawableOptionsFrm3D.UpdateDrawable;
begin
  if Assigned(FOnChange) then
    FOnChange(Self);
end;

{ TDrawable3D }

procedure TDrawable3D.Changed(Sender: TObject);
begin
  if Assigned(FOnChange) then
    FOnChange(Self);
end;

procedure TDrawable3D.Changed;
begin
  if Assigned(FOnChange) then
    FOnChange(Self);
end;

class constructor TDrawable3D.ClassCreate;
begin
  FInstances := TDictionary<TGUID, TDrawable3D>.Create;
  FInstances.OnKeyNotify := InstanceListChanged;
end;

class destructor TDrawable3D.ClassDestroy;
begin
  FreeAndNil(FInstances);
end;

procedure TDrawable3D.Configure(ASettings: TAlgosimStructure);
begin
  inherited;
  for var i := 1 to ASettings.MemberCount do
  begin
    var S := ASettings.Members[i].Name;
    var V := ASettings.Members[i].Value;
    if S = 'title' then
      Title := V.ToString
    else if S = 'description' then
      Description := V.ToString
    else if S = 'windowwidth' then
      FCtl.SetWindowWidth(V.ToInt32)
    else if S = 'windowheight' then
      FCtl.SetWindowHeight(V.ToInt32)
    else if S = 'linewidth' then
      LineWidth := V.ToRealNumber
    else if S = 'visible' then
      Visible := V.ToBoolean
    else if S = 'animationspeed' then
      AnimationSpeed := V.ToRealNumber
    else if S = 'detached' then
      FCtl.SetDetached(V.ToBoolean);
  end;
end;

constructor TDrawable3D.Create(ACtl: TVisCtl3D);
begin
  FVisible := True;
  FCtl := ACtl;
  FLineWidth := 1.5;
  if Succeeded(CreateGUID(FGUID)) and Assigned(FInstances) then
    FInstances.Add(FGUID, Self);
  FDefaultProgram := P_Default;
  FChildren := TList<TDrawable3D>.Create;
  OptionsFormClass := TVis3D_DrawableSettingsFrm;
end;

function TDrawable3D.CreateReference: TAlgosimReference;
begin
  Result := TAlgosimReference.CreateWithValue(FGUID);
end;

function TDrawable3D.CreateChild<T>: T;
begin

  if FCtl = nil then
    Exit(nil);

  if FChildren = nil then
    Exit;

  Result := T.Create(FCtl);
  FCtl.AddObject(Result); // transfer of ownership

  // FCtl now owns Result

  Result.FParent := Self;
  FChildren.Add(Result);

end;

procedure TDrawable3D.DeleteChild(AChild: TDrawable3D);
begin
  if Assigned(FCtl) and Assigned(FChildren) and FChildren.Contains(AChild) then
  begin
    FChildren.Remove(AChild);
    FCtl.RemoveObjectOrChild(AChild);
  end;
end;

procedure TDrawable3D.DeleteChildren(ATagMask: NativeUInt);
begin
  if Assigned(FCtl) and Assigned(FChildren) then
  begin
    var LList := TList<TDrawable3D>.Create;
    try
      for var Child in FChildren do
        if Child.FParentTag and ATagMask <> 0 then
          LList.Add(Child);
      for var Child in LList do
      begin
        FChildren.Remove(Child);
        FCtl.RemoveObjectOrChild(Child);
      end;
    finally
      LList.Free;
    end;
  end;
end;

destructor TDrawable3D.Destroy;
begin
  FreeAndNil(FChildren); // FCtl (not Self) owns each child
  if Assigned(Control) and Assigned(Control.Context) then
    FreeGLResources;
  if Assigned(FInstances) then
    FInstances.Remove(FGUID);
  inherited;
end;

procedure TDrawable3D.Draw(const AGlobalTime: Double);
begin

end;

procedure TDrawable3D.FreeGLResources;
begin

end;

function TDrawable3D.GetChild(Index: Integer): TDrawable3D;
begin
  Result := FChildren[Index];
end;

function TDrawable3D.GetChildCount: Integer;
begin
  if Assigned(Self) and Assigned(FChildren) then
    Result := FChildren.Count
  else
    Result := 0;
end;

function TDrawable3D.GetDisplayed: Boolean;
begin
  Result := Visible and ((FParent = nil) or FParent.Displayed);
end;

function TDrawable3D.GetLineWidth: Single;
begin
  Result := FLineWidth;
end;

class function TDrawable3D.GetRealm: string;
begin
  Result := 'ℝ³';
end;

procedure TDrawable3D.GLRelease;
begin

end;

class procedure TDrawable3D.InstanceListChanged(Sender: TObject;
  const Item: TGUID; Action: TCollectionNotification);
begin
  if Assigned(VisObjListChanged) then
    VisObjListChanged(Sender);
end;

procedure TDrawable3D.ProjectionChanged;
begin

end;

procedure TDrawable3D.Recreate;
begin

end;

procedure TDrawable3D.SetAnimationSpeed(const Value: Double);
begin
  if FAnimationSpeed <> Value then
  begin
    FAnimationSpeed := Value;
    Changed;
  end;
end;

procedure TDrawable3D.SetLineWidth(const Value: Single);
begin
  if FLineWidth <> Value then
  begin
    FLineWidth := Value;
    Changed;
  end;
end;

procedure TDrawable3D.Setup;
begin

end;

procedure TDrawable3D.SetVisible(const Value: Boolean);
begin
  if FVisible <> Value then
  begin
    FVisible := Value;
    Changed;
  end;
end;

procedure TDrawable3D.ShowOptionsForm(AParent: TCustomForm);
var
  LOptionsFrm: TDrawableOptionsFrm3D;
begin
  if Assigned(OptionsFormClass) then
  begin
    if AParent = nil then
      AParent := GetParentForm(FCtl);
    LOptionsFrm := OptionsFormClass.Create(AParent, Self);
    try
      Inc(FModalLevel);
      try
        LOptionsFrm.ShowModal;
      finally
        Dec(FModalLevel);
      end;
    finally
      LOptionsFrm.Free;
    end;
  end
  else
    ShowMessage('This object has no configurable properties.');
end;

function TDrawable3D.TryContextCurrent: Boolean;
begin
  Result := Assigned(Control) and Assigned(Control.Context)
    and Control.Context.TryMakeCurrent;
end;

class function TDrawable3D.TryGetDrawableByGUID(const AGUID: TGUID;
  out ADrawable: TDrawable3D): Boolean;
begin
  Result := Assigned(FInstances) and FInstances.TryGetValue(AGUID, ADrawable);
end;

class function TDrawable3D.Verify(ADrawable: TDrawable3D): Boolean;
begin
  Result := Assigned(FInstances) and FInstances.ContainsValue(ADrawable);
end;

{ TDrawableList3D }

constructor TDrawableList3D.Create(ACtl: TVisCtl3D);
begin
  inherited;
  FList := TObjectList<TDrawable3D>.Create;
  FList.OnNotify := ObjsNotify;
  FSortedList := TList<TDrawable3D>.Create;
  Name := 'Collection';
  OptionsFormClass := TVis3D_DrawableListSettingsFrm;
end;

destructor TDrawableList3D.Destroy;
begin
  FreeAndNil(FSortedList);
  FreeAndNil(FList);
  inherited;
end;

procedure TDrawableList3D.Draw(const AGlobalTime: Double);
begin
  if FSortOrderDirty or FAlphaBlending and (FPrevCameraPos <> Control.CameraPos) then
    Resort;
  FTimeDependent := False;
  glDepthMask(GL_TRUE);
  var DepthWriteDisabled := False;
  try
    var FStencilID: Byte := 0;
    if Assigned(FSortedList) then
      for var obj in FSortedList do
        if Assigned(obj) and obj.Displayed then
        begin
          if Control.Stencil and (FStencilID < $FF) then
          begin
            Inc(FStencilID);
            FStencilIDs[FStencilID] := Pointer(obj);
          end;
          if not obj.DefaultProgram.IsEmpty then
          begin
            Control.ProgramMgr.UseProgram(obj.DefaultProgram);
            if not DepthWriteDisabled and (obj.DefaultProgram[1] = 'z') then
            begin
              glDepthMask(GL_FALSE);
              DepthWriteDisabled := True;
            end;
          end;
          if Control.Stencil then
            glStencilFunc(GL_ALWAYS, FStencilID, 0);
          const tc1 = GetTickCount64;
          obj.Draw(AGlobalTime);
          const tc2 = GetTickCount64;
          obj.FLastDrawTime := UInt64(tc2 - tc1);
          FTimeDependent := FTimeDependent or (obj.AnimationSpeed <> 0);
        end;
    FPrevCameraPos := Control.CameraPos;
  finally
    if DepthWriteDisabled then
      glDepthMask(GL_TRUE);
  end;
end;

procedure TDrawableList3D.FreeGLResources;
begin
  if Assigned(FList) then
    for var obj in FList do
      if Assigned(obj) then
        obj.FreeGLResources;
  inherited;
end;

function TDrawableList3D.GetItem(Index: Integer): TDrawable3D;
begin
  Result := FList[Index];
end;

function TDrawableList3D.GetItemCount: Integer;
begin
  if Assigned(FList) then
    Result := FList.Count
  else
    Result := 0;
end;

function TDrawableList3D.GetObjFromStencilID(AStencilID: Byte): TDrawable3D;
begin
  for var obj in FList do
    if Pointer(obj) = FStencilIDs[AStencilID] then
      Exit(obj);
  Result := nil;
end;

procedure TDrawableList3D.GLRelease;
begin
  if Assigned(FList) then
    for var obj in FList do
      if Assigned(obj) then
        obj.GLRelease;
  inherited;
end;

procedure TDrawableList3D.MoveDown(ADrawable: TDrawable3D);
begin
  var Idx := FList.IndexOf(ADrawable);
  if Idx <> -1 then
  begin
    FList.Move(Idx, Succ(Idx));
    Changed;
  end;
end;

procedure TDrawableList3D.MoveUp(ADrawable: TDrawable3D);
begin
  var Idx := FList.IndexOf(ADrawable);
  if Idx <> -1 then
  begin
    FList.Move(Idx, Pred(Idx));
    Changed;
  end;
end;

procedure TDrawableList3D.ObjsNotify(Sender: TObject; const Item: TDrawable3D;
  Action: TCollectionNotification);
begin
  FAlphaBlending := False;
  if Assigned(FList) then
  begin
    for var Obj in FList do
      if Obj.DefaultProgram.StartsWith('z') then
      begin
        FAlphaBlending := True;
        Break;
      end;
  end;
  Changed;
  FSortOrderDirty := True;
end;

procedure TDrawableList3D.Resort;
begin
  if Assigned(FList) and Assigned(FSortedList) then
  begin
    FSortOrderDirty := False;
    FSortedList.Clear;
    FSortedList.AddRange(FList);
    FSortedList.Sort(
      TComparer<TDrawable3D>.Construct(
        function(const Left, Right: TDrawable3D): Integer
        begin
          var LeftAlpha := (Left.DefaultProgram.Length > 0) and (Left.DefaultProgram[1] = 'z');
          var RightAlpha := (Right.DefaultProgram.Length > 0) and (Right.DefaultProgram[1] = 'z');
          if not LeftAlpha and not RightAlpha then
            Result := CompareStr(Left.DefaultProgram, Right.DefaultProgram)
          else if LeftAlpha and not RightAlpha then
            Result := 1
          else if RightAlpha and not LeftAlpha then
            Result := -1
          else
          begin
            if (Left is TGeometricObject3D) and (Right is TGeometricObject3D) then
            begin
              Result := -CompareValue(
                (TGeometricObject3D(Left).Position - Control.CameraPos).NormSquare,
                (TGeometricObject3D(Right).Position - Control.CameraPos).NormSquare
              )
            end
            else
              Result := 0;
          end;
        end
      )
    );
  end;
end;

procedure TDrawableList3D.SetItem(Index: Integer; const Value: TDrawable3D);
begin
  FList[Index] := Value;
end;

{ TManagedProgram }

constructor TManagedProgram.Create(const AName: string; AProgram: TRglProgram);
begin
  FName := AName;
  FProgram := AProgram;
  FUMVP := FProgram.TryAddUniform<TRglUniformFloatMat4>('MVP');
  FUEye := FProgram.TryAddUniform<TRglUniformFloatVec3>('eye');
  FULightPos := FProgram.TryAddUniform<TRglUniformFloatVec3>('lightpos');
  FUColor := FProgram.TryAddUniform<TRglUniformFloatVec3>('color');
  FUSize := FProgram.TryAddUniform<TRglUniformFloat>('size');
  FUAnchorPoint := FProgram.TryAddUniform<TRglUniformInt>('AnchorPoint');
  FUFaceScreen := FProgram.TryAddUniform<TRglUniformBool>('FaceScreen');
  FUAttribColors := FProgram.TryAddUniform<TRglUniformBool>('AttribColors');
  FUAspect := FProgram.TryAddUniform<TRglUniformFloat>('aspect');
  FUDisplacement := FProgram.TryAddUniform<TRglUniformFloatVec2>('displacement');
  FUObjectMatrix := FProgram.TryAddUniform<TRglUniformFloatMat4>('OM');
  FUNormalMatrix := FProgram.TryAddUniform<TRglUniformFloatMat3>('NormalMatrix');
  FUt := FProgram.TryAddUniform<TRglUniformFloat>('t');
  FUTranspColor := FProgram.TryAddUniform<TRglUniformFloatVec3>('transpcolor');
  FUOpaqueColor := FProgram.TryAddUniform<TRglUniformFloatVec3>('opaquecolor');
  FUTranspColorMode := FProgram.TryAddUniform<TRglUniformInt>('transpmode');
  FUOpacity := FProgram.TryAddUniform<TRglUniformFloat>('opacity');
  FUPP_Greyscale := FProgram.TryAddUniform<TRglUniformBool>('ppgreyscale');
  FUPP_Invert := FProgram.TryAddUniform<TRglUniformBool>('ppinvert');
  FUPP_FlipV := FProgram.TryAddUniform<TRglUniformBool>('ppflipv');
  FUPP_FlipH := FProgram.TryAddUniform<TRglUniformBool>('ppfliph');
  FUPP_Binary := FProgram.TryAddUniform<TRglUniformBool>('ppbinary');
  FUPP_Spectra := FProgram.TryAddUniform<TRglUniformBool>('ppspectra');
  FUPP_EdgeDetect := FProgram.TryAddUniform<TRglUniformBool>('ppedgedetect');
  FUPP_Sharpen := FProgram.TryAddUniform<TRglUniformBool>('ppsharpen');
  FUPP_Blur := FProgram.TryAddUniform<TRglUniformBool>('ppblur');
  FUPP_Underwater := FProgram.TryAddUniform<TRglUniformBool>('ppunderwater');
end;

destructor TManagedProgram.Destroy;
begin
  FreeAndNil(FProgram);
  inherited;
end;

{ TProgramMgr }

procedure TProgramMgr.BeginMonitorTime;
begin
  FTimeDependent := False;
end;

constructor TProgramMgr.Create(AControl: TVisCtl3D);
begin
  FControl := AControl;
  FPrograms := TObjectList<TManagedProgram>.Create;
end;

destructor TProgramMgr.Destroy;
begin
  FCurrentProgram := nil;
  FreeAndNil(FPrograms);
  inherited;
end;

function TProgramMgr.EndMonitorTime: Boolean;
begin
  Result := FTimeDependent;
end;

function TProgramMgr.GetProgram(const AName: string): TManagedProgram;
begin
  for var NP in FPrograms do
    if NP.Name = AName then
      Exit(NP);
  var SL := TStringList.Create;
  try
    var RS := TResourceStream.Create(HInstance, AName, RT_RCDATA);
    try
      SL.LoadFromStream(RS, TEncoding.ASCII);
      Result := LoadProgramResource(AName, SL);
    finally
      RS.Free;
    end;
  finally
    SL.Free;
  end;
end;

function TProgramMgr.LoadProgramResource(const AName: string; AData: TStringList): TManagedProgram;
var
  Sources: array[TShaderKind] of string;
  Shaders: array[TShaderKind] of TRglShader;
begin

  for var NP in FPrograms do
    if NP.Name = AName then
      raise Exception.Create('A program named "%s" is already loaded.');

  var ShaderKind := Vertex;
  for var S in AData do
  begin
    var GLSL := True;
    if (Length(S) >= 1) and (S[1] = '#') then
      for var sk := Low(TShaderKind) to High(TShaderKind) do
        if S.StartsWith('#' + sk.ToString) then
        begin
          ShaderKind := sk;
          GLSL := False;
          Break;
        end;
    if GLSL then
      Sources[ShaderKind] := Sources[ShaderKind] + #13#10 + S;
  end;

  var &Program := TRglProgram.Create(FControl.Context);
  try

    FillChar(Shaders, SizeOf(Shaders), 0);
    try

      for var sk := Low(TShaderKind) to High(TShaderKind) do
        if not Sources[sk].IsEmpty then
        begin
          Shaders[sk] := sk.RglClass.Create(FControl.Context, Sources[sk]);
          Shaders[sk].Compile;
          &Program.AttachShader(Shaders[sk]);
        end;

      &Program.Link;

    finally
      for var sk := Low(TShaderKind) to High(TShaderKind) do
        Shaders[sk].Free;
    end;

  except
    &Program.Free;
    raise;
  end;

  Result := TManagedProgram.Create(AName, &Program); // transfer of ownership
  FPrograms.Add(Result); // transfer of ownership

end;

procedure TProgramMgr.UseProgram(const AName: string);
begin

  var FProgram := GetProgram(AName);
  if FCurrentProgram <> FProgram then
    FProgram.&Program.Use;
  FCurrentProgram := FProgram;
  FProgram.UMVP.SetValue(FControl.CurrentMatrix);
  FProgram.UEye.SetValue(FControl.CameraPos);
  FProgram.ULightPos.SetValue(FControl.LightPos);
  FProgram.UObjectMatrix.SetValue(rglm4.Identity);
  FProgram.UNormalMatrix.SetValue(rglm.Identity);

  FTimeDependent := FTimeDependent or Assigned(FProgram.Ut);

end;

{ TShaderKindHelper }

function TShaderKindHelper.RglClass: TRglShaderClass;
begin
  case Self of
    Vertex:
      Result := TRglVertexShader;
    Geometry:
      Result := TRglGeometryShader;
    Fragment:
      Result := TRglFragmentShader;
  else
    Result := nil;
  end;
end;

function TShaderKindHelper.ToString: string;
begin
  case Self of
    Vertex:
      Result := 'vertex';
    Geometry:
      Result := 'geometry';
    Fragment:
      Result := 'fragment';
  else
    Result := '';
  end;
end;

{ TScene }

procedure TScene.Configure(ASettings: TAlgosimStructure);
begin
  inherited;
  for var i := 1 to ASettings.MemberCount do
  begin
    var S := ASettings.Members[i].Name;
    var V := ASettings.Members[i].Value;
    if S = 'antialiasing' then
      Control.MSAA := TMSAAValue(V.ToInt32)
    else if S = 'lightpos' then
      Control.LightPos := V.ToRealVector
    else if S = 'effects' then
    begin
      var LPPEs: TPPEs := [];
      for var j := 1 to V.ElementCount do
        Include(LPPEs, TPPE.FromString(V.Elements[j].ToString));
      Control.Effects := LPPEs;
    end;
  end;
end;

constructor TScene.Create(ACtl: TVisCtl3D);
begin
  inherited;
  Name := 'Scene';
  OptionsFormClass := TVis3D_SceneSettingsFrm;
end;

function TScene.CreateReference: TAlgosimReference;
begin
  Result := inherited;
  Result.AddSubref('view', FCtl.View.CreateReference);
  Result.AddSubref('axes', FCtl.Axes.CreateReference);
  Result.AddSubref('objects', FCtl.ObjectMgr.CreateReference);
end;

{ TRefAxes }

constructor TRefAxes.Create(ACtl: TVisCtl3D);
begin
  inherited;
  FDefaultProgram := P_Lighting;
  Name := 'Reference axes';
end;

destructor TRefAxes.Destroy;
begin
  inherited;
end;

procedure TRefAxes.Draw(const AGlobalTime: Double);
begin

  glBindVertexArray(FVAO);
  glDrawArrays(GL_TRIANGLE_STRIP, 0, 2*N);
  glDrawArrays(GL_TRIANGLE_STRIP, 2*N, 2*N);
  glDrawArrays(GL_TRIANGLE_STRIP, 4*N, 2*N);
  glBindVertexArray(0);

end;

procedure TRefAxes.FreeGLResources;
begin
  if TryContextCurrent then
  begin
    glDeleteBuffers(1, @FVertexData);   FVertexData := 0;
    glDeleteVertexArrays(1, @FVAO);     FVAO := 0;
  end
  else
    rglLog('TRefAxes.FreeGLResources: TryContextCurrent returned false');
  inherited;
end;

procedure TRefAxes.GLRelease;
begin
  FVertexData := 0;
  FVAO := 0;
  inherited;
end;

procedure TRefAxes.Setup;
var
  VertexData: array[0..3*2*N - 1] of GLfloat9;
  S, C: Single;
  Sʹ, Cʹ: Single;
const
  R: array[0..2] of Double = (1.0, 0.0, 0.0);
  G: array[0..2] of Double = (0.0, 1.0, 0.0);
  B: array[0..2] of Double = (0.0, 0.0, 1.0);
begin

  if (Control = nil) or (Control.Context = nil) then
    Exit;
  Control.Context.MakeCurrent('TRefAxes.Setup');

  for var i := 0 to N - 1 do
  begin
    SinCos(i * 2*Pi / (N - 1), S, C);
    SinCos((i + 0.5) * 2*Pi / (N - 1), Sʹ, Cʹ);
    for var j := 0 to 2 do
    begin
      var k := Succ(j) mod 3;
      var l := Succ(k) mod 3;
      VertexData[2*N*j + 2*i    ][j] :=  0.0;
      VertexData[2*N*j + 2*i    ][k] :=  0.1 * C;
      VertexData[2*N*j + 2*i    ][l] :=  0.1 * S;
      VertexData[2*N*j + 2*i    ][3] :=  R[j];
      VertexData[2*N*j + 2*i    ][4] :=  G[j];
      VertexData[2*N*j + 2*i    ][5] :=  B[j];
      VertexData[2*N*j + 2*i    ][j+6] :=  0;
      VertexData[2*N*j + 2*i    ][k+6] :=  C;
      VertexData[2*N*j + 2*i    ][l+6] :=  S;
      VertexData[2*N*j + 2*i + 1][j] := 10.0;
      VertexData[2*N*j + 2*i + 1][k] :=  0.1 * Cʹ;
      VertexData[2*N*j + 2*i + 1][l] :=  0.1 * Sʹ;
      VertexData[2*N*j + 2*i + 1][3] :=  R[j];
      VertexData[2*N*j + 2*i + 1][4] :=  G[j];
      VertexData[2*N*j + 2*i + 1][5] :=  B[j];
      VertexData[2*N*j + 2*i + 1][j+6] :=  0;
      VertexData[2*N*j + 2*i + 1][k+6] :=  C;
      VertexData[2*N*j + 2*i + 1][l+6] :=  S;
    end;
  end;

  if FVAO = 0 then glGenVertexArrays(1, @FVAO);

  glBindVertexArray(FVAO);
  try
    if FVertexData = 0 then glGenBuffers(1, @FVertexData);
    glBindBuffer(GL_ARRAY_BUFFER, FVertexData);
    glBufferData(GL_ARRAY_BUFFER, SizeOf(VertexData), @VertexData[0], GL_STATIC_DRAW);
    glEnableVertexAttribArray(0);
    glEnableVertexAttribArray(1);
    glEnableVertexAttribArray(2);
    glVertexAttribPointer(0, 3, GL_FLOAT, GL_FALSE, 9*SizeOf(GLfloat), nil);
    glVertexAttribPointer(1, 3, GL_FLOAT, GL_FALSE, 9*SizeOf(GLfloat), Pointer(3*SizeOf(GLfloat)));
    glVertexAttribPointer(2, 3, GL_FLOAT, GL_FALSE, 9*SizeOf(GLfloat), Pointer(6*SizeOf(GLfloat)));
  finally
    glBindVertexArray(0);
  end;

end;

{ TGeometricObject3D }

procedure TGeometricObject3D.Assign(Source: TPersistent);
begin
  if Source is TGeometricObject3D then
  begin
    FColor := TGeometricObject3D(Source).FColor;
    FPosition := TGeometricObject3D(Source).FPosition;
    FDirection := TGeometricObject3D(Source).FDirection;
    FScale := TGeometricObject3D(Source).FScale;
    FRotation := TGeometricObject3D(Source).FRotation;
    FLineWidth := TGeometricObject3D(Source).FLineWidth;
    FAnimationSpeed := TGeometricObject3D(Source).FAnimationSpeed;
    ComputeOM;
    Changed;
  end
  else
    inherited;
end;

procedure TGeometricObject3D.ComputeOM;
begin
  if FUseManualMatrix then
    FObjectMatrix := FManualMatrix
  else
  begin
    var R: rglm4;
    if IsZero(FDirection.x) and IsZero(FDirection.y) then
    begin
      R := rglm4.Identity;
      if FDirection.z < 0 then
        R.m[2, 2] := -1.0;
    end
    else
      R := rglRotate(180*ArcCos(FDirection.Normalized.z)/Pi, vec(0, 0, 1) xor FDirection);
    FObjectMatrix :=
      rglTranslate(FPosition)
        *
      R
        *
      rglRotate(FRotation, vec(0, 0, 1))
        *
      rglScale(FScale.x, FScale.y, FScale.z);
  end;
  if FParent is TGeometricObject3D then
    FObjectMatrix := TGeometricObject3D(FParent).FObjectMatrix * FObjectMatrix;
  FNormalMatrix := rglm(FObjectMatrix).Transpose.Inverse;
  if Assigned(FChildren) then
    for var Child in FChildren do
      if Child is TGeometricObject3D then
        TGeometricObject3D(Child).ComputeOM;
end;

procedure TGeometricObject3D.Configure(ASettings: TAlgosimStructure);
begin
  inherited;
  for var i := 1 to ASettings.MemberCount do
  begin
    var S := ASettings.Members[i].Name;
    var V := ASettings.Members[i].Value;
    if S = 'color' then
      Color := V.ToColor
    else if S = 'position' then
      Position := V.AsRealVector
    else if S = 'direction' then
      Direction := V.AsRealVector
    else if S = 'scale' then
      Scale := V.AsRealVector
    else if S = 'rotation' then
      Rotation := 180 * V.ToRealNumber / Pi;
  end;
end;

constructor TGeometricObject3D.Create(ACtl: TVisCtl3D);
begin
  inherited;
  FDefaultProgram := P_UniformColorLighting;
  FDirection := vec(0, 0, 1);
  FScale := vec(1, 1, 1);
  FManualMatrix := rglm4.Identity;
  ComputeOM;
  Name := 'Geometric object';
  OptionsFormClass := TVis3D_GeoObjSettingsFrm;
end;

procedure TGeometricObject3D.Draw(const AGlobalTime: Double);
begin

  inherited;

  if FAnimationSpeed <> 0.0 then
  begin
    FRotation := AGlobalTime * FAnimationSpeed;
    ComputeOM;
  end;

  Control.ProgramMgr.CurrentProgram.UColor.SetValue(FColor);
  Control.ProgramMgr.CurrentProgram.UObjectMatrix.SetValue(FObjectMatrix);
  Control.ProgramMgr.CurrentProgram.UNormalMatrix.SetValue(FNormalMatrix);

end;

function TGeometricObject3D.GetColor: TColor;
begin
  Result := FColor;
end;

procedure TGeometricObject3D.SetColor(const Value: TColor);
begin

  if FColor <> Value then
  begin
    FColor := Value;
    Changed;
  end;

end;

procedure TGeometricObject3D.SetDirection(const Value: rglv);
begin

  if FDirection <> Value then
  begin
    FDirection := Value;
    ComputeOM;
    Changed;
  end;

end;

procedure TGeometricObject3D.SetManualMatrix;
begin

  var R: rglm4;
  if IsZero(FDirection.x) and IsZero(FDirection.y) then
  begin
    R := rglm4.Identity;
    if FDirection.z < 0 then
      R.m[2, 2] := -1.0;
  end
  else
    R := rglRotate(180*ArcCos(FDirection.Normalized.z)/Pi, vec(0, 0, 1) xor FDirection);

  FManualMatrix :=
    rglTranslate(FPosition)
      *
    R
      *
    rglRotate(FRotation, vec(0, 0, 1))
      *
    rglScale(FScale.x, FScale.y, FScale.z);

end;

procedure TGeometricObject3D.SetManualMatrix(const Value: rglm4);
begin

  if FManualMatrix <> Value then
  begin
    FManualMatrix := Value;
    if FUseManualMatrix then
    begin
      ComputeOM;
      Changed;
    end;
  end;

end;

procedure TGeometricObject3D.SetPosition(const Value: rglv);
begin

  if FPosition <> Value then
  begin
    FPosition := Value;
    ComputeOM;
    Changed;
  end;

end;

procedure TGeometricObject3D.SetRotation(const Value: Single);
begin

  if FRotation <> Value then
  begin
    FRotation := Value;
    ComputeOM;
    Changed;
  end;

end;

procedure TGeometricObject3D.SetScale(const Value: rglv);
begin

  if FScale <> Value then
  begin
    FScale := Value;
    ComputeOM;
    Changed;
  end;

end;

procedure TGeometricObject3D.SetUseManualMatrix(const Value: Boolean);
begin

  if FUseManualMatrix <> Value then
  begin
    FUseManualMatrix := Value;
    ComputeOM;
    Changed;
  end;

end;

{ TAbstractSurface3D }

procedure TAbstractSurface3D.Assign(Source: TPersistent);
begin
  if Source is TAbstractSurface3D then
  begin
    inherited;
    ShowSurface := TAbstractSurface3D(Source).FShowSurface; {setter}
    ShowParameterCurves := TAbstractSurface3D(Source).FShowParameterCurves; {setter}
    ParamCurveCounts := TAbstractSurface3D(Source).FParamCurveCounts; {setter}
    FLineColor := TAbstractSurface3D(Source).FLineColor;
    Changed;
  end
  else
    inherited;
end;

procedure TAbstractSurface3D.Configure(ASettings: TAlgosimStructure);
begin
  inherited;
  for var i := 1 to ASettings.MemberCount do
  begin
    var S := ASettings.Members[i].Name;
    var V := ASettings.Members[i].Value;
    if S = 'showsurface' then
      ShowSurface := V.ToBoolean
    else if S = 'showparametercurves' then
      ShowParameterCurves := V.ToBoolean
    else if S = 'linecolor' then
      LineColor := V.ToColor
    else if S = 'parametercurvecounts' then
      ParamCurveCounts := rglv2(V.AsRealVector())
    else if S = 'unisided' then
      Unisided := V.ToBoolean;
  end;
end;

constructor TAbstractSurface3D.Create(ACtl: TVisCtl3D);
begin
  inherited;
  FShowSurface := True;
  FParamCurveCounts.nx := 64;
  FParamCurveCounts.ny := 64;
  Name := 'Surface';
  OptionsFormClass := TVis3D_SurfaceSettingsFrm;
end;

procedure TAbstractSurface3D.RecreateParamCurves;
begin

end;

procedure TAbstractSurface3D.SetLineColor(const Value: TColor);
begin

  if FLineColor <> Value then
  begin
    FLineColor := Value;
    Changed;
  end;

end;

procedure TAbstractSurface3D.SetParamCurveCounts(
  const Value: TParamCurveFamilySize);
begin

  if FParamCurveCounts <> Value then
  begin
    FParamCurveCounts := Value;
    RecreateParamCurves;
    Changed;
  end;

end;

procedure TAbstractSurface3D.SetShowParameterCurves(const Value: Boolean);
begin

  if FShowParameterCurves <> Value then
  begin
    FShowParameterCurves := Value;
    UpdateDefProgram;
    Changed;
  end;

end;

procedure TAbstractSurface3D.SetShowSurface(const Value: Boolean);
begin

  if FShowSurface <> Value then
  begin
    FShowSurface := Value;
    UpdateDefProgram;
    Changed;
  end;

end;

procedure TAbstractSurface3D.SetUnisided(const Value: Boolean);
begin

  if FUnisided <> Value then
  begin
    FUnisided := Value;
    UpdateDefProgram;
    Changed;
  end;

end;

procedure TAbstractSurface3D.UpdateDefProgram;
begin

end;

{ TSurface3D }

destructor TSurface3D<vtype>.Destroy;
begin
  inherited;
end;

procedure TSurface3D<vtype>.Draw(const AGlobalTime: Double);
begin
  if not FShowSurface and not FShowParameterCurves then
    Exit;
  inherited;
  glBindVertexArray(FVAO);
  if FShowSurface then
  begin
    if FUnisided then
      Control.ProgramMgr.UseProgram(FSurfProgramUnisided)
    else
      Control.ProgramMgr.UseProgram(FSurfProgram);
    Control.ProgramMgr.CurrentProgram.UColor.SetValue(FColor);
    Control.ProgramMgr.CurrentProgram.UObjectMatrix.SetValue(FObjectMatrix);
    Control.ProgramMgr.CurrentProgram.UNormalMatrix.SetValue(FNormalMatrix);
    glBindBuffer(GL_ELEMENT_ARRAY_BUFFER, FIndexData);
    glDrawElements(GL_TRIANGLES, FIndexCount, GL_UNSIGNED_INT, nil);
  end;
  if FShowParameterCurves then
  begin
    Control.ProgramMgr.UseProgram(FCurveProgram);
    Control.ProgramMgr.CurrentProgram.UColor.SetValue(FLineColor);
    Control.ProgramMgr.CurrentProgram.UObjectMatrix.SetValue(FObjectMatrix);
    glBindBuffer(GL_ELEMENT_ARRAY_BUFFER, FPCIData);
    if FLineWidth <> 1.0 then glLineWidth(FLineWidth);
    glDrawElements(GL_LINES, FPCICount, GL_UNSIGNED_INT, nil);
    if FLineWidth <> 1.0 then glLineWidth(1);
  end;
  glBindVertexArray(0);
end;

procedure TSurface3D<vtype>.FreeGLResources;
begin
  if TryContextCurrent then
  begin
    if not FStockSurface then
    begin
      glDeleteBuffers(1, @FIndexData); FIndexData := 0;
      glDeleteBuffers(1, @FVertexData); FVertexData := 0;
    end;
    glDeleteBuffers(1, @FPCIData); FPCIData := 0;
    glDeleteVertexArrays(1, @FVAO); FVAO := 0;
  end
  else
    rglLog('TSurface3D<vtype>.FreeGLResources: TryContextCurrent returned false');
  inherited;
end;

procedure TSurface3D<vtype>.GLRelease;
begin
  FVertexData := 0;
  FIndexData := 0;
  FPCIData := 0;
  FIndexCount := 0;
  FPCICount := 0;
  FVAO := 0;
  inherited;
end;

procedure TSurface3D<vtype>.RecreateParamCurves;
begin

  if FVertexData = 0 then
    Exit; // The object hasn't been initialized yet. When it is, the new values of FParamCurveCounts will be used.

  Control.Context.MakeCurrent('TSurface3D<vtype>');

  glBindVertexArray(FVAO);
  try

    var LVertices: TArray<vtype>;
    var LIndices: TArray<GLuint>;
    var LPCIs: TArray<GLuint>;

    FSurfProc(LVertices, LIndices, LPCIs, 257, 257, FParamCurveCounts.nx,
      FParamCurveCounts.ny, True, Pointer(Self));
    FPCICount := Length(LPCIs);

    if FPCIData = 0 then glGenBuffers(1, @FPCIData);
    glBindBuffer(GL_ELEMENT_ARRAY_BUFFER, FPCIData);
    glBufferData(GL_ELEMENT_ARRAY_BUFFER, Length(LPCIs) * SizeOf(GLuint), Pointer(LPCIs), GL_STATIC_DRAW);

  finally
    glBindVertexArray(0);
  end;

end;

procedure TSurface3D<vtype>.Setup;
begin

  if (Control = nil) or (Control.Context = nil) then
    Exit;
  Control.Context.MakeCurrent('TSurface3D<vtype>');

  if FVAO = 0 then glGenVertexArrays(1, @FVAO);

  glBindVertexArray(FVAO);
  try

    // Stock surfaces must be solid colour
    FStockSurface := FStockSurface and (SizeOf(vtype) = SizeOf(GLfloat6));

    if FStockSurface then
    begin
      var SSD: TStockSurfaceData;
      if Control.Context.FStockSurfaces.TryGetValue(FStockID, SSD) then
      begin
        FVertexData := SSD.VertexData;
        FIndexData := SSD.IndexData;
        FIndexCount := SSD.IndexCount;
        glEnableVertexAttribArray(0);
        glEnableVertexAttribArray(2);
        glBindBuffer(GL_ARRAY_BUFFER, FVertexData);
        glVertexAttribPointer(0, 3, GL_FLOAT, GL_FALSE, SizeOf(vtype), nil);
        glVertexAttribPointer(2, 3, GL_FLOAT, GL_FALSE, SizeOf(vtype), Pointer(3*SizeOf(GLfloat)));
        RecreateParamCurves;
        Exit;
      end
    end;

    var LVertices: TArray<vtype>;
    var LIndices: TArray<GLuint>;
    var LPCIs: TArray<GLuint>;

    FSurfProc(LVertices, LIndices, LPCIs, 257, 257, FParamCurveCounts.nx,
      FParamCurveCounts.ny, False, Pointer(Self));
    FIndexCount := Length(LIndices);
    FPCICount := Length(LPCIs);

    if (FVertexData = 0) or FStockSurface then glGenBuffers(1, @FVertexData);
    glBindBuffer(GL_ARRAY_BUFFER, FVertexData);
    glBufferData(GL_ARRAY_BUFFER, Length(LVertices) * SizeOf(vtype), Pointer(LVertices), GL_STATIC_DRAW);

    if (FIndexData = 0) or FStockSurface then glGenBuffers(1, @FIndexData);
    glBindBuffer(GL_ELEMENT_ARRAY_BUFFER, FIndexData);
    glBufferData(GL_ELEMENT_ARRAY_BUFFER, Length(LIndices) * SizeOf(GLuint), Pointer(LIndices), GL_STATIC_DRAW);

    if FPCIData = 0 then glGenBuffers(1, @FPCIData);
    glBindBuffer(GL_ELEMENT_ARRAY_BUFFER, FPCIData);
    glBufferData(GL_ELEMENT_ARRAY_BUFFER, Length(LPCIs) * SizeOf(GLuint), Pointer(LPCIs), GL_STATIC_DRAW);

    glEnableVertexAttribArray(0);
    if SizeOf(vtype) = SizeOf(GLfloat9) then
      glEnableVertexAttribArray(1);
    glEnableVertexAttribArray(2);
    glBindBuffer(GL_ARRAY_BUFFER, FVertexData);
    glVertexAttribPointer(0, 3, GL_FLOAT, GL_FALSE, SizeOf(vtype), nil);
    if SizeOf(vtype) = SizeOf(GLfloat9) then
    begin
      glVertexAttribPointer(1, 3, GL_FLOAT, GL_FALSE, SizeOf(vtype), Pointer(3*SizeOf(GLfloat)));
      glVertexAttribPointer(2, 3, GL_FLOAT, GL_FALSE, SizeOf(vtype), Pointer(6*SizeOf(GLfloat)));
    end
    else
      glVertexAttribPointer(2, 3, GL_FLOAT, GL_FALSE, SizeOf(vtype), Pointer(3*SizeOf(GLfloat)));

    if FStockSurface then
    begin
      var SSD := Default(TStockSurfaceData);
      SSD.VertexData := FVertexData;
      SSD.IndexData := FIndexData;
      SSD.IndexCount := FIndexCount;
      Control.Context.FStockSurfaces.Add(FStockID, SSD);
    end;

  finally
    glBindVertexArray(0);
  end;

end;

procedure TSurface3D<vtype>.UpdateDefProgram;
begin
  if FShowSurface then
  begin
    if FUnisided then
      FDefaultProgram := FSurfProgramUnisided
    else
      FDefaultProgram := FSurfProgram
  end
  else if FShowParameterCurves then
    FDefaultProgram := FCurveProgram;
end;

{ TEllipsoid }

procedure TEllipsoid.Configure(ASettings: TAlgosimStructure);
begin
  inherited;
  for var i := 1 to ASettings.MemberCount do
  begin
    var S := ASettings.Members[i].Name;
    var V := ASettings.Members[i].Value;
    if S = 'axislengths' then
      AxisLengths := V.AsRealVector
    else if S = 'radius' then
    begin
      var r := V.ToASR;
      AxisLengths := vec(r, r, r);
    end
  end;
end;

constructor TEllipsoid.Create(ACtl: TVisCtl3D);
begin
  inherited;
  FSurfProc := rglSpherePolar;
  FStockSurface := True;
  FStockID := STOCKSURF_SPHERE;
  Name := 'Ellipsoid';
end;

procedure TEllipsoid.SetScale(const Value: rglv);
begin
  Scale := Value;
end;

{ TSphere }

constructor TSphere.Create(ACtl: TVisCtl3D);
begin
  inherited;
  Name := 'Sphere';
end;

function TSphere.GetRadius: Single;
begin
  Result := Scale.x;
end;

procedure TSphere.SetRadius(const Value: Single);
begin
  Scale := vec(Value, Value, Value);
end;

{ TCylinder }

procedure TCylinder.Configure(ASettings: TAlgosimStructure);
begin
  inherited;
  for var i := 1 to ASettings.MemberCount do
  begin
    var S := ASettings.Members[i].Name;
    var V := ASettings.Members[i].Value;
    if S = 'axislengths' then
      AxisLengths := V.AsRealVector
    else if S = 'radius' then
      Radius := V.ToASR
    else if S = 'height' then
      Height := V.ToASR;
  end;
end;

constructor TCylinder.Create(ACtl: TVisCtl3D);
begin
  inherited;
  FSurfProc := rglCylinder;
  FStockSurface := True;
  FStockID := STOCKSURF_CYLINDER;
  Name := 'Cylinder';
end;

function TCylinder.GetAxisLengths: rglv2;
begin
  Result.x := Scale.x;
  Result.y := Scale.y;
end;

function TCylinder.GetHeight: Single;
begin
  Result := Scale.z;
end;

function TCylinder.GetRadius: Single;
begin
  Result := FScale.x;
end;

procedure TCylinder.SetAxisLengths(const Value: rglv2);
begin
  Scale := vec(Value.x, Value.y, FScale.z);
end;

procedure TCylinder.SetHeight(const Value: Single);
begin
  Scale := vec(FScale.x, FScale.y, Value);
end;

procedure TCylinder.SetRadius(const Value: Single);
begin
  Scale := vec(Value, Value, FScale.z);
end;

{ TCone }

procedure TCone.Configure(ASettings: TAlgosimStructure);
begin
  inherited;
  for var i := 1 to ASettings.MemberCount do
  begin
    var S := ASettings.Members[i].Name;
    var V := ASettings.Members[i].Value;
    if S = 'axislengths' then
      AxisLengths := V.AsRealVector
    else if S = 'radius' then
    begin
      var r := V.ToASR;
      AxisLengths := vec2(r, r);
    end
    else if S = 'height' then
      Height := V.ToASR;
  end;
end;

constructor TCone.Create(ACtl: TVisCtl3D);
begin
  inherited;
  FSurfProc := rglCone;
  Name := 'Cone';
end;

function TCone.GetAxisLengths: rglv2;
begin
  Result.x := Scale.x;
  Result.y := Scale.y;
end;

function TCone.GetHeight: Single;
begin
  Result := Scale.z;
end;

procedure TCone.SetAxisLengths(const Value: rglv2);
begin
  Scale := vec(Value.x, Value.y, FScale.z);
end;

procedure TCone.SetHeight(const Value: Single);
begin
  Scale := vec(FScale.x, FScale.y, Value);
end;

{ TPlane }

constructor TPlane.Create(ACtl: TVisCtl3D);
begin
  inherited;
  FSurfProc := rglPlane;
  FStockSurface := True;
  FStockID := STOCKSURF_PLANE;
  Name := 'Plane';
end;

{ TParamCurveFamilySize }

constructor TParamCurveFamilySize.Create(X, Y: Integer);
begin
  nx := X;
  ny := Y;
end;

class operator TParamCurveFamilySize.Equal(const Left,
  Right: TParamCurveFamilySize): Boolean;
begin
  Result := (Left.nx = Right.nx) and (Left.ny = Right.ny);
end;

class operator TParamCurveFamilySize.Implicit(
  const AValue: rglv2): TParamCurveFamilySize;
begin
  Result.nx := Round(AValue.x);
  Result.ny := Round(AValue.y);
end;

class operator TParamCurveFamilySize.Implicit(
  const AValue: Integer): TParamCurveFamilySize;
begin
  Result.nx := AValue;
  Result.ny := AValue;
end;

class operator TParamCurveFamilySize.Implicit(
  const AValue: TSize): TParamCurveFamilySize;
begin
  Result.nx := AValue.cx;
  Result.ny := AValue.cy;
end;

class operator TParamCurveFamilySize.NotEqual(const Left,
  Right: TParamCurveFamilySize): Boolean;
begin
  Result := not (Left = Right);
end;

{ TInfinitePlane }

constructor TInfinitePlane.Create(ACtl: TVisCtl3D);
begin
  inherited;
  FDefaultProgram := P_UniformColorInfinity;
  FShowSurface := True;
  Name := 'Infinite plane';
end;

destructor TInfinitePlane.Destroy;
begin
  inherited;
end;

procedure TInfinitePlane.Draw(const AGlobalTime: Double);
begin
  if not FShowSurface and not FShowParameterCurves then
    Exit;
  inherited;
  glBindVertexArray(FVAO);
  if FShowSurface then
  begin
    Control.ProgramMgr.CurrentProgram.UColor.SetValue(FColor);
    glBindBuffer(GL_ELEMENT_ARRAY_BUFFER, FIndexData);
    glDrawElements(GL_TRIANGLES, FIndexCount, GL_UNSIGNED_INT, nil);
  end;
  if FShowParameterCurves then
  begin
    Control.ProgramMgr.CurrentProgram.UColor.SetValue(FLineColor);
    glBindBuffer(GL_ELEMENT_ARRAY_BUFFER, FPCIData);
    if FLineWidth <> 1.0 then glLineWidth(FLineWidth);
    glDrawElements(GL_LINES, FPCICount, GL_UNSIGNED_INT, nil);
    if FLineWidth <> 1.0 then glLineWidth(1);
  end;
  glBindVertexArray(0);
end;

procedure TInfinitePlane.FreeGLResources;
begin
  if TryContextCurrent then
  begin
    glDeleteBuffers(1, @FPCIData);     FPCIData := 0;
    glDeleteBuffers(1, @FIndexData);   FIndexData := 0;
    glDeleteBuffers(1, @FVertexData);  FVertexData := 0;
    glDeleteVertexArrays(1, @FVAO);    FVAO := 0;
  end
  else
    rglLog('TInfinitePlane.FreeGLResources: TryContextCurrent returned false');
  inherited;
end;

procedure TInfinitePlane.GLRelease;
begin
  FVertexData := 0;
  FIndexData := 0;
  FPCIData := 0;
  FIndexCount := 0;
  FVAO := 0;
  inherited;
end;

procedure TInfinitePlane.Recreate;
begin
  if FVertexData <> 0 then
    Setup;
end;

procedure TInfinitePlane.Setup;
begin

  if (Control = nil) or (Control.Context = nil) then
    Exit;
  Control.Context.MakeCurrent('TInfinitePlane.Setup');

  if FVAO = 0 then glGenVertexArrays(1, @FVAO);

  glBindVertexArray(FVAO);
  try

    var LVertices: TArray<GLfloat6>;
    var LIndices: TArray<GLuint>;
    var LPCIs: TArray<GLuint>;

    const Wh = 500;
    const Hh = 500;

    var A, B: Integer;

  //  if FShowParameterCurves then
  //  begin
      A := 2 * Wh + 1;
      B := 2 * Hh + 1;
  //  end
  //  else
  //  begin
  //    A := 2;
  //    B := 2;
  //  end;

    TriangulateSurface(__planefcn, __planenormalfcn, -Wh, Wh, -Hh, Hh, A, B,
      A, B, False, LVertices, LIndices, LPCIs, False, nil);

    FIndexCount := Length(LIndices);
    FPCICount := Length(LPCIs);

    if FVertexData = 0 then glGenBuffers(1, @FVertexData);
    glBindBuffer(GL_ARRAY_BUFFER, FVertexData);
    glBufferData(GL_ARRAY_BUFFER, Length(LVertices) * SizeOf(GLfloat6), Pointer(LVertices), GL_STATIC_DRAW);

    if FIndexData = 0 then glGenBuffers(1, @FIndexData);
    glBindBuffer(GL_ELEMENT_ARRAY_BUFFER, FIndexData);
    glBufferData(GL_ELEMENT_ARRAY_BUFFER, Length(LIndices) * SizeOf(GLuint), Pointer(LIndices), GL_STATIC_DRAW);

    if FPCIData = 0 then glGenBuffers(1, @FPCIData);
    glBindBuffer(GL_ELEMENT_ARRAY_BUFFER, FPCIData);
    glBufferData(GL_ELEMENT_ARRAY_BUFFER, Length(LPCIs) * SizeOf(GLuint), Pointer(LPCIs), GL_STATIC_DRAW);

    glEnableVertexAttribArray(0);
    glEnableVertexAttribArray(2);
    glBindBuffer(GL_ARRAY_BUFFER, FVertexData);
    glVertexAttribPointer(0, 3, GL_FLOAT, GL_FALSE, 6*SizeOf(GLfloat), nil);
    glVertexAttribPointer(2, 3, GL_FLOAT, GL_FALSE, 6*SizeOf(GLfloat), Pointer(3*SizeOf(GLfloat)));

  finally
    glBindVertexArray(0);
  end;

end;

{ TLightSourceDummy }

constructor TLightSourceDummy.Create(ACtl: TVisCtl3D);
begin
  inherited;
  Radius := 0.5;
  Color := clWhite;
  Name := 'Light source dummy';
end;

{ TCustomSurface }

constructor TCustomSurface.Create(ACtl: TVisCtl3D);
begin
  inherited;
  FSurfProc := TCustomSurface.SurfProc;
end;

procedure TCustomSurface.Recreate;
begin
  if FVertexData <> 0 then
    Setup;
end;

procedure TCustomSurface.SetData(const Value: TArray<rglv>);
begin
  if FData <> Value then
  begin
    FData := Value;
    if Length(Value) > 0 then
      FSurfaceFunction := nil;
    Recreate;
    Changed;
  end;
end;

procedure TCustomSurface.SetDomain(const Value: TRectDom);
begin
  if FDomain <> Value then
  begin
    FDomain := Value;
    Recreate;
    Changed;
  end;
end;

procedure TCustomSurface.SetSurfaceFunction(const Value: TSurfParamFcn);
begin
  if @FSurfaceFunction <> @Value then
  begin
    @FSurfaceFunction := @Value;
    if Assigned(Value) then
      FData := nil;
    Recreate;
    Changed;
  end;
end;

class procedure TCustomSurface.SurfProc(out Vertices: TArray<GLfloat6>; out Indices,
  PCIs: TArray<GLuint>; A, B, pccx, pccy: Integer; PCOnly: Boolean;
  Data: Pointer);
begin
  if TObject(Data) is TCustomSurface then
  begin
    var s := TCustomSurface(Data);
    var d := s.Domain;
    zdef([@A, @B, @pccx, @pccy], [129, 129, 64, 64]);
    if Assigned(s.Data) then
    begin
      A := s.Nx;
      B := s.Ny;
    end;
    TriangulateSurface(s.SurfaceFunction, nil, d.umin, d.umax, d.vmin, d.vmax,
      A, B, pccx, pccy, False, Vertices, Indices, PCIs, PCOnly, s.FData);
  end;
end;

{ TRectDom }

constructor TRectDom.Create(const umin, umax, vmin, vmax: Double);
begin
  Self.umin := umin;
  Self.umax := umax;
  Self.vmin := vmin;
  Self.vmax := vmax;
end;

class operator TRectDom.Equal(const Left, Right: TRectDom): Boolean;
begin
  Result :=
    (Left.umin = Right.umin)
      and
    (Left.umax = Right.umax)
      and
    (Left.vmin = Right.vmin)
      and
    (Left.vmax = Right.vmax);
end;

class operator TRectDom.NotEqual(const Left, Right: TRectDom): Boolean;
begin
  Result := not (Left = Right);
end;

{ TBasicSurface3D }

constructor TBasicSurface3D.Create(ACtl: TVisCtl3D);
begin
  inherited;
  FSurfProgram := P_UniformColorLighting;
  FSurfProgramUnisided := P_UniformColorLightingUnisided;
  FCurveProgram := P_UniformColorDefault;
  FDefaultProgram := FSurfProgram;
end;

{ TColoredSurface3D }

constructor TColoredSurface3D.Create(ACtl: TVisCtl3D);
begin
  inherited;
  FSurfProgram := P_Lighting;
  FSurfProgramUnisided := P_Lighting;
  FCurveProgram := P_Default;
  FDefaultProgram := FSurfProgram;
  Name := 'Coloured surface';
  FColorNotApplicable := True;
end;


{ TCustomColoredSurface }

constructor TCustomColoredSurface.Create(ACtl: TVisCtl3D);
begin
  inherited;
  FSurfProc := TCustomColoredSurface.SurfProc;
end;

procedure TCustomColoredSurface.Recreate;
begin
  if FVertexData <> 0 then
    Setup;
end;

procedure TCustomColoredSurface.SetData(const Value: TArray<GLr3c3v>);
begin
  if FData <> Value then
  begin
    FData := Value;
    if Length(Value) > 0 then
    begin
      FSurfaceFunction := nil;
      FSurfaceColorFunction := nil;
    end;
    Recreate;
    Changed;
  end;
end;

procedure TCustomColoredSurface.SetDomain(const Value: TRectDom);
begin
  if FDomain <> Value then
  begin
    FDomain := Value;
    Recreate;
    Changed;
  end;
end;

procedure TCustomColoredSurface.SetSurfaceColorFunction(
  const Value: TSurfParamColorFcn);
begin
  if @FSurfaceColorFunction <> @Value then
  begin
    @FSurfaceColorFunction := @Value;
    if Assigned(Value) then
      FData := nil;
    Recreate;
    Changed;
  end;
end;

procedure TCustomColoredSurface.SetSurfaceFunction(const Value: TSurfParamFcn);
begin
  if @FSurfaceFunction <> @Value then
  begin
    @FSurfaceFunction := @Value;
    if Assigned(Value) then
      FData := nil;
    Recreate;
    Changed;
  end;
end;

class procedure TCustomColoredSurface.SurfProc(out Vertices: TArray<GLfloat9>;
  out Indices, PCIs: TArray<GLuint>; A, B, pccx, pccy: Integer; PCOnly: Boolean;
  Data: Pointer);
begin
  if TObject(Data) is TCustomColoredSurface then
  begin
    var s := TCustomColoredSurface(Data);
    var d := s.Domain;
    zdef([@A, @B, @pccx, @pccy], [129, 129, 64, 64]);
    if Assigned(s.Data) then
    begin
      A := s.Nx;
      B := s.Ny;
    end;
    TriangulateColoredSurface(s.SurfaceFunction, s.SurfaceColorFunction, nil,
      d.umin, d.umax, d.vmin, d.vmax, A, B, pccx, pccy, False, Vertices, Indices,
      PCIs, PCOnly, s.FData);
  end;
end;

{ TDisk }

procedure TDisk.Configure(ASettings: TAlgosimStructure);
begin
  inherited;
  for var i := 1 to ASettings.MemberCount do
  begin
    var S := ASettings.Members[i].Name;
    var V := ASettings.Members[i].Value;
    if S = 'radius' then
      Radius := V.ToASR;
  end;
end;

constructor TDisk.Create(ACtl: TVisCtl3D);
begin
  inherited;
  FSurfProc := rglDisk;
  FStockSurface := True;
  FStockID := STOCKSURF_DISK;
  Name := 'Disk';
end;

function TDisk.GetRadius: Single;
begin
  Result := Scale.x;
end;

procedure TDisk.SetRadius(const Value: Single);
begin
  Scale := vec(Value, Value, Value);
end;

{ TCurve3D }

constructor TCurve3D.Create(ACtl: TVisCtl3D);
begin
  inherited;
  FDefaultProgram := P_UniformColorDefault;
  Name := 'Curve';
end;

destructor TCurve3D.Destroy;
begin
  inherited;
end;

procedure TCurve3D.Draw(const AGlobalTime: Double);
begin
  inherited;
  glBindVertexArray(FVAO);
  if FLineWidth <> 1.0 then glLineWidth(FLineWidth);
  glDrawArrays(GL_LINE_STRIP, 0, FCount);
  if FLineWidth <> 1.0 then glLineWidth(1);
  glBindVertexArray(0);
end;

procedure TCurve3D.FreeGLResources;
begin
  if TryContextCurrent then
  begin
    glDeleteBuffers(1, @FVertexData);     FVertexData := 0;
    glDeleteVertexArrays(1, @FVAO);       FVAO := 0;
  end
  else
    rglLog('TCurve3D.FreeGLResources: TryContextCurrent returned false');
  inherited;
end;

procedure TCurve3D.GLRelease;
begin
  FVertexData := 0;
  FCount := 0;
  FVAO := 0;
  inherited;
end;

procedure TCurve3D.Recreate;
begin
  if FVertexData <> 0 then
    Setup;
end;

procedure TCurve3D.Sample(out Vertices: TArray<rglv>);
begin

  Vertices := nil;

  if @FCurveFunction = nil then
    Exit;

  if FDomain.b = FDomain.a then
    Exit;

  var dt := (FDomain.b - FDomain.a) / 1000;

  SetLength(Vertices, 1000);
  for var i := 0 to High(Vertices) do
  begin
    var t := FDomain.a + dt * i;
    Vertices[i] := FCurveFunction(t);
  end;

end;

procedure TCurve3D.SetCurveFunction(const Value: TCurveParamFcn);
begin
  if @FCurveFunction <> @Value then
  begin
    @FCurveFunction := @Value;
    if Assigned(Value) then
      FData := nil;
    Recreate;
    Changed;
  end;
end;

procedure TCurve3D.SetData(const Value: TArray<rglv>);
begin
  if FData <> Value then
  begin
    FData := Value;
    if Length(Value) > 0 then
      FCurveFunction := nil;
    Recreate;
    Changed;
  end;
end;

procedure TCurve3D.SetDomain(const Value: TInterval);
begin
  if FDomain <> Value then
  begin
    FDomain := Value;
    Recreate;
    Changed;
  end;
end;

procedure TCurve3D.Setup;
begin

  if (Control = nil) or (Control.Context = nil) then
    Exit;
  Control.Context.MakeCurrent('TCurve3D.Setup');

  if FVAO = 0 then glGenVertexArrays(1, @FVAO);

  glBindVertexArray(FVAO);
  try

    var LVertices: TArray<rglv>;
    if Assigned(FData) then
      LVertices := FData
    else
      Sample(LVertices);

    FCount := Length(LVertices);

    if FVertexData = 0 then glGenBuffers(1, @FVertexData);
    glBindBuffer(GL_ARRAY_BUFFER, FVertexData);
    glBufferData(GL_ARRAY_BUFFER, Length(LVertices) * SizeOf(GLfloat3), Pointer(LVertices), GL_STATIC_DRAW);

    glEnableVertexAttribArray(0);
    glBindBuffer(GL_ARRAY_BUFFER, FVertexData);
    glVertexAttribPointer(0, 3, GL_FLOAT, GL_FALSE, 3*SizeOf(GLfloat), nil);

  finally
    glBindVertexArray(0);
  end;

end;

{ TInterval }

constructor TInterval.Create(const a, b: Double);
begin
  Self.a := a;
  Self.b := b;
end;

class operator TInterval.Equal(const Left, Right: TInterval): Boolean;
begin
  Result := (Left.a = Right.a) and (Left.b = Right.b);
end;

class operator TInterval.NotEqual(const Left, Right: TInterval): Boolean;
begin
  Result := not (Left = Right);
end;

{ TColoredCurve3D }

constructor TColoredCurve3D.Create(ACtl: TVisCtl3D);
begin
  inherited;
  FDefaultProgram := P_Default;
  Name := 'Coloured curve';
  FColorNotApplicable := True;
end;

destructor TColoredCurve3D.Destroy;
begin
  inherited;
end;

procedure TColoredCurve3D.Draw(const AGlobalTime: Double);
begin
  inherited;
  glBindVertexArray(FVAO);
  if FLineWidth <> 1.0 then glLineWidth(FLineWidth);
  glDrawArrays(GL_LINE_STRIP, 0, FCount);
  if FLineWidth <> 1.0 then glLineWidth(1);
  glBindVertexArray(0);
end;

procedure TColoredCurve3D.FreeGLResources;
begin
  if TryContextCurrent then
  begin
    glDeleteBuffers(1, @FVertexData);  FVertexData := 0;
    glDeleteVertexArrays(1, @FVAO);    FVAO := 0;
  end
  else
    rglLog('TColoredCurve3D.FreeGLResources: TryContextCurrent returned false');
  inherited;
end;

procedure TColoredCurve3D.GLRelease;
begin
  FVertexData := 0;
  FCount := 0;
  FVAO := 0;
  inherited;
end;

procedure TColoredCurve3D.Recreate;
begin
  if FVertexData <> 0 then
    Setup;
end;

procedure TColoredCurve3D.Sample(out Vertices: TArray<GLr3c3v>);
begin

  Vertices := nil;

  if @FCurveFunction = nil then
    Exit;

  if FDomain.b = FDomain.a then
    Exit;

  var dt := (FDomain.b - FDomain.a) / 1000;

  SetLength(Vertices, 1000);
  for var i := 0 to High(Vertices) do
  begin
    var t := FDomain.a + dt * i;
    Vertices[i].r := FCurveFunction(t);
    if Assigned(FCurveColorFunction) then
      Vertices[i].c := FCurveColorFunction(t);
  end;

end;

procedure TColoredCurve3D.SetCurveColorFunction(
  const Value: TCurveParamColorFcn);
begin
  if @FCurveColorFunction <> @Value then
  begin
    @FCurveColorFunction := @Value;
    if Assigned(Value) then
      FData := nil;
    Recreate;
    Changed;
  end;
end;

procedure TColoredCurve3D.SetCurveFunction(const Value: TCurveParamFcn);
begin
  if @FCurveFunction <> @Value then
  begin
    @FCurveFunction := @Value;
    if Assigned(Value) then
      FData := nil;
    Recreate;
    Changed;
  end;
end;

procedure TColoredCurve3D.SetData(const Value: TArray<GLr3c3v>);
begin
  if FData <> Value then
  begin
    FData := Value;
    if Length(Value) > 0 then
    begin
      FCurveFunction := nil;
      FCurveColorFunction := nil;
    end;
    Recreate;
    Changed;
  end;
end;

procedure TColoredCurve3D.SetDomain(const Value: TInterval);
begin
  if FDomain <> Value then
  begin
    FDomain := Value;
    Recreate;
    Changed;
  end;
end;

procedure TColoredCurve3D.Setup;
begin

  if (Control = nil) or (Control.Context = nil) then
    Exit;
  Control.Context.MakeCurrent('TColoredCurve3D.Setup');

  if FVAO = 0 then glGenVertexArrays(1, @FVAO);

  glBindVertexArray(FVAO);
  try

    var LVertices: TArray<GLr3c3v>;
    if Assigned(FData) then
      LVertices := FData
    else
      Sample(LVertices);

    FCount := Length(LVertices);

    if FVertexData = 0 then glGenBuffers(1, @FVertexData);
    glBindBuffer(GL_ARRAY_BUFFER, FVertexData);
    glBufferData(GL_ARRAY_BUFFER, Length(LVertices) * SizeOf(GLfloat6), Pointer(LVertices), GL_STATIC_DRAW);

    glEnableVertexAttribArray(0);
    glEnableVertexAttribArray(1);
    glBindBuffer(GL_ARRAY_BUFFER, FVertexData);
    glVertexAttribPointer(0, 3, GL_FLOAT, GL_FALSE, 6*SizeOf(GLfloat), nil);
    glVertexAttribPointer(1, 3, GL_FLOAT, GL_FALSE, 6*SizeOf(GLfloat), Pointer(3*SizeOf(GLfloat)));

  finally
    glBindVertexArray(FVAO);
  end;

end;

{ TScatterPlot }

procedure TScatterPlot.Configure(ASettings: TAlgosimStructure);
begin
  inherited;
  for var i := 1 to ASettings.MemberCount do
  begin
    var S := ASettings.Members[i].Name;
    var V := ASettings.Members[i].Value;
    if S = 'size' then
      Size := V.ToASR;
  end;
end;

constructor TScatterPlot.Create(ACtl: TVisCtl3D);
begin
  inherited;
  FSize := 0.1;
  Name := 'Scatter plot';
  OptionsFormClass := TVis3D_ScatterPlotSettingsFrm;
end;

destructor TScatterPlot.Destroy;
begin
  inherited;
end;

procedure TScatterPlot.Draw(const AGlobalTime: Double);
begin
  inherited;
  Control.ProgramMgr.CurrentProgram.USize.SetValue(FSize);
end;

procedure TScatterPlot.FreeGLResources;
begin
  if TryContextCurrent then
  begin
    glDeleteBuffers(1, @FInstanceData);     FInstanceData := 0;
    glDeleteVertexArrays(1, @FVAO);         FVAO := 0;
  end
  else
    rglLog('TScatterPlot.FreeGLResources: TryContextCurrent returned false');
  inherited;
end;

procedure TScatterPlot.GLRelease;
begin
  FVertexData := 0;
  FIndexData := 0;
  FIndexCount := 0;
  FVAO := 0;
  FInstanceData := 0;
  inherited;
end;

procedure TScatterPlot.MakeBaseMarker;
begin

  var LVertices: TArray<GLfloat6>;
  var LIndices: TArray<GLuint>;
  var LPCIs: TArray<GLuint>;

  rglSpherePolar(LVertices, LIndices, LPCIs, 33, 33, 0, 0, False, nil);
  FIndexCount := Length(LIndices);

  if FVertexData = 0 then glGenBuffers(1, @FVertexData);
  glBindBuffer(GL_ARRAY_BUFFER, FVertexData);
  glBufferData(GL_ARRAY_BUFFER, Length(LVertices) * SizeOf(GLfloat6), Pointer(LVertices), GL_STATIC_DRAW);

  if FIndexData = 0 then glGenBuffers(1, @FIndexData);
  glBindBuffer(GL_ELEMENT_ARRAY_BUFFER, FIndexData);
  glBufferData(GL_ELEMENT_ARRAY_BUFFER, Length(LIndices) * SizeOf(GLuint), Pointer(LIndices), GL_STATIC_DRAW);

end;

procedure TScatterPlot.Recreate;
begin
  if FVAO <> 0 then
    Setup;
end;

procedure TScatterPlot.SetSize(const Value: Single);
begin
  if FSize <> Value then
  begin
    FSize := Value;
    Changed;
  end;
end;

{ TSimpleScatterPlot }

constructor TSimpleScatterPlot.Create(ACtl: TVisCtl3D);
begin
  inherited;
  FDefaultProgram := P_Scatter;
  FColor := clRed;
end;

procedure TSimpleScatterPlot.Draw(const AGlobalTime: Double);
begin
  inherited;
  glBindVertexArray(FVAO);
  glDrawElementsInstanced(GL_TRIANGLES, FIndexCount, GL_UNSIGNED_INT, nil,
    Length(FPoints));
  glBindVertexArray(0);
end;

procedure TSimpleScatterPlot.SetPoints(const Value: TArray<GLfloat3>);
begin
  if FPoints <> Value then
  begin
    FPoints := Value;
    Recreate;
    Changed;
  end;
end;

procedure TSimpleScatterPlot.SetPoints(const Value: TArray<TASR3>);
begin
  SetLength(FPoints, Length(Value));
  for var i := 0 to High(FPoints) do
  begin
    FPoints[i][0] := Value[i].X;
    FPoints[i][1] := Value[i].Y;
    FPoints[i][2] := Value[i].Z;
  end;
  Recreate;
  Changed;
end;

procedure TSimpleScatterPlot.Setup;
begin

  if (Control = nil) or (Control.Context = nil) then
    Exit;
  Control.Context.MakeCurrent('TSimpleScatterPlot.Setup');

  if FVAO = 0 then glGenVertexArrays(1, @FVAO);

  glBindVertexArray(FVAO);
  try

    var SSD := Default(TStockSurfaceData);
    if Control.Context.FStockSurfaces.TryGetValue(STOCKSURF_SPHERELET, SSD) then
    begin
      FVertexData := SSD.VertexData;
      FIndexData := SSD.IndexData;
      FIndexCount := SSD.IndexCount;
    end
    else
    begin
      MakeBaseMarker;
      SSD.VertexData := FVertexData;
      SSD.IndexData := FIndexData;
      SSD.IndexCount := FIndexCount;
      Control.Context.FStockSurfaces.Add(STOCKSURF_SPHERELET, SSD);
    end;

    glBindBuffer(GL_ARRAY_BUFFER, FVertexData);
    glBindBuffer(GL_ELEMENT_ARRAY_BUFFER, FIndexData);

    if FInstanceData = 0 then glGenBuffers(1, @FInstanceData);
    glBindBuffer(GL_ARRAY_BUFFER, FInstanceData);
    glBufferData(GL_ARRAY_BUFFER, Length(FPoints) * SizeOf(GLfloat3), Pointer(FPoints), GL_STATIC_DRAW);

    glEnableVertexAttribArray(0);
    glEnableVertexAttribArray(2);
    glEnableVertexAttribArray(3);
    glBindBuffer(GL_ARRAY_BUFFER, FVertexData);
    glVertexAttribPointer(0, 3, GL_FLOAT, GL_FALSE, 6*SizeOf(GLfloat), nil);
    glVertexAttribPointer(2, 3, GL_FLOAT, GL_FALSE, 6*SizeOf(GLfloat), Pointer(3*SizeOf(GLfloat)));
    glBindBuffer(GL_ARRAY_BUFFER, FInstanceData);
    glVertexAttribPointer(3, 3, GL_FLOAT, GL_FALSE, 3*SizeOf(GLfloat), nil);
    glVertexAttribDivisor(3, 1);

  finally
    glBindVertexArray(0);
  end;

end;

{ TAdvScatterPlot }

constructor TAdvScatterPlot.Create(ACtl: TVisCtl3D);
begin
  inherited;
  FDefaultProgram := P_AdvScatter;
  FColorNotApplicable := True;
  Name := 'Advanced scatter plot';
end;

procedure TAdvScatterPlot.Draw(const AGlobalTime: Double);
begin
  inherited;
  glBindVertexArray(FVAO);
  glDrawElementsInstanced(GL_TRIANGLES, FIndexCount, GL_UNSIGNED_INT, nil,
    Length(FPoints));
  glBindVertexArray(0);
end;

procedure TAdvScatterPlot.SetPoints(const Value: TArray<GLfloat7>);
begin
  if FPoints <> Value then
  begin
    FPoints := Value;
    Recreate;
    Changed;
  end;
end;

procedure TAdvScatterPlot.SetPoints(const Value: TArray<Double>);
begin
  SetLength(FPoints, Length(Value) div 5);
  for var i := 0 to High(FPoints) do
  begin
    FPoints[i][0] := Value[5*i + 0]; // x
    FPoints[i][1] := Value[5*i + 1]; // y
    FPoints[i][2] := Value[5*i + 2]; // z
    var Color := TRGB(TColor(RBSwap(Round(Value[5*i + 3]))));
    FPoints[i][3] := Color.Red;
    FPoints[i][4] := Color.Green;
    FPoints[i][5] := Color.Blue;
    FPoints[i][6] := Value[5*i + 4]; // s
  end;
  Recreate;
  Changed;
end;

procedure TAdvScatterPlot.Setup;
begin

  if (Control = nil) or (Control.Context = nil) then
    Exit;
  Control.Context.MakeCurrent('TAdvScatterPlot.Setup');

  if FVAO = 0 then glGenVertexArrays(1, @FVAO);

  glBindVertexArray(FVAO);
  try

    if (FVertexData = 0) or (FIndexData = 0) then
    begin
      MakeBaseMarker;
    end
    else
    begin
      glBindBuffer(GL_ARRAY_BUFFER, FVertexData);
      glBindBuffer(GL_ELEMENT_ARRAY_BUFFER, FIndexData);
    end;

    if FInstanceData = 0 then glGenBuffers(1, @FInstanceData);
    glBindBuffer(GL_ARRAY_BUFFER, FInstanceData);
    glBufferData(GL_ARRAY_BUFFER, Length(FPoints) * SizeOf(GLfloat7), Pointer(FPoints), GL_STATIC_DRAW);

    glEnableVertexAttribArray(0);
    glEnableVertexAttribArray(2);
    glEnableVertexAttribArray(3);
    glEnableVertexAttribArray(4);
    glEnableVertexAttribArray(5);
    glBindBuffer(GL_ARRAY_BUFFER, FVertexData);
    glVertexAttribPointer(0, 3, GL_FLOAT, GL_FALSE, 6*SizeOf(GLfloat), nil);
    glVertexAttribPointer(2, 3, GL_FLOAT, GL_FALSE, 6*SizeOf(GLfloat), Pointer(3*SizeOf(GLfloat)));
    glBindBuffer(GL_ARRAY_BUFFER, FInstanceData);
    glVertexAttribPointer(3, 3, GL_FLOAT, GL_FALSE, 7*SizeOf(GLfloat), nil);
    glVertexAttribPointer(4, 3, GL_FLOAT, GL_FALSE, 7*SizeOf(GLfloat), Pointer(3*SizeOf(GLfloat)));
    glVertexAttribPointer(5, 1, GL_FLOAT, GL_FALSE, 7*SizeOf(GLfloat), Pointer(6*SizeOf(GLfloat)));
    glVertexAttribDivisor(3, 1);
    glVertexAttribDivisor(4, 1);
    glVertexAttribDivisor(5, 1);

  finally
    glBindVertexArray(0);
  end;

end;

{ TVectorField }

procedure TVectorField.Configure(ASettings: TAlgosimStructure);
begin
  inherited;
  for var i := 1 to ASettings.MemberCount do
  begin
    var S := ASettings.Members[i].Name;
    var V := ASettings.Members[i].Value;
    if S = 'size' then
      Size := V.ToASR
    else if S = 'pervertexcolors' then
      PerVertexColors := V.ToBoolean
    else if S = 'anchorpoint' then
      AnchorPoint := V.ToRealNumber;
  end;
end;

constructor TVectorField.Create(ACtl: TVisCtl3D);
begin
  inherited;
  FDefaultProgram := P_VectorField;
  FSize := 1.0;
  FColor := clRed;
  FAnchorPoint := 0.5;
  Name := 'Vector field';
  OptionsFormClass := TVis3D_VectorFieldSettingsFrm;
end;

destructor TVectorField.Destroy;
begin
  inherited;
end;

procedure TVectorField.Draw(const AGlobalTime: Double);
begin
  inherited;
  if IsZero(FMaxNorm) then
    Control.ProgramMgr.CurrentProgram.USize.SetValue(FSize)
  else
    Control.ProgramMgr.CurrentProgram.USize.SetValue(FSize / FMaxNorm);
  Control.ProgramMgr.CurrentProgram.UAttribColors.SetValue(FAttribColors);
  Control.ProgramMgr.CurrentProgram.UDisplacement.SetValue(FAnchorPoint - 0.5, 0.0);
  glBindVertexArray(FVAO);
  glDrawArraysInstanced(GL_TRIANGLES, 0, FVertexCount, Length(FVectors));
  glBindVertexArray(0);
end;

procedure TVectorField.FreeGLResources;
begin
  if TryContextCurrent then
  begin
    glDeleteBuffers(1, @FInstanceData);     FInstanceData := 0;
    glDeleteVertexArrays(1, @FVAO);         FVAO := 0;
  end
  else
    rglLog('TVectorField.FreeGLResources: TryContextCurrent returned false');
  inherited;
end;

procedure TVectorField.GLRelease;
begin
  FVertexData := 0;
  FVAO := 0;
  FInstanceData := 0;
  inherited;
end;

procedure TVectorField.SetAnchorPoint(const Value: Single);
begin
  if FAnchorPoint <> Value then
  begin
    FAnchorPoint := Value;
    Changed;
  end;
end;

procedure TVectorField.SetAttribColors(const Value: Boolean);
begin
  if FAttribColors <> Value then
  begin
    FAttribColors := Value;
    FColorNotApplicable := FAttribColors;
    Changed;
  end;
end;

procedure TVectorField.SetSize(const Value: Single);
begin
  if FSize <> Value then
  begin
    FSize := Value;
    Changed;
  end;
end;

procedure TVectorField.SetVectors(const Value: TArray<GLr3v3c3v>);
begin
  if FVectors <> Value then
  begin
    FVectors := Value;
    Recreate;
    Changed;
  end;
end;

procedure TVectorField.MakeBaseArrow;

  const
    N = 32;
    R = 0.03;
    L = 1.00;
    Q = 0.10;
    f = 0.35;

  Geometry: record
    Disk,
    Cylinder,
    Septum,
    Cone: Integer;
  end
    =
  (
    Disk:       3*N;
    Cylinder:   6*N;
    Septum:     3*N;
    Cone:       3*N;
  );

var
  Sines, Cosines: array[0..N] of Single;

begin

  var LVertices: TArray<GLfloat6>;

  FVertexCount :=
    Geometry.Disk +
    Geometry.Cylinder +
    Geometry.Septum +
    Geometry.Cone;

  SetLength(LVertices, FVertexCount);    

  var Idx := 0;

  for var i := 0 to N do
    SinCos(Single(i * 2*Pi/N), Sines[i], Cosines[i]);

  // Disk
  for var i := 0 to N - 1 do
  begin

    GLr3n3v(LVertices[Idx]).r := vec(0, 0, -L/2);
    GLr3n3v(LVertices[Idx]).n := vec(0, 0, -1);
    Inc(Idx);

    GLr3n3v(LVertices[Idx]).r := vec(R*Cosines[Succ(i)], R*Sines[Succ(i)], -L/2);
    GLr3n3v(LVertices[Idx]).n := vec(0, 0, -1);
    Inc(Idx);

    GLr3n3v(LVertices[Idx]).r := vec(R*Cosines[i], R*Sines[i], -L/2);
    GLr3n3v(LVertices[Idx]).n := vec(0, 0, -1);
    Inc(Idx);

  end;

  // Cylinder
  for var i := 0 to N - 1 do
  begin

    GLr3n3v(LVertices[Idx]).r := vec(R*Cosines[i], R*Sines[i], -L/2);
    GLr3n3v(LVertices[Idx]).n := vec(Cosines[i], Sines[i], 0);
    Inc(Idx);

    GLr3n3v(LVertices[Idx]).r := vec(R*Cosines[Succ(i)], R*Sines[Succ(i)], -L/2);
    GLr3n3v(LVertices[Idx]).n := vec(Cosines[Succ(i)], Sines[Succ(i)], 0);
    Inc(Idx);

    GLr3n3v(LVertices[Idx]).r := vec(R*Cosines[i], R*Sines[i], +L/2 - f*L);
    GLr3n3v(LVertices[Idx]).n := vec(Cosines[i], Sines[i], 0);
    Inc(Idx);

    GLr3n3v(LVertices[Idx]).r := vec(R*Cosines[Succ(i)], R*Sines[Succ(i)], -L/2);
    GLr3n3v(LVertices[Idx]).n := vec(Cosines[Succ(i)], Sines[Succ(i)], 0);
    Inc(Idx);

    GLr3n3v(LVertices[Idx]).r := vec(R*Cosines[Succ(i)], R*Sines[Succ(i)], +L/2 - f*L);
    GLr3n3v(LVertices[Idx]).n := vec(Cosines[Succ(i)], Sines[Succ(i)], 0);
    Inc(Idx);

    GLr3n3v(LVertices[Idx]).r := vec(R*Cosines[i], R*Sines[i], +L/2 - f*L);
    GLr3n3v(LVertices[Idx]).n := vec(Cosines[i], Sines[i], 0);
    Inc(Idx);

  end;

  // Septum
  for var i := 0 to N - 1 do
  begin

    GLr3n3v(LVertices[Idx]).r := vec(0, 0, +L/2 - f*L);
    GLr3n3v(LVertices[Idx]).n := vec(0, 0, -1);
    Inc(Idx);

    GLr3n3v(LVertices[Idx]).r := vec(Q*Cosines[Succ(i)], Q*Sines[Succ(i)], +L/2 - f*L);
    GLr3n3v(LVertices[Idx]).n := vec(0, 0, -1);
    Inc(Idx);

    GLr3n3v(LVertices[Idx]).r := vec(Q*Cosines[i], Q*Sines[i], +L/2 - f*L);
    GLr3n3v(LVertices[Idx]).n := vec(0, 0, -1);
    Inc(Idx);

  end;

  // Cone
  for var i := 0 to N - 1 do
  begin

    GLr3n3v(LVertices[Idx]).r := vec(0, 0, +L/2);
    GLr3n3v(LVertices[Idx]).n := vec(Cosines[i], Sines[i], f*L/Q).Normalized;
    Inc(Idx);

    GLr3n3v(LVertices[Idx]).r := vec(Q*Cosines[i], Q*Sines[i], +L/2 - f*L);
    GLr3n3v(LVertices[Idx]).n := vec(Cosines[i], Sines[i], f*L/Q).Normalized;
    Inc(Idx);

    GLr3n3v(LVertices[Idx]).r := vec(Q*Cosines[Succ(i)], Q*Sines[Succ(i)], +L/2 - f*L);
    GLr3n3v(LVertices[Idx]).n := vec(Cosines[Succ(i)], Sines[Succ(i)], f*L/Q).Normalized;
    Inc(Idx);

  end;

  Assert(Idx = Length(LVertices));

  if FVertexData = 0 then glGenBuffers(1, @FVertexData);
  glBindBuffer(GL_ARRAY_BUFFER, FVertexData);
  glBufferData(GL_ARRAY_BUFFER, Length(LVertices) * SizeOf(GLfloat6),
    Pointer(LVertices), GL_STATIC_DRAW);

end;

class function TVectorField.MakeMatrix(const AVector: rglv): rglm;
begin

  var LNorm := AVector.Norm;

  if IsZero(LNorm) then
    Exit(rglm.Zero);

  if IsZero(AVector.x) and IsZero(AVector.y) then
    Exit(AVector.z * rglm.Identity);

  var LDirection := AVector / LNorm;

  var a := LDirection.x;
  var b := LDirection.y;
  var c := LDirection.z;
  var a2 := a*a;
  var ab := a*b;
  var b2 := b*b;
  var q := -1/(1+c);

  Result := LNorm * mat_transpose(
    1 + a2*q,       ab*q,           a,
    ab*q,           1 + b2*q,       b,
    -a,             -b,             1 + (a2 + b2)*q
  );

end;

class function TVectorField.Prepare(
  const AVectors: TArray<GLr3v3c3v>; out AMaxNorm: Single): TArray<GLfloat15>;
begin

  SetLength(Result, Length(AVectors));

  AMaxNorm := 0.0;

  for var i := 0 to High(Result) do
  begin
    GLr3m9c3v(Result[i]).r := AVectors[i].r;
    GLr3m9c3v(Result[i]).m := MakeMatrix(AVectors[i].v);
    GLr3m9c3v(Result[i]).c := AVectors[i].c;
    var LThisNorm := AVectors[i].v.Norm;
    if LThisNorm > AMaxNorm then
      AMaxNorm := LThisNorm;        
  end;

end;

procedure TVectorField.Recreate;
begin
  if FVAO <> 0 then
    Setup;
end;

procedure TVectorField.Setup;
begin

  if (Control = nil) or (Control.Context = nil) then
    Exit;
  Control.Context.MakeCurrent('TVectorField.Setup');

  if FVAO = 0 then glGenVertexArrays(1, @FVAO);

  glBindVertexArray(FVAO);
  try

    var SSD := Default(TStockSurfaceData);
    if Control.Context.FStockSurfaces.TryGetValue(STOCKSURF_ARROW, SSD) then
      FVertexData := SSD.VertexData
    else
    begin
      MakeBaseArrow;
      SSD.VertexData := FVertexData;
      Control.Context.FStockSurfaces.Add(STOCKSURF_ARROW, SSD);
    end;

    glBindBuffer(GL_ARRAY_BUFFER, FVertexData);

    if FInstanceData = 0 then glGenBuffers(1, @FInstanceData);
    glBindBuffer(GL_ARRAY_BUFFER, FInstanceData);

    begin
      var LBufferData := Prepare(FVectors, FMaxNorm);
      glBufferData(GL_ARRAY_BUFFER, Length(LBufferData) * SizeOf(GLfloat15),
        Pointer(LBufferData), GL_STATIC_DRAW);
    end;

    glEnableVertexAttribArray(0);
    glEnableVertexAttribArray(2);
    glEnableVertexAttribArray(3);
    glEnableVertexAttribArray(4);
    glEnableVertexAttribArray(5);
    glEnableVertexAttribArray(6);
    glEnableVertexAttribArray(7);
    glBindBuffer(GL_ARRAY_BUFFER, FVertexData);
    glVertexAttribPointer(0, 3, GL_FLOAT, GL_FALSE, 6*SizeOf(GLfloat), nil);
    glVertexAttribPointer(2, 3, GL_FLOAT, GL_FALSE, 6*SizeOf(GLfloat), Pointer(3*SizeOf(GLfloat)));
    glBindBuffer(GL_ARRAY_BUFFER, FInstanceData);
    glVertexAttribPointer(3, 3, GL_FLOAT, GL_FALSE, 15*SizeOf(GLfloat), nil);
    glVertexAttribPointer(4, 3, GL_FLOAT, GL_FALSE, 15*SizeOf(GLfloat), Pointer(3*SizeOf(GLfloat)));
    glVertexAttribPointer(5, 3, GL_FLOAT, GL_FALSE, 15*SizeOf(GLfloat), Pointer(6*SizeOf(GLfloat)));
    glVertexAttribPointer(6, 3, GL_FLOAT, GL_FALSE, 15*SizeOf(GLfloat), Pointer(9*SizeOf(GLfloat)));
    glVertexAttribPointer(7, 3, GL_FLOAT, GL_FALSE, 15*SizeOf(GLfloat), Pointer(12*SizeOf(GLfloat)));
    glVertexAttribDivisor(3, 1);
    glVertexAttribDivisor(4, 1);
    glVertexAttribDivisor(5, 1);
    glVertexAttribDivisor(6, 1);
    glVertexAttribDivisor(7, 1);

  finally
    glBindVertexArray(0);
  end;

end;

{ TImageRect }

procedure TImageRect.BitmapChanged(Sender: TObject);
begin
  Recreate;
  Changed;
end;

procedure TImageRect.Configure(ASettings: TAlgosimStructure);
begin
  inherited;
  for var i := 1 to ASettings.MemberCount do
  begin
    var S := ASettings.Members[i].Name;
    var V := ASettings.Members[i].Value;
    if S = 'bitmap' then
    begin
      var bm := (V as TAlgosimPixmap).Value.CreateGDIBitmap;
      try
        Bitmap := bm;
      finally
        bm.Free;
      end;
    end
    else if S = 'transparentcolor' then
      TransparentColor := V.ToColor
    else if S = 'opaquecolor' then
      OpaqueColor := V.ToColor
    else if S = 'transparencymode' then
      TransparentColorMode := TTransparentColorMode.FromString(V.ToString);
  end;
end;

constructor TImageRect.Create(ACtl: TVisCtl3D);
begin
  inherited;
  FDefaultProgram := P_Image;
  FBitmap := TBitmap.Create;
  FBitmap.OnChange := BitmapChanged;
  Name := 'Pixmap';
  OptionsFormClass := TVis3D_ImageRectSettingsFrm;
end;

destructor TImageRect.Destroy;
begin
  FreeAndNil(FBitmap);
  inherited;
end;

procedure TImageRect.Draw(const AGlobalTime: Double);
begin
  inherited;
  Control.ProgramMgr.CurrentProgram.UTranspColor.SetValue(FTransparentColor);
  Control.ProgramMgr.CurrentProgram.UOpaqueColor.SetValue(FOpaqueColor);
  Control.ProgramMgr.CurrentProgram.UTranspColorMode.SetValue(Ord(FTransparentColorMode));
  glBindVertexArray(FVAO);
  glBindTexture(GL_TEXTURE_2D, FTexture);
  glDrawArrays(GL_TRIANGLES, 0, 6);
  glBindVertexArray(0);
end;

procedure TImageRect.FreeGLResources;
begin
  if TryContextCurrent then
  begin
    glDeleteTextures(1, @FTexture);       FTexture := 0;
    glDeleteBuffers(1, @FVertexData);     FVertexData := 0;
    glDeleteVertexArrays(1, @FVAO);       FVAO := 0;
  end
  else
    rglLog('TImageRect.FreeGLResources: TryContextCurrent returned false');
  inherited;
end;

procedure TImageRect.GLRelease;
begin
  FTexture := 0;
  FVertexData := 0;
  FVAO := 0;
  inherited;
end;

procedure TImageRect.Recreate;
begin
  if FVAO <> 0 then
    Setup;
end;

procedure TImageRect.SetBitmap(const Value: TBitmap);
begin
  if FBitmap <> Value then
  begin
    FBitmap.Assign(Value);
    Recreate;
  end;
end;

procedure TImageRect.SetTransparentColor(const Value: TColor);
begin
  if FTransparentColor <> Value then
  begin
    FTransparentColor := Value;
    Changed;
  end;
end;

procedure TImageRect.SetOpaqueColor(const Value: TColor);
begin
  if FOpaqueColor <> Value then
  begin
    FOpaqueColor := Value;
    Changed;
  end;
end;

procedure TImageRect.SetTransparentColorMode(
  const Value: TTransparentColorMode);
begin
  if FTransparentColorMode <> Value then
  begin
    FTransparentColorMode := Value;
    Changed;
  end;
end;

procedure TImageRect.Setup;

const
  FrameQuad: array[0..29] of GLfloat =
    (
       0.0,  0.0,  0.0,    0.0, 0.0,
       0.0,  1.0,  0.0,    1.0, 0.0,
       0.0,  1.0,  1.0,    1.0, 1.0,
       0.0,  0.0,  0.0,    0.0, 0.0,
       0.0,  1.0,  1.0,    1.0, 1.0,
       0.0,  0.0,  1.0,    0.0, 1.0
    );

begin

  if (Control = nil) or (Control.Context = nil) then
    Exit;
  Control.Context.MakeCurrent('TImageRect.Setup');

  if FVAO = 0 then glGenVertexArrays(1, @FVAO);

  glBindVertexArray(FVAO);
  try

    if FVertexData = 0 then glGenBuffers(1, @FVertexData);
    glBindBuffer(GL_ARRAY_BUFFER, FVertexData);
    glBufferData(GL_ARRAY_BUFFER, Length(FrameQuad) * SizeOf(GLfloat5),
      @FrameQuad, GL_STATIC_DRAW);

    glEnableVertexAttribArray(0);
    glEnableVertexAttribArray(1);
    glBindBuffer(GL_ARRAY_BUFFER, FVertexData);
    glVertexAttribPointer(0, 3, GL_FLOAT, GL_FALSE, 5*SizeOf(GLfloat), nil);
    glVertexAttribPointer(1, 2, GL_FLOAT, GL_FALSE, 5*SizeOf(GLfloat), Pointer(3*SizeOf(GLfloat)));

    if FTexture = 0 then glGenTextures(1, @FTexture);
    glBindTexture(GL_TEXTURE_2D, FTexture);
    if Assigned(FBitmap) and (FBitmap.Height >= 1) then
    begin
      FBitmap.PixelFormat := pf24bit;
      glTexImage2D(GL_TEXTURE_2D, 0, GL_RGB, FBitmap.Width, FBitmap.Height,
        0, GL_BGR, GL_UNSIGNED_BYTE, FBitmap.ScanLine[FBitmap.Height - 1]);
    end;
    glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR);
    glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR);

  finally
    glBindVertexArray(0);
  end;

end;

{ TTextRect }

procedure TTextRect.Configure(ASettings: TAlgosimStructure);
begin
  inherited;
  for var i := 1 to ASettings.MemberCount do
  begin
    var S := ASettings.Members[i].Name;
    var V := ASettings.Members[i].Value;
    if S = 'text' then
      Text := V.ToString
    else if S = 'fontname' then
      Font.Name := V.ToString
    else if S = 'fontsize' then
      Font.Size := V.ToInt32
    else if S = 'bold' then
      if V.ToBoolean then
        Font.Style := Font.Style + [fsBold]
      else
        Font.Style := Font.Style - [fsBold]
    else if S = 'italic' then
      if V.ToBoolean then
        Font.Style := Font.Style + [fsItalic]
      else
        Font.Style := Font.Style - [fsItalic]
    else if S = 'underline' then
      if V.ToBoolean then
        Font.Style := Font.Style + [fsUnderline]
      else
        Font.Style := Font.Style - [fsUnderline]
    else if S = 'strikethrough' then
      if V.ToBoolean then
        Font.Style := Font.Style + [fsStrikeout]
      else
        Font.Style := Font.Style - [fsStrikeout]
    else if S = 'textcolor' then
      Font.Color := V.ToColor
    else if S = 'textanchorpoint' then
      AnchorPoint := TAnchorPoint.FromString(V.ToString)
    else if S = 'opacity' then
      Opacity := V.ToASR
    else if S = 'textresfactor' then
      TextResFactor := V.ToASR
    else if S = 'highquality' then
      HighQuality := V.ToBoolean
    else if S = 'facescreen' then
      FaceScreen := V.ToBoolean
    else if S = 'displacement' then
      Displacement := V.AsRealVector;
  end;
end;

constructor TTextRect.Create(ACtl: TVisCtl3D);
begin
  inherited;
  FDefaultProgram := P_Text;
  FTextResFactor := 1.0;
  FHighQuality := True;
  FAnchorPoint := apTopLeft;
  FOpacity := 1.0;
  FFont := TFont.Create;
  FFont.OnChange := FontChanged;
  Name := 'Text';
  OptionsFormClass := TVis3D_TextRectSettingsFrm;
end;

destructor TTextRect.Destroy;
begin
  FreeAndNil(FFont);
  inherited;
end;

procedure TTextRect.Draw(const AGlobalTime: Double);
begin
  inherited;
  Control.ProgramMgr.CurrentProgram.UAnchorPoint.SetValue(Ord(FAnchorPoint));
  Control.ProgramMgr.CurrentProgram.UFaceScreen.SetValue(FFaceScreen);
  Control.ProgramMgr.CurrentProgram.UAspect.SetValue(FAspect / Control.AspectRatio);
  Control.ProgramMgr.CurrentProgram.UDisplacement.SetValue(FDisplacement);
  Control.ProgramMgr.CurrentProgram.UOpacity.SetValue(FOpacity);
  Control.ProgramMgr.CurrentProgram.USize.SetValue(FFont.Size / 24.0);
  glBindVertexArray(FVAO);
  glBindTexture(GL_TEXTURE_2D, FTexture);
  glDrawArrays(GL_TRIANGLES, 0, 6);
  glBindVertexArray(0);
end;

procedure TTextRect.FontChanged(Sender: TObject);
begin
  Recreate;
  Changed;
end;

procedure TTextRect.FreeGLResources;
begin
  if TryContextCurrent then
  begin
    glDeleteTextures(1, @FTexture);       FTexture := 0;
    glDeleteBuffers(1, @FVertexData);     FVertexData := 0;
    glDeleteVertexArrays(1, @FVAO);       FVAO := 0;
  end
  else
    rglLog('TTextRect.FreeGLResources: TryContextCurrent returned false');
  inherited;
end;

procedure TTextRect.GLRelease;
begin
  FTexture := 0;
  FVertexData := 0;
  FVAO := 0;
  inherited;
end;

procedure TTextRect.SetAnchorPoint(const Value: TAnchorPoint);
begin
  if FAnchorPoint <> Value then
  begin
    FAnchorPoint := Value;
    Changed;
  end;
end;

procedure TTextRect.SetDisplacement(const Value: rglv2);
begin
  if FDisplacement <> Value then
  begin
    FDisplacement := Value;
    Changed;
  end;
end;

procedure TTextRect.SetFaceScreen(const Value: Boolean);
begin
  if FFaceScreen <> Value then
  begin
    FFaceScreen := Value;
    Changed;
  end;
end;

procedure TTextRect.SetFont(const Value: TFont);
begin
  FFont.Assign(Value);
end;

procedure TTextRect.SetHighQuality(const Value: Boolean);
begin
  if FHighQuality <> Value then
  begin
    FHighQuality := Value;
    Recreate;
    Changed;
  end;
end;

procedure TTextRect.SetOpacity(const Value: Double);
begin
  var LOpacity := EnsureRange(Value, 0.0, 1.0);
  if FOpacity <> LOpacity then
  begin
    FOpacity := LOpacity;
    Changed;
  end;
end;

function TTextRect.MakeBitmap: TBitmap;
const
  eps = 2;
begin

  Result := TBitmap.Create;

  try

    Result.Canvas.Font := FFont;

    var OptimalHeight: Integer;
    if FText.Length <= 4 then
      OptimalHeight := Round(1.5 * Screen.Height)
    else if FText.Length <= 12 then
      OptimalHeight := Screen.Height
    else
      OptimalHeight := Screen.Height div 2;

    OptimalHeight := Round(FTextResFactor * OptimalHeight);

    Result.Canvas.Font.Height := EnsureRange(OptimalHeight, 100, 2500);

    var LSize := Result.Canvas.TextExtent(FText) + TSize.Create(2*eps, 2*eps);
    var LArea := UInt64(LSize.Width) * UInt64(LSize.Height);

    const MaxArea = 7372800;
    const MaxLength = IfThen(Control.ImplData.MaxTextureSize > 0,
      Control.ImplData.MaxTextureSize, 4096);

    var Factor := Max(Max(LSize.cx / MaxLength, LSize.cy / MaxLength), Sqrt(LArea / MaxArea));

    if Factor > 1.0 then
    begin
      Result.Canvas.Font.Height := EnsureRange(Round(Result.Canvas.Font.Height / Factor), 32, 2500);
      LSize := Result.Canvas.TextExtent(FText) + TSize.Create(2*eps, 2*eps);
      // LArea := UInt64(LSize.Width) * UInt64(LSize.Height);
    end;

    if LSize.Width > MaxLength then
      LSize.Width := MaxLength;
    if LSize.Height > MaxLength then
      LSize.Height := MaxLength;

    Result.PixelFormat := pf24bit;
    Result.SetSize(LSize.Width, LSize.Height);
    Result.Canvas.Brush.Color := clBlack;
    Result.Canvas.FillRect(Rect(0, 0, LSize.Width, LSize.Height));
    Result.Canvas.Font.Color := clWhite;
    Result.Canvas.TextOut(eps, eps, FText);

    if LSize.cy <> 0 then
      FAspect := LSize.cx / LSize.cy;

  except
    Result.Free;
    raise;
  end;

end;

procedure TTextRect.Recreate;
begin
  if FVAO <> 0 then
    Setup;
end;

procedure TTextRect.SetText(const Value: string);
begin
  if FText <> Value then
  begin
    FText := Value;
    Recreate;
    Changed;
  end;
end;

procedure TTextRect.SetTextResFactor(const Value: Double);
begin
  if FTextResFactor <> Value then
  begin
    FTextResFactor := Value;
    Recreate;
    Changed;
  end;
end;

procedure TTextRect.Setup;

const
  FrameQuad: array[0..29] of GLfloat =
    (
       0.0,  0.0,  0.0,    0.0, 1.0,
       1.0,  0.0,  0.0,    0.0, 0.0,
       1.0,  1.0,  0.0,    1.0, 0.0,
       0.0,  0.0,  0.0,    0.0, 1.0,
       1.0,  1.0,  0.0,    1.0, 0.0,
       0.0,  1.0,  0.0,    1.0, 1.0
    );

    swiz: array[0..3] of GLint = (GL_ZERO, GL_ZERO, GL_ZERO, GL_RED);

begin

  if (Control = nil) or (Control.Context = nil) then
    Exit;
  Control.Context.MakeCurrent('TTextRect.Setup');

  if FVAO = 0 then glGenVertexArrays(1, @FVAO);

  glBindVertexArray(FVAO);
  try

    if FVertexData = 0 then glGenBuffers(1, @FVertexData);
    glBindBuffer(GL_ARRAY_BUFFER, FVertexData);
    glBufferData(GL_ARRAY_BUFFER, Length(FrameQuad) * SizeOf(GLfloat5),
      @FrameQuad, GL_STATIC_DRAW);

    glEnableVertexAttribArray(0);
    glEnableVertexAttribArray(1);
    glBindBuffer(GL_ARRAY_BUFFER, FVertexData);
    glVertexAttribPointer(0, 3, GL_FLOAT, GL_FALSE, 5*SizeOf(GLfloat), nil);
    glVertexAttribPointer(1, 2, GL_FLOAT, GL_FALSE, 5*SizeOf(GLfloat), Pointer(3*SizeOf(GLfloat)));

    if FTexture = 0 then glGenTextures(1, @FTexture);
    glBindTexture(GL_TEXTURE_2D, FTexture);
    begin
      var LBitmap := MakeBitmap;
      try
        glTexImage2D(GL_TEXTURE_2D, 0, GL_R8, LBitmap.Width, LBitmap.Height,
          0, GL_BGR, GL_UNSIGNED_BYTE, LBitmap.ScanLine[LBitmap.Height - 1]);
      finally
        LBitmap.Free;
      end;
    end;
    glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR);
    glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR);
    glTexParameteriv(GL_TEXTURE_2D, GL_TEXTURE_SWIZZLE_RGBA, @swiz);
    glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_CLAMP_TO_BORDER);
    glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP_TO_BORDER);
    const black: rglv4 = rglv4.Zero;
    glTexParameterfv(GL_TEXTURE_2D, GL_TEXTURE_BORDER_COLOR, @black);
    if FHighQuality then
    begin
      glGenerateMipmap(GL_TEXTURE_2D);
      glTexParameterf(GL_TEXTURE_2D, GL_TEXTURE_MAX_ANISOTROPY_EXT,
        Min(16.0, Control.ImplData.MaxTextureAnisotropy));
      glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR_MIPMAP_LINEAR);
      glTexParameterf(GL_TEXTURE_2D, GL_TEXTURE_LOD_BIAS, -0.75);
    end;

    FScale.y := FScale.x * FAspect;
    ComputeOM;

  finally
    glBindVertexArray(0);
  end;

end;

{ TAxes }

procedure TAxes.AxisChanged(Sender: TObject);
begin
  Changed;
end;

function TAxes.GetGridCount: Integer;
begin
  Result := 0;
  for var Child in FChildren do
    if Child is TGrid then
      Inc(Result);
end;

procedure TAxes.GridChanged(Sender: TObject);
begin
  Changed;
end;

procedure TAxes.Configure(ASettings: TAlgosimStructure);
begin
  inherited;
  for var i := 1 to ASettings.MemberCount do
  begin
    var S := ASettings.Members[i].Name;
    var V := ASettings.Members[i].Value;
    if S = 'gridcount' then
      GridCount := V.ToInt32;
  end;
end;

constructor TAxes.Create(ACtl: TVisCtl3D);
begin

  inherited;

  Name := 'Axes';

  FXAxis := CreateChild<TAxis>;
  FXAxis.FIndex := 0;
  FXAxis.FCylinder.Direction := vec(1, 0, 0);
  FXAxis.FCylinder.Color := clRed;
  FXAxis.OnChange := AxisChanged;
  FXAxis.Name := 'X axis';

  FYAxis := CreateChild<TAxis>;
  FYAxis.FIndex := 1;
  FYAxis.FCylinder.Direction := vec(0, 1, 0);
  FYAxis.FCylinder.Color := clGreen;
  FYAxis.OnChange := AxisChanged;
  FYAxis.Name := 'Y axis';

  FZAxis := CreateChild<TAxis>;
  FZAxis.FIndex := 2;
  FZAxis.FCylinder.Direction := vec(0, 0, 1);
  FZAxis.FCylinder.Color := clBlue;
  FZAxis.OnChange := AxisChanged;
  FZAxis.Name := 'Z axis';

  var LXYGrid := CreateChild<TGrid>;
  LXYGrid.FIndex := 0;
  LXYGrid.Direction := vec(0, 0, 1);
  LXYGrid.OnChange := GridChanged;
  LXYGrid.Name := 'z = 0 grid';

  var LYZGrid := CreateChild<TGrid>;
  LYZGrid.FIndex := 0;
  LYZGrid.Direction := vec(1, 0, 0);
  LYZGrid.Rotation := 90;
  LYZGrid.OnChange := GridChanged;
  LYZGrid.Name := 'x = 0 grid';

  var LXZGrid := CreateChild<TGrid>;
  LXZGrid.FIndex := 0;
  LXZGrid.Direction := vec(0, 1, 0);
  LXZGrid.Rotation := -90;
  LXZGrid.OnChange := GridChanged;
  LXZGrid.Name := 'y = 0 grid';

  OptionsFormClass := TVis3D_AxesSettingsFrm;

end;

function TAxes.CreateReference: TAlgosimReference;
begin
  Result := inherited;
  Result.AddSubref('x', FXAxis.CreateReference);
  Result.AddSubref('y', FYAxis.CreateReference);
  Result.AddSubref('z', FZAxis.CreateReference);
  var n := 1;
  for var Child in FChildren do
    if Child is TGrid then
    begin
      Result.AddSubref('grid' + n.ToString, Child.CreateReference);
      Inc(n);
    end;
end;

procedure TAxes.SetGridCount(const Value: Integer);
begin
  if not InRange(Value, 0, 1024) then
    raise ERglError.Create('Number of grids must be between 0 and 1024.');
  var CurrentCount := GetGridCount;
  if CurrentCount > Value then
  begin
    var GridsToRemove := CurrentCount - Value;
    for var i := FChildren.Count - 1 downto 0 do
      if FChildren[i] is TGrid then
      begin
        DeleteChild(FChildren[i]);
        Dec(GridsToRemove);
        if GridsToRemove = 0 then
          Break;
      end;
  end;
  for var i := CurrentCount + 1 to Value do
    CreateChild<TGrid>
end;

procedure TAxes.SetXAxis(const Value: TAxis);
begin
  FXAxis.Assign(Value);
end;

procedure TAxes.SetYAxis(const Value: TAxis);
begin
  FYAxis.Assign(Value);
end;

procedure TAxes.SetZAxis(const Value: TAxis);
begin
  FZAxis.Assign(Value);
end;

{ TAxis }

function TAxis.AxisName: string;
begin
  case FIndex of
    0:
      Result := 'x';
    1:
      Result := 'y';
    2:
      Result := 'z';
  else
    Result := '';
  end;
end;

procedure TAxis.Configure(ASettings: TAlgosimStructure);
begin
  inherited;
  for var i := 1 to ASettings.MemberCount do
  begin
    var S := ASettings.Members[i].Name;
    var V := ASettings.Members[i].Value;
    if S = 'labels' then
      Labels := V.ToBoolean
    else if S = 'labelformat' then
      LabelFormat := V.ToString
    else if S = 'labeldistance' then
      LabelDelta := V.ToASR
    else if S = 'length' then
      Length := V.ToASR
    else if S = 'negativelength' then
      NegativeLength := Abs(V.ToASR)
    else if S = 'radius' then
      Radius := V.ToASR
    else if S = 'labelfontname' then
      LabelFont.Name := V.ToString
    else if S = 'labelfontsize' then
      LabelFont.Size := V.ToInt32
    else if S = 'labelbold' then
      if V.ToBoolean then
        LabelFont.Style := LabelFont.Style + [fsBold]
      else
        LabelFont.Style := LabelFont.Style - [fsBold]
    else if S = 'labelitalic' then
      if V.ToBoolean then
        LabelFont.Style := LabelFont.Style + [fsItalic]
      else
        LabelFont.Style := LabelFont.Style - [fsItalic]
    else if S = 'labelunderline' then
      if V.ToBoolean then
        LabelFont.Style := LabelFont.Style + [fsUnderline]
      else
        LabelFont.Style := LabelFont.Style - [fsUnderline]
    else if S = 'labelstrikethrough' then
      if V.ToBoolean then
        LabelFont.Style := LabelFont.Style + [fsStrikeout]
      else
        LabelFont.Style := LabelFont.Style - [fsStrikeout]
    else if S = 'labeltextcolor' then
      LabelFont.Color := V.ToColor
  end;
end;

constructor TAxis.Create(ACtl: TVisCtl3D);
begin
  inherited;
  FCylinder := CreateChild<TCylinder>;
  FLabelFont := TFont.Create;
  FLabelFont.Size := 8;
  FLabelFont.OnChange := FontChange;
  FLabels := True;
  FLabelDelta := 1.0;
  FLabelFormat := '0';
  FLength := 10.0;
  FRadius := 0.1;
  Name := 'Axis';
  OptionsFormClass := TVis3D_AxisSettingsFrm;
end;

function TAxis.CreateReference: TAlgosimReference;
begin
  Result := inherited;
  Result.AddSubref('cylinder', FCylinder.CreateReference);
end;

destructor TAxis.Destroy;
begin
  FreeAndNil(FLabelFont);
  inherited;
end;

procedure TAxis.FontChange(Sender: TObject);
begin
  SetupLabels;
  Changed;
end;

function TAxis.FormatAxisLabel(const AFormat: string;
  const AValue: Double): string;
begin
  Result := FormatFloat(AFormat, AValue, InvFS)
    .Replace(HYPHEN_MINUS, MINUS_SIGN)
end;

function TAxis.GetColor: TColor;
begin
  if Assigned(FCylinder) then
    Result := FCylinder.Color
  else
    Result := clBlack;
end;

procedure TAxis.ProjectionChanged;
begin
  if (FIndex = 2) and FLabels then
    for var lbl in FChildren do
      if (lbl is TTextRect) and (lbl.FParentTag and PTAG_AXISLABEL <> 0) then
        case Control.Projection of
          Orthographic:
            begin
              TTextRect(lbl).FaceScreen := False;
              TTextRect(lbl).Direction := vec(1.0, 0.0, 0.0);
              TTextRect(lbl).Rotation := 0;
              TTextRect(lbl).Position := vec(0.0, -1.5 * FCylinder.Radius, TTextRect(lbl).Position.z);
              TTextRect(lbl).AnchorPoint := apRight;
            end;
          Perspective:
            begin
              TTextRect(lbl).FaceScreen := True;
              TTextRect(lbl).Position := vec(0, 0, TTextRect(lbl).Position.z);
              TTextRect(lbl).Direction := vec(1.0, 0.0, 0.0);
              TTextRect(lbl).Displacement := vec2(-0.25, 0);
              TTextRect(lbl).Rotation := 90;
              TTextRect(lbl).AnchorPoint := apRight;
            end;
        end;
end;

procedure TAxis.Recreate;
begin
  Setup;
end;

procedure TAxis.SetColor(const Value: TColor);
begin
  if Assigned(FCylinder) then
    FCylinder.Color := Value;
end;

procedure TAxis.SetLabelDelta(const Value: Double);
begin
  if (FLabelDelta <> Value) and (Value > Single.Epsilon) then
  begin
    FLabelDelta := Value;
    SetupLabels;
    Changed;
  end;
end;

procedure TAxis.SetLabelFont(const Value: TFont);
begin
  if FLabelFont <> Value then
    FLabelFont.Assign(Value);
end;

procedure TAxis.SetLabelFormat(const Value: string);
begin
  if FLabelFormat <> Value then
  begin
    FLabelFormat := Value;
    SetupLabels;
    Changed;
  end;
end;

procedure TAxis.SetLabels(const Value: Boolean);
begin
  if FLabels <> Value then
  begin
    FLabels := Value;
    SetupLabels;
    Changed;
  end;
end;

procedure TAxis.SetLength(const Value: Double);
begin
  if (FLength <> Value) and (Value >= 0.0) then
  begin
    FLength := Value;
    Recreate;
    Changed;
  end;
end;

procedure TAxis.SetNegativeLength(const Value: Double);
begin
  if (FNegativeLength <> Value) and (Value >= 0.0) then
  begin
    FNegativeLength := Value;
    Recreate;
    Changed;
  end;
end;

procedure TAxis.SetRadius(const Value: Double);
begin
  if (FRadius <> Value) and (Value > 0.0) then
  begin
    FRadius := Value;
    Recreate;
    Changed;
  end;
end;

procedure TAxis.Setup;
begin

  if (Control = nil) or (Control.Context = nil) then
    Exit;
  Control.Context.MakeCurrent('TAxis.Setup');

  if FCylinder = nil then
    FCylinder := CreateChild<TCylinder>;

  FCylinder.Radius := FRadius;
  FCylinder.Height := FNegativeLength + FLength;
  FCylinder.Position := -FNegativeLength * vec(Ord(FIndex = 0), Ord(FIndex = 1), Ord(FIndex = 2));
  FCylinder.Name := AxisName + #32'axis cylinder';

  SetupLabels;

end;

procedure TAxis.SetupLabels;
begin

  Control.Context.MakeCurrent('TAxis.SetupLabels');

  DeleteChildren(PTAG_AXISLABEL);

  if not FLabels then
    Exit;

  for var LNegative := False to True do
  begin

    var x := 0.0;

    var LLimit: Double;
    if LNegative then
      LLimit := FNegativeLength
    else
      LLimit := FLength;

    while x <= LLimit do
    begin
      var L := CreateChild<TTextRect>;
      var LSign := 1 - 2*Ord(LNegative);
      L.FParentTag := PTAG_AXISLABEL;
      L.Text := FormatAxisLabel(FLabelFormat, LSign * x);
      if InRange(FIndex, 0, 2) then
        L.Name := Format('%s axis label %s', [AxisName, L.Text]);
      case FIndex of
        0:
          begin
            L.Position := vec(LSign * x, 0, -FCylinder.Radius);
            L.Direction := vec(0, 1, 0);
            L.AnchorPoint := apTop;
            L.Rotation := 90;
          end;
        1:
          begin
            L.Position := vec(0, LSign * x, -FCylinder.Radius);
            L.Direction := vec(1, 0, 0);
            L.AnchorPoint := apTop;
            L.Rotation := 0;
          end;
        2:
          begin
            if Control.Projection = Perspective then
            begin
              L.Position := vec(0, 0, LSign * x);
              L.AnchorPoint := apRight;
              L.FaceScreen := True;
              L.Displacement := vec2(-0.25, 0);
              L.Direction := vec(1, 1, 0);
              L.Rotation := 45;
            end
            else
            begin
              L.Position := vec(0, -1.5*FCylinder.Radius, LSign * x);
              L.Direction := vec(1.0, 0.0, 0.0);
              L.Rotation := 0;
              L.AnchorPoint := apRight;
            end;
          end;
      end;
      L.TextResFactor := 0.5;
      L.Font := FLabelFont;
      L.Color := FLabelFont.Color;
      x := x + FLabelDelta;
    end;

  end;

end;

{ TGrid }

procedure TGrid.Configure(ASettings: TAlgosimStructure);
begin
  inherited;
  for var i := 1 to ASettings.MemberCount do
  begin
    var S := ASettings.Members[i].Name;
    var V := ASettings.Members[i].Value;
    if S = 'umin' then
      XMin := V.ToASR
    else if S = 'umax' then
      XMax := V.ToASR
    else if S = 'vmin' then
      YMin := V.ToASR
    else if S = 'vmax' then
      YMax := V.ToASR
    else if S = 'ustep' then
      XDelta := V.ToASR
    else if S = 'vstep' then
      YDelta := V.ToASR
  end;
end;

constructor TGrid.Create(ACtl: TVisCtl3D);
begin
  inherited;
  FXMin := 0.0;
  FXMax := 10.0;
  FXDelta := 1.0;
  FYMin := 0.0;
  FYMax := 10.0;
  FYDelta := 1.0;
  FColor := clBlack;
  FDefaultProgram := P_UniformColorDefault;
  Name := 'Grid';
  OptionsFormClass := TVis3D_GridSettingsFrm;
end;

destructor TGrid.Destroy;
begin
  inherited;
end;

procedure TGrid.Draw(const AGlobalTime: Double);
begin
  inherited;
  glBindVertexArray(FVAO);
  glBindBuffer(GL_ARRAY_BUFFER, FVertexData);
  if FLineWidth <> 1.0 then glLineWidth(FLineWidth);
  glDrawArrays(GL_LINES, 0, FCount);
  if FLineWidth <> 1.0 then glLineWidth(1);
  glBindVertexArray(0);
end;

procedure TGrid.FreeGLResources;
begin
  if TryContextCurrent then
  begin
    glDeleteBuffers(1, @FVertexData);       FVertexData := 0;
    glDeleteVertexArrays(1, @FVAO);         FVAO := 0;
  end
  else
    rglLog('TGrid.FreeGLResources: TryContextCurrent returned false');
  inherited;
end;

procedure TGrid.GLRelease;
begin
  FVertexData := 0;
  FCount := 0;
  FVAO := 0;
  inherited;
end;

procedure TGrid.Recreate;
begin
  if FVertexData <> 0 then
    Setup;
end;

procedure TGrid.Setup;
begin

  if (Control = nil) or (Control.Context = nil) then
    Exit;
  Control.Context.MakeCurrent('TGrid.Setup');

  if FVAO = 0 then glGenVertexArrays(1, @FVAO);

  glBindVertexArray(FVAO);
  try

    var LVertices: TArray<GLfloat3>;

    var LLineCountX :=
      Floor((FXMax - FXMin) / FXDelta + FXDelta / 1000) + 1;
    var LLineCountY :=
      Floor((FYMax - FYMin) / FYDelta + FYDelta / 1000) + 1;
    var LLineCount := LLineCountX + LLineCountY;
    FCount := 2 * LLineCount;
    SetLength(LVertices, FCount);

    var Idx := 0;
    for var i := 0 to LLineCountX - 1 do
    begin
      var x := FXMin + FXDelta * i;
      LVertices[Idx] := vec(x, FYMin, 0);
      Inc(Idx);
      LVertices[Idx] := vec(x, FYMax, 0);
      Inc(Idx);
    end;
    for var i := 0 to LLineCountY - 1 do
    begin
      var y := FYMin + FYDelta * i;
      LVertices[Idx] := vec(FXMin, y, 0);
      Inc(Idx);
      LVertices[Idx] := vec(FXMax, y, 0);
      Inc(Idx);
    end;

    if FVertexData = 0 then glGenBuffers(1, @FVertexData);
    glBindBuffer(GL_ARRAY_BUFFER, FVertexData);
    glBufferData(GL_ARRAY_BUFFER, Length(LVertices) * SizeOf(GLfloat3), Pointer(LVertices), GL_STATIC_DRAW);

    glEnableVertexAttribArray(0);
    glBindBuffer(GL_ARRAY_BUFFER, FVertexData);
    glVertexAttribPointer(0, 3, GL_FLOAT, GL_FALSE, 3*SizeOf(GLfloat), nil);

  finally
    glBindVertexArray(0);
  end;

end;

procedure TGrid.SetXDelta(const Value: Double);
begin
  if (FXDelta <> Value) and (Value > Single.Epsilon) then
  begin
    FXDelta := Value;
    Recreate;
    Changed;
  end;
end;

procedure TGrid.SetXMax(const Value: Double);
begin
  if FXMax <> Value then
  begin
    FXMax := Value;
    Recreate;
    Changed;
  end;
end;

procedure TGrid.SetXMin(const Value: Double);
begin
  if FXMin <> Value then
  begin
    FXMin := Value;
    Recreate;
    Changed;
  end;
end;

procedure TGrid.SetYDelta(const Value: Double);
begin
  if (FYDelta <> Value) and (Value > Single.Epsilon) then
  begin
    FYDelta := Value;
    Recreate;
    Changed;
  end;
end;

procedure TGrid.SetYMax(const Value: Double);
begin
  if FYMax <> Value then
  begin
    FYMax := Value;
    Recreate;
    Changed;
  end;
end;

procedure TGrid.SetYMin(const Value: Double);
begin
  if FYMin <> Value then
  begin
    FYMin := Value;
    Recreate;
    Changed;
  end;
end;

{ TSolidModel }

class constructor TSolidModel.ClassCreate;
begin
  RegisterClass(TSolidCube, 'cube');
  RegisterClass(TSolidCylinder, 'cylinder');
  RegisterClass(TSolidCone, 'cone');
  RegisterClass(TSolidTetrahedron, 'tetrahedron');
  RegisterClass(TSolidOctahedron, 'octahedron');
  RegisterClass(TSolidDodecahedron, 'dodecahedron');
  RegisterClass(TSolidIcosahedron, 'icosahedron');
  RegisterClass(TSolidPyramid, 'pyramid');
end;

class destructor TSolidModel.ClassDestroy;
begin
  FreeAndNil(FSolidClasses);
end;

constructor TSolidModel.Create(ACtl: TVisCtl3D);
begin
  inherited;
  Name := 'Solid model';
end;

destructor TSolidModel.Destroy;
begin
  inherited;
end;

procedure TSolidModel.Draw(const AGlobalTime: Double);
begin
  inherited;
  if FVertexData = 0 then
    Exit;
  glBindVertexArray(FVAO);
  glDrawArrays(GL_TRIANGLES, 0, FCount);
  glBindVertexArray(0);
end;

procedure TSolidModel.FreeGLResources;
begin
  if TryContextCurrent then
  begin
    glDeleteVertexArrays(1, @FVAO); FVAO := 0;
    if FVertexData <> 0 then
    begin
      if Stored then
      begin
        var Rec := Default(TSolidStoreRec);
        if Assigned(Control.Context.FStoredSolids) and Control.Context.FStoredSolids.TryGetValue(ModelClass, Rec) then
        begin
          Assert(Rec.VertexData = FVertexData);
          Assert(Rec.Count = FCount);
          Dec(Rec.RefCnt);
          if Rec.RefCnt = 0 then
          begin
            glDeleteBuffers(1, @FVertexData); FVertexData := 0;
            Control.Context.FStoredSolids.Remove(ModelClass);
          end
          else
          begin
            Control.Context.FStoredSolids.AddOrSetValue(ModelClass, Rec);
            FVertexData := 0;
          end;
        end
        else
        begin
          glDeleteBuffers(1, @FVertexData); FVertexData := 0;
        end;
      end
      else
      begin
        glDeleteBuffers(1, @FVertexData); FVertexData := 0;
      end;
    end;
  end
  else
    rglLog('TSolidModel.FreeGLResources: TryContextCurrent returned false');
  inherited;
end;

class function TSolidModel.FromString(const S: string): TDrawable3DClass;
begin
  if (FSolidClasses = nil) or not FSolidClasses.TryGetValue(S, Result) then
    raise Exception.CreateFmt('Unknown solid: "%s".', [S]);
end;

procedure TSolidModel.GLRelease;
begin
  FVertexData := 0;
  FCount := 0;
  FVAO := 0;
  inherited;
end;

procedure TSolidModel.MakeBaseBuffer;
begin

end;

function TSolidModel.ModelClass: TSolidModelClass;
begin
  Result := TSolidModelClass(ClassType);
end;

procedure TSolidModel.Recreate;
begin
  if FVertexData <> 0 then
    Setup;
end;

class procedure TSolidModel.RegisterClass(const AClass: TDrawable3DClass;
  const AName: string);
begin
  if FSolidClasses = nil then
    FSolidClasses := TDictionary<string, TDrawable3DClass>.Create;
  FSolidClasses.Add(AName, AClass);
end;

procedure TSolidModel.Setup;
begin

  if (Control = nil) or (Control.Context = nil) then
    Exit;
  Control.Context.MakeCurrent('TSolidModel.Setup');

  if FVAO = 0 then glGenVertexArrays(1, @FVAO);

  glBindVertexArray(FVAO);
  try

    if Stored then
    begin
      var Rec := Default(TSolidStoreRec);
      if Control.Context.FStoredSolids.TryGetValue(ModelClass, Rec) then
      begin
        FVertexData := Rec.VertexData;
        FCount := Rec.Count;
        Inc(Rec.RefCnt);
        Control.Context.FStoredSolids.AddOrSetValue(ModelClass, Rec);
      end
      else
      begin
        MakeBaseBuffer; if FVertexData = 0 then Exit;
        Rec.VertexData := FVertexData;
        Rec.Count := FCount;
        Rec.RefCnt := 1;
        Control.Context.FStoredSolids.Add(ModelClass, Rec);
      end;
    end
    else
      MakeBaseBuffer;

    if FVertexData = 0 then
      Exit;

    glBindBuffer(GL_ARRAY_BUFFER, FVertexData);
    glEnableVertexAttribArray(0);
    glEnableVertexAttribArray(2);
    glVertexAttribPointer(0, 3, GL_FLOAT, GL_FALSE, 6*SizeOf(GLfloat), nil);
    glVertexAttribPointer(2, 3, GL_FLOAT, GL_FALSE, 6*SizeOf(GLfloat), Pointer(3*SizeOf(GLfloat)));

  finally
    glBindVertexArray(0);
  end;

end;

class function TSolidModel.TryFromString(const S: string;
  out AClass: TDrawable3DClass): Boolean;
begin
  Result := Assigned(FSolidClasses) and FSolidClasses.TryGetValue(S, AClass);
end;

{ TObjModel }

procedure TObjModel.LoadModel(const AData: string);
begin
  FSource := AData;
  FBuf := ObjFile.ParseObjData(AData.Split([#13#10]));
  Recreate;
  Changed;
end;

procedure TObjModel.Configure(ASettings: TAlgosimStructure);
begin
  inherited;
  for var i := 1 to ASettings.MemberCount do
  begin
    var S := ASettings.Members[i].Name;
    var V := ASettings.Members[i].Value;
    if S = 'source' then
      Source := V.ToString;
  end;
end;

constructor TObjModel.Create(ACtl: TVisCtl3D);
begin
  inherited;
  OptionsFormClass := TVis3D_ModelSettingsFrm;
end;

procedure TObjModel.LoadModel(const AData: TArray<string>);
begin
  FSource := string.Join(#13#10, AData);
  FBuf := ObjFile.ParseObjData(AData);
  Recreate;
  Changed;
end;

procedure TObjModel.LoadModelFromFile(const AFileName: TFileName;
  const Encoding: TEncoding);
begin
  LoadModel(TFile.ReadAllLines(AFileName, Encoding));
end;

procedure TObjModel.LoadModelFromFile(const AFileName: TFileName);
begin
  LoadModel(TFile.ReadAllLines(AFileName));
end;

procedure TObjModel.MakeBaseBuffer;
begin
  if FBuf = nil then
    Exit;
  if FVertexData = 0 then glGenBuffers(1, @FVertexData);
  glBindBuffer(GL_ARRAY_BUFFER, FVertexData);
  glBufferData(GL_ARRAY_BUFFER, Length(FBuf) * SizeOf(GLfloat6), Pointer(FBuf),
    GL_STATIC_DRAW);
  FCount := Length(FBuf);
end;

{ TRawModel }

function TRawModel.GetRawData: TArray<GLfloat6>;
begin
  Result := nil;
end;

procedure TRawModel.MakeBaseBuffer;
begin

  var RawBuffer := GetRawData;

  if RawBuffer = nil then
    Exit;

  if FVertexData = 0 then glGenBuffers(1, @FVertexData);
  glBindBuffer(GL_ARRAY_BUFFER, FVertexData);
  glBufferData(GL_ARRAY_BUFFER, Length(RawBuffer) * SizeOf(GLfloat6),
    Pointer(RawBuffer), GL_STATIC_DRAW);
  FCount := Length(RawBuffer);

end;

{ TSolidCube }

constructor TSolidCube.Create(ACtl: TVisCtl3D);
begin
  inherited;
  Stored := True;
  Name := 'Solid cube';
end;

function TSolidCube.GetRawData: TArray<GLfloat6>;
const
  s = 0.5;
  Data: array[0..6*2*3-1] of GLfloat6 =
    (
    //  Front face, upper triangle
    //  x,  y,  z,     nx,   ny,   nz
      (+s, -s, +s,   +1.0,  0.0,  0.0),
      (+s, -s, -s,   +1.0,  0.0,  0.0),
      (+s, +s, +s,   +1.0,  0.0,  0.0),
    //  Front face, lower triangle
    //  x,  y,  z,     nx,   ny,   nz
      (+s, -s, -s,   +1.0,  0.0,  0.0),
      (+s, +s, -s,   +1.0,  0.0,  0.0),
      (+s, +s, +s,   +1.0,  0.0,  0.0),
    //  Right face, upper triangle
    //  x,  y,  z,     nx,   ny,   nz
      (+s, +s, +s,    0.0, +1.0,  0.0),
      (+s, +s, -s,    0.0, +1.0,  0.0),
      (-s, +s, +s,    0.0, +1.0,  0.0),
    //  Right face, lower triangle
    //  x,  y,  z,     nx,   ny,   nz
      (+s, +s, -s,    0.0, +1.0,  0.0),
      (-s, +s, -s,    0.0, +1.0,  0.0),
      (-s, +s, +s,    0.0, +1.0,  0.0),
    //  Back face, upper triangle
    //  x,  y,  z,     nx,   ny,   nz
      (-s, +s, -s,   -1.0,  0.0,  0.0),
      (-s, -s, +s,   -1.0,  0.0,  0.0),
      (-s, +s, +s,   -1.0,  0.0,  0.0),
    //  Back face, lower triangle
    //  x,  y,  z,     nx,   ny,   nz
      (-s, -s, -s,   -1.0,  0.0,  0.0),
      (-s, -s, +s,   -1.0,  0.0,  0.0),
      (-s, +s, -s,   -1.0,  0.0,  0.0),
    //  Left face, upper triangle
    //  x,  y,  z,     nx,   ny,   nz
      (-s, -s, -s,    0.0, -1.0,  0.0),
      (+s, -s, +s,    0.0, -1.0,  0.0),
      (-s, -s, +s,    0.0, -1.0,  0.0),
    //  Left face, lower triangle
    //  x,  y,  z,     nx,   ny,   nz
      (-s, -s, -s,    0.0, -1.0,  0.0),
      (+s, -s, -s,    0.0, -1.0,  0.0),
      (+s, -s, +s,    0.0, -1.0,  0.0),
    //  Top face, near triangle
    //  x,  y,  z,     nx,   ny,   nz
      (+s, -s, +s,    0.0,  0.0, +1.0),
      (+s, +s, +s,    0.0,  0.0, +1.0),
      (-s, +s, +s,    0.0,  0.0, +1.0),
    //  Top face, far triangle
    //  x,  y,  z,     nx,   ny,   nz
      (-s, -s, +s,    0.0,  0.0, +1.0),
      (+s, -s, +s,    0.0,  0.0, +1.0),
      (-s, +s, +s,    0.0,  0.0, +1.0),
    //  Bottom face, near triangle
    //  x,  y,  z,     nx,   ny,   nz
      (+s, -s, -s,    0.0,  0.0, -1.0),
      (-s, -s, -s,    0.0,  0.0, -1.0),
      (+s, +s, -s,    0.0,  0.0, -1.0),
    //  Bottom face, far triangle
    //  x,  y,  z,     nx,   ny,   nz
      (-s, -s, -s,    0.0,  0.0, -1.0),
      (-s, +s, -s,    0.0,  0.0, -1.0),
      (+s, +s, -s,    0.0,  0.0, -1.0)
    );

begin
  SetLength(Result, Length(Data));
  TArray.Copy<GLfloat6>(Data, Result, Length(Data));
end;

{ TSolidCylinder }

constructor TSolidCylinder.Create(ACtl: TVisCtl3D);
begin
  inherited;
  FAngle := 360;
  Name := 'Solid cylinder';
  OptionsFormClass := TVis3D_CylinderSettingsFrm;
end;

destructor TSolidCylinder.Destroy;
begin
  inherited;
end;

procedure TSolidCylinder.ConstructBufferSinHole;
begin

  if FVertexData <> 0 then
    raise Exception.Create('Vertex data already present.');

  var LAngle: Single := EnsureRange(FAngle, 0.1, 360) * Pi / 180;
  var LSlice := LAngle < 2*Pi;

  const N = Ceil(128 * LAngle/2*Pi);

  var TrigVals: TArray<rglv2>;
  SetLength(TrigVals, N + 1);
  for var i := 0 to N do
  begin
    var s, c: Single;
    SinCos(LAngle / N * i, s, c);
    TrigVals[i] := vec2(c, s);
  end;

  FCounts := [2 + N, 2 + 2*N + 8*Ord(LSlice), 2 + N];  
  FTwoSides := False;

  var Data: TArray<GLfloat6>;
  SetLength(Data,
    FCounts[0]
        +
    FCounts[1]
        +
    FCounts[2]);

  var Idx := 0;

  // Top disk (triangle fan)

  GLr3n3v(Data[Idx]).r := vec(0.0, 0.0, 1.0);
  GLr3n3v(Data[Idx]).n := vec(0, 0, 1.0);
  Inc(Idx);
  for var i := 0 to N do
  begin
    GLr3n3v(Data[Idx]).r := vec(TrigVals[i].x, TrigVals[i].y, 1.0);
    GLr3n3v(Data[Idx]).n := vec(0, 0, 1.0);
    Inc(Idx);
  end;

  // Cylinder + edges (triangle strip)

  if LSlice then
  begin
  
    GLr3n3v(Data[Idx]).r := vec(0.0, 0.0, 1.0);
    GLr3n3v(Data[Idx]).n := vec(0.0, -1.0, 0.0);
    Inc(Idx);

    GLr3n3v(Data[Idx]).r := vec(0.0, 0.0, 0.0);
    GLr3n3v(Data[Idx]).n := vec(0.0, -1.0, 0.0);
    Inc(Idx);

    GLr3n3v(Data[Idx]).r := vec(TrigVals[0].x, TrigVals[0].y, 1.0);
    GLr3n3v(Data[Idx]).n := vec(0.0, -1.0, 0.0);
    Inc(Idx);

    GLr3n3v(Data[Idx]).r := vec(TrigVals[0].x, TrigVals[0].y, 0.0);
    GLr3n3v(Data[Idx]).n := vec(0.0, -1.0, 0.0);
    Inc(Idx);

  end;

  GLr3n3v(Data[Idx]).r := vec(TrigVals[0].x, TrigVals[0].y, 1.0);
  GLr3n3v(Data[Idx]).n := vec(TrigVals[0].x, TrigVals[0].y, 0.0);
  Inc(Idx);

  for var i := 0 to N - 1 do
  begin
    GLr3n3v(Data[Idx]).r := vec(TrigVals[i].x, TrigVals[i].y, 0.0);
    GLr3n3v(Data[Idx]).n := vec(TrigVals[i].x, TrigVals[i].y, 0.0);
    Inc(Idx);
    GLr3n3v(Data[Idx]).r := vec(TrigVals[Succ(i)].x, TrigVals[Succ(i)].y, 1.0);
    GLr3n3v(Data[Idx]).n := vec(TrigVals[Succ(i)].x, TrigVals[Succ(i)].y, 0.0);
    Inc(Idx);
  end;

  GLr3n3v(Data[Idx]).r := vec(TrigVals[High(TrigVals)].x, TrigVals[High(TrigVals)].y, 0.0);
  GLr3n3v(Data[Idx]).n := vec(TrigVals[High(TrigVals)].x, TrigVals[High(TrigVals)].y, 0.0);
  Inc(Idx);

  if LSlice then
  begin

    GLr3n3v(Data[Idx]).r := vec(TrigVals[High(TrigVals)].x, TrigVals[High(TrigVals)].y, 1.0);
    GLr3n3v(Data[Idx]).n := vec(-TrigVals[High(TrigVals)].y, TrigVals[High(TrigVals)].x, 0);
    Inc(Idx);

    GLr3n3v(Data[Idx]).r := vec(TrigVals[High(TrigVals)].x, TrigVals[High(TrigVals)].y, 0.0);
    GLr3n3v(Data[Idx]).n := vec(-TrigVals[High(TrigVals)].y, TrigVals[High(TrigVals)].x, 0);
    Inc(Idx);

    GLr3n3v(Data[Idx]).r := vec(0.0, 0.0, 1.0);
    GLr3n3v(Data[Idx]).n := vec(-TrigVals[High(TrigVals)].y, TrigVals[High(TrigVals)].x, 0);
    Inc(Idx);

    GLr3n3v(Data[Idx]).r := vec(0.0, 0.0, 0.0);
    GLr3n3v(Data[Idx]).n := vec(-TrigVals[High(TrigVals)].y, TrigVals[High(TrigVals)].x, 0);
    Inc(Idx);

  end;

  // Bottom disk (triangle fan)

  GLr3n3v(Data[Idx]).r := vec(0.0, 0.0, 0.0);
  GLr3n3v(Data[Idx]).n := vec(0, 0, -1.0);
  Inc(Idx);

  for var i := N downto 0 do
  begin
    GLr3n3v(Data[Idx]).r := vec(TrigVals[i].x, TrigVals[i].y, 0.0);
    GLr3n3v(Data[Idx]).n := vec(0, 0, -1.0);
    Inc(Idx);
  end;

  Assert(Idx = Length(Data));

  glGenBuffers(1, @FVertexData);
  glBindBuffer(GL_ARRAY_BUFFER, FVertexData);
  glBufferData(GL_ARRAY_BUFFER, Length(Data) * SizeOf(GLfloat6), Pointer(Data), GL_STATIC_DRAW);

end;

procedure TSolidCylinder.Configure(ASettings: TAlgosimStructure);
begin
  inherited;
  for var i := 1 to ASettings.MemberCount do
  begin
    var S := ASettings.Members[i].Name;
    var V := ASettings.Members[i].Value;
    if S = 'axislengths' then
      AxisLengths := V.AsRealVector
    else if S = 'radius' then
      Radius := V.ToASR
    else if S = 'height' then
      Height := V.ToASR
    else if S = 'innerradius' then
      InnerRadiusFraction := V.ToASR
    else if S = 'angle' then
      Angle := 180 * V.ToASR / Pi;
  end;
end;

procedure TSolidCylinder.ConstructBufferConHole;
begin

  if FVertexData <> 0 then
    raise Exception.Create('Vertex data already present.');

  var LAngle: Single := EnsureRange(FAngle, 0.1, 360) * Pi / 180;
  var LSlice := LAngle < 2*Pi;  
  var LInnerRadius: Single := EnsureRange(FInnerRadius, 0.0, 1.0);
  var ρ := LInnerRadius;

  const N = Ceil(128 * LAngle/2*Pi);

  var TrigVals: TArray<rglv2>;
  SetLength(TrigVals, N + 1);
  for var i := 0 to N do
  begin
    var s, c: Single;
    SinCos(LAngle / N * i, s, c);
    TrigVals[i] := vec2(c, s);
  end;

  FCounts := [2 * (N + 1), 4 + 4*N + 8*Ord(LSlice), 2 * (N+1)];
  FTwoSides := not LSlice;

  var Data: TArray<GLfloat6>;
  SetLength(Data,
    FCounts[0]
        +
    FCounts[1]
        +
    FCounts[2]);    

  var Idx := 0;

  // Top annulus (triangle strip)

  for var i := 0 to N do
  begin
    GLr3n3v(Data[Idx]).r := vec(ρ * TrigVals[i].x, ρ * TrigVals[i].y, 1.0);
    GLr3n3v(Data[Idx]).n := vec(0, 0, 1.0);
    Inc(Idx);
    GLr3n3v(Data[Idx]).r := vec(TrigVals[i].x, TrigVals[i].y, 1.0);
    GLr3n3v(Data[Idx]).n := vec(0, 0, 1.0);
    Inc(Idx);
  end;

  // Cylinders + edges (triangle strip)

  if LSlice then
  begin

    GLr3n3v(Data[Idx]).r := vec(ρ * TrigVals[0].x, ρ * TrigVals[0].y, 1.0);
    GLr3n3v(Data[Idx]).n := vec(0.0, -1.0, 0.0);
    Inc(Idx);

    GLr3n3v(Data[Idx]).r := vec(ρ * TrigVals[0].x, ρ * TrigVals[0].y, 0.0);
    GLr3n3v(Data[Idx]).n := vec(0.0, -1.0, 0.0);
    Inc(Idx);

    GLr3n3v(Data[Idx]).r := vec(TrigVals[0].x, TrigVals[0].y, 1.0);
    GLr3n3v(Data[Idx]).n := vec(0.0, -1.0, 0.0);
    Inc(Idx);

    GLr3n3v(Data[Idx]).r := vec(TrigVals[0].x, TrigVals[0].y, 0.0);
    GLr3n3v(Data[Idx]).n := vec(0.0, -1.0, 0.0);
    Inc(Idx);

  end;

  GLr3n3v(Data[Idx]).r := vec(TrigVals[0].x, TrigVals[0].y, 1.0);
  GLr3n3v(Data[Idx]).n := vec(TrigVals[0].x, TrigVals[0].y, 0.0);
  Inc(Idx);

  for var i := 0 to N - 1 do
  begin
    GLr3n3v(Data[Idx]).r := vec(TrigVals[i].x, TrigVals[i].y, 0.0);
    GLr3n3v(Data[Idx]).n := vec(TrigVals[i].x, TrigVals[i].y, 0.0);
    Inc(Idx);
    GLr3n3v(Data[Idx]).r := vec(TrigVals[Succ(i)].x, TrigVals[Succ(i)].y, 1.0);
    GLr3n3v(Data[Idx]).n := vec(TrigVals[Succ(i)].x, TrigVals[Succ(i)].y, 0.0);
    Inc(Idx);
  end;

  GLr3n3v(Data[Idx]).r := vec(TrigVals[High(TrigVals)].x, TrigVals[High(TrigVals)].y, 0.0);
  GLr3n3v(Data[Idx]).n := vec(TrigVals[High(TrigVals)].x, TrigVals[High(TrigVals)].y, 0.0);
  Inc(Idx);

  if LSlice then
  begin
  
    GLr3n3v(Data[Idx]).r := vec(TrigVals[High(TrigVals)].x, TrigVals[High(TrigVals)].y, 1.0);
    GLr3n3v(Data[Idx]).n := vec(-TrigVals[High(TrigVals)].y, TrigVals[High(TrigVals)].x, 0);
    Inc(Idx);

    GLr3n3v(Data[Idx]).r := vec(TrigVals[High(TrigVals)].x, TrigVals[High(TrigVals)].y, 0.0);
    GLr3n3v(Data[Idx]).n := vec(-TrigVals[High(TrigVals)].y, TrigVals[High(TrigVals)].x, 0);
    Inc(Idx);

    GLr3n3v(Data[Idx]).r := vec(ρ * TrigVals[High(TrigVals)].x, ρ * TrigVals[High(TrigVals)].y, 1.0);
    GLr3n3v(Data[Idx]).n := vec(-TrigVals[High(TrigVals)].y, TrigVals[High(TrigVals)].x, 0);
    Inc(Idx);

    GLr3n3v(Data[Idx]).r := vec(ρ * TrigVals[High(TrigVals)].x, ρ * TrigVals[High(TrigVals)].y, 0.0);
    GLr3n3v(Data[Idx]).n := vec(-TrigVals[High(TrigVals)].y, TrigVals[High(TrigVals)].x, 0);
    Inc(Idx);

  end;

  GLr3n3v(Data[Idx]).r := vec(ρ * TrigVals[High(TrigVals)].x, ρ * TrigVals[High(TrigVals)].y, 1.0);
  GLr3n3v(Data[Idx]).n := vec(-TrigVals[High(TrigVals)].y, TrigVals[High(TrigVals)].x, 0);
  Inc(Idx);

  for var i := N - 1 downto 0 do
  begin
    GLr3n3v(Data[Idx]).r := vec(ρ * TrigVals[Succ(i)].x, ρ * TrigVals[Succ(i)].y, 0.0);
    GLr3n3v(Data[Idx]).n := vec(ρ * TrigVals[Succ(i)].x, ρ * TrigVals[Succ(i)].y, 0.0);
    Inc(Idx);
    GLr3n3v(Data[Idx]).r := vec(ρ * TrigVals[i].x, ρ * TrigVals[i].y, 1.0);
    GLr3n3v(Data[Idx]).n := vec(ρ * TrigVals[i].x, ρ * TrigVals[i].y, 0.0);
    Inc(Idx);
  end;

  GLr3n3v(Data[Idx]).r := vec(ρ * TrigVals[0].x, ρ * TrigVals[0].y, 0.0);
  GLr3n3v(Data[Idx]).n := vec(ρ * TrigVals[0].x, ρ * TrigVals[0].y, 0.0);
  Inc(Idx);

  // Bottom annulus (triangle strip)

  for var i := N downto 0 do
  begin
    GLr3n3v(Data[Idx]).r := vec(ρ * TrigVals[i].x, ρ * TrigVals[i].y, 0.0);
    GLr3n3v(Data[Idx]).n := vec(0, 0, -1.0);
    Inc(Idx);
    GLr3n3v(Data[Idx]).r := vec(TrigVals[i].x, TrigVals[i].y, 0.0);
    GLr3n3v(Data[Idx]).n := vec(0, 0, -1.0);
    Inc(Idx);
  end;

  Assert(Idx = Length(Data));

  glGenBuffers(1, @FVertexData);
  glBindBuffer(GL_ARRAY_BUFFER, FVertexData);
  glBufferData(GL_ARRAY_BUFFER, Length(Data) * SizeOf(GLfloat6), Pointer(Data), GL_STATIC_DRAW);

end;

procedure TSolidCylinder.Draw(const AGlobalTime: Double);
begin
  inherited;
  glBindVertexArray(FVAO);
  if FInnerRadius = 0.0 then
  begin
    glDrawArrays(GL_TRIANGLE_FAN, 0, FCounts[0]);
    glDrawArrays(GL_TRIANGLE_STRIP, FCounts[0], FCounts[1]);
    glDrawArrays(GL_TRIANGLE_FAN, FCounts[0] + FCounts[1], FCounts[2]);
  end
  else
  begin
    glDrawArrays(GL_TRIANGLE_STRIP, 0, FCounts[0]);
    if FTwoSides then
    begin
      glDrawArrays(GL_TRIANGLE_STRIP, FCounts[0], FCounts[1] div 2);
      glDrawArrays(GL_TRIANGLE_STRIP, FCounts[0] + FCounts[1] div 2, FCounts[1] div 2);
    end
    else
      glDrawArrays(GL_TRIANGLE_STRIP, FCounts[0], FCounts[1]);
    glDrawArrays(GL_TRIANGLE_STRIP, FCounts[0] + FCounts[1], FCounts[2]);
  end;
  glBindVertexArray(0);
end;

procedure TSolidCylinder.FreeGLResources;
begin
  if TryContextCurrent then
  begin
    glDeleteVertexArrays(1, @FVAO); FVAO := 0;
    ReleaseBuffer;
  end
  else
    rglLog('TSolidCylinder.FreeGLResources: TryContextCurrent returned false');
  inherited;
end;

function TSolidCylinder.GetAxisLengths: rglv2;
begin
  Result.x := Scale.x;
  Result.y := Scale.y;
end;

function TSolidCylinder.GetHeight: Single;
begin
  Result := Scale.z;
end;

function TSolidCylinder.GetRadius: Single;
begin
  Result := FScale.x;
end;

procedure TSolidCylinder.GLRelease;
begin
  FVertexData := 0;
  FCounts := nil;
  FVAO := 0;
  inherited;
end;

procedure TSolidCylinder.GetBufferData;
begin

  var LBufferStore: TDictionary<TBufferStoreKey, TBufferStoreItem>;

  var Buf := TObject(nil);
  if Control.Context.FCustomBuffers.TryGetValue(TSolidCylinder, Buf) then
    LBufferStore := Buf as TDictionary<TBufferStoreKey, TBufferStoreItem>
  else
  begin
    LBufferStore := TDictionary<TBufferStoreKey, TBufferStoreItem>.Create;
    Control.Context.FCustomBuffers.AddOrSetValue(TSolidCylinder, LBufferStore);
  end;

  var Key := Default(TBufferStoreKey);
  Key.InnerRadius := FInnerRadius;
  Key.Angle := FAngle;

  var BSI := Default(TBufferStoreItem);

  if LBufferStore.TryGetValue(Key, BSI) then
  begin
    Assert(BSI.InnerRadius = FInnerRadius);
    Assert(BSI.Angle = FAngle);
    FVertexData := BSI.VertexData;
    FCounts := Copy(BSI.Counts);
    FTwoSides := BSI.TwoSides;
    Inc(BSI.RefCnt);
    LBufferStore.AddOrSetValue(Key, BSI);
    FBSK := Key;
  end
  else
  begin
    if FInnerRadius = 0.0 then
      ConstructBufferSinHole
    else
      ConstructBufferConHole;
    BSI.InnerRadius := FInnerRadius;
    BSI.Angle := FAngle;
    BSI.VertexData := FVertexData;
    BSI.Counts := Copy(FCounts);
    BSI.TwoSides := FTwoSides;
    BSI.RefCnt := 1;
    LBufferStore.Add(Key, BSI);
    FBSK := Key;
  end;

end;

procedure TSolidCylinder.Recreate;
begin
  if FVertexData <> 0 then
  begin
    ReleaseBuffer;
    Setup;
  end;
end;

procedure TSolidCylinder.ReleaseBuffer;
begin

  if FVertexData = 0 then
    Exit;

  if TryContextCurrent then
  begin

    var Key := FBSK;
    var BSI := Default(TBufferStoreItem);

    var bobj := TObject(nil);

    if
      Assigned(Control.Context.FCustomBuffers)
        and
      Control.Context.FCustomBuffers.TryGetValue(TSolidCylinder, bobj)
        and
      (bobj is TDictionary<TBufferStoreKey, TBufferStoreItem>)
        and
      TDictionary<TBufferStoreKey, TBufferStoreItem>(bobj).TryGetValue(Key, BSI)
    then
    begin
      var LBufferStore := TDictionary<TBufferStoreKey, TBufferStoreItem>(bobj);
      Assert(BSI.InnerRadius = Key.InnerRadius);
      Assert(BSI.Angle = Key.Angle);
      Assert(BSI.VertexData = FVertexData);
      Dec(BSI.RefCnt);
      if BSI.RefCnt = 0 then
      begin
        glDeleteBuffers(1, @FVertexData); FVertexData := 0;
        LBufferStore.Remove(Key);
      end
      else
      begin
        LBufferStore.AddOrSetValue(Key, BSI);
        FVertexData := 0;
      end;
    end
    else
      FVertexData := 0;

  end;

end;

procedure TSolidCylinder.SetAngle(const Value: Double);
begin

  var LValue := EnsureRange(Value, 0, 360);

  if FAngle <> LValue then
  begin
    FAngle := LValue;
    Recreate;
    Changed;
  end;

end;

procedure TSolidCylinder.SetAxisLengths(const Value: rglv2);
begin
  Scale := vec(Value.x, Value.y, FScale.z);
end;

procedure TSolidCylinder.SetHeight(const Value: Single);
begin
  Scale := vec(FScale.x, FScale.y, Value);
end;

procedure TSolidCylinder.SetInnerRadiusFraction(const Value: Double);
begin
  var LValue := EnsureRange(Value, 0.0, 1.0);
  if FInnerRadius <> LValue then
  begin
    FInnerRadius := LValue;
    Recreate;
    Changed;
  end;
end;

procedure TSolidCylinder.SetRadius(const Value: Single);
begin
  Scale := vec(Value, Value, FScale.z);
end;

procedure TSolidCylinder.Setup;
begin

  if (Control = nil) or (Control.Context = nil) then
    Exit;
  Control.Context.MakeCurrent('TSolidCylinder.Setup');

  if FVAO = 0 then glGenVertexArrays(1, @FVAO);

  glBindVertexArray(FVAO);
  try

    GetBufferData;

    glBindBuffer(GL_ARRAY_BUFFER, FVertexData);
    glEnableVertexAttribArray(0);
    glEnableVertexAttribArray(2);
    glVertexAttribPointer(0, 3, GL_FLOAT, GL_FALSE, 6*SizeOf(GLfloat), nil);
    glVertexAttribPointer(2, 3, GL_FLOAT, GL_FALSE, 6*SizeOf(GLfloat), Pointer(3*SizeOf(GLfloat)));

  finally
    glBindVertexArray(0);
  end;

end;

{ TSolidCone }

procedure TSolidCone.Configure(ASettings: TAlgosimStructure);
begin
  inherited;
  for var i := 1 to ASettings.MemberCount do
  begin
    var S := ASettings.Members[i].Name;
    var V := ASettings.Members[i].Value;
    if S = 'axislengths' then
      AxisLengths := V.AsRealVector
    else if S = 'radius' then
      Radius := V.ToASR
    else if S = 'height' then
      Height := V.ToASR;
  end;
end;

constructor TSolidCone.Create(ACtl: TVisCtl3D);
begin
  inherited;
  Name := 'Solid cone';
end;

destructor TSolidCone.Destroy;
begin
  inherited;
end;

procedure TSolidCone.Draw(const AGlobalTime: Double);
begin
  inherited;
  glBindVertexArray(FVAO);
  glDrawArrays(GL_TRIANGLE_FAN, 0, FCount + 2);
  glDrawArrays(GL_TRIANGLE_FAN, FCount + 2, FCount + 2);
  glBindVertexArray(0);
end;

procedure TSolidCone.FreeGLResources;
begin
  if TryContextCurrent then
  begin
    glDeleteVertexArrays(1, @FVAO); FVAO := 0;
    if FVertexData <> 0 then
    begin
      var Rec := Default(TSolidStoreRec);
      if Assigned(Control.Context.FStoredSolids) and Control.Context.FStoredSolids.TryGetValue(TSolidCone, Rec) then
      begin
        Assert(Rec.VertexData = FVertexData);
        Assert(Rec.Count = FCount);
        Dec(Rec.RefCnt);
        if Rec.RefCnt = 0 then
        begin
          glDeleteBuffers(1, @FVertexData); FVertexData := 0;
          Control.Context.FStoredSolids.Remove(TSolidCone);
        end
        else
        begin
          Control.Context.FStoredSolids.AddOrSetValue(TSolidCone, Rec);
          FVertexData := 0;
        end;
      end
      else
      begin
        glDeleteBuffers(1, @FVertexData); FVertexData := 0;
      end;
    end;
  end
  else
    rglLog('TSolidCone.FreeGLResources: TryContextCurrent returned false');
  inherited;
end;

function TSolidCone.GetAxisLengths: rglv2;
begin
  Result.x := Scale.x;
  Result.y := Scale.y;
end;

function TSolidCone.GetHeight: Single;
begin
  Result := Scale.z;
end;

function TSolidCone.GetRadius: Single;
begin
  Result := FScale.x;
end;

procedure TSolidCone.GLRelease;
begin
  FVertexData := 0;
  FCount := 0;
  FVAO := 0;
  inherited;
end;

procedure TSolidCone.MakeBaseBuffer;
begin

  const N = 128;

  var TrigVals: TArray<rglv2>;
  SetLength(TrigVals, N + 1);
  for var i := 0 to N do
  begin
    var s, c: Single;
    SinCos(2*Pi / N * i, s, c);
    TrigVals[i] := vec2(c, s);
  end;

  FCount := N;

  var Data: TArray<GLfloat6>;
  SetLength(Data,
    N + 2
        +
    N + 2);

  var Idx := 0;

  // Cone (triangle fan)

  GLr3n3v(Data[Idx]).r := vec(0.0, 0.0, 1.0);
  GLr3n3v(Data[Idx]).n := rglv.Zero;
  Inc(Idx);

  for var i := 0 to N do
  begin
    GLr3n3v(Data[Idx]).r := vec(TrigVals[i].x, TrigVals[i].y, 0.0);
    GLr3n3v(Data[Idx]).n := vec(TrigVals[i].x, TrigVals[i].y, 1.0).Normalized;
    Inc(Idx);
  end;

  // Bottom disk (triangle fan)

  GLr3n3v(Data[Idx]).r := vec(0.0, 0.0, 0.0);
  GLr3n3v(Data[Idx]).n := vec(0, 0, -1.0);
  Inc(Idx);

  for var i := N downto 0 do
  begin
    GLr3n3v(Data[Idx]).r := vec(TrigVals[i].x, TrigVals[i].y, 0.0);
    GLr3n3v(Data[Idx]).n := vec(0, 0, -1.0);
    Inc(Idx);
  end;

  Assert(Idx = Length(Data));

  if FVertexData = 0 then glGenBuffers(1, @FVertexData);
  glBindBuffer(GL_ARRAY_BUFFER, FVertexData);
  glBufferData(GL_ARRAY_BUFFER, Length(Data) * SizeOf(GLfloat6), Pointer(Data), GL_STATIC_DRAW);

end;

procedure TSolidCone.Recreate;
begin
  if FVertexData <> 0 then
    Setup;
end;

procedure TSolidCone.SetAxisLengths(const Value: rglv2);
begin
  Scale := vec(Value.x, Value.y, FScale.z);
end;

procedure TSolidCone.SetHeight(const Value: Single);
begin
  Scale := vec(FScale.x, FScale.y, Value);
end;

procedure TSolidCone.SetRadius(const Value: Single);
begin
  Scale := vec(Value, Value, FScale.z);
end;

procedure TSolidCone.Setup;
begin

  if (Control = nil) or (Control.Context = nil) then
    Exit;
  Control.Context.MakeCurrent('TSolidCone.Setup');

  if FVAO = 0 then glGenVertexArrays(1, @FVAO);

  glBindVertexArray(FVAO);
  try

    if FVertexData = 0 then
    begin
      var Rec := Default(TSolidStoreRec);
      if Control.Context.FStoredSolids.TryGetValue(TSolidCone, Rec) then
      begin
        FVertexData := Rec.VertexData;
        FCount := Rec.Count;
        Inc(Rec.RefCnt);
        Control.Context.FStoredSolids.AddOrSetValue(TSolidCone, Rec);
      end
      else
      begin
        MakeBaseBuffer; if FVertexData = 0 then Exit;
        Rec.VertexData := FVertexData;
        Rec.Count := FCount;
        Rec.RefCnt := 1;
        Control.Context.FStoredSolids.Add(TSolidCone, Rec);
      end;
    end;

    glBindBuffer(GL_ARRAY_BUFFER, FVertexData);
    glEnableVertexAttribArray(0);
    glEnableVertexAttribArray(2);
    glVertexAttribPointer(0, 3, GL_FLOAT, GL_FALSE, 6*SizeOf(GLfloat), nil);
    glVertexAttribPointer(2, 3, GL_FLOAT, GL_FALSE, 6*SizeOf(GLfloat), Pointer(3*SizeOf(GLfloat)));

  finally
    glBindVertexArray(0);
  end;

end;

{ TSolidTetrahedron }

constructor TSolidTetrahedron.Create(ACtl: TVisCtl3D);
begin
  inherited;
  Stored := True;
  Name := 'Solid tetrahedron';
end;

function TSolidTetrahedron.GetRawData: TArray<GLfloat6>;
const
  Data: array[0..71] of GLfloat =
    (
      0.942809045, 0, -1/3, 0.471404523, 0.816496611, 1/3,
      -0.471404523, 0.816496611, -1/3, 0.471404523, 0.816496611, 1/3,
      0, 0, 1, 0.471404523, 0.816496611, 1/3,
      -0.471404523, 0.816496611, -1/3, -0.942809045, 0, 1/3,
      -0.471404523, -0.816496611, -1/3, -0.942809045, 0, 1/3,
      0, 0, 1, -0.942809045, 0, 1/3,
      -0.471404523, -0.816496611, -1/3, 0.471404523, -0.816496611, 1/3,
      0.942809045, 0, -1/3, 0.471404523, -0.816496611, 1/3,
      0, 0, 1, 0.471404523, -0.816496611, 1/3,
      0.942809045, 0, -1/3, 0, 0, -1,
      -0.471404523, -0.816496611, -1/3, 0, 0, -1,
      -0.471404523, 0.816496611, -1/3, 0, 0, -1
    );
begin
  SetLength(Result, Length(Data) div 6);
  CopyMemory(Pointer(Result), @Data, SizeOf(Data));
end;

{ TSolidOctahedron }

constructor TSolidOctahedron.Create(ACtl: TVisCtl3D);
begin
  inherited;
  Stored := True;
  Name := 'Solid octahedron';
end;

function TSolidOctahedron.GetRawData: TArray<GLfloat6>;
const
  x = 0.577350269189625764;
  Data: array[0..143] of GLfloat =
    (
      0, 0, 1, x, x, x,
      1, 0, 0, x, x, x,
      0, 1, 0, x, x, x,
      0, 0, 1, -x, -x, x,
      -1, 0, 0, -x, -x, x,
      0, -1, 0, -x, -x, x,
      0, 0, 1, x, -x, x,
      0, -1, 0, x, -x, x,
      1, 0, 0, x, -x, x,
      0, 0, 1, -x, x, x,
      0, 1, 0, -x, x, x,
      -1, 0, 0, -x, x, x,
      1, 0, 0, x, x, -x,
      0, 0, -1, x, x, -x,
      0, 1, 0, x, x, -x,
      0, 0, -1, -x, -x, -x,
      0, -1, 0, -x, -x, -x,
      -1, 0, 0, -x, -x, -x,
      1, 0, 0, x, -x, -x,
      0, -1, 0, x, -x, -x,
      0, 0, -1, x, -x, -x,
      -1, 0, 0, -x, x, -x,
      0, 1, 0, -x, x, -x,
      0, 0, -1, -x, x, -x
    );
begin
  SetLength(Result, Length(Data) div 6);
  CopyMemory(Pointer(Result), @Data, SizeOf(Data));
end;

{ TSolidDodecahedron }

constructor TSolidDodecahedron.Create(ACtl: TVisCtl3D);
begin
  inherited;
  Stored := True;
  Name := 'Solid dodecahedron';
end;

function TSolidDodecahedron.GetRawData: TArray<GLfloat6>;
const
  Data: array[0..647] of GLfloat =
    (
      0, -1.6180340, 0.6180340, 0.5257311, -0.8506507, 0,
      0, -1.6180340, -0.6180340, 0.5257311, -0.8506507, 0,
      1, -1, -1, 0.5257311, -0.8506507, 0,
      0, -1.6180340, 0.6180340, 0.5257311, -0.8506508, 0,
      1, -1, -1, 0.5257311, -0.8506508, 0,
      1.6180340, -0.6180340, 0, 0.5257311, -0.8506508, 0,
      0, -1.6180340, 0.6180340, 0.5257311, -0.8506507, 0,
      1.6180340, -0.6180340, 0, 0.5257311, -0.8506507, 0,
      1, -1, 1, 0.5257311, -0.8506507, 0,
      1, -1, 1, 0.8506507, 0, 0.5257311,
      1.6180340, -0.6180340, 0, 0.8506507, 0, 0.5257311,
      1.6180340, 0.6180340, 0, 0.8506507, 0, 0.5257311,
      1, -1, 1, 0.8506508, 0, 0.5257311,
      1.6180340, 0.6180340, 0, 0.8506508, 0, 0.5257311,
      1, 1, 1, 0.8506508, 0, 0.5257311,
      1, -1, 1, 0.8506508, 0, 0.5257311,
      1, 1, 1, 0.8506508, 0, 0.5257311,
      0.6180340, 0, 1.6180340, 0.8506508, 0, 0.5257311,
      0, -1.6180340, 0.6180340, 0, -0.5257311, 0.8506507,
      1, -1, 1, 0, -0.5257311, 0.8506507,
      0.6180340, 0, 1.6180340, 0, -0.5257311, 0.8506507,
      0, -1.6180340, 0.6180340, 0, -0.5257311, 0.8506508,
      0.6180340, 0, 1.6180340, 0, -0.5257311, 0.8506508,
      -0.6180340, 0, 1.6180340, 0, -0.5257311, 0.8506508,
      0, -1.6180340, 0.6180340, 0, -0.5257311, 0.8506507,
      -0.6180340, 0, 1.6180340, 0, -0.5257311, 0.8506507,
      -1, -1, 1, 0, -0.5257311, 0.8506507,
      0, -1.6180340, -0.6180340, -0.5257311, -0.8506507, 0,
      0, -1.6180340, 0.6180340, -0.5257311, -0.8506507, 0,
      -1, -1, 1, -0.5257311, -0.8506507, 0,
      0, -1.6180340, -0.6180340, -0.5257311, -0.8506508, 0,
      -1, -1, 1, -0.5257311, -0.8506508, 0,
      -1.6180340, -0.6180340, 0, -0.5257311, -0.8506508, 0,
      0, -1.6180340, -0.6180340, -0.5257311, -0.8506507, 0,
      -1.6180340, -0.6180340, 0, -0.5257311, -0.8506507, 0,
      -1, -1, -1, -0.5257311, -0.8506507, 0,
      0, -1.6180340, -0.6180340, 0, -0.5257311, -0.8506507,
      -1, -1, -1, 0, -0.5257311, -0.8506507,
      -0.6180340, 0, -1.6180340, 0, -0.5257311, -0.8506507,
      0, -1.6180340, -0.6180340, 0, -0.5257311, -0.8506508,
      -0.6180340, 0, -1.6180340, 0, -0.5257311, -0.8506508,
      0.6180340, 0, -1.6180340, 0, -0.5257311, -0.8506508,
      0, -1.6180340, -0.6180340, 0, -0.5257311, -0.8506507,
      0.6180340, 0, -1.6180340, 0, -0.5257311, -0.8506507,
      1, -1, -1, 0, -0.5257311, -0.8506507,
      1, -1, -1, 0.8506508, 0, -0.5257311,
      0.6180340, 0, -1.6180340, 0.8506508, 0, -0.5257311,
      1, 1, -1, 0.8506508, 0, -0.5257311,
      1, -1, -1, 0.8506508, 0, -0.5257311,
      1, 1, -1, 0.8506508, 0, -0.5257311,
      1.6180340, 0.6180340, 0, 0.8506508, 0, -0.5257311,
      1, -1, -1, 0.8506507, 0, -0.5257311,
      1.6180340, 0.6180340, 0, 0.8506507, 0, -0.5257311,
      1.6180340, -0.6180340, 0, 0.8506507, 0, -0.5257311,
      -1, -1, 1, -0.8506508, 0, 0.5257311,
      -0.6180340, 0, 1.6180340, -0.8506508, 0, 0.5257311,
      -1, 1, 1, -0.8506508, 0, 0.5257311,
      -1, -1, 1, -0.8506508, 0, 0.5257311,
      -1, 1, 1, -0.8506508, 0, 0.5257311,
      -1.6180340, 0.6180340, 0, -0.8506508, 0, 0.5257311,
      -1, -1, 1, -0.8506507, 0, 0.5257311,
      -1.6180340, 0.6180340, 0, -0.8506507, 0, 0.5257311,
      -1.6180340, -0.6180340, 0, -0.8506507, 0, 0.5257311,
      -1, 1, 1, 0, 0.5257311, 0.8506507,
      -0.6180340, 0, 1.6180340, 0, 0.5257311, 0.8506507,
      0.6180340, 0, 1.6180340, 0, 0.5257311, 0.8506507,
      -1, 1, 1, 0, 0.5257311, 0.8506508,
      0.6180340, 0, 1.6180340, 0, 0.5257311, 0.8506508,
      1, 1, 1, 0, 0.5257311, 0.8506508,
      -1, 1, 1, 0, 0.5257311, 0.8506508,
      1, 1, 1, 0, 0.5257311, 0.8506508,
      0, 1.6180340, 0.6180340, 0, 0.5257311, 0.8506508,
      1, 1, 1, 0.5257311, 0.8506508, 0,
      1.6180340, 0.6180340, 0, 0.5257311, 0.8506508, 0,
      1, 1, -1, 0.5257311, 0.8506508, 0,
      1, 1, 1, 0.5257311, 0.8506508, 0,
      1, 1, -1, 0.5257311, 0.8506508, 0,
      0, 1.6180340, -0.6180340, 0.5257311, 0.8506508, 0,
      1, 1, 1, 0.5257311, 0.8506507, 0,
      0, 1.6180340, -0.6180340, 0.5257311, 0.8506507, 0,
      0, 1.6180340, 0.6180340, 0.5257311, 0.8506507, 0,
      -1, 1, 1, -0.5257311, 0.8506507, 0,
      0, 1.6180340, 0.6180340, -0.5257311, 0.8506507, 0,
      0, 1.6180340, -0.6180340, -0.5257311, 0.8506507, 0,
      -1, 1, 1, -0.5257311, 0.8506508, 0,
      0, 1.6180340, -0.6180340, -0.5257311, 0.8506508, 0,
      -1, 1, -1, -0.5257311, 0.8506508, 0,
      -1, 1, 1, -0.5257311, 0.8506508, 0,
      -1, 1, -1, -0.5257311, 0.8506508, 0,
      -1.6180340, 0.6180340, 0, -0.5257311, 0.8506508, 0,
      -1, 1, -1, -0.8506508, 0, -0.5257311,
      -0.6180340, 0, -1.6180340, -0.8506508, 0, -0.5257311,
      -1, -1, -1, -0.8506508, 0, -0.5257311,
      -1, 1, -1, -0.8506508, 0, -0.5257311,
      -1, -1, -1, -0.8506508, 0, -0.5257311,
      -1.6180340, -0.6180340, 0, -0.8506508, 0, -0.5257311,
      -1, 1, -1, -0.8506507, 0, -0.5257311,
      -1.6180340, -0.6180340, 0, -0.8506507, 0, -0.5257311,
      -1.6180340, 0.6180340, 0, -0.8506507, 0, -0.5257311,
      1, 1, -1, 0, 0.5257311, -0.8506507,
      0.6180340, 0, -1.6180340, 0, 0.5257311, -0.8506507,
      -0.6180340, 0, -1.6180340, 0, 0.5257311, -0.8506507,
      1, 1, -1, 0, 0.5257311, -0.8506508,
      -0.6180340, 0, -1.6180340, 0, 0.5257311, -0.8506508,
      -1, 1, -1, 0, 0.5257311, -0.8506508,
      1, 1, -1, 0, 0.5257311, -0.8506508,
      -1, 1, -1, 0, 0.5257311, -0.8506508,
      0, 1.6180340, -0.6180340, 0, 0.5257311, -0.8506508
    );
begin
  SetLength(Result, Length(Data) div 6);
  CopyMemory(Pointer(Result), @Data, SizeOf(Data));
end;

{ TSolidIcosahedron }

constructor TSolidIcosahedron.Create(ACtl: TVisCtl3D);
begin
  inherited;
  Stored := True;
  Name := 'Solid icosahedron';
end;

function TSolidIcosahedron.GetRawData: TArray<GLfloat6>;
const
  Data: array[0..359] of GLfloat =
    (
      1.61803401, 0, 1, 0.57735026, 0.57735026, 0.57735026,
      1, 1.61803401, 0, 0.57735026, 0.57735026, 0.57735026,
      0, 1, 1.61803401, 0.57735026, 0.57735026, 0.57735026,
      1.61803401, 0, 1, 0.93417233, 0.35682210, 0,
      1.61803401, 0, -1, 0.93417233, 0.35682210, 0,
      1, 1.61803401, 0, 0.93417233, 0.35682210, 0,
      0, 1, 1.61803401, 0, 0.93417233, 0.35682210,
      1, 1.61803401, 0, 0, 0.93417233, 0.35682210,
      -1, 1.61803401, 0, 0, 0.93417233, 0.35682210,
      1, 1.61803401, 0, 0, 0.93417233, -0.35682210,
      0, 1, -1.61803401, 0, 0.93417233, -0.35682210,
      -1, 1.61803401, 0, 0, 0.93417233, -0.35682210,
      1.61803401, 0, -1, 0.57735026, 0.57735026, -0.57735026,
      0, 1, -1.61803401, 0.57735026, 0.57735026, -0.57735026,
      1, 1.61803401, 0, 0.57735026, 0.57735026, -0.57735026,
      0, 1, 1.61803401, -0.57735026, 0.57735026, 0.57735026,
      -1, 1.61803401, 0, -0.57735026, 0.57735026, 0.57735026,
      -1.61803401, 0, 1, -0.57735026, 0.57735026, 0.57735026,
      -1, 1.61803401, 0, -0.93417233, 0.35682210, 0,
      -1.61803401, 0, -1, -0.93417233, 0.35682210, 0,
      -1.61803401, 0, 1, -0.93417233, 0.35682210, 0,
      -1.61803401, 0, 1, -0.93417233, -0.35682210, 0,
      -1.61803401, 0, -1, -0.93417233, -0.35682210, 0,
      -1, -1.61803401, 0, -0.93417233, -0.35682210, 0,
      -1.61803401, 0, 1, -0.57735026, -0.57735026, 0.57735026,
      -1, -1.61803401, 0, -0.57735026, -0.57735026, 0.57735026,
      0, -1, 1.61803401, -0.57735026, -0.57735026, 0.57735026,
      -1, -1.61803401, 0, 0, -0.93417233, 0.35682210,
      1, -1.61803401, 0, 0, -0.93417233, 0.35682210,
      0, -1, 1.61803401, 0, -0.93417233, 0.35682210,
      -1, -1.61803401, 0, 0, -0.93417233, -0.35682210,
      0, -1, -1.61803401, 0, -0.93417233, -0.35682210,
      1, -1.61803401, 0, 0, -0.93417233, -0.35682210,
      1, -1.61803401, 0, 0.57735026, -0.57735026, -0.57735026,
      0, -1, -1.61803401, 0.57735026, -0.57735026, -0.57735026,
      1.61803401, 0, -1, 0.57735026, -0.57735026, -0.57735026,
      -1.61803401, 0, -1, -0.35682210, 0, -0.93417233,
      0, 1, -1.61803401, -0.35682210, 0, -0.93417233,
      0, -1, -1.61803401, -0.35682210, 0, -0.93417233,
      0, -1, -1.61803401, 0.35682210, 0, -0.93417233,
      0, 1, -1.61803401, 0.35682210, 0, -0.93417233,
      1.61803401, 0, -1, 0.35682210, 0, -0.93417233,
      -1, 1.61803401, 0, -0.57735026, 0.57735026, -0.57735026,
      0, 1, -1.61803401, -0.57735026, 0.57735026, -0.57735026,
      -1.61803401, 0, -1, -0.57735026, 0.57735026, -0.57735026,
      0, 1, 1.61803401, -0.35682210, 0, 0.93417233,
      -1.61803401, 0, 1, -0.35682210, 0, 0.93417233,
      0, -1, 1.61803401, -0.35682210, 0, 0.93417233,
      0, 1, 1.61803401, 0.35682210, 0, 0.93417233,
      0, -1, 1.61803401, 0.35682210, 0, 0.93417233,
      1.61803401, 0, 1, 0.35682210, 0, 0.93417233,
      1, -1.61803401, 0, 0.93417233, -0.35682210, 0,
      1.61803401, 0, -1, 0.93417233, -0.35682210, 0,
      1.61803401, 0, 1, 0.93417233, -0.35682210, 0,
      0, -1, 1.61803401, 0.57735026, -0.57735026, 0.57735026,
      1, -1.61803401, 0, 0.57735026, -0.57735026, 0.57735026,
      1.61803401, 0, 1, 0.57735026, -0.57735026, 0.57735026,
      -1.61803401, 0, -1, -0.57735026, -0.57735026, -0.57735026,
      0, -1, -1.61803401, -0.57735026, -0.57735026, -0.57735026,
      -1, -1.61803401, 0, -0.57735026, -0.57735026, -0.57735026
    );
begin
  SetLength(Result, Length(Data) div 6);
  CopyMemory(Pointer(Result), @Data, SizeOf(Data));
end;

{ TSolidPyramid }

constructor TSolidPyramid.Create(ACtl: TVisCtl3D);
begin
  inherited;
  Stored := True;
  Name := 'Solid pyramid';
end;

function TSolidPyramid.GetRawData: TArray<GLfloat6>;
const
  Data: array[0..107] of GLfloat =
    (
      -0.5, -0.5, -0.5, 0, 0, -1,
      -0.5, 0.5, -0.5, 0, 0, -1,
      0.5, 0.5, -0.5, 0, 0, -1,
      -0.5, -0.5, -0.5, 0, 0, -1,
      0.5, 0.5, -0.5, 0, 0, -1,
      0.5, -0.5, -0.5, 0, 0, -1,
      0, 0, 0.5, 0.89442718, 0, 0.44721359,
      0.5, -0.5, -0.5, 0.89442718, 0, 0.44721359,
      0.5, 0.5, -0.5, 0.89442718, 0, 0.44721359,
      0, 0, 0.5, 0, -0.89442718, 0.44721359,
      -0.5, -0.5, -0.5, 0, -0.89442718, 0.44721359,
      0.5, -0.5, -0.5, 0, -0.89442718, 0.44721359,
      0, 0, 0.5, -0.89442718, 0, 0.44721359,
      -0.5, 0.5, -0.5, -0.89442718, 0, 0.44721359,
      -0.5, -0.5, -0.5, -0.89442718, 0, 0.44721359,
      0, 0, 0.5, 0, 0.89442718, 0.44721359,
      0.5, 0.5, -0.5, 0, 0.89442718, 0.44721359,
      -0.5, 0.5, -0.5, 0, 0.89442718, 0.44721359
    );
begin
  SetLength(Result, Length(Data) div 6);
  CopyMemory(Pointer(Result), @Data, SizeOf(Data));
end;

{ TView3D }

procedure TView3D.AnimateTo(const ATarget: rglv);
const
  Gamma = 4.0;
var
  i: Integer;
  F, t: Double;
begin

  var LTarget := rθφ(ATarget);
  var LCurrent := CameraPositionSp;

  if Abs(LTarget.φ - LCurrent.φ) > Pi then
    if LTarget.φ > LCurrent.φ then
      LTarget.φ := LTarget.φ - 2*Pi
    else
      LCurrent.φ := LCurrent.φ - 2*Pi;

  F := 1 / ArcTan(Gamma);
  for i := 0 to High(FAnimation) do
  begin
    t := i / High(FAnimation);                                                   // [0, 1]
    t := 2 * t - 1;                                                              // [-1, 1]
    t := F * ArcTan(Gamma * t);                                                  // Sigmoid transformation
    t := (t + 1) / 2;                                                            // [0, 1]
    FAnimation[i] := (1 - t) * LCurrent + t * LTarget;
  end;

  FAnimationBegin := Now;
  FAnimationEnd := IncMilliSecond(FAnimationBegin,
    Round(1000 * AnimationDurationSec));
  FAnimationTimer.Enabled := True;

end;

procedure TView3D.AnimationTimerTimer(Sender: TObject);
begin
  if CompareTime(Now, FAnimationEnd) = GreaterThanValue then
  begin
    FAnimationTimer.Enabled := False;
  end;
  var f: Double :=
    EnsureRange(
      MilliSecondsBetween(FAnimationBegin, Now) /
        MilliSecondsBetween(FAnimationBegin, FAnimationEnd),
      0,
      1
    );
  var i: Integer := EnsureRange(
    Round(f * High(FAnimation)),
    Low(FAnimation),
    High(FAnimation)
  );
  CameraPositionSp := FAnimation[i];
end;

procedure TView3D.Configure(ASettings: TAlgosimStructure);
begin
  inherited;
  for var i := 1 to ASettings.MemberCount do
  begin
    var S := ASettings.Members[i].Name;
    var V := ASettings.Members[i].Value;
    if S = 'r' then
      r := V.ToASR
    else if S = 'θ' then
      Theta := 180 * V.ToASR / Pi
    else if S = 'φ' then
      Phi := 180 * V.ToASR / Pi
    else if S = 'xyz' then
      CameraPosition := V.ToRealVector
    else if S = 'rθφ' then
      CameraPositionSp := TSphericalCoordinates.RealVectorAsSphericalCoordinates(V.ToRealVector)
    else if S = 'xyzt' then
      AnimateTo(V.ToRealVector)
    else if S = 'rθφt' then
      AnimateTo(TSphericalCoordinates.RealVectorAsSphericalCoordinates(V.ToRealVector))
    else if S = 'projection' then
      Control.Projection := TProjection.FromString(V.ToString)
    else if S = 'fov' then
      Control.FOV := 180 * V.ToASR / Pi;
  end;
end;

constructor TView3D.Create(ACtl: TVisCtl3D);
begin
  inherited;
  FAnimationTimer := TAnimationTimer.Create(nil);
  FAnimationTimer.Control := Control;
  FAnimationTimer.Enabled := False;
  FAnimationTimer.OnTimer := AnimationTimerTimer;
  Name := 'View';
  OptionsFormClass := TVis3D_ViewSettingsFrm;
end;

destructor TView3D.Destroy;
begin
  FreeAndNil(FAnimationTimer);
  inherited;
end;

function TView3D.GetCameraPosition: rglv;
begin
  Result := Control.CameraPos;
end;

function TView3D.GetCameraPositionSp: TSphericalCoordinates;
begin
  Result.r := Control.r;
  Result.θ := Control.θ;
  Result.φ := Control.φ;
end;

function TView3D.GetPhi: Double;
begin
  Result := Control.φ;
end;

function TView3D.GetR: Double;
begin
  Result := Control.r;
end;

function TView3D.GetTheta: Double;
begin
  Result := Control.θ;
end;

procedure TView3D.SetCameraPosition(const Value: rglv);
begin
  if Control.CameraPos <> Value then
  begin
    with TSphericalCoordinates(Value) do
    begin
      Control.r := r;
      Control.θ := θ;
      Control.φ := φ;
    end;
    Changed;
  end;
end;

procedure TView3D.SetCameraPositionSp(const Value: TSphericalCoordinates);
begin
  if (Value.r <> Control.r) or (Value.θ <> Control.θ) or (Value.φ <> Control.φ) then
  begin
    Control.r := EnsureRange(Value.r, 0.01, 900);
    Control.θ := EnsureRange(Value.θ, 0, Pi);
    Control.φ := rmod(Value.φ, 2*Pi);
    Changed;
  end;
end;

procedure TView3D.SetPhi(const Value: Double);
begin
  var LValue := Pi * Value / 180;
  if not SameValue(Control.φ, LValue) then
  begin
    Control.φ := rmod(LValue, 2*Pi);
    Changed;
  end;
end;

procedure TView3D.SetR(const Value: Double);
begin
  if not SameValue(Control.r, Value) then
  begin
    Control.r := EnsureRange(Value, 0.01, 900);
    Changed;
  end;
end;

procedure TView3D.SetTheta(const Value: Double);
begin
  var LValue := Pi * Value / 180;
  if not SameValue(Control.θ, LValue) then
  begin
    Control.θ := EnsureRange(LValue, 0, Pi);
    Changed;
  end;
end;

{ TSphericalCoordinates }

class operator TSphericalCoordinates.Add(const Left,
  Right: TSphericalCoordinates): TSphericalCoordinates;
begin
  Result.r := Left.r + Right.r;
  Result.θ := Left.θ + Right.θ;
  Result.φ := Left.φ + Right.φ;
end;

class operator TSphericalCoordinates.Equal(const Left,
  Right: TSphericalCoordinates): Boolean;
begin
  Result := (Left.r = Right.r) and (Left.θ = Right.θ) and (Left.φ = Right.φ);
end;

class operator TSphericalCoordinates.Implicit(
  const ACoords: TCartesianCoordinates): TSphericalCoordinates;
begin
  Result.r := EnsureRange(ACoords.Norm, 0.01, 900);
  if IsZero(ACoords.xy.Norm) then
    Result.θ := Pi * Ord(ACoords.z < 0)
  else
    Result.θ := EnsureRange(Pi/2 - ArcTan(ACoords.z / ACoords.xy.Norm), 0, Pi);
  Result.φ := rmod(ArcTan2(ACoords.y, ACoords.x), 2*Pi);
end;

class operator TSphericalCoordinates.Multiply(const Left: Single;
  Right: TSphericalCoordinates): TSphericalCoordinates;
begin
  Result.r := Left * Right.r;
  Result.θ := Left * Right.θ;
  Result.φ := Left * Right.φ;
end;

class operator TSphericalCoordinates.NotEqual(const Left,
  Right: TSphericalCoordinates): Boolean;
begin
  Result := not (Left = Right);
end;

class function TSphericalCoordinates.RealVectorAsSphericalCoordinates(
  const ARealVector: TRealVector): TSphericalCoordinates;
begin
  if ARealVector.Dimension <> 3 then
    raise Exception.Create('Vector must be three-dimensional.');
  Result.r := ARealVector[0];
  Result.θ := ARealVector[1];
  Result.φ := ARealVector[2];
end;

class operator TSphericalCoordinates.Implicit(
  const ACoords: TSphericalCoordinates): TCartesianCoordinates;
begin
  with ACoords do
  begin
    var Sinθ, Cosθ, Sinφ, Cosφ: Single;
    SinCos(θ, Sinθ, Cosθ);
    SinCos(φ, Sinφ, Cosφ);
    Result.x := r * Sinθ * Cosφ;
    Result.y := r * Sinθ * Sinφ;
    Result.z := r * Cosθ;
  end;
end;

{ TAnimationTimer }

class procedure TAnimationTimer.AppIdle(Sender: TObject; var Done: Boolean);
begin
  Done := True;
  if Assigned(FInstances) then
    for var Timer in FInstances do
    begin
      if not Timer.Enabled or (Timer.Control = nil) or not Assigned(TImer.OnTimer) then
        Continue;
      Timer.OnTimer(Sender);
      Timer.Control.Update;
      Timer.Interval := 1000;
      Done := False;
    end;
end;

class constructor TAnimationTimer.ClassCreate;
begin
  FInstances := TList<TAnimationTimer>.Create;
  FAppEvents := TApplicationEvents.Create(nil);
end;

class destructor TAnimationTimer.ClassDestroy;
begin
  FreeAndNil(FAppEvents);
  FreeAndNil(FInstances);
end;

constructor TAnimationTimer.Create(AOwner: TComponent);
begin
  inherited;
  if FPrioritize then
    Interval := 1000
  else
    Interval := 30;
  if Assigned(FInstances) then
    FInstances.Add(Self);
end;

destructor TAnimationTimer.Destroy;
begin
  if Assigned(FInstances) then
    FInstances.Remove(Self);
  inherited;
end;

class procedure TAnimationTimer.SetPrioritize(const Value: Boolean);
begin
  if FPrioritize <> Value then
  begin
    FPrioritize := Value;
    if Value then
    begin
      FAppEvents.OnIdle := AppIdle;
      if Assigned(FInstances) then
        for var Timer in FInstances do
          Timer.Interval := 1000;
    end
    else
    begin
      FAppEvents.OnIdle := nil;
      if Assigned(FInstances) then
        for var Timer in FInstances do
          Timer.Interval := 30;
    end;
  end;
end;

{ TTransparentColorModeHelper }

class function TTransparentColorModeHelper.FromString(
  const S: string): TTransparentColorMode;
begin
  if S = 'opaque' then
    Result := tcmOff
  else if S = 'equal' then
    Result := tcmEqual
  else if S = 'distance' then
    Result := tcmDistance
  else if S = 'bipolar' then
    Result := tcmBipolar
  else
    raise ERglError.CreateFmt('Unknown transparency mode: "%".', [S]);
end;

function TTransparentColorModeHelper.ToString: string;
begin
  case Self of
    tcmOff:
      Result := 'Opaque';
    tcmEqual:
      Result := 'Single-colour transparency';
    tcmDistance:
      Result := 'Unipolar interpolation';
    tcmBipolar:
      Result := 'Bipolar interpolation';
  else
    Result := '';
  end;
end;

{ TProjectionHelper }

class function TProjectionHelper.FromString(const S: string): TProjection;
begin
  for var p := Low(TProjection) to High(TProjection) do
    if SameText(p.ToString, S) then
      Exit(p);
  raise ERglError.CreateFmt('Unknown projection: "%s".', [S]);
end;

function TProjectionHelper.ToString: string;
begin
  case Self of
    Orthographic:
      Result := 'orthographic';
    Perspective:
      Result := 'perspective';
  else
    Result := 'unknown projection';
  end;
end;

{ TArrow }

procedure TArrow.Configure(ASettings: TAlgosimStructure);
begin
  inherited;
  for var i := 1 to ASettings.MemberCount do
  begin
    var S := ASettings.Members[i].Name;
    var V := ASettings.Members[i].Value;
    if S = 'vector' then
      Vector := V.AsRealVector
    else if S = 'headsize' then
      HeadSize := V.ToASR
    else if S = 'headaspect' then
      Aspect := V.ToASR;
  end;
end;

constructor TArrow.Create(ACtl: TVisCtl3D);
begin

  inherited;

  Name := 'Arrow';

  FLineWidth := 0.02;
  FHeadSize := 0.2;
  Q := 0.5;

  FHead := CreateChild<TSolidCone>;
  FHead.Name := 'Head';
  FLine := CreateChild<TSolidCylinder>;
  FLine.Name := 'Line';

  FOptionsFrmClass := TVis3D_ArrowSettingsFrm;

end;

function TArrow.CreateReference: TAlgosimReference;
begin
  Result := inherited;
  Result.AddSubref('head', FHead.CreateReference);
  Result.AddSubref('line', FLine.CreateReference);
end;

function TArrow.GetColor: TColor;
begin
  if Assigned(FLine) then
    Result := FLine.Color
  else
    Result := inherited;
end;

function TArrow.GetLineWidth: Single;
begin
  if Assigned(FLine) then
    Result := FLine.Radius
  else
    Result := inherited;
end;

procedure TArrow.Recreate;
begin
  if FSetup then
    Setup;
end;

procedure TArrow.SetAspect(const Value: Single);
begin
  if Q <> Value then
  begin
    Q := Value;
    Recreate;
    Changed;
  end;
end;

procedure TArrow.SetColor(const Value: TColor);
begin
  inherited;
  if Assigned(FLine) then
    FLine.Color := Value;
  if Assigned(FHead) then
    FHead.Color := Value;
end;

procedure TArrow.SetHeadSize(const Value: Single);
begin
  if FHeadSize <> Value then
  begin
    FHeadSize := Value;
    Recreate;
    Changed;
  end;
end;

procedure TArrow.SetLineWidth(const Value: Single);
begin
  inherited;
  if Assigned(FLine) then
    FLine.Radius := Value;
end;

procedure TArrow.Setup;
begin

  if (Control = nil) or (Control.Context = nil) then
    Exit;
  Control.Context.MakeCurrent('TArrow.Setup');

  var LVectorNorm := v.Norm;
  var LIsZeroVector := LVectorNorm < FHeadSize / 10;

  FHead.Height := FHeadSize;
  FHead.Radius := Q*FHeadSize;
  FHead.Position := vec(0, 0, LVectorNorm - FHead.Height);
  FHead.Visible := not LIsZeroVector;

  FLine.Height := LVectorNorm - FHead.Height;
  FLine.Radius := FLineWidth;
  FLine.Visible := not LIsZeroVector;

  FSetup := True;

end;

procedure TArrow.SetVector(const Value: rglv);
begin
  if v <> Value then
  begin
    v := Value;
    Direction := v;
    Recreate;
    Changed;
  end;
end;

initialization
  InvFS := TFormatSettings.Invariant;

end.
