Rejbrand Algosim 3D Visualisation Control

Documentation

Surfaces

Graphs

const f = function(const u, v: Double): Double
  begin
    const r = Sqrt(u*u + v*v);
    Result := 10 * if IsZero(r) then 1.0 else Sin(r) / r;
  end;

var LSurf := FVisCtl3D.NewObject<TCustomSurface>;

LSurf.SurfaceFunction := function(const u, v: Double): rglv
  begin
    Result.x := u;
    Result.y := v;
    Result.z := f(u, v);
  end;

LSurf.Domain := TRectDom.Create(-10, 10, -10, 10);
LSurf.Color := clRed;

Or, with parameter curves:

The graph z = sinc(x, y) with (x, y) parameter curves.

LSurf.ShowParameterCurves := True;

You can customise the number of parameter curves and their visual attributes, such as their colour:

The graph z = sinc(x, y) with 128 + 128 golden (x, y) parameter curves.

LSurf.ShowParameterCurves := True;
LSurf.ParamCurveCounts := TParamCurveFamilySize.Create(128, 128);
LSurf.LineColor := clWebGold;

You can choose to display the parameter curves alone:

Two families of 128 + 128 navy (x, y) parameter curves for the graph z = sinc(x, y).

LSurf.ShowParameterCurves := True;
LSurf.ParamCurveCounts := TParamCurveFamilySize.Create(128, 128);
LSurf.LineColor := clNavy;
LSurf.ShowSurface := False;

Coloured graphs

The graph z = sinc(x, y) with (x, y) parameter curves and a custom colour function.

const f = function(const u, v: Double): Double
  begin
    const r = Sqrt(u*u + v*v);
    Result := 10 * if IsZero(r) then 1.0 else Sin(r) / r;
  end;

var LSurf := FVisCtl3D.NewObject<TCustomColoredSurface>;

LSurf.SurfaceFunction := function(const u, v: Double): rglv
  begin
    Result.x := u;
    Result.y := v;
    Result.z := f(u, v);
  end;

LSurf.SurfaceColorFunction := function(const u, v: Double): rglv
  begin
    const z = f(u, v);
    Result.r := EnsureRange(Abs(z) / 5, 0.0, 1.0);
    Result.g := 1.0;
    Result.b := 0.0;
  end;

LSurf.Domain := TRectDom.Create(-10, 10, -10, 10);
LSurf.ShowParameterCurves := True;

Parameterised surfaces

A golden rendition of the Klein bottle in its ℝ³ bottle shape.

const F = function(const u, v: Double): rglv
  begin
    var cu, su, cv, sv: Double;
    SinCos(u, su, cu);
    SinCos(v, sv, cv);
    const cu2 = cu * cu;
    const cu3 = cu2 * cu;
    const cu4 = cu2 * cu2;
    const cu5 = cu4 * cu;
    const cu6 = cu3 * cu3;
    const cu7 = cu6 * cu;
    Result := vec(
      -2/15 * cu * (3*cv - 30*su + 90*cu4*su - 60*cu6*su + 5*cu*cv*su),
      -1/15 * su * (3*cv - 3*cu2*cv - 48*cu4*cv + 48*cu6*cv - 60*su
                      + 5*cu*cv*su - 5*cu3*cv*su - 80*cu5*cv*su + 80*cu7*cv*su),
       2/15 * (3 + 5*cu*su)*sv
    );
  end;

var LSurf := FVisCtl3D.NewObject<TCustomSurface>;

LSurf.SurfaceFunction := F;
LSurf.Domain := TRectDom.Create(0, Pi, 0, 2*Pi);
LSurf.Color := clWebGoldenRod;
LSurf.Direction := vec(0, 1, 0);
LSurf.Unisided := True;

The Direction property is set to align the bottle with the z axis (which it would not do by default with the given parameterisation). Unisided := True makes the lighting the same on both sides of the surface (otherwise the back side will be much darker). In this case, we don’t really care about the orientation (surface normal direction).

Curves

const F = function(const t: Double): rglv
  begin
    Result := vec(
      Sin(t),
      Sin(t) * (Exp(Cos(t)) - 2*Cos(4*t) - Power(Sin(t/12), 5)),
      Cos(t) * (Exp(Cos(t)) - 2*Cos(4*t) - Power(Sin(t/12), 5))
    );
  end;

var LCurve := FVisCtl3D.NewObject<TCurve3D>;

LCurve.CurveFunction := F;
LCurve.Domain := TInterval.Create(-20, 20);
LCurve.Color := clRed;

Coloured curves

A coloured butterfly curve embedded in ℝ³.

const F = function(const t: Double): rglv
  begin
    Result := vec(
      Sin(t),
      Sin(t) * (Exp(Cos(t)) - 2*Cos(4*t) - Power(Sin(t/12), 5)),
      Cos(t) * (Exp(Cos(t)) - 2*Cos(4*t) - Power(Sin(t/12), 5))
    );
  end;

const G = function(const t: Double): rglv
  begin
    Result := vec(
      Sin(t),
      Cos(t),
      1
    );
  end;

var LCurve := FVisCtl3D.NewObject<TColoredCurve3D>;

LCurve.CurveFunction := F;
LCurve.CurveColorFunction := G;
LCurve.Domain := TInterval.Create(-20, 20);

Scatter plots

A scatter plot in ℝ³ depicting randomly generated data.

const R = function: Double
  begin
    Result := (Random() + Random() + Random() + Random() + Random()) / 5
  end;

const F = function: rglv
  begin
    Result := vec(
      20*(R() - 0.5),
      20*(R() - 0.5),
      5*Random()
    );
  end;

const N = 10_000;
var LData := TArray<GLfloat3>(nil);
SetLength(LData, N);
for var i := 0 to N - 1 do
  LData[i] := F();

var LPlot := FVisCtl3D.NewObject<TSimpleScatterPlot>;
LPlot.Data := LData;

A scatter plot in ℝ³ depicting the butterfly curve.

const F = function(const t: Double): rglv
  begin
    Result := vec(
      Sin(t),
      Sin(t) * (Exp(Cos(t)) - 2*Cos(4*t) - Power(Sin(t/12), 5)),
      Cos(t) * (Exp(Cos(t)) - 2*Cos(4*t) - Power(Sin(t/12), 5))
    );
  end;

const N = 10_000;
var LData := TArray<GLfloat3>(nil);
SetLength(LData, N);
for var i := 0 to N - 1 do
  LData[i] := F(-5 + 10*Random);

var LPlot := FVisCtl3D.NewObject<TSimpleScatterPlot>;
LPlot.Data := LData;

A scatter plot in ℝ³ depicting the butterfly curve with random noise applied to its points.

const F = function(const t: Double): rglv
  begin
    Result := vec(
      Sin(t) + 0.5*Random,
      Sin(t) * (Exp(Cos(t)) - 2*Cos(4*t) - Power(Sin(t/12), 5)) + 0.5*Random,
      Cos(t) * (Exp(Cos(t)) - 2*Cos(4*t) - Power(Sin(t/12), 5)) + 0.5*Random
    );
  end;

const N = 10_000;
var LData := TArray<GLfloat3>(nil);
SetLength(LData, N);
for var i := 0 to N - 1 do
  LData[i] := F(-5 + 10*Random);

var LPlot := FVisCtl3D.NewObject<TSimpleScatterPlot>;
LPlot.Data := LData;

A scatter plot in ℝ³ depicting randomly generated data, with a colour and size associated with each data point.

const F = function: GLr3c3f1v
  begin
    Result.r := vec(10*Random, 10*Random, 10*Random); // position
    Result.c := vec(Result.r.x / 10, Result.r.y / 10, Result.r.z / 10); // RGB colour
    Result.q := Random(); // size factor
  end;

const N = 10_000;
var LData := TArray<GLfloat7>(nil);
SetLength(LData, N);
for var i := 0 to N - 1 do
  LData[i] := GLfloat7(F());

var LPlot := FVisCtl3D.NewObject<TAdvScatterPlot>;
LPlot.Data := LData;

The data is given to the TAdvScatterPlot object via the Data property, which is an array of GLfloat7 records, each describing a point in the scatter plot. Each such record consists of seven Single members. To make it easy to use, you can overlay the GLr3c3f1v record, giving names to the individual floats. The GLr3c3f1v record consists of three floats describing the position (r) of the point, three floats describing the RGB colour of this point (c), and one describing the size factor of the individual point (a single float parameter). Hence the “r3c3f1” part of the name GLr3c3f1v; the final “v” indicates that the record groups its fields in three separate nested records (position, colour, and size) instead of just being a flat array of seven floats. In code,

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;

This naming convention is used consistently in this control.

Vector fields

A Möbius strip with its normal vector field.

const F = function(const u, v: Double): rglv
  begin
    Result :=
      vec(
        (1 + 0.5*v*Cos(u/2)) * Cos(u),
        (1 + 0.5*v*Cos(u/2)) * Sin(u),
        0.5*v*Sin(u/2)
      );
  end;

const N = function(u, v: Double): rglv
  begin
    const δ = 0.001;
    const dFdu = (F(u + δ, v) - F(u - δ, v)) / (2*δ);
    const dFdv = (F(u, v + δ) - F(u, v - δ)) / (2*δ);
    Result := (dFdu xor dFdv).Normalized;
  end;

var LSurf := FVisCtl3D.NewObject<TCustomSurface>;
LSurf.SurfaceFunction := F;
LSurf.Domain := TRectDom.Create(0, 2*Pi, -1, 1);
LSurf.Color := clRed;
LSurf.Unisided := True;
LSurf.ShowParameterCurves := True;
LSurf.ParamCurveCounts := TParamCurveFamilySize.Create(64, 8);
LSurf.LineColor := clMaroon;

var LVectorField := FVisCtl3D.NewObject<TVectorField>;
LVectorField.Size := 0.1;
LVectorField.AnchorPoint := 1.03;
LVectorField.Color := clWebGold;

var LVectors := TList<GLr3v3c3v>.Create;
try
  var q := Default(GLr3v3c3v);
  const A = 64;
  const B = 8;
  for var i := 0 to A - 1 do
    for var j := 0 to B - 1 do
    begin
      const u = 2*Pi/A * i;
      const v = -1 + 2/(B - 1) * j;
      q.r := F(u, v);
      q.v := N(u, v);
      LVectors.Add(q);
    end;
  LVectorField.Data := LVectors.ToArray;
finally
  LVectors.Free;
end;

This example draws a normal vector field on a Möbius strip.

The data is given to the TVectorField object via the Data property, which is an array of GLr3v3c3v records, each describing a visual vector. Each such record consists of nine Single members: three describing the position (r) in the field, three describing the vector at that point (v), and three describing the colour (c) of the arrow at that point. Hence the “r3v3c3” part of the name GLr3v3c3v; the final “v” indicates that the record groups its fields in three separate nested records (each containing three floats) instead of just being a flat array of nine floats. In code,

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;

This naming convention is used consistently in this control.

By default, a visual vector will be drawn with the midpoint of its cylindrical core at the field point having the vector as its value. This doesn’t look good when the field is a normal vector field on a surface.

In this case, we’d prefer to have the end of the arrow at the field point. To achieve this, we set AnchorPoint := 1.03. A value of 1.0 would put the end of the arrow precisely at the field point; by offsetting it slightly from the surface, we reduce the risk of z fighting.

Similarly, a value of 0.0 would put the tip of the arrow precisely at the field point. The default value of AnchorPoint is 0.5, which puts the middle of the arrow’s core cylinder at the field point.

To make each arrow have its own colour (its GLr3v3c3v.c member), set PerVertexColors := True.

Geometric primitives

The control recognises a number of geometric primitives, such as cubes, spheres, and cylinders:

var LIco := FVisCtl3D.NewObject<TSolidIcosahedron>;
LIco.Color := clSilver;

The following classes are available:

Class	Description	Key properties
`TEllipsoid`	An ellipsoid.	`AxisLengths` (rglv)
`TSphere`	A sphere, an ellipsoid with all three axis lengths equal.	`Radius`
`TCylinder`	A right elliptic cylinder.	`AxisLengths` (rglv2), `Radius` (in case of circular cylinder: sets both axis lengths to the same number), `Height`
`TCone`	A right elliptic cone.	`AxisLengths` (rglv2), `Height`
`TPlane`	A rectangular part of a plane.
`TDisk`	A circular part of a plane.
`TArrow`	A 3D vector arrow.	`Vector` (rglv), `Aspect` (ratio radius ∶ height of top cone), `HeadSize` (ratio top cone height ∶ core cylinder height)
`TSolidCylinder`	A customisable right solid elliptic cylinder (or cylindrical sector or cylindrical annulus or both).	`AxisLengths` (rglv2), `Radius` (in case of circular cylinder) `Height`, `Angle` (for sector: default 2π), `InnerRadiusFraction` (for annulus: default 0.0)
`TSolidCone`	A customisable right solid elliptic cone.	`AxisLengths` (rglv2), `Radius` (in case of circular cone) `Height`
`TSolidCube`	A solid cube.
`TSolidDodecahedron`	A solid dodecahedron.
`TSolidIcosahedron`	A solid icosahedron.
`TSolidOctahedron`	A solid octahedron.
`TSolidPyramid`	A solid pyramid.
`TSolidTetrahedron`	A solid tetrahedron.

In addition to the “key properties”, which are unique to the class, all of the classes also support the Position, Scale, Direction, and Rotation properties that are common to all geometric objects. Furthermore, the first six classes in the list are subclasses of the base surface class, which means that they inherit the ShowSurface, ShowParameterCurves, ParamCurveCounts, Color, and LineColor properties from this base class.

Please note that in the case of TEllipsoid, TCylinder, TCone, TSolidCylinder, and TSolidCone, the AxisLengths and Height (when applicable) properties are implemented by means of the common Scale property. This means that for a LCyl: TCylinder, for example, LCyl.AxisLengths reads and writes the two first elements of LCyl.Scale, while LCyl.Height reads and write the third element of LCyl.Scale. Hence, LCyl.Height := 5; LCyl.Scale := vec(1, 1, 3) will make LCyl have height 3, and not 15.

OBJ models

You can load any *.obj model:

var LSource := '';

var LDlg := TFileOpenDialog.Create(Self);
try
  var LItem := LDlg.FileTypes.Add;
  LItem.DisplayName := 'OBJ models';
  LItem.FileMask := '*.obj';
  if LDlg.Execute then
    LSource := TFile.ReadAllText(LDlg.FileName)
  else
    Abort;
finally
  LDlg.Free;
end;

var LModel := FVisCtl3D.NewObject<TObjModel>;
LModel.Source := LSource;
LModel.Color := clWebGoldenRod;

Text and image planes

TTextRect and TImageRect are used to display text and bitmap images, respectively:

A scene with a dodecahedron, the text “Algosim” and a semi-transparent bitmap of a butterfly.

var LText := FVisCtl3D.NewObject<TTextRect>;
LText.Direction := vec(1, 0, 0);
LText.Text := 'Algosim';
LText.Font.Name := 'Palatino Linotype';

var LImage := FVisCtl3D.NewObject<TImageRect>;
LImage.Bitmap.LoadFromFile('C:\Users\kvadr\Pictures\sample.bmp');
LImage.TransparentColorMode := tcmDistance;
LImage.TransparentColor := clWhite;

var LDodeca := FVisCtl3D.NewObject<TSolidDodecahedron>;
LDodeca.Color := clRed;
LDodeca.Position := vec(-3, -2, 0);

TTextRect.FaceScreen is a boolean property that, when set to True, makes the text plane always face the camera.

TImageRect.TransparentColorMode is one of tcmOff, tcmEqual, tcmDistance, and tcmBipolar. tcmOff makes the image plane opaque. tcmEqual makes the image plane fully transparent at pixels with the precise colour TImageRect.TransparentColor; at all other positions in the image plane, it is fully opaque. tcmDistance makes the opacity of an image plane pixel a linear function of the distance from the pixel’s colour value to the TransparentColor colour. Finally, tcmBipolar makes pixels with the TransparentColor fully transparent, pixels with the OpaqueColor fully opaque, and interpolates the transparency linearly between these two colours in RGB space.

Coordinate axes

The default coordinate axes and grids can be turned on and off both programmatically and using the control’s context menu (right-click menu).

Programmatically, the control’s ShowAxes property is used to toggle the visibility of the default coordinate axes and their associated grids.

This coordinate system (axes + grids) is represented by the Axes: TAxes property, and Axes.Visible is functionally equivalent to ShowAxes; the control’s ShowAxes property simply reads and sets the Axes.Visible property.

Axes.X, Axes.Y, and Axes.Z represent each individual coordinate axis (TAxis). Each axis contains a cylinder with optional labels. The cylinder extends from −NegativeLength via the origin to +Length in its direction.

The following properties of an axis are used to customise its appearance:

Labels (Boolean): Show or hide labels on the axis.
LabelFont (TFont): The font used for the labels on the axis.
LabelFormat (string): The format string used to format the numeric axis labels as strings.
LabelDelta (Double): The distance between consecutive labels on the axis.
Length (Double): The extent in the axis’ positive direction of the axis cylinder
NegativeLength (Double): The extent in the axis’ negative direction of the axis cylinder.
Radius (Double): The radius of the axis cylinder.
Color (TColor): The colour of the axis cylinder. By default, the X, Y, and Z axis cylinders are red, green, and blue, respectively.

By default, each axis has Length = 10 and NegativeLength = 0, meaning that it extends from the origin to 10.0 in its direction. In this example, we change the axes so that the X and Y axes both extend from −10 to +10 while the Z axis only extends from the origin to +5:

A coordinate system with three axes: The x axis extends from −10 to +10, as do the y axis. The z axis, however, only extends from 0 to +5. The axes are orthogonal. The x, y, and z axis are red, green, and blue, respectively. Each axis has axis labels at the integer intervals.

FVisCtl3D.Axes.X.NegativeLength := 10;
FVisCtl3D.Axes.X.Length := 10;

FVisCtl3D.Axes.Y.NegativeLength := 10;
FVisCtl3D.Axes.Y.Length := 10;

FVisCtl3D.Axes.Z.NegativeLength := 0;
FVisCtl3D.Axes.Z.Length := 5;

FVisCtl3D.Axes.GridCount := 0;

Notice that we also removed all grids by setting Axes.GridCount := 0. By default, three grids occupy the {0}×[0, 10]×[0, 10], [0, 10]×{0}×[0, 10], and [0, 10]×[0, 10]×{0} regions.

Each grid is a child object of the Axes, so Axes.GridCount simply returns the number of child objects that are of the grid class (TGrid). Setting this property adds or removes grid child objects; you can have any number of grids in a coordinate system (TAxes object). To access the grids of a TAxes object, use the Children and ChildCount properties.

In the following example, we first remove the three default grids and then add a single, large grid in the [−10, +10]²×{0} region:

FVisCtl3D.Axes.X.NegativeLength := 10;
FVisCtl3D.Axes.X.Length := 10;

FVisCtl3D.Axes.Y.NegativeLength := 10;
FVisCtl3D.Axes.Y.Length := 10;

FVisCtl3D.Axes.Z.NegativeLength := 0;
FVisCtl3D.Axes.Z.Length := 5;

FVisCtl3D.Axes.GridCount := 0;
var LGrid := FVisCtl3D.Axes.CreateChild<TGrid>;
LGrid.Direction := vec(0, 0, 1);
LGrid.XMin := -10;
LGrid.XMax := +10;
LGrid.YMin := -10;
LGrid.YMax := +10;

In this final example, we make all axes and grids golden:

FVisCtl3D.Axes.X.NegativeLength := 10;
FVisCtl3D.Axes.X.Length := 10;
FVisCtl3D.Axes.X.Color := clWebGold;

FVisCtl3D.Axes.Y.NegativeLength := 10;
FVisCtl3D.Axes.Y.Length := 10;
FVisCtl3D.Axes.Y.Color := clWebGold;

FVisCtl3D.Axes.Z.NegativeLength := 0;
FVisCtl3D.Axes.Z.Length := 5;
FVisCtl3D.Axes.Z.Color := clWebGold;

FVisCtl3D.Axes.GridCount := 0;
var LGrid := FVisCtl3D.Axes.CreateChild<TGrid>;
LGrid.Direction := vec(0, 0, 1);
LGrid.XMin := -10;
LGrid.XMax := +10;
LGrid.YMin := -10;
LGrid.YMax := +10;
LGrid.Color := clWebGold;

Additional coordinate systems

You may create any number of coordinate systems:

Three sets of coordinate axes (and grid sets).

var LAxes2 := FVisCtl3D.NewObject<TAxes>;
LAxes2.Position := vec(10, 00, 0);

var LAxes3 := FVisCtl3D.NewObject<TAxes>;
LAxes3.Position := vec(20, 00, 0);

Here we have created two new coordinate systems (axes + grid sets) in addition to the default one (rightmost).

Please note that a “coordinate system” in this sense (a TAxes object) is only a graphical object (like any teapot or graph). The control’s world coordinate system always aligns with the default axes only (and only if you don’t transform that TAxes object).

Common object properties

Almost every object you can display in a scene derives from TGeometricObject3D. This class has four basic properties: Scale (vector), Position (vector), Direction (vector), and Rotation (scalar). These determine the object’s size, position, and orientation in space.

Scale is a three-dimensional vector (an rglv) with scale factors in the three spatial directions. Direction specifies the object’s orientation in space; it directly or indirectly specifies the direction of the object’s vertical axis. Rotation then rotates the object about this axis. Finally, Position translates the object so that its origin is placed at the specified point. While Scale and Position are straightforward, the semantics and behaviour of Direction and Rotation are, unfortunately, somewhat inconsistent between different classes of geometric objects.

You may also bypass these four properties and manually specify the object’s transformation matrix (as a 4×4 matrix, an rglm4) using the ManualMatrix (rglm4) and UseManualMatrix (boolean) properties.

Finally, each geometric object has an AnimationSpeed (double) property, which by default is 0.0. If set to a positive value, the object will be animated and the value is used as the speed of the animation. The type of animation depends on the actual class of geometric object, but typically it involves rotation (spinning) about the object’s vertical axis.

Object groups

A key feature of the control’s scene system is that every object can have child objects, thus making a scene graph. (We have already seen an example of this: The TGrid children of a TAxes object.)

You can create a child node and attach it to any object using the object’s CreateChild<T> function. If you need an object that is only to serve as a parent for child objects, and not have any visual representation itself, you should use TGeometricObject3D.

For example, here’s a water molecule:

A red sphere and two adjacent, marginally smaller, white spheres. The centre points of the three spheres form an isosceles triangle with the red sphere at the top and the corresponding angle is 104.45°.

var LWater := FVisCtl3D.NewObject<TGeometricObject3D>;

var LOxygen := LWater.CreateChild<TSphere>;
LOxygen.Color := clRed;
LOxygen.Radius := 1.52;

const α = DegToRad(104.45) / 2;

var LHydrogen1 := LWater.CreateChild<TSphere>;
LHydrogen1.Position := 0.9584 * vec(Sin(α), 0, -Cos(α));
LHydrogen1.Color := clWhite;
LHydrogen1.Radius := 1.20;

var LHydrogen2 := LWater.CreateChild<TSphere>;
LHydrogen2.Position := 0.9584 * vec(-Sin(α), 0, -Cos(α));
LHydrogen2.Color := clWhite;
LHydrogen2.Radius := 1.20;

In this example, the use of a parent group adds little benefit. However, if we would like to display many water molecules, the benefit of this grouping becomes obvious:

A large number of randomly positioned and oriented water molecules.

const N = 200;

const R = function(): Double begin Result := 30*(Random - 0.5) end;

for var i := 1 to N do
begin

  var LWater := FVisCtl3D.NewObject<TGeometricObject3D>;
  LWater.Position := vec(R(), R(), R());
  LWater.Direction := vec(R(), R(), R()).Normalized;
  LWater.Rotation := 2*Pi*Random;
  LWater.Scale := 0.2 * rglv_ones;

  var LOxygen := LWater.CreateChild<TSphere>;
  LOxygen.Color := clRed;
  LOxygen.Radius := 1.52;

  const α = DegToRad(104.45) / 2;

  var LHydrogen1 := LWater.CreateChild<TSphere>;
  LHydrogen1.Position := 0.9584 * vec(Sin(α), 0, -Cos(α));
  LHydrogen1.Color := clWhite;
  LHydrogen1.Radius := 1.20;

  var LHydrogen2 := LWater.CreateChild<TSphere>;
  LHydrogen2.Position := 0.9584 * vec(-Sin(α), 0, -Cos(α));
  LHydrogen2.Color := clWhite;
  LHydrogen2.Radius := 1.20;

end;

Here we can trivially position each water molecule individually, and its constituent atoms are moved along with it. Had we not used the grouping concept, we had been forced to compute the position of each individual oxygen and hydrogen atom manually.

(If we are very, very, unlucky, the preceding code snippet may fail at runtime. Why is that?)

We can also add all of the molecules to a common group, LOcean, and set this group’s AnimationSpeed := 10 to have the entire “ocean” rotate about its axis. Were it not for this group, this effect had not been possible. An AnimationSpeed := 10 on each molecule would similarly make each molecule rotate (or spin) about its own axis; again, this would not have been possible without the molecule group. So without groups, we could only set AnimationSpeed := 10 on each individual oxygen or hydrogen atom, and this effect would be rather boring (why?).

const N = 200;

const R = function(): Double begin Result := 30*(Random - 0.5) end;

var LOcean := FVisCtl3D.NewObject<TGeometricObject3D>;
LOcean.AnimationSpeed := 10;

for var i := 1 to N do
begin

  var LWater := LOcean.CreateChild<TGeometricObject3D>;
  LWater.Position := vec(R(), R(), R());
  LWater.Direction := vec(R(), R(), R()).Normalized;
  LWater.Rotation := 2*Pi*Random;
  LWater.Scale := 0.2 * rglv_ones;

  var LOxygen := LWater.CreateChild<TSphere>;
  LOxygen.Color := clRed;
  LOxygen.Radius := 1.52;

  const α = DegToRad(104.45) / 2;

  var LHydrogen1 := LWater.CreateChild<TSphere>;
  LHydrogen1.Position := 0.9584 * vec(Sin(α), 0, -Cos(α));
  LHydrogen1.Color := clWhite;
  LHydrogen1.Radius := 1.20;

  var LHydrogen2 := LWater.CreateChild<TSphere>;
  LHydrogen2.Position := 0.9584 * vec(-Sin(α), 0, -Cos(α));
  LHydrogen2.Color := clWhite;
  LHydrogen2.Radius := 1.20;

end;

Please note that the standard TSphere uses a high-resolution triangulation to approximate a sphere. For that reason it is not a good idea to create a huge number of such objects. 200 is OK on modern hardware, but for thousands or tens of thousands of objects, you need to use simpler objects, such as the markers in a single scatter plot. (If you absolutely have to use individual objects, cubes are a decent choice, since each cube consists of only eight vertices.)

The camera

The camera always orbits a specific point (x, y, z), the “look at” or “(orbit) centre” point. By default, this point is the origin, (0, 0, 0). The camera is positioned a distance r > 0 from this point and directed straight towards it. Its position on this sphere is stored as the two spherical coordinates θ and φ. Hence, the pose (position and orientation) of the camera is specified by six parameters: x, y, z, r, θ, and φ.

The position of the camera is

𝐫 = \underset{̲}{𝐞} (\begin{matrix} x + r \sin θ \cos ϕ \\ y + r \sin θ \sin ϕ \\ z + r \cos θ \end{matrix})

and it is looking straight at (x, y, z). It is not possible to rotate the camera about this axis.

Keyboard interface

When the control has keyboard focus, it responds to keyboard commands. The following commands are used to move the camera:

Orbit

The Up and Down arrow keys decrease and increase θ, respectively, which is capped to the interval [0, π].

The Left and Right arrow keys decrease and increase φ, respectively, which is understood to be modulo 2π.

The + and − keys decrease and increase r, respectively, which is capped to the interval [0.01, 900].

In all three cases, the Shift modifier can be used to make finer adjustments (smaller ∆θ, ∆φ, and ∆r steps).

In addition, X (or Y or Z) adjusts θ and φ so that the camera is looking in the positive x (or y or z) direction. Shift+X (or Shift+Y or Shift+Z) adjusts θ and φ so that the camera is looking in the negative x (or y or z) direction.

Finally, R moves the camera by picking random values for θ and φ (keeping x, y, z, and r unchanged).

Translation of centre point

The W and S keys move the centre point into and out from the screen, respectively, while keeping the z coordinate fixed. If θ = 0° or 180°, these keys have no effect.

The A and D keys move the centre point to the left and to the right, respectively, while keeping the z coordinate fixed. If θ = 0° or 180°, these keys have no effect.

The Q and E keys decrease and increase the z coordinate, respectively.

In all three cases, the Shift modifier can be used to make smaller steps.

Finally, 0 moves the centre point to the origin (0, 0, 0).

You can press C to reveal the current location of the orbit centre point. This turns on the centre point marker, which is then turned off again automatically after a second or so.

Mouse interface

Moving the mouse while keeping the primary mouse button (typically the left mouse button) down orbits by adjusting θ (vertically) and φ (horizontally).

Moving the mouse while keeping the middle mouse button (typically the scroll wheel) down translates the centre point in the same manner as A and D (horizontally) and Q and E (vertically).

The scroll wheel adjusts the r coordinate; effectively, it “zooms”.

In all three cases, the Shift modifier can be used to move the camera more slowly.

A panning operation (i.e., a camera operation involving moving the mouse with the primary or middle button down) can be aborted and undone by pressing Esc (only in raw input mode); pressing this key will restore the view to the pre-mouse-button-down state (again, only in raw input mode).

Mouse input modes

There are two mouse input modes: classic input mode and raw input mode.

In classic input mode, the mouse cursor stays visible during panning, and when the cursor hits an edge of the control, it jumps to the opposite edge (as if the control had a toroidal topology). Under the hood, the ordinary Windows desktop mouse cursor is used as input.

In raw input mode, raw data from the pointing device is used for input during panning. The mouse cursor is hidden while panning is taking place and when the panning operation ends, the mouse cursor is brought back at the same location as before the operation. If the user presses Esc while panning, the operation is immediately aborted and the view is restored to the pre-panning state.

Raw data from the pointing device can be either relative or absolute. In absolute data mode, panning may be obstructed by the edges of the screen (even though the mouse cursor isn’t visible), so relative data mode is preferable. A typical mouse on a physical Windows machine will produce relative data, but sometimes only absolute data is available, especially in remote-desktop scenarios. If this is the case, classic input mode may be the better choice.

You choose your preferred mode using the RawInput boolean property. If True, raw input mode is used if at all possible; otherwise, classic input mode is used. There’s also a boolean property AllowAbandonRaw. If this is True, the control will automatically set RawInput to False if it detects that the pointing device is sending absolute data or it detects that the application is running in a remote desktop setting (which typically involves absolute data). If AllowAbandonRaw = False, the control will never change the RawInput property on its own.

By default, both RawInput and AllowAbandonRaw are True, meaning that the control will use raw input mode (the best input mode) if that will work properly, and automatically revert to classic input mode otherwise.

Programmatic interface

You can manipulate the view programmatically by means of the View property. This object has properties that can be read and set:

r (Double): The r parameter.
Theta (Double): The θ parameter (degrees).
ThetaRad (Double): The θ parameter (radians).
Phi (Double): The φ parameter (degrees).
PhiRad (Double): The φ parameter (radians).
TargetCenter (vector, rglv): The orbit centre point.
CentrePoint (object): The orbit centre point, accessible from the Object Inspector at design time. Semantically equivalent to TargetCenter.
CameraRelativePosition (vector, rglv): The vector from the orbit centre point to the camera.
CameraRelativePositionSp (vector, TSphericalCoordinates): The vector from the orbit centre point to the camera expressed in spherical coordinates (r, θ, φ) with the angles in radians.

In addition, there are overloaded procedures FixCamera that set the centre point (x, y, z) and orbit parameters (r, θ, φ) simultaneously.

There are also overloaded procedures AnimateTo that set the centre point and (in most overloads) orbit parameters simultaneously, and animate the transition to the new coordinates. One of the overloads changes the centre point exclusively, keeping the orbit parameters unchanged. The animation is eased at both ends and takes about a second. It is aborted, “fast-forwarded”, if the user tries to use the mouse wheel to zoom. It can also be aborted using the FinishAnimation procedure. This too will “fast-forward” to the final position in the animation.

Projections

The control supports two kinds of projections: orthographic and perspective (default).

Programmatically, you can use the Projection property to change the projection. At runtime, the user can use the context menu (right-click menu) to change the projection. In addition, the O (orthographic) and P (perspective) keys can be used when the control has keyboard focus.

Light position

You can programmatically change the position of the main light source using the control’s LightPos (vector, rglv) property. Using the default shaders, this light source is omnidirectional and the light is not attenuated as you move away from it.

Built-in documentation

At runtime, the “Quick help” context (right click) menu item can be used to display the built-in quick reference dialog. Alternatively, the H key can be used to display this dialog (when the control has keyboard focus).

A table dialog describing many of the control’s keyboard shortcuts and its mouse interface.

OpenGL implementation data

If you hold the Shift key down and right click the control, the context menu will have two additional items: “OpenGL info” and “OpenGL extensions”. These will display information about the system’s OpenGL implementation (graphics card and drivers) and list the OpenGL extensions supported by the implementation.

A table dialog describing the system’s OpenGL implementation (graphics card and drivers).

A table dialog showing the OpenGL extensions supported by the implementation (graphics card and drivers).

System requirements

Since the control is based on modern OpenGL, the system running the application must support this API for the control to work. While essentially any reasonably modern real computer does support OpenGL, either with a dedicated graphics card or an integrated graphics solution on the CPU, the same does not necessarily hold for virtual machines. A virtual machine may lack the required OpenGL support, and the control is designed to handle this nicely:

A window with the Rejbrand Algosim 3D Visualisation Control on a system that lacks OpenGL support. The client area of the control contains only the text “OpenGL context not set up.”.

You may be able to install a software-based OpenGL driver that will make the control work (but probably with fairly poor performance).

Source code

{ **************************************************************************** }
{ Rejbrand Algosim 3d visualisation control                                    }
{ Copyright © 2017–2026 Andreas Rejbrand                                       }
{ https://english.rejbrand.se/                                                 }
{ **************************************************************************** }

unit trgl;

interface

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

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_Tex = 'tex';
  P_Scatter = 'scatter';
  P_AdvScatter = 'advsca';
  P_VectorField = 'vf';
  P_Image = 'zimage';
  P_Text = 'ztext';

type
  TImageFormat = (ifFromExtension, ifBitmap, ifPNG, ifJPG);

  TAnchorPoint =
    (
      apTopLeft,      apTop,        apTopRight,
      apLeft,         apCenter,     apRight,
      apBottomLeft,   apBottom,     apBottomRight
    );

  TLinearAlignment = (laNegative, laMiddle, laPositive);

  TAnchorPointHelper = record helper for TAnchorPoint
  strict private const
    PointNames: array[TAnchorPoint] of string =
      (
        'top-left',     'top',        'top-right',
        'left',         'center',     'right',
        'bottom-left',  'bottom',     'bottom-right'
      );
  public
    function H: TLinearAlignment; inline;
    function V: TLinearAlignment; inline;
    function ToString: string;
    class function FromString(const S: string): TAnchorPoint; static;
  end;

  TPPE = (ppIdentity);
  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 = [];

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;
    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;

  Prglv = ^rglv;
  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;
    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;
    constructor Create(const r, θ, φ: Single);
  end;

  rθφ = TSphericalCoordinates;

  TCameraPose = record
    SceneCenter: rglv;
    RelativePosition: rglv;
    class operator Equal(const Left, Right: TCameraPose): Boolean;
    class operator NotEqual(const Left, Right: TCameraPose): Boolean;
  end;

  TCameraPoseSp = record
    SceneCenter: rglv;
    RelativePosition: rθφ;
    class operator Equal(const Left, Right: TCameraPoseSp): Boolean;
    class operator NotEqual(const Left, Right: TCameraPoseSp): Boolean;
  end;

  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
  XYPlaneProjection: rglm = (elem: (1, 0, 0, 0, 1, 0, 0, 0, 0));
  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);
  rglv_ones:  rglv = (x: 1.0; y: 1.0; z: 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 = reference to function(const u, v: Double): rglv;
  TSurfParamColorFcn = reference to function(const u, v: Double): rglv;
  TSurfParamNormalFcn = reference to function(const u, v: Double): rglv;

  TCurveParamFcn = reference to function(const t: Double): rglv;
  TCurveParamColorFcn = reference to function(const t: Double): rglv;
  TCurveParamNormalFcn = reference to 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;

  __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(TCustomControl)
  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(TPersistent)
  strict private
    class var FModalLevel: Integer;
  public
    class property ModalLevel: Integer read FModalLevel;
  protected
    FTag: NativeInt;
    FVisible: Boolean;
    FCtl: TVisCtl3D;
    FDefaultProgram: string;
    FLineWidth: Single;
    FAnimationSpeed: Double;
    FOnChange: TNotifyEvent;
    FOptionsFrmClass: TDrawableOptionsFrmClass3D;
    FParent: TDrawable3D;
    FChildren: TList<TDrawable3D>;
    FParentTag: NativeUInt;
    FState: NativeInt;
    function TryContextCurrent: Boolean;
  private
    FOnClick: TNotifyEvent;
    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;
    procedure DoClick;
    procedure Click; virtual;
  public
    constructor Create(ACtl: TVisCtl3D); virtual;
    destructor Destroy; override;
    function CreateChild<T: TDrawable3D>: T;
    procedure DeleteChild(AChild: TDrawable3D);
    procedure DeleteChildren(ATagMask: NativeUInt);
    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 State: NativeInt read FState write FState;
    property OptionsFormClass: TDrawableOptionsFrmClass3D read FOptionsFrmClass write FOptionsFrmClass;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property OnClick: TNotifyEvent read FOnClick write FOnClick;
  end;

  TDrawableList3D = class(TDrawable3D)
  strict private
    FList: TObjectList<TDrawable3D>;
    FSortedList: TList<TDrawable3D>;
    FTimeDependent: Boolean;
    FAlphaBlending: Boolean;
    FPrevCameraPose: TCameraPose;
    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;
  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 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;
    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
    function GetScale: rglv;
    procedure SetScale(const Value: rglv);
  public
    constructor Create(ACtl: TVisCtl3D); override;
    property AxisLengths: rglv read GetScale 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;
    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;
    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;

  TDisk = class(TBasicSurface3D)
  private
    function GetRadius: Single;
    procedure SetRadius(const Value: Single);
  public
    constructor Create(ACtl: TVisCtl3D); 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;
    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;
  public
    constructor Create(ACtl: TVisCtl3D); override;
    property Data: TArray<GLfloat3> 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;
    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;
    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;
    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;
    procedure Setup; override;
    procedure Recreate; override;
    procedure ProjectionChanged; override;
  public
    constructor Create(ACtl: TVisCtl3D); 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;
    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;
    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 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;
    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;
    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;
    property Aspect: Single read Q write SetAspect;
    property HeadSize: Single read FHeadSize write SetHeadSize;
    property Vector: rglv read v write SetVector;
  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;

  TPublishedCoordinates = class(TPersistent)
  strict private
    FVectorPtr: Prglv;
    FNotifier: TProc;
    function GetCoordinate(AIndex: Integer): GLfloat;
    procedure SetCoordinate(AIndex: Integer; const Value: GLfloat);
  private
    constructor Create(AVector: Prglv; const ANotifier: TProc);
  published
    property X: GLfloat index 0 read GetCoordinate write SetCoordinate;
    property Y: GLfloat index 1 read GetCoordinate write SetCoordinate;
    property Z: GLfloat index 2 read GetCoordinate write SetCoordinate;
  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 TCameraPoseSp;
    FTargetCenterIntf: TPublishedCoordinates;
    procedure AnimationTimerTimer(Sender: TObject);
  private
    function GetCameraRelativePosition: rglv; inline;
    function GetCameraRelativePositionSp: TSphericalCoordinates; inline;
    function GetPhi: Double; inline;
    function GetPhiRad: Double; inline;
    function GetR: Double; inline;
    function GetTheta: Double; inline;
    function GetThetaRad: Double; inline;
    function GetTargetCenter: rglv; inline;
    procedure SetCameraRelativePosition(const Value: rglv);
    procedure SetCameraRelativePositionSp(const Value: TSphericalCoordinates);
    procedure SetPhi(const Value: Double);
    procedure SetPhiRad(const Value: Double);
    procedure SetR(const Value: Double);
    procedure SetTheta(const Value: Double);
    procedure SetThetaRad(const Value: Double);
    procedure SetTargetCenter(const Value: rglv);
  public
    constructor Create(ACtl: TVisCtl3D); override;
    destructor Destroy; override;
    property TargetCenter: rglv read GetTargetCenter write SetTargetCenter;
    property CameraRelativePosition: rglv read GetCameraRelativePosition write SetCameraRelativePosition;
    property CameraRelativePositionSp: TSphericalCoordinates read GetCameraRelativePositionSp write SetCameraRelativePositionSp;
    procedure FixCamera(const ACenter: rglv; const ARelativePosition: rglv); overload;
    procedure FixCamera(const ACameraPose: TCameraPose); overload; inline;
    procedure FixCamera(const ACameraPose: TCameraPoseSp); overload; inline;
    procedure AnimateTo(const ATargetCenter: rglv; const ATargetRelativePosition: rglv); overload;
    procedure AnimateTo(const ATargetCenter: rglv); overload;
    procedure AnimateTo(const ACameraPose: TCameraPose); overload;
    procedure AnimateTo(const ACameraPose: TCameraPoseSp); overload;
    procedure FinishAnimation;
  published
    property r: Double read GetR write SetR;
    property Theta: Double read GetTheta write SetTheta;
    property Phi: Double read GetPhi write SetPhi;
    property ThetaRad: Double read GetThetaRad write SetThetaRad;
    property PhiRad: Double read GetPhiRad write SetPhiRad;
    property CentrePoint: TPublishedCoordinates read FTargetCenterIntf;
  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;  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;
  end;

  TProgramMgr = class
  strict private
    FControl: TVisCtl3D;
    FPrograms: TObjectList<TManagedProgram>;
    FCurrentProgram: TManagedProgram;
    FTimeDependent: Boolean;
    function LoadProgramResource(const AName: string; const AData: string): 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;

  [ComponentPlatforms(pidWin32 or pidWin64)]
  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;
  const
    InvalidRawPoint: TPoint = (X: FixedInt.MinValue; Y: FixedInt.MaxValue);
  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;
    FHelpMnuItem: TMenuItem;
    FEffects: TPPEs;
    FMaxSamples: Integer;
    FPrevTick: Int64;
    FGlobalTime: Double;
    FImplData: TGLImplInfo;
    FExts: TArray<string>;
    FStencil: Boolean;
    FScene: TScene;
    FView: TView3D;
    FAxes: TAxes;
    FCenterMarker: TGeometricObject3D;
    FCenterMarkerHiderTimer: TTimer;
    FMButtonDown: Boolean;
    FRawInputAvailable: Boolean;
    FPreferRawInput: Boolean;
    FAbandonRawInputIfAbsoluteDevice: Boolean;
    FAbandonRawInputOnPanEnd: Boolean;
    FPrePanMousePos: TPoint;
    FPrePanCamPose: TCameraPose;
    FRawPanning: Boolean;
    FPrevRawPoint: TPoint;
    FPanSensitivity,
    FOrbitSensitivity: Double;
    FCanClick: Boolean;
    FOnViewChanged: TNotifyEvent;
    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 MnuToggleAxes(Sender: TObject);
    procedure MnuSaveSceneToFile(Sender: TObject);
    procedure MnuCopySceneToClipboard(Sender: TObject);
    procedure MnuSetProj(Sender: TObject);
    procedure MnuSetMSAA(Sender: TObject);
    procedure MnuImplInfo(Sender: TObject);
    procedure MnuExtInfo(Sender: TObject);
    procedure MnuQuickHelp(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;
    function GetCameraPose: TCameraPose;
    procedure SetCameraPose(const APose: TCameraPose);
    function GetCameraRelativePos: rglv;
    procedure SetCameraRelativePos(const ARelativePos: rglv);
    procedure CenterMarkerHiderTimerTimer(Sender: TObject);
    procedure CancelPanning(AAbort: Boolean = False);
    procedure Pan(∆X, ∆Y: Integer);
    procedure RevealCenterMarker;
    procedure DoViewChanged;
  private
    LookAt: rglv;
    r, φ, θ: Double;
    procedure RemoveObjectOrChild(AObject: TDrawable3D);
  protected
    procedure GLInit; override;
    procedure FramebufferSetup(const ARenderOutputData: TRenderOutputData);
    procedure Paint; override;
    procedure Resize; override;
    procedure Click; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X: Integer; Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; 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;
    procedure WndProc(var Message: TMessage); override;
  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; overload;
    function HitTest(const P: TPoint): TDrawable3D; overload; inline;
    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 ObjectMgr: TDrawableList3D read FObjs;
    property ProgramMgr: TProgramMgr read FProgramMgr;
    property CurrentMatrix: rglm4 read MVP;
    property CameraPos: rglv read Eye;
    property CameraRelativePos: rglv read GetCameraRelativePos write SetCameraRelativePos;
    property CameraPose: TCameraPose read GetCameraPose write SetCameraPose;
    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 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 FOV: Double read FFOV write SetFov;
    property Projection: TProjection read FProjection write SetProjection default Perspective;
    property PanSensitivity: Double read FPanSensitivity write FPanSensitivity;
    property OrbitSensitivity: Double read FOrbitSensitivity write FOrbitSensitivity;
    property MSAA: TMSAAValue read FMSAAValue write SetMSAAValue;
    property ShowAxes: Boolean read GetShowAxes write SetShowAxes default True;
    property TabStop default True;
    property Visible;
    property View: TView3D read FView;
    property RawInput: Boolean read FPreferRawInput write FPreferRawInput default True;
    property AllowAbandonRaw: Boolean read FAbandonRawInputIfAbsoluteDevice
      write FAbandonRawInputIfAbsoluteDevice default True;
    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;
    property OnViewChanged: TNotifyEvent read FOnViewChanged write FOnViewChanged;
  end;

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

procedure SaveGraphicToFile(AGraphics: TGraphic; const AFileName: TFileName;
  AFormat: TImageFormat); overload;
procedure SaveGraphicToFile(AGraphics: TGraphic; ADlgOwner: TComponent;
  const ADefFilename: TFileName = ''); overload;

type
  ERglObjFileError = class(Exception);

function ObjFileParseObjData(const AData: TArray<string>): TArray<GLfloat6>;
function ObjFilePrintRawBuffer(ABuffer: Pointer; ALength:
  Integer; const ASep: string = ''): string; overload;
function ObjFilePrintRawBuffer(ABuffer: TArray<GLfloat6>;
  const ASep: string = ''): string; overload;

procedure Register;

implementation

uses
  StrUtils, Math, DateUtils, IOUtils, Clipbrd, Jpeg, PngImage, TrglImageSizeForm,
  Character, TrglTableDialog;

{ Win32 Raw Input }

{$REGION Win32 Raw Input}

type
  PRawInputDevice = ^TRawInputDevice;
  TRawInputDevice = record
    usUsagePage: USHORT;
    usUsage: USHORT;
    dwFlags: DWORD;
    hwndTarget: HWND;
  end;

  PRawInputHeader = ^TRawInputHeader;
  TRawInputHeader = record
    dwType: DWORD;
    dwSize: DWORD;
    hDevice: THandle;
    wParam: WPARAM;
  end;

  PRawMouse = ^TRawMouse;
  TRawMouse = record
  public
    usFlags: USHORT;
  strict private
    Buttons: record
      case Boolean of
        False: (
          ulButtons: ULONG;
        );
        True: (
          usButtonFlags: USHORT;
          usButtonData: USHORT;
        );
      end;
  public
    ulRawButtons: ULONG;
    lLastX: LONG;
    lLastY: LONG;
    ulExtraInformation: ULONG;
    property ulButtons: ULONG read Buttons.ulButtons write Buttons.ulButtons;
    property usButtonFlags: USHORT read Buttons.usButtonFlags write Buttons.usButtonFlags;
    property usButtonData: USHORT read Buttons.usButtonData write Buttons.usButtonData;
  end;

  PRawKeyboard = ^TRawKeyboard;
  TRawKeyboard = record
    MakeCode: USHORT;
    Flags: USHORT;
    Reserved: USHORT;
    VKey: USHORT;
    &Message: UInt;
    ExtraInformation: ULONG;
  end;

  PRawHid = ^TRawHid;
  TRawHid = record
    dwSizeHid: DWORD;
    dwCount: DWORD;
    bRawData: array[0..0] of Byte;
  end;

  PRawInput = ^TRawInput;
  TRawInput = record
    header: TRawInputHeader;
    data: record
      case Byte of
        0: (mouse: TRawMouse);
        1: (keyboard: TRawKeyboard);
        2: (hid: TRawHid);
    end;
  end;

const
  RIM_TYPEMOUSE = 0;
  RIM_TYPEKEYBOARD = 1;
  RIM_TYPEHID = 2;

  RID_HEADER = $10000005;
  RID_INPUT = $10000003;

  MOUSE_MOVE_RELATIVE = $00;
  MOUSE_MOVE_ABSOLUTE = $01;
  MOUSE_VIRTUAL_DESKTOP = $02;
  MOUSE_ATTRIBUTES_CHANGED = $04;
  MOUSE_MOVE_NOCOALESCE = $08;


function RegisterRawInputDevices(pRawInputDevices: PRAWINPUTDEVICE;
  uiNumDevices: UINT; cbSize: UINT): BOOL; stdcall; external user32 name 'RegisterRawInputDevices';

function GetRawInputData(hRawInput: LPARAM; uiCommand: UINT; pData: Pointer;
  var pcbSize: UINT; cbSizeHeader: UINT): UINT; stdcall; external user32 name 'GetRawInputData';

{$ENDREGION}

var
  InvFS: TFormatSettings;
  RglDebugLog: Boolean;

procedure glLineWidth(width: GLfloat); inline;
begin
end;

function Floor64(const X: Double): Int64;
begin
  Result := Int64(Trunc(X));
  if Frac(X) < 0 then
    Dec(Result);
end;

function rmod(const x, y: Double): Double; inline;
begin
  Result := x - Floor64(x / y) * y;
end;

{ TAnchorPointHelper }

class function TAnchorPointHelper.FromString(const S: string): TAnchorPoint;
begin
  for var ap := Low(TAnchorPoint) to High(TAnchorPoint) do
    if ap.ToString = S then
      Exit(ap);
  raise Exception.Create('Invalid anchor point.');
end;

function TAnchorPointHelper.H: TLinearAlignment;
begin
  case Self of
    apTopLeft,
    apLeft,
    apBottomLeft:
      Result := laNegative;
    apTop,
    apCenter,
    apBottom:
      Result := laMiddle;
    apTopRight,
    apRight,
    apBottomRight:
      Result := laPositive;
  else
    raise Exception.Create('Invalid anchor point.');
  end;
end;

function TAnchorPointHelper.ToString: string;
begin
  if InRange(Ord(Self), Ord(Low(TAnchorPoint)), Ord(High(TAnchorPoint))) then
    Result := PointNames[Self]
  else
    Result := '';
end;

function TAnchorPointHelper.V: TLinearAlignment;
begin
  case Self of
    apTopLeft,
    apTop,
    apTopRight:
      Result := laNegative;
    apLeft,
    apCenter,
    apRight:
      Result := laMiddle;
    apBottomLeft,
    apBottom,
    apBottomRight:
      Result := laPositive;
  else
    raise Exception.Create('Invalid anchor point.');
  end;
end;

{ 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 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;

{ 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';
  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;

  if not Assigned(glGenFramebuffers) then
    raise Exception.Create('OpenGL not available.');

  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);
  try
    FContext := TRglContext.Create(Handle);
  except
    on E: Exception do
      OutputDebugString(PChar(E.Message));
  end;
  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.Brush.Style := bsSolid;
      Canvas.FillRect(ClientRect);
      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;

{ TCenterMarker }

type
  TCenterMarker = class(TGeometricObject3D)
  private
    FXAxis,
    FYAxis,
    FZAxis: TCylinder;
  private
    procedure AxisChanged(Sender: TObject);
  public
    constructor Create(ACtl: TVisCtl3D); override;
    property X: TCylinder read FXAxis;
    property Y: TCylinder read FYAxis;
    property Z: TCylinder read FZAxis;
  end;

constructor TCenterMarker.Create(ACtl: TVisCtl3D);
begin

  inherited;

  const L: Double = 100.0;

  FXAxis := CreateChild<TCylinder>;
  FXAxis.Direction := vec(1, 0, 0);
  FXAxis.Position := vec(-L / 2, 0, 0);
  FXAxis.Radius := 0.01;
  FXAxis.Height := L;
  FXAxis.Color := clSilver;
  FXAxis.OnChange := AxisChanged;

  FYAxis := CreateChild<TCylinder>;
  FYAxis.Direction := vec(0, 1, 0);
  FYAxis.Position := vec(0, -L / 2, 0);
  FYAxis.Radius := 0.01;
  FYAxis.Height := L;
  FYAxis.Color := clSilver;
  FYAxis.OnChange := AxisChanged;

  FZAxis := CreateChild<TCylinder>;
  FZAxis.Direction := vec(0, 0, 1);
  FZAxis.Position := vec(0, 0, -L / 2);
  FZAxis.Radius := 0.01;
  FZAxis.Height := L;
  FZAxis.Color := clSilver;
  FZAxis.OnChange := AxisChanged;

  var LLabel := CreateChild<TTextRect>;
  LLabel.FaceScreen := True;
  LLabel.Text := 'Camera orbit point';
  LLabel.AnchorPoint := apBottomLeft;
  LLabel.Font.Size := 16;
  LLabel.Displacement := vec2(0.25, 0.25);
  LLabel.Opacity := 0.5;

end;

procedure TCenterMarker.AxisChanged(Sender: TObject);
begin
  Changed;
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 }

procedure SaveGraphicToFile(AGraphics: TGraphic; const AFileName: TFileName;
  AFormat: TImageFormat); overload;
const
  exts: array[TImageFormat] of string =
    (
      '',
      'bmp',
      'png',
      'jpg|jpeg'
    );
  clss: array[TImageFormat] of TGraphicClass =
    (
      nil,
      TBitmap,
      TPngImage,
      TJPEGImage
    );
var
  ext: string;
  &if: TImageFormat;
  TargetGraphic: TGraphic;
begin

  if AFormat = ifFromExtension then
  begin
    ext := ExtractFileExt(AFileName).TrimLeft(['.']);
    for &if := Low(TImageFormat) to High(TImageFormat) do
      if IndexText(ext, exts[&if].Split(['|'])) <> -1 then
      begin
        AFormat := &if;
        Break;
      end;
  end;

  if AFormat = ifFromExtension then
    raise Exception.CreateFmt('Unsupported file extension: "%s".', [ext]);

  if AGraphics.InheritsFrom(clss[AFormat]) then
    AGraphics.SaveToFile(AFileName)
  else
  begin
    TargetGraphic := clss[AFormat].Create;
    try
      TargetGraphic.Assign(AGraphics);
      TargetGraphic.SaveToFile(AFileName);
    finally
      TargetGraphic.Free;
    end;
  end;

end;

procedure SaveGraphicToFile(AGraphics: TGraphic; ADlgOwner: TComponent;
  const ADefFilename: TFileName); overload;
const
  ImageFormats: array[0..2] of TImageFormat = (ifBitmap, ifPng, ifJpg);
var
  dlg: TFileSaveDialog;
begin

  dlg := TFileSaveDialog.Create(ADlgOwner);
  try
    dlg.ClientGuid := '{DB7FB35D-C336-4A82-B108-29738F9E77CB}';
    with dlg.FileTypes.Add do
    begin
      FileMask := '*.bmp';
      DisplayName := 'Bitmap images';
    end;
    with dlg.FileTypes.Add do
    begin
      FileMask := '*.png';
      DisplayName := 'PNG images';
    end;
    with dlg.FileTypes.Add do
    begin
      FileMask := '*.jpg;*.jpeg';
      DisplayName := 'JPEG images';
    end;
    dlg.DefaultExtension := '.bmp';
    dlg.FileName := ADefFilename;
    dlg.Options := dlg.Options + [fdoOverwritePrompt];
    if dlg.Execute and InRange(Pred(dlg.FileTypeIndex), Ord(Low(ImageFormats)), Ord(High(ImageFormats))) then
      SaveGraphicToFile(AGraphics, dlg.FileName, ImageFormats[Pred(dlg.FileTypeIndex)]);
  finally
    dlg.Free;
  end;

end;

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;

function TVisCtl3D.GetCameraPose: TCameraPose;
begin
  Result.SceneCenter := LookAt;
  Result.RelativePosition := CameraPos - LookAt;
end;

procedure TVisCtl3D.SetCameraPose(const APose: TCameraPose);
begin
  View.FixCamera(APose);
end;

function TVisCtl3D.GetCameraRelativePos: rglv;
begin
  Result := CameraPos - LookAt;
end;

procedure TVisCtl3D.SetCameraRelativePos(const ARelativePos: rglv);
begin
  View.FixCamera(LookAt, ARelativePos);
end;

procedure TVisCtl3D.CenterMarkerHiderTimerTimer(Sender: TObject);
begin
  if Assigned(FCenterMarkerHiderTimer) then
    FCenterMarkerHiderTimer.Enabled := False;
  if Assigned(FCenterMarker) then
    FCenterMarker.Visible := False;
end;

procedure TVisCtl3D.CancelPanning(AAbort: Boolean);
begin
  if FRawPanning then
  begin
    FRawPanning := False;
    Screen.Cursor := crDefault;
    Mouse.CursorPos := FPrePanMousePos;
    if AAbort then
      View.AnimateTo(FPrePanCamPose);
    if FAbandonRawInputOnPanEnd then
      FPreferRawInput := False;
  end;
end;

procedure TVisCtl3D.Pan(∆X: Integer; ∆Y: Integer);

  function rmod(const x, y: Double): Double;
  begin
    Result := x - Floor64(x / y) * y;
  end;

const
  P: rglm = (elem: (1, 0, 0, 0, 1, 0, 0, 0, 0));

begin
  if (∆X <> 0) or (∆Y <> 0) then
    FCanClick := False;
  const LShift = IfThen(GetKeyState(VK_SHIFT) < 0, 0.1, 1.0);
  if csLButtonDown in ControlState then
  begin
    const LSensitivity = FPanSensitivity * LShift;
    θ := EnsureRange(θ - ∆Y * LSensitivity / 250, 0, Pi);
    φ := rmod(φ - ∆X * LSensitivity / 500, 2*Pi);
    ComputeV;
    Invalidate;
    DoViewChanged;
  end
  else if FMButtonDown then
  begin
    const LSensitivity = FOrbitSensitivity * LShift;
    View.TargetCenter := View.TargetCenter + vec(0, 0, ∆Y * LSensitivity / 25) -
      P * (vec(0, 0, 1) xor View.CameraRelativePosition.Normalized) * (∆X * LSensitivity / 25);
  end;
end;

procedure TVisCtl3D.RevealCenterMarker;
begin
  if Assigned(FCenterMarker) then
  begin
    FCenterMarker.Position := LookAt;
    FCenterMarker.Visible := True;
    if Assigned(FCenterMarkerHiderTimer) then
    begin
      FCenterMarkerHiderTimer.Enabled := False;
      FCenterMarkerHiderTimer.Enabled := True;
    end;
  end;
end;

procedure TVisCtl3D.DoViewChanged;
begin
  if Assigned(FOnViewChanged) then
    FOnViewChanged(Self);
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;
    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);
    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);
  if Assigned(FCenterMarker) and ((FCenterMarker.Position <> LookAt) or (LookAt <> LookAt.Zero)) then
  begin
    FCenterMarker.Position := LookAt;
    FCenterMarker.Visible := True;
    FCenterMarkerHiderTimer.Enabled := False;
    FCenterMarkerHiderTimer.Enabled := True;
  end;
  Invalidate;
  DoViewChanged;
end;

procedure TVisCtl3D.WMContextMenu(var Message: TWMContextMenu);
var
  P: TPoint;
begin
  if Assigned(FPopupMenu) and Assigned(Context) 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.WndProc(var Message: TMessage);
begin
  inherited;
  case Message.Msg of
    WM_MBUTTONDOWN:
      begin
        FMButtonDown := True;
        SetCaptureControl(Self);
      end;
    WM_MBUTTONUP:
      begin
        FMButtonDown := False;
        if GetCapture = Handle then
          SetCaptureControl(nil)
      end;
    WM_CANCELMODE:
      begin
        FMButtonDown := False;
        CancelPanning;
      end;
    WM_CAPTURECHANGED:
      if GetCapture <> Handle then
      begin
        FMButtonDown := False;
        CancelPanning;
      end;
    WM_INPUT:
      begin
        var RI := Default(TRawInput);
        var LSize: Cardinal := SizeOf(RI);
        if GetRawInputData(Message.LParam, RID_INPUT, @RI, LSize, SizeOf(TRawInputHeader)) > 0 then
        begin
          if RI.header.dwType <> RIM_TYPEMOUSE then
            Exit;
          if FRawPanning then
          begin
            if RI.data.mouse.usFlags and MOUSE_MOVE_ABSOLUTE <> 0 then
            begin
              if FAbandonRawInputIfAbsoluteDevice then
                FAbandonRawInputOnPanEnd := True;
              var LThisRawPoint := Point(RI.data.mouse.lLastX, RI.data.mouse.lLastY);
              begin
                // Since MOUSE_MOVE_ABSOLUTE is set, LThisRawPoint is an absolute point -- in a relative coordinate system.
                // We need to convert it to the absolute point int the standard absolute desktop coordinate system.
                const LIsVirtual = RI.Data.mouse.usFlags and MOUSE_VIRTUAL_DESKTOP <> 0;
                const LWidth = GetSystemMetrics(IfThen(LIsVirtual, SM_CXVIRTUALSCREEN, SM_CXSCREEN));
                const LHeight = GetSystemMetrics(IfThen(LIsVirtual, SM_CYVIRTUALSCREEN, SM_CYSCREEN));
                LThisRawPoint.X := Round(LThisRawPoint.X / Word.MaxValue * LWidth);
                LThisRawPoint.Y := Round(LThisRawPoint.Y / Word.MaxValue * LHeight);
              end;
              if FPrevRawPoint <> InvalidRawPoint then
                with LThisRawPoint - FPrevRawPoint do
                  Pan(X, Y);
              FPrevRawPoint := LThisRawPoint;
            end
            else
              Pan(RI.data.mouse.lLastX, RI.data.mouse.lLastY);
          end;
        end;
      end;
  end;
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 := Power(1.1, -F * Delta);
  r := q * r;
  r := EnsureRange(r, 0.01, 900);
  ComputeV;
  if FProjection = Orthographic then
    ComputeP(FRenderOutputData);
  Invalidate;
  DoViewChanged;
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) and (LObj <> FCenterMarker) 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 := LookAt.x + r*Sin(θ)*Cos(φ);
  eye.y := LookAt.y + r*Sin(θ)*Sin(φ);
  eye.z := LookAt.z + r*Cos(θ);
  const z = eye.x; // cycl.
  const x = eye.y;
  const y = eye.z;
  const LAz = LookAt.x; // cycl.
  const LAx = LookAt.y;
  const LAy = LookAt.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, LAx, LAy, LAz, u.x, u.y, u.z);
end;

constructor TVisCtl3D.Create(AOwner: TComponent);
begin
  inherited;
  Width := 600;
  Height := 400;
  FMSAAValue := msaa8;
  ClearMask := 0;
  r := 25;
  θ := Pi/4;
  φ := Pi/4;
  ComputeM;
  ComputeV;
  FPrevRawPoint := InvalidRawPoint;
  FPanSensitivity := 1.0;
  FOrbitSensitivity := 1.0;
  FPreferRawInput := True;
  FAbandonRawInputIfAbsoluteDevice := True;
  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;
  FCenterMarker := NewObject<TCenterMarker>;
  FCenterMarker.FProtected := True;
  FCenterMarker.Visible := False;
  FCenterMarkerHiderTimer := TTimer.Create(Self);
  FCenterMarkerHiderTimer.Interval := 1000;
  FCenterMarkerHiderTimer.Enabled := False;
  FCenterMarkerHiderTimer.OnTimer := CenterMarkerHiderTimerTimer;
  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;
end;

procedure TVisCtl3D.CreateWnd;
begin

  inherited;

  var RID := Default(TRawInputDevice);
  RID.usUsagePage := 1;
  RID.usUsage := 2;
  RID.hwndTarget := Handle;
  FRawInputAvailable := RegisterRawInputDevices(@RID, 1, SizeOf(RID));

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);
const
  P: rglm = (elem: (1, 0, 0, 0, 1, 0, 0, 0, 0));
begin
  inherited;
  if [ssCtrl, ssAlt] * Shift <> [] then
    Exit;
  const Tenth = IfThen(ssShift in Shift, 0.1, 1.0);
  case Key of
    VK_ESCAPE:
      CancelPanning(True);
    VK_LEFT:
      View.PhiRad := φ - Pi/50 * Tenth;
    VK_RIGHT:
      View.PhiRad := φ + Pi/50 * Tenth;
    VK_UP:
      View.ThetaRad := θ - Pi/50 * Tenth;
    VK_DOWN:
      View.ThetaRad := θ + Pi/50 * Tenth;
    VK_OEM_MINUS, VK_SUBTRACT:
      ZoomOut(1, Shift);
    VK_OEM_PLUS, VK_ADD:
      ZoomIn(1, Shift);
    Ord('0'), VK_NUMPAD0:
      View.AnimateTo(rglv.Zero);
    Ord('E'):
      View.TargetCenter := View.TargetCenter + vec(0, 0, 1 * Tenth);
    Ord('Q'):
      View.TargetCenter := View.TargetCenter - vec(0, 0, 1 * Tenth);
    Ord('W'):
      View.TargetCenter := View.TargetCenter - Tenth * P * View.CameraRelativePosition.Normalized;
    Ord('S'):
      View.TargetCenter := View.TargetCenter + Tenth * P * View.CameraRelativePosition.Normalized;
    Ord('A'):
      View.TargetCenter := View.TargetCenter - Tenth * P * (vec(0, 0, 1) xor View.CameraRelativePosition.Normalized);
    Ord('D'):
      View.TargetCenter := View.TargetCenter + Tenth * P * (vec(0, 0, 1) xor View.CameraRelativePosition.Normalized);
  end;
end;

procedure TVisCtl3D.KeyPress(var Key: Char);
begin
  inherited;
  case Key of
    'X':
      View.AnimateTo(View.TargetCenter, View.r * vec(1, 0, 0));
    'Y':
      View.AnimateTo(View.TargetCenter, View.r * vec(0, 1, 0));
    'Z':
      View.AnimateTo(View.TargetCenter, View.r * vec(0, 0, 1));
    'x':
      View.AnimateTo(View.TargetCenter, View.r * vec(-1, 0, 0));
    'y':
      View.AnimateTo(View.TargetCenter, View.r * vec(0, -1, 0));
    'z':
      View.AnimateTo(View.TargetCenter, View.r * vec(0, 0, -1));
    'o':
      Projection := Orthographic;
    'p':
      Projection := Perspective;
    'r':
      View.AnimateTo(View.TargetCenter, rθφ.Create(View.r, 2*Pi*Random, ArcCos(2*Random - 1)));
    'h':
      MnuQuickHelp(Self);
    'c':
      RevealCenterMarker;
    ^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 := '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'#9'O';
  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'#9'P' ;
  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;

  FPopupMenu.Items.NewBottomLine;

  mi := TMenuItem.Create(FPopupMenu);
  mi.Caption := 'Quick &help'#9'H';
  mi.Hint := 'Displays information about the 3D visualisation control’s keyboard and mouse interface.';
  mi.OnClick := MnuQuickHelp;
  FPopupMenu.Items.Add(mi);
  FHelpMnuItem := mi;

  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),
    '3D Visualisation Control',
    '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

  var LExts := TList<TPair<string, string>>.Create;
  try

    LExts.Capacity := Length(FExts) div 2 + Ord(Odd(Length(FExts)));
    for var i := 0 to Length(FExts) div 2 - 1 do
      LExts.Add(TPair<string, string>.Create(FExts[2*i], FExts[2*i + 1]));
    if Odd(Length(FExts)) then
      LExts.Add(TPair<string, string>.Create(FExts[High(FExts)], ''));

    TTableDialog.ShowTable(
      GetParentForm(Self),
      '3D Visualisation Control',
      'OpenGL Extensions',
      LExts.ToArray,
      TMsgDlgType.mtCustom
    );

  finally
    LExts.Free;
  end;

end;

procedure TVisCtl3D.MnuQuickHelp(Sender: TObject);

  function p(const A: string = ''; const B: string = ''; const Cond: Boolean = True): TPair<string, string>;
  begin
    if not Cond then
      Exit(Default(TPair<string, string>));
    Result.Key := A;
    Result.Value := B;
  end;

begin

  while True do
    if
      (
        TTableDialog.ShowTable(
          GetParentForm(Self),
          '3D Visualisation Control',
          'Quick Reference',
          TArray<TPair<string, string>>.Create(
            p('W', 'Moves the orbit centre forward keeping z fixed.'),
            p('S', 'Moves the orbit centre backward keeping z fixed.'),
            p('A', 'Moves the orbit centre to the left keeping z fixed.'),
            p('D', 'Moves the orbit centre to the right keeping z fixed.'),
            p('Q', 'Moves the orbit centre down (decreasing z).'),
            p('E', 'Moves the orbit centre up (increasing z).'),
            p('MMB-drag', 'Horizontally: left/right. Vertically: z.'),
            p,
            p('0', 'Moves the orbit centre to (0, 0, 0).'),
            p,
            p('Left', 'Orbits around the centre: Decrease φ.'),
            p('Right', 'Orbits around the centre: Increase φ.'),
            p('Up', 'Orbits around the centre: Decrease θ.'),
            p('Down', 'Orbits around the centre: Increase θ.'),
            p('R', 'Orbits around the centre: Move to random (θ, φ).'),
            p('LMB-drag', 'Horizontally: φ. Vertically: θ.'),
            p,
            p('+', 'Decreases distance from orbit centre.'),
            p('−', 'Increases distance from orbit centre.'),
            p,
            p('Shift', 'Moves at 1/10 the speed (modifier).'),
            p('Escape', 'Aborts and undoes the current mouse panning operation.', FRawInputAvailable and FPreferRawInput)
          ),
          [mrRetry, mrClose],
          ['&More', 'Close'],
          mrClose,
          mrClose,
          TMsgDlgType.mtCustom
        ) <> mrRetry
      )
    or
      (
        TTableDialog.ShowTable(
          GetParentForm(Self),
          '3D Visualisation Control',
          'Quick Reference',
          TArray<TPair<string, string>>.Create(
            p('x', 'Orbits the view to look in the +x̂ direction.'),
            p('X', 'Orbits the view to look in the −x̂ direction.'),
            p('y', 'Orbits the view to look in the +ŷ direction.'),
            p('Y', 'Orbits the view to look in the −ŷ direction.'),
            p('z', 'Orbits the view to look in the +ẑ direction.'),
            p('Z', 'Orbits the view to look in the −ẑ direction.'),
            p,
            p('p', 'Sets projection mode to perspective.'),
            p('o', 'Sets projection mode to orthographic.'),
            p,
            p('c', 'Reveals the camera orbit centre point.'),
            p('h', 'Displays these quick reference tables.')
          ),
          [mrRetry, mrClose],
          ['&Back', 'Close'],
          mrClose,
          mrClose,
          TMsgDlgType.mtCustom
        ) <> mrRetry
      )
    then
      Break;

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.MnuSetMSAA(Sender: TObject);
begin
  if Sender is TMenuItem then
    MSAA := TMSAAValue(TMenuItem(Sender).Tag);
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.Click;
begin
  inherited;
  if FCanClick then
  begin
    const LObj = HitTest(ScreenToClient(Mouse.CursorPos));
    if Assigned(LObj) then
      LObj.Click;
  end;
end;

procedure TVisCtl3D.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
  inherited;
  FPrevMousePoint := Point(X, Y);
  FCanClick := True;
  if CanFocus then
    SetFocus;
  if Context = nil then
    Exit;
  if
    FRawInputAvailable and FPreferRawInput
      and
    (Button in [TMouseButton.mbLeft, TMouseButton.mbMiddle])
      and
    not FRawPanning
  then
  begin
    if FAbandonRawInputIfAbsoluteDevice then
    begin
      if GetSystemMetrics(SM_REMOTESESSION) <> 0 then
      begin
        FPreferRawInput := False;
        Exit;
      end;
    end;
    FPrevRawPoint := InvalidRawPoint;
    FRawPanning := True;
    FAbandonRawInputOnPanEnd := False;
    Screen.Cursor := crNone;
    FPrePanMousePos := Mouse.CursorPos;
    FPrePanCamPose := CameraPose;
  end;
end;

procedure TVisCtl3D.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
  inherited;
  if
    FRawPanning
  and
    not (csLButtonDown in ControlState)
  and
    not FMButtonDown
  then
    CancelPanning;
end;

procedure TVisCtl3D.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
  inherited;
  if not FRawInputAvailable or not FPreferRawInput then
  begin
    if (csLButtonDown in ControlState) or FMButtonDown then
    begin
      const ∆X = X - FPrevMousePoint.X;
      const ∆Y = Y - FPrevMousePoint.Y;
      if (Abs(∆x) < ClientWidth) and (Abs(∆y) < ClientHeight) then
        Pan(∆x, ∆y);
      FPrevMousePoint := Point(X, Y);
      if not ClientRect.Contains(Point(X, Y)) then
      begin
        FPrevMousePoint.X := (X + ClientWidth) mod ClientWidth;
        FPrevMousePoint.Y := (Y + ClientHeight) mod ClientHeight;
        Mouse.CursorPos := ClientToScreen(FPrevMousePoint);
      end;
    end;
  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
  if Assigned(FView) then
    FView.FinishAnimation;
  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;

  if Context = nil then
    Exit;

  Context.MakeCurrent('TVisCtl3D.GLInit');

  {$IFDEF DEBUG}
  if Assigned(glDebugMessageCallback) then
  begin
    glEnable(GL_DEBUG_OUTPUT);
    glEnable(GL_DEBUG_OUTPUT_SYNCHRONOUS_ARB);
    glDebugMessageCallback(debugproc, nil);
  end;
  {$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);
    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(const P: TPoint): TDrawable3D;
begin
  Result := HitTest(P.X, P.Y);
end;

function TVisCtl3D.HitTest(X: Integer; Y: Integer): TDrawable3D;
begin
  if Context = nil then
    Exit(nil);
  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;

constructor TDrawable3D.Create(ACtl: TVisCtl3D);
begin
  FVisible := True;
  FCtl := ACtl;
  FLineWidth := 1.5;
  FDefaultProgram := P_Default;
  FChildren := TList<TDrawable3D>.Create;
end;

function TDrawable3D.CreateChild<T>: T;
begin

  if FCtl = nil then
    Exit(nil);

  if FChildren = nil then
    Exit(nil);

  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;
  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;

procedure TDrawable3D.GLRelease;
begin

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.DoClick;
begin
  if Assigned(FOnClick) then
    FOnClick(Self);
end;

procedure TDrawable3D.Click;
begin
  DoClick;
end;

procedure TDrawable3D.Setup;
begin

end;

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

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

{ TDrawableList3D }

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

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

procedure TDrawableList3D.Draw(const AGlobalTime: Double);
begin
  if FSortOrderDirty or FAlphaBlending and (FPrevCameraPose <> Control.CameraPose) 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);
          obj.Draw(AGlobalTime);
          FTimeDependent := FTimeDependent or (obj.AnimationSpeed <> 0);
        end;
    FPrevCameraPose := Control.CameraPose;
  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
          if (Left = nil) or (Right = nil) then
            Exit(CompareValue(NativeUInt(Left), NativeUInt(Right)));
          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;
          if Result = 0 then
            Result := CompareValue(NativeUInt(Left), NativeUInt(Right));
        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');
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;

const
  Shaders:
    array[0..10] of record
      Name,
      Code: string;
    end
  =
    (
      (Name: P_Default;
      Code:
      '''
      #vertex shader
      #version 330 core
      layout (location = 0) in vec3 coords;
      layout (location = 1) in vec3 color;
      varying vec3 v_color;

      uniform mat4 MVP;
      uniform mat4 OM;

      void main()
      {
        gl_Position = MVP * OM * vec4(coords, 1.0);
        v_color = color;
      };

      #fragment shader
      #version 330 core
      out vec4 FragColor;
      varying vec3 v_color;

      void main()
      {
        FragColor = vec4(v_color, 1.0);
      };
      '''
      ),
      (Name: P_Lighting;
      Code:
      '''
      #vertex shader
      #version 330 core
      layout (location = 0) in vec3 coords;
      layout (location = 1) in vec3 color;
      layout (location = 2) in vec3 normal;
      out vec3 v_coords;
      out vec3 v_normal;
      out vec3 v_color;

      uniform mat4 MVP;
      uniform mat4 OM;
      uniform mat3 NormalMatrix;

      void main()
      {
        gl_Position = MVP * OM * vec4(coords, 1.0);
        v_normal = NormalMatrix * normal;
        v_color = color;
        v_coords = vec3(OM * vec4(coords, 1.0));
      };

      #fragment shader
      #version 330 core
      out vec4 FragColor;
      in vec3 v_coords;
      in vec3 v_normal;
      in vec3 v_color;

      uniform vec3 eye;
      uniform vec3 lightpos;

      void main()
      {
        vec3 whitened = mix(v_color, vec3(1.0, 1.0, 1.0), 0.2);
        vec3 lightdir = normalize(v_coords - lightpos);
        vec3 N = normalize(v_normal);
        vec3 refdir = reflect(lightdir, N);
        vec3 viewdir = normalize(eye - v_coords);
        vec3 ambient = v_color * 0.30;
        vec3 diffuse = v_color * max(0.0, dot(N, -lightdir)) * 0.50;
        vec3 specular = whitened * pow(max(0.0, dot(viewdir, refdir)), 32) * 0.20;
        vec3 contrast1 = v_color * max(0.0, dot(N, -normalize(vec3(1, -0.5, -0.2)))) * 0.05;
        vec3 contrast2 = v_color * max(0.0, dot(N, -normalize(vec3(0.5, 0.4, 0.9)))) * 0.04;
        vec3 contrast3 = v_color * max(0.0, dot(N, -normalize(vec3(0.4, 0.3, -0.5)))) * 0.07;
        FragColor = vec4(clamp(ambient + diffuse + specular + contrast1 + contrast2 + contrast3, 0.0, 1.0), 1.0);
      };
      '''
      ),
      (
      Name: P_UniformColorDefault;
      Code:
      '''
      #vertex shader
      #version 330 core
      layout (location = 0) in vec3 coords;

      uniform mat4 MVP;
      uniform mat4 OM;

      void main()
      {
        gl_Position = MVP * OM * vec4(coords, 1.0);
      };

      #fragment shader
      #version 330 core
      out vec4 FragColor;

      uniform vec3 color;

      void main()
      {
        FragColor = vec4(color, 1.0);
      };
      '''
      ),
      (
      Name: P_UniformColorLighting;
      Code:
      '''
      #vertex shader
      #version 330 core
      layout (location = 0) in vec3 coords;
      layout (location = 2) in vec3 normal;
      out vec3 v_coords;
      out vec3 v_normal;

      uniform mat4 MVP;
      uniform mat4 OM;
      uniform mat3 NormalMatrix;

      void main()
      {
        gl_Position = MVP * OM * vec4(coords, 1.0);
        v_normal = NormalMatrix * normal;
        v_coords = vec3(OM * vec4(coords, 1.0));
      };

      #fragment shader
      #version 330 core
      out vec4 FragColor;
      in vec3 v_coords;
      in vec3 v_normal;

      uniform vec3 eye;
      uniform vec3 color;
      uniform vec3 lightpos;

      void main()
      {
        vec3 whitened = mix(color, vec3(1.0, 1.0, 1.0), 0.2);
        vec3 lightdir = normalize(v_coords - lightpos);
        vec3 N = normalize(v_normal);
        vec3 refdir = reflect(lightdir, N);
        vec3 viewdir = normalize(eye - v_coords);
        vec3 ambient = color * 0.30;
        vec3 diffuse = color * max(0.0, dot(N, -lightdir)) * 0.50;
        vec3 specular = whitened * pow(max(0.0, dot(viewdir, refdir)), 32) * 0.20;
        vec3 contrast1 = color * max(0.0, dot(N, -normalize(vec3(1, -0.5, -0.2)))) * 0.05;
        vec3 contrast2 = color * max(0.0, dot(N, -normalize(vec3(0.5, 0.4, 0.9)))) * 0.04;
        vec3 contrast3 = color * max(0.0, dot(N, -normalize(vec3(0.4, 0.3, -0.5)))) * 0.07;
        FragColor = vec4(clamp(ambient + diffuse + specular + contrast1 + contrast2 + contrast3, 0.0, 1.0), 1.0);
      };
      '''
      ),
      (
      Name: P_Text;
      Code:
      '''
      #vertex shader
      #version 330 core
      layout (location = 0) in vec3 coords;
      layout (location = 1) in vec2 texcoords;

      out vec2 v_texcoords;

      uniform mat4 MVP;
      uniform mat4 OM;
      uniform int AnchorPoint;
      uniform bool FaceScreen;
      uniform float aspect;
      uniform vec2 displacement;
      uniform float size;

      const vec3[9] AnchorDeltas3 = vec3[]
        (
          vec3( 0.0,  0.0,  0.0),
          vec3( 0.0, -0.5,  0.0),
          vec3( 0.0, -1.0,  0.0),
          vec3(-0.5,  0.0,  0.0),
          vec3(-0.5, -0.5,  0.0),
          vec3(-0.5, -1.0,  0.0),
          vec3(-1.0,  0.0,  0.0),
          vec3(-1.0, -0.5,  0.0),
          vec3(-1.0, -1.0,  0.0)
        );

      const vec2[9] AnchorDeltas2 = vec2[]
        (
          vec2( 0.0,  0.0),
          vec2(-0.5,  0.0),
          vec2(-1.0,  0.0),
          vec2( 0.0,  0.5),
          vec2(-0.5,  0.5),
          vec2(-1.0,  0.5),
          vec2( 0.0,  1.0),
          vec2(-0.5,  1.0),
          vec2(-1.0,  1.0)
        );

      void main()
      {
        if (FaceScreen)
        {
          gl_Position = MVP * OM * vec4(0.0, 0.0, 0.0, 1.0);
          gl_Position.xy = gl_Position.xy +
            (vec2(0.0, -1.0) + texcoords + AnchorDeltas2[AnchorPoint]) * vec2(aspect, 1.0) * pow(determinant(OM) / pow(aspect, 2), 1.0/3.0) * size +
            displacement;
          v_texcoords = texcoords;
        }
        else
        {
          gl_Position = MVP * OM * vec4(size * (coords + AnchorDeltas3[AnchorPoint]), 1.0);
          v_texcoords = texcoords;
        }
      };

      #fragment shader
      #version 330 core
      out vec4 FragColor;
      in vec2 v_texcoords;

      uniform sampler2D screentex;
      uniform vec3 color;
      uniform float opacity;

      void main()
      {
        FragColor = texture(screentex, v_texcoords) * opacity + vec4(color, 0.0);
        if (FragColor.a == 0.0) discard;
      };
      '''
      ),
      (
      Name: P_Tex;
      Code:
      '''
      #vertex shader
      #version 330 core
      layout (location = 0) in vec2 coords;
      layout (location = 1) in vec2 texcoords;

      out vec2 v_texcoords;

      void main()
      {
        gl_Position = vec4(coords, 0.0, 1.0);
        v_texcoords = texcoords;
      };

      #fragment shader
      #version 330 core
      out vec4 FragColor;
      in vec2 v_texcoords;

      uniform sampler2D screentex;
      uniform float t;

      void main()
      {
        vec2 texcoords = v_texcoords;
        FragColor = texture(screentex, texcoords);
      };
      '''
      ),
      (
      Name: P_Image;
      Code:
      '''
      #vertex shader
      #version 330 core
      layout (location = 0) in vec3 coords;
      layout (location = 1) in vec2 texcoords;

      out vec2 v_texcoords;

      uniform mat4 MVP;
      uniform mat4 OM;

      void main()
      {
        gl_Position = MVP * OM * vec4(coords, 1.0);
        v_texcoords = texcoords;
      };

      #fragment shader
      #version 330 core
      out vec4 FragColor;
      in vec2 v_texcoords;

      uniform sampler2D screentex;
      uniform int transpmode;
      uniform vec3 transpcolor;
      uniform vec3 opaquecolor;

      const int tcmOff      = 0;
      const int tcmEqual    = 1;
      const int tcmDistance = 2;
      const int tcmBipolar  = 3;

      const vec3 epsilon = vec3(1.0 / 255.0);

      void main()
      {
        FragColor = texture(screentex, v_texcoords);
        switch (transpmode)
        {
          case tcmOff:
            break;
          case tcmEqual:
            if (all(lessThanEqual(abs(FragColor.rgb - transpcolor), epsilon))) discard;
            break;
          case tcmDistance:
            FragColor.a = distance(FragColor.rgb, transpcolor) / sqrt(3);
            break;
          case tcmBipolar:
            vec3 delta = opaquecolor - transpcolor;
            float t = dot(FragColor.rgb - transpcolor, delta) / dot(delta, delta);
            FragColor.a = t;
            break;
        }
      };
      '''
      ),
      (
      Name: P_UniformColorLightingUnisided;
      Code:
      '''
      #vertex shader
      #version 330 core
      layout (location = 0) in vec3 coords;
      layout (location = 2) in vec3 normal;
      out vec3 v_coords;
      out vec3 v_normal;

      uniform mat4 MVP;
      uniform mat4 OM;
      uniform mat3 NormalMatrix;

      void main()
      {
        gl_Position = MVP * OM * vec4(coords, 1.0);
        v_normal = NormalMatrix * normal;
        v_coords = vec3(OM * vec4(coords, 1.0));
      };

      #fragment shader
      #version 330 core
      out vec4 FragColor;
      in vec3 v_coords;
      in vec3 v_normal;

      uniform vec3 eye;
      uniform vec3 color;
      uniform vec3 lightpos;

      void main()
      {
        vec3 whitened = mix(color, vec3(1.0, 1.0, 1.0), 0.2);
        vec3 lightdir = normalize(v_coords - lightpos);
        vec3 N = normalize(v_normal);
        vec3 refdir = reflect(lightdir, N);
        vec3 viewdir = normalize(eye - v_coords);
        vec3 ambient = color * 0.30;
        vec3 diffuse = color * abs(dot(N, -lightdir)) * 0.50;
        vec3 specular = whitened * pow(abs(dot(viewdir, refdir)), 32) * 0.20;
        vec3 contrast1 = color * abs(dot(N, -normalize(vec3(1, -0.5, -0.2)))) * 0.05;
        vec3 contrast2 = color * abs(dot(N, -normalize(vec3(0.5, 0.4, 0.9)))) * 0.04;
        vec3 contrast3 = color * abs(dot(N, -normalize(vec3(0.4, 0.3, -0.5)))) * 0.07;
        FragColor = vec4(clamp(ambient + diffuse + specular + contrast1 + contrast2 + contrast3, 0.0, 1.0), 1.0);
      };
      '''
      ),
      (
      Name: P_Scatter;
      Code:
      '''
      #vertex shader
      #version 330 core
      layout (location = 0) in vec3 coords;
      layout (location = 2) in vec3 normal;
      layout (location = 3) in vec3 origin;
      out vec3 v_normal;

      uniform mat4 MVP;
      uniform mat4 OM;
      uniform mat3 NormalMatrix;
      uniform float size;

      void main()
      {
        gl_Position = MVP * OM * vec4(origin + size*coords, 1.0);
        v_normal = NormalMatrix * normal;
      };

      #fragment shader
      #version 330 core
      out vec4 FragColor;
      in vec3 v_normal;

      uniform vec3 color;

      const vec3 lightdir = vec3(1.0, 1.0, 1.0) / sqrt(3);

      void main()
      {
        vec3 N = normalize(v_normal);
        vec3 ambient = color * 0.5;
        vec3 diffuse = color * max(0.0, dot(N, lightdir)) * 0.5;
        FragColor = vec4(clamp(ambient + diffuse, 0.0, 1.0), 1.0);
      };
      '''
      ),
      (
      Name: P_AdvScatter;
      Code:
      '''
      #vertex shader
      #version 330 core
      layout (location = 0) in vec3 coords;
      layout (location = 2) in vec3 normal;
      layout (location = 3) in vec3 origin;
      layout (location = 4) in vec3 color;
      layout (location = 5) in float relsize;
      out vec3 v_normal;
      out vec3 v_color;

      uniform mat4 MVP;
      uniform mat4 OM;
      uniform mat3 NormalMatrix;
      uniform float size;

      void main()
      {
        gl_Position = MVP * OM * vec4(origin + relsize*size*coords, 1.0);
        v_normal = NormalMatrix * normal;
        v_color = color;
      };

      #fragment shader
      #version 330 core
      out vec4 FragColor;
      in vec3 v_normal;
      in vec3 v_color;

      const vec3 lightdir = vec3(1.0, 1.0, 1.0) / sqrt(3);

      void main()
      {
        vec3 N = normalize(v_normal);
        vec3 ambient = v_color * 0.5;
        vec3 diffuse = v_color * max(0.0, dot(N, lightdir)) * 0.5;
        FragColor = vec4(clamp(ambient + diffuse, 0.0, 1.0), 1.0);
      };
      '''
      ),
      (
      Name: P_VectorField;
      Code:
      '''
      #vertex shader
      #version 330 core
      layout (location = 0) in vec3 coords;
      layout (location = 2) in vec3 normal;
      layout (location = 3) in vec3 origin;
      layout (location = 4) in vec3 trc1;
      layout (location = 5) in vec3 trc2;
      layout (location = 6) in vec3 trc3;
      layout (location = 7) in vec3 color;
      out vec3 v_normal;
      out vec3 v_color;

      uniform mat4 MVP;
      uniform mat4 OM;
      uniform mat3 NormalMatrix;
      uniform float size;
      uniform vec2 displacement;

      void main()
      {
        mat3 A = mat3(trc1, trc2, trc3);
        gl_Position = MVP * OM * vec4(origin + size*A*(coords + vec3(0, 0, displacement.x)), 1.0);
        v_normal = NormalMatrix * normal;
        v_color = color;
      };

      #fragment shader
      #version 330 core
      out vec4 FragColor;
      in vec3 v_normal;
      in vec3 v_color;

      uniform vec3 color;
      uniform bool AttribColors;

      const vec3 lightdir = vec3(1.0, 1.0, 1.0) / sqrt(3);
      const vec3 shadowdir = vec3(0.0, 0.0, -1.0);

      void main()
      {
        vec3 actcolor = mix(color, v_color, float(AttribColors));
        vec3 N = normalize(v_normal);
        vec3 ambient = actcolor * 0.5;
        vec3 diffuse = actcolor * max(0.0, dot(N, lightdir)) * 0.5;
        vec3 shadow = actcolor * max(0.0, pow(dot(N, shadowdir), 64)) * 0.05;
        FragColor = vec4(clamp(ambient + diffuse - shadow, 0.0, 1.0), 1.0);
      };
      '''
      )
    );

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
    for var sh in Shaders do
      if SameText(sh.Name, AName) then
        Exit(LoadProgramResource(AName, sh.Code));
    raise ERglError.CreateFmt('Shader not found: "%s"', [AName]);
  finally
    SL.Free;
  end;
end;

function TProgramMgr.LoadProgramResource(const AName: string; const AData: string): 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.Split([#13#10]) 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 }

constructor TScene.Create(ACtl: TVisCtl3D);
begin
  inherited;
end;

{ TRefAxes }

constructor TRefAxes.Create(ACtl: TVisCtl3D);
begin
  inherited;
  FDefaultProgram := P_Lighting;
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;

constructor TGeometricObject3D.Create(ACtl: TVisCtl3D);
begin
  inherited;
  FDefaultProgram := P_UniformColorLighting;
  FDirection := vec(0, 0, 1);
  FScale := vec(1, 1, 1);
  FManualMatrix := rglm4.Identity;
  ComputeOM;
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;

constructor TAbstractSurface3D.Create(ACtl: TVisCtl3D);
begin
  inherited;
  FShowSurface := True;
  FParamCurveCounts.nx := 64;
  FParamCurveCounts.ny := 64;
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 }

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

function TEllipsoid.GetScale: rglv;
begin
  Result := Scale;
end;

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

{ TSphere }

constructor TSphere.Create(ACtl: TVisCtl3D);
begin
  inherited;
end;

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

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

{ TCylinder }

constructor TCylinder.Create(ACtl: TVisCtl3D);
begin
  inherited;
  FSurfProc := rglCylinder;
  FStockSurface := True;
  FStockID := STOCKSURF_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 }

constructor TCone.Create(ACtl: TVisCtl3D);
begin
  inherited;
  FSurfProc := rglCone;
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;
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;

{ 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;
  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 }

constructor TDisk.Create(ACtl: TVisCtl3D);
begin
  inherited;
  FSurfProc := rglDisk;
  FStockSurface := True;
  FStockID := STOCKSURF_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;
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;
  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 }

constructor TScatterPlot.Create(ACtl: TVisCtl3D);
begin
  inherited;
  FSize := 0.1;
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.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;
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;

function RBSwap(AColor: Integer): Integer;
begin
  Result := AColor and $FF00FF00 or Byte(AColor shr 16) or Byte(AColor) shl 16;
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 := TColor(RBSwap(Round(Value[5*i + 3])));
    FPoints[i][3] := GetRValue(Color) / 255;
    FPoints[i][4] := GetGValue(Color) / 255;
    FPoints[i][5] := GetBValue(Color) / 255;
    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 }

constructor TVectorField.Create(ACtl: TVisCtl3D);
begin
  inherited;
  FDefaultProgram := P_VectorField;
  FSize := 1.0;
  FColor := clRed;
  FAnchorPoint := 0.5;
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;

constructor TImageRect.Create(ACtl: TVisCtl3D);
begin
  inherited;
  FDefaultProgram := P_Image;
  FBitmap := TBitmap.Create;
  FBitmap.OnChange := BitmapChanged;
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 }

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;
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;

constructor TAxes.Create(ACtl: TVisCtl3D);
begin

  inherited;

  FXAxis := CreateChild<TAxis>;
  FXAxis.FIndex := 0;
  FXAxis.FCylinder.Direction := vec(1, 0, 0);
  FXAxis.FCylinder.Color := clRed;
  FXAxis.OnChange := AxisChanged;

  FYAxis := CreateChild<TAxis>;
  FYAxis.FIndex := 1;
  FYAxis.FCylinder.Direction := vec(0, 1, 0);
  FYAxis.FCylinder.Color := clGreen;
  FYAxis.OnChange := AxisChanged;

  FZAxis := CreateChild<TAxis>;
  FZAxis.FIndex := 2;
  FZAxis.FCylinder.Direction := vec(0, 0, 1);
  FZAxis.FCylinder.Color := clBlue;
  FZAxis.OnChange := AxisChanged;

  var LXYGrid := CreateChild<TGrid>;
  LXYGrid.FIndex := 0;
  LXYGrid.Direction := vec(0, 0, 1);
  LXYGrid.OnChange := GridChanged;

  var LYZGrid := CreateChild<TGrid>;
  LYZGrid.FIndex := 0;
  LYZGrid.Direction := vec(1, 0, 0);
  LYZGrid.Rotation := 90;
  LYZGrid.OnChange := GridChanged;

  var LXZGrid := CreateChild<TGrid>;
  LXZGrid.FIndex := 0;
  LXZGrid.Direction := vec(0, 1, 0);
  LXZGrid.Rotation := -90;
  LXZGrid.OnChange := GridChanged;

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 }

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;
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('-', '−')
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));

  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);
      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 }

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;
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;
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 := ObjFileParseObjData(AData.Split([#13#10]));
  Recreate;
  Changed;
end;

constructor TObjModel.Create(ACtl: TVisCtl3D);
begin
  inherited;
end;

procedure TObjModel.LoadModel(const AData: TArray<string>);
begin
  FSource := string.Join(#13#10, AData);
  FBuf := ObjFileParseObjData(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;
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;
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.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 }

constructor TSolidCone.Create(ACtl: TVisCtl3D);
begin
  inherited;
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;
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;
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;
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;
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;
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;

{ TPublishedCoordinates }

constructor TPublishedCoordinates.Create(AVector: Prglv;
  const ANotifier: TProc);
begin
  if AVector = nil then
    raise Exception.Create('TPublishedCoordinates: Nil pointer.');
  inherited Create;
  FVectorPtr := AVector;
  FNotifier := ANotifier;
end;

function TPublishedCoordinates.GetCoordinate(AIndex: Integer): GLfloat;
begin
  if Assigned(FVectorPtr) and (AIndex in [0, 1, 2]) then
    Result := FVectorPtr.elem[AIndex]
  else
    Result := 0.0;
end;

procedure TPublishedCoordinates.SetCoordinate(AIndex: Integer;
  const Value: GLfloat);
begin
  if Assigned(FVectorPtr) and (AIndex in [0, 1, 2]) then
  begin
    FVectorPtr.elem[AIndex] := Value;
    if Assigned(FNotifier) then
      FNotifier();
  end;
end;

{ TView3D }

procedure TView3D.FixCamera(const ACenter: rglv; const ARelativePosition: rglv);
begin
  if Control = nil then
    Exit;
  if Control.Context = nil then
    Exit;
  if (Control.CameraPos <> ARelativePosition) or (Control.LookAt <> ACenter) then
  begin
    with TSphericalCoordinates(ARelativePosition) do
    begin
      Control.r := r;
      Control.θ := θ;
      Control.φ := φ;
      Control.LookAt := ACenter;
    end;
    Changed;
  end;
end;

procedure TView3D.FixCamera(const ACameraPose: TCameraPose);
begin
  FixCamera(ACameraPose.SceneCenter, ACameraPose.RelativePosition);
end;

procedure TView3D.FinishAnimation;
begin
  FAnimationEnd := Now;
end;

procedure TView3D.FixCamera(const ACameraPose: TCameraPoseSp);
begin
  FixCamera(ACameraPose.SceneCenter, ACameraPose.RelativePosition);
end;

procedure TView3D.AnimateTo(const ATargetCenter: rglv; const ATargetRelativePosition: rglv);
const
  Gamma = 4.0;
var
  i: Integer;
  F, t: Double;
begin

  if Control = nil then
    Exit;

  if Control.Context = nil then
    Exit;

  var LTargetCenter := ATargetCenter;
  var LCurrentCenter := Control.LookAt;

  var LTargetRelativePosition := rθφ(ATargetRelativePosition);
  var LCurrentRelativePosition := CameraRelativePositionSp;

  if Abs(LTargetRelativePosition.φ - LCurrentRelativePosition.φ) > Pi then
    if LTargetRelativePosition.φ > LCurrentRelativePosition.φ then
      LTargetRelativePosition.φ := LTargetRelativePosition.φ - 2*Pi
    else
      LCurrentRelativePosition.φ := LCurrentRelativePosition.φ - 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].SceneCenter := (1 - t) * LCurrentCenter + t * LTargetCenter;
    FAnimation[i].RelativePosition := (1 - t) * LCurrentRelativePosition + t * LTargetRelativePosition;
  end;

  FAnimationBegin := Now;
  FAnimationEnd := IncMilliSecond(FAnimationBegin,
    Round(1000 * AnimationDurationSec));
  FAnimationTimer.Enabled := True;

end;

procedure TView3D.AnimateTo(const ATargetCenter: rglv);
begin
  AnimateTo(ATargetCenter, CameraRelativePosition);
end;

procedure TView3D.AnimateTo(const ACameraPose: TCameraPose);
begin
  AnimateTo(ACameraPose.SceneCenter, ACameraPose.RelativePosition);
end;

procedure TView3D.AnimateTo(const ACameraPose: TCameraPoseSp);
begin
  AnimateTo(ACameraPose.SceneCenter, ACameraPose.RelativePosition);
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)
  );
  FixCamera(FAnimation[i]);
end;

constructor TView3D.Create(ACtl: TVisCtl3D);
begin
  inherited;
  FTargetCenterIntf := TPublishedCoordinates.Create(@ACtl.LookAt, Changed);
  FAnimationTimer := TAnimationTimer.Create(nil);
  FAnimationTimer.Control := Control;
  FAnimationTimer.Enabled := False;
  FAnimationTimer.OnTimer := AnimationTimerTimer;
end;

destructor TView3D.Destroy;
begin
  FreeAndNil(FAnimationTimer);
  FreeAndNil(FTargetCenterIntf);
  inherited;
end;

function TView3D.GetCameraRelativePosition: rglv;
begin
  Result := Control.CameraRelativePos;
end;

function TView3D.GetCameraRelativePositionSp: TSphericalCoordinates;
begin
  Result.r := Control.r;
  Result.θ := Control.θ;
  Result.φ := Control.φ;
end;

function TView3D.GetPhi: Double;
begin
  Result := 180 / Pi * Control.φ;
end;

function TView3D.GetPhiRad: Double;
begin
  Result := Control.φ;
end;

function TView3D.GetR: Double;
begin
  Result := Control.r;
end;

function TView3D.GetTheta: Double;
begin
  Result := 180 / Pi * Control.θ;
end;

function TView3D.GetThetaRad: Double;
begin
  Result := Control.θ;
end;

function TView3D.GetTargetCenter: rglv;
begin
  Result := Control.LookAt;
end;

procedure TView3D.SetCameraRelativePosition(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.SetCameraRelativePositionSp(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 / 180 * Value;
  if not SameValue(Control.φ, LValue) then
  begin
    Control.φ := rmod(LValue, 2*Pi);
    Changed;
  end;
end;

procedure TView3D.SetPhiRad(const Value: Double);
begin
  if not SameValue(Control.φ, Value) then
  begin
    Control.φ := rmod(Value, 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 / 180 * Value;
  if not SameValue(Control.θ, LValue) then
  begin
    Control.θ := EnsureRange(LValue, 0, Pi);
    Changed;
  end;
end;

procedure TView3D.SetThetaRad(const Value: Double);
begin
  if not SameValue(Control.θ, Value) then
  begin
    Control.θ := EnsureRange(Value, 0, Pi);
    Changed;
  end;
end;

procedure TView3D.SetTargetCenter(const Value: rglv);
begin
  if Control.LookAt <> Value then
  begin
    Control.LookAt := Value;
    Changed;
  end;
end;

{ TSphericalCoordinates }

constructor TSphericalCoordinates.Create(const r: Single; const θ: Single; const φ: Single);
begin
  Self.r := r;
  Self.θ := θ;
  Self.φ := φ;
end;

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 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;

{ TCameraPose }

class operator TCameraPose.Equal(const Left: TCameraPose; const Right: TCameraPose): Boolean;
begin
  Result := (Left.SceneCenter = Right.SceneCenter) and (Left.RelativePosition = Right.RelativePosition);
end;

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

{ TCameraPoseSp }

class operator TCameraPoseSp.Equal(const Left: TCameraPoseSp; const Right: TCameraPoseSp): Boolean;
begin
  Result := (Left.SceneCenter = Right.SceneCenter) and (Left.RelativePosition = Right.RelativePosition);
end;

class operator TCameraPoseSp.NotEqual(const Left: TCameraPoseSp; const Right: TCameraPoseSp): Boolean;
begin
  Result := not (Left = Right);
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 }

constructor TArrow.Create(ACtl: TVisCtl3D);
begin

  inherited;

  FLineWidth := 0.02;
  FHeadSize := 0.2;
  Q := 0.5;

  FHead := CreateChild<TSolidCone>;
  FLine := CreateChild<TSolidCylinder>;

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;

function Tokenize(const S: string; ADefs: TDictionary<string, string>): TArray<string>;

  function TDA(const AToken: string): string;
  begin
    if (ADefs = nil) or (ADefs.Count = 0) or
      not ADefs.TryGetValue(AToken, Result)
    then
      Result := AToken;
  end;

begin

  var ActualLength := 0;
  SetLength(Result, 32);

  var InToken := False;
  var p := 0;

  for var i := 1 to S.Length do
  begin

    if InToken then
    begin
      if S[i].IsWhiteSpace then
      begin
        InToken := False;
        Result[ActualLength] := TDA(Copy(S, p, i - p));
        Inc(ActualLength);
        if ActualLength = Length(Result) then
          Break;
      end;
    end
    else
    begin
      if not S[i].IsWhiteSpace then
      begin
        InToken := True;
        p := i;
      end;
    end;

  end;

  if InToken and (ActualLength < Length(Result)) then
  begin
    Result[ActualLength] := TDA(Copy(S, p));
    Inc(ActualLength);
  end;

  SetLength(Result, ActualLength);

end;

procedure ParseVec(AList: TList<rglv>; const AData: TArray<string>;
  ANormalize: Boolean);
begin

  if Length(AData) < 4 then
    raise ERglObjFileError.Create('Vector is of too small dimension.');

  var v := vec(
    StrToFloat(AData[1], InvFS),
    StrToFloat(AData[2], InvFS),
    StrToFloat(AData[3], InvFS)
  );

  if ANormalize and not IsZero(v.Norm) then
    v := v.Normalized;

  if Assigned(AList) then
    AList.Add(v);

end;

type
  TVertexData = record
    VertexIndex: Integer;
    TextureIndex: Integer;
    NormalIndex: Integer;
    FaceData: GLr3n3v;
  end;

function ParseVertex(const AData: string): TVertexData;
begin

  Result := Default(TVertexData);

  var P := AData.Split(['/']);

  if Length(P) >= 1 then
    Result.VertexIndex := StrToInt(P[0]);

  if Length(P) >= 2 then
  begin
    if (Length(P) = 2) or not P[1].IsEmpty then
      Result.TextureIndex := StrToInt(P[1]);
  end;

  if Length(P) >= 3 then
    Result.NormalIndex := StrToInt(P[2]);

end;

procedure TranslateVertex(var Vertex: TVertexData; AVertices: TList<rglv>);
begin
  case Sign(Vertex.VertexIndex) of
    NegativeValue:
      Vertex.FaceData.r := AVertices[AVertices.Count + Vertex.VertexIndex];
    PositiveValue:
      Vertex.FaceData.r := AVertices[Vertex.VertexIndex - 1];
  else
    raise ERglObjFileError.Create('Invalid vertex index.');
  end;
end;

procedure TranslateNormal(var Vertex: TVertexData; ANormals: TList<rglv>;
  const ADefNormal: rglv);
begin
  case Sign(Vertex.NormalIndex) of
    NegativeValue:
      Vertex.FaceData.n := ANormals[ANormals.Count + Vertex.NormalIndex];
    PositiveValue:
      Vertex.FaceData.n := ANormals[Vertex.NormalIndex - 1];
  else
    Vertex.FaceData.n := ADefNormal;
  end;
end;

procedure ParseFace(AVertices, ANormals: TList<rglv>; AFaces: TList<GLfloat6>;
  AData: TArray<string>);
begin

  if Length(AData) < 4 then
    raise ERglObjFileError.Create('Vector is of too small dimension.');

  if Length(AData) >= 5 then
  begin
    ParseFace(AVertices, ANormals, AFaces, Copy(AData, 0, 4));
    for var i := 3 to High(AData) - 1 do
      ParseFace(AVertices, ANormals, AFaces, ['f', AData[1], AData[i], AData[Succ(i)]]);
    Exit;
  end;

  var A := ParseVertex(AData[1]);
  var B := ParseVertex(AData[2]);
  var C := ParseVertex(AData[3]);

  TranslateVertex(A, AVertices);
  TranslateVertex(B, AVertices);
  TranslateVertex(C, AVertices);

  var LComputedNormal := rglv.Zero;

  if (A.NormalIndex = 0) or (B.NormalIndex = 0) or (C.NormalIndex = 0) then
  begin
    var u := B.FaceData.r - A.FaceData.r;
    var v := C.FaceData.r - B.FaceData.r;
    LComputedNormal := u xor v;
    if not IsZero(LComputedNormal.Norm) then
      LComputedNormal := LComputedNormal.Normalized;
  end;

  TranslateNormal(A, ANormals, LComputedNormal);
  TranslateNormal(B, ANormals, LComputedNormal);
  TranslateNormal(C, ANormals, LComputedNormal);

  if Assigned(AFaces) then
  begin
    AFaces.Add(GLfloat6(A.FaceData));
    AFaces.Add(GLfloat6(B.FaceData));
    AFaces.Add(GLfloat6(C.FaceData));
  end;

end;

function ObjFileParseObjData(const AData: TArray<string>): TArray<GLfloat6>;
begin

  var Defines := TDictionary<string, string>.Create;
  try
    var Vertices := TList<rglv>.Create;
    try
      var Normals := TList<rglv>.Create;
      try
        var Faces := TList<GLfloat6>.Create;
        try

          var i := 0;

          try

            while i <= High(AData) do
            begin

              var L := AData[i].Trim;
              Inc(i);

              if L.IsEmpty or L.StartsWith('#') then
                Continue;

              var P := Tokenize(L, Defines);

              if Length(P) = 0 then
                Continue;

              if P[0] = 'v' then
                ParseVec(Vertices, P, False)
              else if P[0] = 'vn' then
                ParseVec(Normals, P, True)
              else if P[0] = 'f' then
                ParseFace(Vertices, Normals, Faces, P)
              else if (P[0] = 'def') and (Length(P) >= 2) then
                Defines.Add(P[1], string.Join(#32, Copy(P, 2)));

            end;

          except
            on E: Exception do
              raise ERglObjFileError.CreateFmt('Couldn''t parse OBJ file at line %d.'#32 + E.Message, [i]);
          end;

          Result := Faces.ToArray;

        finally
          Faces.Free;
        end;
      finally
        Normals.Free;
      end;
    finally
      Vertices.Free;
    end;
  finally
    Defines.Free;
  end;

end;

type
  PFloat = ^Single;

function FormatFloat(p: Single): string;
begin
  Result := SysUtils.FormatFloat('0.########', p, InvFS);
end;

function FormatFloat6(p: PFloat; const ASep: string): string;
begin
  var LSep := ASep;
  if LSep = '' then
    LSep := #32;
  Result := FormatFloat(p^);
  Inc(p); Result := Result + LSep + FormatFloat(p^);
  Inc(p); Result := Result + LSep + FormatFloat(p^);
  Inc(p); Result := Result + LSep + FormatFloat(p^);
  Inc(p); Result := Result + LSep + FormatFloat(p^);
  Inc(p); Result := Result + LSep + FormatFloat(p^) + LSep.TrimRight;
end;

function ObjFilePrintRawBuffer(ABuffer: Pointer; ALength: Integer;
  const ASep: string): string;
begin

  const FloatCount = ALength div SizeOf(Single);
  const VertexCount = FloatCount div 6;

  var L: TArray<string> := nil;

  SetLength(L, VertexCount);

  var p: PFloat := PFloat(ABuffer);
  for var i := 0 to High(L) do
  begin
    L[i] := FormatFloat6(p, ASep);
    Inc(p, 6);
  end;

  Result := string.Join(#13#10, L);

end;

function ObjFilePrintRawBuffer(ABuffer: TArray<GLfloat6>;
  const ASep: string): string;
begin
  Result := ObjFilePrintRawBuffer(Pointer(ABuffer), Length(ABuffer) * SizeOf(GLfloat6),
    ASep);
end;

procedure Register;
begin
  RegisterComponents('Rejbrand', [TVisCtl3D]);
end;

initialization
  InvFS := TFormatSettings.Invariant;

end.

Downloads

Delphi source and package (zipped)

Licence

Rejbrand Algosim 3D Visualisation Control

Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:

The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.

THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

Table of contents

Documentation

Surfaces

Graphs

Coloured graphs

Parameterised surfaces

Curves

Coloured curves

Scatter plots

Vector fields

Geometric primitives

OBJ models

Text and image planes

Coordinate axes

Additional coordinate systems

Common object properties

Object groups

The camera

Keyboard interface

Orbit

Translation of centre point

Mouse interface

Mouse input modes

Programmatic interface

Projections

Light position

Built-in documentation

OpenGL implementation data

System requirements

Source code

Downloads

Licence