{$WARN DUPLICATE_CTOR_DTOR OFF}
{$WARN PRIVATE_PROPACCESSOR OFF}
unit rgl;
interface
uses
Windows, SysUtils, OpenGL, OpenGLext, Generics.Defaults, Generics.Collections,
Messages, Graphics, Types, UITypes, Classes, Controls, Forms, ASObjects, ASNum,
Dialogs, Menus, ExtCtrls, AppEvnts, TableDialog, VisCtl, VisCtl2D;
const
P_Default = 'default';
P_UniformColorDefault = 'ucdef';
P_Lighting = 'light';
P_UniformColorLighting = 'uclight';
P_UniformColorLightingUnisided = 'uclightus';
P_UniformColorInfinity = 'ucinf';
P_Tex = 'tex';
P_Scatter = 'scatter';
P_AdvScatter = 'advsca';
P_VectorField = 'vf';
P_Image = 'zimage';
P_Text = 'ztext';
type
TPPE = (ppIdentity, ppGreyscale, ppInvert, ppFlipH, ppFlipV, ppBinary,
ppSpectra, ppEdgeDetect, ppBlur, ppSharpen, ppUnderwater);
TPPEHelper = record helper for TPPE
function ID: Integer;
function Name: string;
class function FromString(const S: string): TPPE; static;
end;
TPPEs = set of TPPE;
const
AnimatedEffects: TPPEs = [ppUnderwater];
type
TStockSurfaceIndex = (
STOCKSURF_SPHERE = 1,
STOCKSURF_CYLINDER = 2,
STOCKSURF_PLANE = 3,
STOCKSURF_DISK = 4,
STOCKSURF_SPHERELET= 5,
STOCKSURF_ARROW = 6
);
type
GLfloat2 = array[0..1] of GLfloat;
GLfloat3 = array[0..2] of GLfloat;
GLfloat4 = array[0..3] of GLfloat;
GLfloat5 = array[0..4] of GLfloat;
GLfloat6 = array[0..5] of GLfloat;
GLfloat7 = array[0..6] of GLfloat;
GLfloat9 = array[0..8] of GLfloat;
GLfloat15 = array[0..14] of GLfloat;
ERglError = class(Exception);
rglv2 = record
class operator Add(const Left, Right: rglv2): rglv2;
class operator Subtract(const Left, Right: rglv2): rglv2;
class operator Multiply(const Left: Single; const Right: rglv2): rglv2;
class operator Multiply(const Left: rglv2; const Right: Single): rglv2;
class operator Multiply(const Left, Right: rglv2): Single;
class operator Divide(const Left: rglv2; const Right: Single): rglv2;
class operator Equal(const Left, Right: rglv2): Boolean;
class operator NotEqual(const Left, Right: rglv2): Boolean;
class operator Implicit(const arr: GLfloat2): rglv2;
class operator Implicit(const v: rglv2): GLfloat2;
class operator Implicit(const v: TRealVector): rglv2;
function Norm: Single;
function Normalized: rglv2;
function NormSquare: Single;
constructor Create(const x, y: Single);
function ptr: PGLfloat;
class function Zero: rglv2; static;
case Byte of
0:
(elem: GLfloat2);
1:
(x, y: GLfloat);
2:
(u, v: GLfloat);
3:
(s, t: GLfloat);
end;
rglv = record
class operator Add(const Left, Right: rglv): rglv;
class operator Subtract(const Left, Right: rglv): rglv;
class operator Multiply(const Left: Single; const Right: rglv): rglv;
class operator Multiply(const Left: rglv; const Right: Single): rglv;
class operator Multiply(const Left, Right: rglv): Single;
class operator Divide(const Left: rglv; const Right: Single): rglv;
class operator Equal(const Left, Right: rglv): Boolean;
class operator NotEqual(const Left, Right: rglv): Boolean;
class operator LogicalXor(const Left, Right: rglv): rglv;
class operator Implicit(const arr: GLfloat3): rglv;
class operator Implicit(const v: rglv): GLfloat3;
class operator Implicit(const c: TColor): rglv;
class operator Implicit(const v: TRealVector): rglv;
function xy: rglv2;
function Norm: Single;
function Normalized: rglv;
function NormSquare: Single; inline;
constructor Create(const x, y, z: Single);
function ptr: PGLfloat;
class function Zero: rglv; static;
case Byte of
0:
(elem: GLfloat3);
1:
(x, y, z: GLfloat);
2:
(r, g, b: GLfloat);
3:
(s, t, p: GLfloat);
end;
TCartesianCoordinates = rglv;
TSphericalCoordinates = record
r, θ, φ: Single;
class operator Implicit(const ACoords: TSphericalCoordinates): TCartesianCoordinates;
class operator Implicit(const ACoords: TCartesianCoordinates): TSphericalCoordinates;
class operator Equal(const Left, Right: TSphericalCoordinates): Boolean;
class operator NotEqual(const Left, Right: TSphericalCoordinates): Boolean;
class operator Add(const Left, Right: TSphericalCoordinates): TSphericalCoordinates;
class operator Multiply(const Left: Single; Right: TSphericalCoordinates): TSphericalCoordinates;
class function RealVectorAsSphericalCoordinates(const ARealVector: TRealVector): TSphericalCoordinates; static;
end;
rθφ = TSphericalCoordinates;
rglv4 = record
class operator Add(const Left, Right: rglv4): rglv4;
class operator Subtract(const Left, Right: rglv4): rglv4;
class operator Multiply(const Left: Single; const Right: rglv4): rglv4;
class operator Multiply(const Left, Right: rglv4): Single;
class operator Divide(const Left: rglv4; const Right: Single): rglv4;
class operator Equal(const Left, Right: rglv4): Boolean;
class operator NotEqual(const Left, Right: rglv4): Boolean;
function Norm: Single;
function Normalized: rglv4;
function NormSquare: Single;
constructor Create(const x, y, z, w: Single);
function ptr: PGLfloat;
class function Zero: rglv4; static;
case Byte of
0:
(elem: GLfloat4);
1:
(x, y, z, w: GLfloat);
2:
(r, g, b, a: GLfloat);
3:
(s, t, p, q: GLfloat);
end;
rglm = record
private const
_dim = 3;
_dimh = _dim - 1;
_elemc = _dim * _dim;
_elemh = _elemc - 1;
public
class operator Add(const Left, Right: rglm): rglm;
class operator Subtract(const Left, Right: rglm): rglm;
class operator Multiply(const Left: Single; const Right: rglm): rglm;
class operator Multiply(const Left: rglm; const Right: rglv): rglv;
class operator Multiply(const Left, Right: rglm): rglm;
class operator Divide(const Left: rglm; const Right: Single): rglm;
class operator Equal(const Left, Right: rglm): Boolean;
class operator NotEqual(const Left, Right: rglm): Boolean;
constructor Create(const m11, m12, m13, m21, m22, m23, m31, m32, m33: Single);
constructor CreateFromColumns(const u, v, w: rglv);
function ptr: PGLfloat;
function Transpose: rglm;
function Inverse: rglm;
function ToString: string;
class function Zero: rglm; static;
class function Identity: rglm; static;
case Boolean of
False:
(elem: array[0.._elemh] of GLfloat);
True:
(m: array[0.._dimh] of array [0.._dimh] of GLfloat);
end;
rglm4 = record
private const
_dim = 4;
_dimh = _dim - 1;
_elemc = _dim * _dim;
_elemh = _elemc - 1;
public
class operator Add(const Left, Right: rglm4): rglm4;
class operator Subtract(const Left, Right: rglm4): rglm4;
class operator Multiply(const Left: Single; const Right: rglm4): rglm4;
class operator Multiply(const Left: rglm4; const Right: rglv4): rglv4;
class operator Multiply(const Left, Right: rglm4): rglm4;
class operator Divide(const Left: rglm4; const Right: Single): rglm4;
class operator Equal(const Left, Right: rglm4): Boolean;
class operator NotEqual(const Left, Right: rglm4): Boolean;
class operator Explicit(const Mat4: rglm4): rglm;
class operator Explicit(const Mat: rglm): rglm4;
constructor Create(const m11, m12, m13, m14, m21, m22, m23, m24, m31, m32, m33, m34,
m41, m42, m43, m44: Single);
function ptr: PGLfloat;
function Transpose: rglm4;
class function Identity: rglm4; static;
case Boolean of
False:
(elem: array[0.._elemh] of GLfloat);
True:
(m: array[0.._dimh] of array [0.._dimh] of GLfloat);
end;
GLr3c3 = packed record
x, y, z,
r, g, b: GLfloat
end;
GLr3c3v = packed record
r, c: rglv;
end;
GLr3u3 = packed record
x, y, z,
u, v: GLfloat
end;
GLr3u3v = packed record
r: rglv;
u: rglv2;
end;
GLr3c4 = packed record
x, y, z,
r, g, b, a: GLfloat
end;
GLr3c4v = packed record
r: rglv;
c: rglv4
end;
GLr3c3f1 = packed record
x, y, z,
r, g, b,
q: GLfloat
end;
GLr3c3f1v = packed record
r, c: rglv;
q: GLfloat;
end;
GLr3n3 = packed record
x, y, z,
u, v, w: GLfloat
end;
GLr3n3v = packed record
r, n: rglv;
end;
GLr3v3 = packed record
x, y, z,
u, v, w: GLfloat
end;
GLr3v3v = packed record
r, v: rglv;
end;
GLr3c3n3 = packed record
x, y, z,
r, g, b,
u, v, w: GLfloat
end;
GLr3c3n3v = packed record
r, c, n: rglv;
end;
GLr3v3c3 = packed record
x, y, z,
u, v, w,
r, g, b: GLfloat
end;
GLr3v3c3v = packed record
r, v, c: rglv;
end;
GLr3m9c3v = packed record
r: rglv;
m: rglm;
c: rglv;
end;
function vec(const x, y, z: Single): rglv;
function vec2(const x, y: Single): rglv2;
function vec4(const x, y, z, w: Single): rglv4;
function mat(const m11, m12, m13, m21, m22, m23, m31, m32, m33: Single): rglm;
function mat4(const m11, m12, m13, m14, m21, m22, m23, m24, m31, m32, m33, m34,
m41, m42, m43, m44: Single): rglm4;
function mat_transpose(const m11, m12, m13, m21, m22, m23, m31, m32, m33: Single): rglm;
const
rglv_red: rglv = (r: 1.0; g: 0.0; b: 0.0);
rglv_green: rglv = (r: 0.0; g: 1.0; b: 0.0);
rglv_blue: rglv = (r: 0.0; g: 0.0; b: 1.0);
rglv_black: rglv = (r: 0.0; g: 0.0; b: 0.0);
rglv_white: rglv = (r: 1.0; g: 1.0; b: 1.0);
function rglLookAt(const eyeX, eyeY, eyeZ: Single;
const centerX, centerY, centerZ: Single; const upX, upY, upZ: Single): rglm4; overload;
function rglLookAt(const eye, center, up: rglv): rglm4; overload;
function rglPerspective(const fovy, aspect, &near, &far: Double): rglm4;
function rglOrtho(const left, right, bottom, top, &near, &far: Double): rglm4;
function rglOrtho2D(const left, right, bottom, top: Double): rglm4;
function rglScale(const x, y, z: Single): rglm4;
function rglTranslate(const x, y, z: Single): rglm4; overload;
function rglTranslate(const v: rglv): rglm4; overload;
function rglRotate(const a, x, y, z: Single): rglm4; overload;
function rglRotate(const a: Single; const v: rglv): rglm4; overload;
function rglGetString(name: GLenum): string;
type
TSurfParamFcn = function(const u, v: Double): rglv;
TSurfParamColorFcn = function(const u, v: Double): rglv;
TSurfParamNormalFcn = function(const u, v: Double): rglv;
TCurveParamFcn = function(const t: Double): rglv;
TCurveParamColorFcn = function(const t: Double): rglv;
TCurveParamNormalFcn = function(const t: Double): rglv;
procedure TriangulateSurface(F: TSurfParamFcn;
N: TSurfParamNormalFcn; const umin, umax, vmin, vmax: Double;
A, B, pccx, pccy: Integer; Normalize: Boolean; out Vertices: TArray<GLfloat6>;
out Indices, PCIs: TArray<GLuint>; PCOnly: Boolean; ListData: TArray<rglv>);
procedure TriangulateColoredSurface(F: TSurfParamFcn; C: TSurfParamColorFcn;
N: TSurfParamNormalFcn; const umin, umax, vmin, vmax: Double;
A, B, pccx, pccy: Integer; Normalize: Boolean; out Vertices: TArray<GLfloat9>;
out Indices, PCIs: TArray<GLuint>; PCOnly: Boolean; ListData: TArray<GLr3c3v>);
type
TParamSurfProc<vtype> = procedure(out Vertices: TArray<vtype>;
out Indices, PCIs: TArray<GLuint>; A, B, pccx, pccy: Integer;
PCOnly: Boolean; Data: Pointer);
TSimpleParamSurfProc = TParamSurfProc<GLfloat6>;
TColoredParamSurfProc = TParamSurfProc<GLfloat9>;
TrglSphereMapType = (rglSphereMapPolar, rglSphereMapConstantArea);
procedure rglSpherePolar(out Vertices: TArray<GLfloat6>;
out Indices, PCIs: TArray<GLuint>; A, B, pccx, pccy: Integer; PCOnly: Boolean;
Data: Pointer);
procedure rglSphereConstArea(out Vertices: TArray<GLfloat6>;
out Indices, PCIs: TArray<GLuint>; A, B, pccx, pccy: Integer; PCOnly: Boolean;
Data: Pointer);
procedure rglCylinder(out Vertices: TArray<GLfloat6>;
out Indices, PCIs: TArray<GLuint>; A, B, pccx, pccy: Integer; PCOnly: Boolean;
Data: Pointer);
procedure rglCone(out Vertices: TArray<GLfloat6>;
out Indices, PCIs: TArray<GLuint>; A, B, pccx, pccy: Integer; PCOnly: Boolean;
Data: Pointer);
procedure rglPlane(out Vertices: TArray<GLfloat6>;
out Indices, PCIs: TArray<GLuint>; A, B, pccx, pccy: Integer; PCOnly: Boolean;
Data: Pointer);
procedure rglDisk(out Vertices: TArray<GLfloat6>;
out Indices, PCIs: TArray<GLuint>; A, B, pccx, pccy: Integer; PCOnly: Boolean;
Data: Pointer);
type
TRglContext = class;
TRglShader = class;
TRglShaderClass = class of TRglShader;
TShaderKind = (Vertex, Geometry, Fragment);
TShaderKindHelper = record helper for TShaderKind
function ToString: string;
function RglClass: TRglShaderClass;
end;
TRglShader = class abstract
private
FContext: TRglContext;
FKind: Cardinal;
FHandle: Cardinal;
FSource: AnsiString;
public
constructor Create(AContext: TRglContext; const ASource: string); virtual;
destructor Destroy; override;
procedure Compile;
property Handle: Cardinal read FHandle;
property Kind: Cardinal read FKind;
property Source: AnsiString read FSource;
end;
TRglVertexShader = class(TRglShader)
constructor Create(AContext: TRglContext; const ASource: string); override;
end;
TRglFragmentShader = class(TRglShader)
constructor Create(AContext: TRglContext; const ASource: string); override;
end;
TRglGeometryShader = class(TRglShader)
constructor Create(AContext: TRglContext; const ASource: string); override;
end;
TRglUniform = class abstract
strict private
FContext: TRglContext;
FName: string;
FHandle: Integer;
private
constructor Create; overload;
constructor Create(AContext: TRglContext; AProgram: Cardinal;
const AName: string); overload;
class function TryCreate(AContext: TRglContext; AProgram: Cardinal;
const AName: string): TRglUniform;
public
destructor Destroy; override;
property Context: TRglContext read FContext;
property Name: string read FName;
property Handle: Integer read FHandle;
end;
TRglUniformClass = class of TRglUniform;
TRglUniformFloat = class(TRglUniform)
procedure SetValue(const AValue: GLfloat);
end;
TRglUniformFloatVec2 = class(TRglUniform)
procedure SetValue(const AValue: rglv2); overload;
procedure SetValue(const a0, a1: GLfloat); overload;
end;
TRglUniformFloatVec3 = class(TRglUniform)
procedure SetValue(const AValue: rglv); overload;
procedure SetValue(const a0, a1, a2: GLfloat); overload;
end;
TRglUniformFloatVec4 = class(TRglUniform)
procedure SetValue(const AValue: rglv4); overload;
procedure SetValue(const a0, a1, a2, a3: GLfloat); overload;
end;
TRglUniformFloatMat3 = class(TRglUniform)
procedure SetValue(const AValue: rglm);
end;
TRglUniformFloatMat4 = class(TRglUniform)
procedure SetValue(const AValue: rglm4);
end;
TRglUniformInt = class(TRglUniform)
procedure SetValue(const AValue: GLint);
end;
TRglUniformUInt = class(TRglUniform)
procedure SetValue(const AValue: GLuint);
end;
TRglUniformDouble = class(TRglUniform)
procedure SetValue(const AValue: Double);
end;
TRglUniformBool = class(TRglUniform)
procedure SetValue(const AValue: Boolean);
end;
TRglProgram = class
strict private
FContext: TRglContext;
FShaders: TDictionary<Integer, AnsiString>;
FHandle: Cardinal;
FUniforms: TObjectList<TRglUniform>;
public
constructor Create(AContext: TRglContext);
destructor Destroy; override;
procedure AttachShader(AShader: TRglShader);
procedure Link;
function AddAttribute(const AName: string): Integer;
function AddUniform<T: TRglUniform>(const AName: string): T;
function TryAddUniform<T: TRglUniform>(const AName: string): T;
procedure Use;
procedure Unuse;
end;
__version = record
Major, Minor: Integer
end;
__range = packed record
Min, Max: Integer
end;
__linewidths = record
Aliased, Smooth: __range
end;
TGLImplInfo = record
Version: __version;
VersionString: string;
Vendor: string;
Renderer: string;
GLSL: string;
ContextProfileMask: Integer;
ContextFlags: Integer;
LineWidths: __linewidths;
MaxSamples: Integer;
MaxTextureSize: Integer;
MaxTextureAnisotropy: GLfloat;
end;
TStockSurfaceData = record
VertexData: GLuint;
IndexData: GLuint;
IndexCount: GLuint;
end;
TSolidModel = class;
TSolidModelClass = class of TSolidModel;
TSolidStoreRec = record
VertexData: GLuint;
Count: Integer;
RefCnt: Integer;
end;
TDrawable3D = class;
TDrawable3DClass = class of TDrawable3D;
TRglContext = class
strict private
FWnd: HWND;
FDC: HDC;
FRC: HGLRC;
class var FInstances: TList<TRglContext>;
class constructor ClassCreate;
class destructor ClassDestroy;
class procedure DoMakeCurrent(DC: HDC; RC: HGLRC; const ACaller: string); static;
private
FStockSurfaces: TDictionary<TStockSurfaceIndex, TStockSurfaceData>;
FStoredSolids: TDictionary<TDrawable3DClass, TSolidStoreRec>;
FCustomBuffers: TObjectDictionary<TDrawable3DClass, TObject>;
class var FCurrentDC: HDC;
class var FCurrentRC: HGLRC;
public
constructor Create(AWnd: HWND);
destructor Destroy; override;
procedure SwapBuffers;
function GetExtensionNames: TArray<string>;
function GetImplInfo: TGLImplInfo;
procedure MakeCurrent(const ACaller: string); overload; inline;
class procedure MakeCurrent(DC: HDC; RC: HGLRC; const ACaller: string); overload; static; inline;
function TryMakeCurrent: Boolean; overload;
class function TryMakeCurrent(DC: HDC; RC: HGLRC): Boolean; overload; static; inline;
class function GlobalCount: Integer;
end;
TRglControl = class(TVisCtl)
strict private
FContext: TRglContext;
FClearMask: Cardinal;
FGlCtlColor: rglv;
FPrevTick: Int64;
FFPS: Double;
function GetAspectRatio: Double;
private
FPerfFreq: Int64;
protected
procedure ApplyClearColor;
procedure Resize; override;
procedure CreateWnd; override;
procedure DestroyWnd; override;
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;
procedure WMDestroy(var Message: TWMDestroy); message WM_DESTROY;
procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
procedure GLInit; virtual;
procedure CreateParams(var Params: TCreateParams); override;
property ClearMask: Cardinal read FClearMask write FClearMask;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property Context: TRglContext read FContext;
property FPS: Double read FFPS;
property AspectRatio: Double read GetAspectRatio;
published
property Color;
end;
TDrawableOptionsFrm3D = class(TForm)
protected
FInitialized: Boolean;
FDrawable: TDrawable3D;
FOnChange: TNotifyEvent;
procedure DrawableDestroyed(Sender: TObject);
public
constructor Create(AOwner: TComponent; ADrawable: TDrawable3D); reintroduce; virtual;
procedure Reassign(ADrawable: TDrawable3D);
procedure Initialize; virtual;
property Initialized: Boolean read FInitialized;
procedure UpdateDrawable; virtual;
property Drawable: TDrawable3D read FDrawable;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
end;
TDrawableOptionsFrmClass3D = class of TDrawableOptionsFrm3D;
TVisCtl3D = class;
TDrawable3D = class(TVisObj)
strict private
class var FInstances: TDictionary<TGUID, TDrawable3D>;
class var FModalLevel: Integer;
class procedure InstanceListChanged(Sender: TObject; const Item: TGUID;
Action: TCollectionNotification);
class constructor ClassCreate;
class destructor ClassDestroy;
public
class function TryGetDrawableByGUID(const AGUID: TGUID;
out ADrawable: TDrawable3D): Boolean; static;
class property ModalLevel: Integer read FModalLevel;
class function Verify(ADrawable: TDrawable3D): Boolean; static;
class property Instances: TDictionary<TGUID, TDrawable3D> read FInstances;
class function GetRealm: string; override; final;
protected
FTag: NativeInt;
FVisible: Boolean;
FCtl: TVisCtl3D;
FDefaultProgram: string;
FLineWidth: Single;
FAnimationSpeed: Double;
FOnChange: TNotifyEvent;
FOptionsFrmClass: TDrawableOptionsFrmClass3D;
FParent: TDrawable3D;
FChildren: TList<TDrawable3D>;
FParentTag: NativeUInt;
function TryContextCurrent: Boolean;
private
FProtected: Boolean;
procedure SetVisible(const Value: Boolean);
procedure Draw(const AGlobalTime: Double); virtual;
procedure Setup; virtual;
procedure Recreate; virtual;
procedure ProjectionChanged; virtual;
function GetChild(Index: Integer): TDrawable3D;
function GetChildCount: Integer;
property DefaultProgram: string read FDefaultProgram;
procedure SetAnimationSpeed(const Value: Double);
function GetDisplayed: Boolean;
protected
procedure Changed; overload; inline;
procedure Changed(Sender: TObject); overload; inline;
procedure FreeGLResources; virtual;
procedure GLRelease; virtual;
function GetLineWidth: Single; virtual;
procedure SetLineWidth(const Value: Single); virtual;
public
constructor Create(ACtl: TVisCtl3D); virtual;
destructor Destroy; override;
procedure ShowOptionsForm(AParent: TCustomForm = nil); override;
procedure Configure(ASettings: TAlgosimStructure); virtual;
function CreateChild<T: TDrawable3D>: T;
procedure DeleteChild(AChild: TDrawable3D);
procedure DeleteChildren(ATagMask: NativeUInt);
function CreateReference: TAlgosimReference; virtual;
property AnimationSpeed: Double read FAnimationSpeed write SetAnimationSpeed;
property ChildCount: Integer read GetChildCount;
property Children[Index: Integer]: TDrawable3D read GetChild;
property Control: TVisCtl3D read FCtl;
property Visible: Boolean read FVisible write SetVisible;
property Displayed: Boolean read GetDisplayed;
property LineWidth: Single read GetLineWidth write SetLineWidth;
property Parent: TDrawable3D read FParent;
property Tag: NativeInt read FTag write FTag;
property OptionsFormClass: TDrawableOptionsFrmClass3D read FOptionsFrmClass write FOptionsFrmClass;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
end;
TDrawableList3D = class(TDrawable3D)
strict private
FList: TObjectList<TDrawable3D>;
FSortedList: TList<TDrawable3D>;
FTimeDependent: Boolean;
FAlphaBlending: Boolean;
FPrevCameraPos: rglv;
FStencilIDs: array[Byte] of Pointer;
FSortOrderDirty: Boolean;
function GetItem(Index: Integer): TDrawable3D;
procedure SetItem(Index: Integer; const Value: TDrawable3D);
function GetItemCount: Integer;
procedure ObjsNotify(Sender: TObject; const Item: TDrawable3D;
Action: TCollectionNotification);
procedure Resort;
private
procedure Draw(const AGlobalTime: Double); override;
function GetObjFromStencilID(AStencilID: Byte): TDrawable3D;
protected
procedure FreeGLResources; override;
procedure GLRelease; override;
public
constructor Create(ACtl: TVisCtl3D); override;
destructor Destroy; override;
procedure MoveUp(ADrawable: TDrawable3D);
procedure MoveDown(ADrawable: TDrawable3D);
property List: TObjectList<TDrawable3D> read FList;
property Items[Index: Integer]: TDrawable3D read GetItem write SetItem; default;
property ItemCount: Integer read GetItemCount;
property TimeDependent: Boolean read FTimeDependent;
end;
TScene = class(TDrawable3D)
public
constructor Create(ACtl: TVisCtl3D); override;
function CreateReference: TAlgosimReference; override;
procedure Configure(ASettings: TAlgosimStructure); override;
end;
TRefAxes = class(TDrawable3D)
strict private
const N = 64;
var FVertexData: GLuint;
var FVAO: GLuint;
private
procedure Draw(const AGlobalTime: Double); override;
procedure Setup; override;
protected
procedure FreeGLResources; override;
procedure GLRelease; override;
public
constructor Create(ACtl: TVisCtl3D); override;
destructor Destroy; override;
end;
TGeometricObject3D = class(TDrawable3D)
private
FColor: TColor;
FPosition: rglv;
FDirection: rglv;
FScale: rglv;
FRotation: Single;
FObjectMatrix: rglm4;
FNormalMatrix: rglm;
FManualMatrix: rglm4;
FUseManualMatrix: Boolean;
FColorNotApplicable: Boolean;
function GetColor: TColor; virtual;
procedure SetColor(const Value: TColor); virtual;
procedure SetPosition(const Value: rglv);
procedure SetDirection(const Value: rglv);
procedure SetScale(const Value: rglv);
procedure SetRotation(const Value: Single);
private
procedure ComputeOM; virtual;
procedure Draw(const AGlobalTime: Double); override;
procedure SetManualMatrix(const Value: rglm4); overload;
procedure SetUseManualMatrix(const Value: Boolean);
public
constructor Create(ACtl: TVisCtl3D); override;
procedure Assign(Source: TPersistent); override;
procedure Configure(ASettings: TAlgosimStructure); override;
procedure SetManualMatrix; overload;
property Color: TColor read GetColor write SetColor;
property Position: rglv read FPosition write SetPosition;
property Direction: rglv read FDirection write SetDirection;
property Scale: rglv read FScale write SetScale;
property Rotation: Single read FRotation write SetRotation;
property ManualMatrix: rglm4 read FManualMatrix write SetManualMatrix;
property UseManualMatrix: Boolean read FUseManualMatrix write SetUseManualMatrix;
property ColorNotApplicable: Boolean read FColorNotApplicable;
end;
TParamCurveFamilySize = record
nx, ny: Integer;
class operator Equal(const Left, Right: TParamCurveFamilySize): Boolean;
class operator NotEqual(const Left, Right: TParamCurveFamilySize): Boolean;
class operator Implicit(const AValue: Integer): TParamCurveFamilySize;
class operator Implicit(const AValue: TSize): TParamCurveFamilySize;
class operator Implicit(const AValue: rglv2): TParamCurveFamilySize;
constructor Create(X, Y: Integer);
end;
TAbstractSurface3D = class abstract(TGeometricObject3D)
private
FShowSurface: Boolean;
FShowParameterCurves: Boolean;
FLineColor: TColor;
FParamCurveCounts: TParamCurveFamilySize;
FUnisided: Boolean;
private
procedure RecreateParamCurves; virtual;
procedure SetShowParameterCurves(const Value: Boolean);
procedure SetShowSurface(const Value: Boolean);
procedure UpdateDefProgram; virtual;
procedure SetLineColor(const Value: TColor);
procedure SetParamCurveCounts(const Value: TParamCurveFamilySize);
procedure SetUnisided(const Value: Boolean);
public
constructor Create(ACtl: TVisCtl3D); override;
procedure Assign(Source: TPersistent); override;
procedure Configure(ASettings: TAlgosimStructure); override;
property LineColor: TColor read FLineColor write SetLineColor;
property ShowSurface: Boolean read FShowSurface write SetShowSurface;
property ShowParameterCurves: Boolean read FShowParameterCurves write SetShowParameterCurves;
property Unisided: Boolean read FUnisided write SetUnisided;
property ParamCurveCounts: TParamCurveFamilySize read FParamCurveCounts write SetParamCurveCounts;
end;
TSurface3D<vtype> = class abstract(TAbstractSurface3D)
private
FVertexData: GLuint;
FIndexData: GLuint;
FPCIData: GLuint;
FIndexCount: Integer;
FPCICount: Integer;
FVAO: GLuint;
FSurfProgram: string;
FSurfProgramUnisided: string;
FCurveProgram: string;
var
FStockSurface: Boolean;
FStockID: TStockSurfaceIndex;
private
procedure Setup; override;
procedure Draw(const AGlobalTime: Double); override;
procedure RecreateParamCurves; override;
procedure UpdateDefProgram; override;
protected
FSurfProc: TParamSurfProc<vtype>;
protected
procedure FreeGLResources; override;
procedure GLRelease; override;
public
destructor Destroy; override;
end;
TBasicSurface3D = class abstract(TSurface3D<GLfloat6>)
constructor Create(ACtl: TVisCtl3D); override;
end;
TColoredSurface3D = class abstract(TSurface3D<GLfloat9>)
constructor Create(ACtl: TVisCtl3D); override;
end;
TRectDom = record
umin, umax,
vmin, vmax: Double;
class operator Equal(const Left, Right: TRectDom): Boolean;
class operator NotEqual(const Left, Right: TRectDom): Boolean;
constructor Create(const umin, umax, vmin, vmax: Double);
end;
TCustomSurface = class(TBasicSurface3D)
strict private
FSurfaceFunction: TSurfParamFcn;
FData: TArray<rglv>;
FDomain: TRectDom;
procedure SetDomain(const Value: TRectDom);
procedure SetSurfaceFunction(const Value: TSurfParamFcn);
procedure SetData(const Value: TArray<rglv>);
class procedure SurfProc(out Vertices: TArray<GLfloat6>;
out Indices, PCIs: TArray<GLuint>; A, B, pccx, pccy: Integer;
PCOnly: Boolean; Data: Pointer); static;
private
procedure Recreate; override;
public
Nx, Ny: Integer;
constructor Create(ACtl: TVisCtl3D); override;
property SurfaceFunction: TSurfParamFcn read FSurfaceFunction write SetSurfaceFunction;
property Data: TArray<rglv> read FData write SetData;
property Domain: TRectDom read FDomain write SetDomain;
end;
TCustomColoredSurface = class(TColoredSurface3D)
strict private
FSurfaceFunction: TSurfParamFcn;
FSurfaceColorFunction: TSurfParamColorFcn;
FData: TArray<glr3c3v>;
FDomain: TRectDom;
procedure SetDomain(const Value: TRectDom);
procedure SetSurfaceFunction(const Value: TSurfParamFcn);
procedure SetSurfaceColorFunction(const Value: TSurfParamColorFcn);
procedure SetData(const Value: TArray<GLr3c3v>);
class procedure SurfProc(out Vertices: TArray<GLfloat9>;
out Indices, PCIs: TArray<GLuint>; A, B, pccx, pccy: Integer;
PCOnly: Boolean; Data: Pointer); static;
private
procedure Recreate; override;
public
Nx, Ny: Integer;
constructor Create(ACtl: TVisCtl3D); override;
property SurfaceFunction: TSurfParamFcn read FSurfaceFunction
write SetSurfaceFunction;
property SurfaceColorFunction: TSurfParamColorFcn read FSurfaceColorFunction
write SetSurfaceColorFunction;
property Data: TArray<GLr3c3v> read FData write SetData;
property Domain: TRectDom read FDomain write SetDomain;
end;
TEllipsoid = class(TBasicSurface3D)
private
FScale: rglv;
procedure SetScale(const Value: rglv);
public
constructor Create(ACtl: TVisCtl3D); override;
procedure Configure(ASettings: TAlgosimStructure); override;
property AxisLengths: rglv read FScale write SetScale;
end;
TSphere = class(TEllipsoid)
private
function GetRadius: Single;
procedure SetRadius(const Value: Single);
public
constructor Create(ACtl: TVisCtl3D); override;
property Radius: Single read GetRadius write SetRadius;
end;
TCylinder = class(TBasicSurface3D)
private
function GetAxisLengths: rglv2;
function GetHeight: Single;
procedure SetAxisLengths(const Value: rglv2);
procedure SetHeight(const Value: Single);
function GetRadius: Single;
procedure SetRadius(const Value: Single);
public
constructor Create(ACtl: TVisCtl3D); override;
procedure Configure(ASettings: TAlgosimStructure); override;
property AxisLengths: rglv2 read GetAxisLengths write SetAxisLengths;
property Height: Single read GetHeight write SetHeight;
property Radius: Single read GetRadius write SetRadius;
end;
TCone = class(TBasicSurface3D)
private
function GetAxisLengths: rglv2;
function GetHeight: Single;
procedure SetAxisLengths(const Value: rglv2);
procedure SetHeight(const Value: Single);
public
constructor Create(ACtl: TVisCtl3D); override;
procedure Configure(ASettings: TAlgosimStructure); override;
property AxisLengths: rglv2 read GetAxisLengths write SetAxisLengths;
property Height: Single read GetHeight write SetHeight;
end;
TPlane = class(TBasicSurface3D)
public
constructor Create(ACtl: TVisCtl3D); override;
end;
TInfinitePlane = class(TAbstractSurface3D)
private
FVertexData: GLuint;
FIndexData: GLuint;
FPCIData: GLuint;
FIndexCount: Integer;
FPCICount: Integer;
FVAO: GLuint;
private
procedure Setup; override;
procedure Recreate; override;
procedure Draw(const AGlobalTime: Double); override;
protected
procedure FreeGLResources; override;
procedure GLRelease; override;
public
constructor Create(ACtl: TVisCtl3D); override;
destructor Destroy; override;
end;
TDisk = class(TBasicSurface3D)
private
function GetRadius: Single;
procedure SetRadius(const Value: Single);
public
constructor Create(ACtl: TVisCtl3D); override;
procedure Configure(ASettings: TAlgosimStructure); override;
property Radius: Single read GetRadius write SetRadius;
end;
TInterval = record
a, b: Double;
class operator Equal(const Left, Right: TInterval): Boolean;
class operator NotEqual(const Left, Right: TInterval): Boolean;
constructor Create(const a, b: Double);
end;
TCurve3D = class(TGeometricObject3D)
strict private
FVertexData: GLuint;
FCount: Integer;
FCurveFunction: TCurveParamFcn;
FData: TArray<rglv>;
FDomain: TInterval;
FVAO: GLuint;
procedure SetDomain(const Value: TInterval);
procedure SetCurveFunction(const Value: TCurveParamFcn);
procedure SetData(const Value: TArray<rglv>);
procedure Sample(out Vertices: TArray<rglv>);
private
procedure Recreate; override;
private
procedure Setup; override;
procedure Draw(const AGlobalTime: Double); override;
protected
procedure FreeGLResources; override;
procedure GLRelease; override;
public
constructor Create(ACtl: TVisCtl3D); override;
destructor Destroy; override;
property CurveFunction: TCurveParamFcn read FCurveFunction write SetCurveFunction;
property Data: TArray<rglv> read FData write SetData;
property Domain: TInterval read FDomain write SetDomain;
end;
TColoredCurve3D = class(TGeometricObject3D)
strict private
FVertexData: GLuint;
FCount: Integer;
FCurveFunction: TCurveParamFcn;
FCurveColorFunction: TCurveParamColorFcn;
FData: TArray<GLr3c3v>;
FDomain: TInterval;
FVAO: GLuint;
procedure SetDomain(const Value: TInterval);
procedure SetCurveFunction(const Value: TCurveParamFcn);
procedure SetCurveColorFunction(const Value: TCurveParamColorFcn);
procedure SetData(const Value: TArray<GLr3c3v>);
procedure Sample(out Vertices: TArray<GLr3c3v>);
private
procedure Recreate; override;
private
procedure Setup; override;
procedure Draw(const AGlobalTime: Double); override;
protected
procedure FreeGLResources; override;
procedure GLRelease; override;
public
constructor Create(ACtl: TVisCtl3D); override;
destructor Destroy; override;
property CurveFunction: TCurveParamFcn read FCurveFunction write SetCurveFunction;
property CurveColorFunction: TCurveParamColorFcn read FCurveColorFunction
write SetCurveColorFunction;
property Data: TArray<GLr3c3v> read FData write SetData;
property Domain: TInterval read FDomain write SetDomain;
end;
TScatterPlot = class abstract(TGeometricObject3D)
private
FVertexData: GLuint;
FIndexData: GLuint;
FIndexCount: Integer;
FVAO: GLuint;
FInstanceData: GLuint;
FSize: Single;
procedure MakeBaseMarker;
procedure SetSize(const Value: Single);
procedure Recreate; override;
procedure Draw(const AGlobalTime: Double); override;
protected
procedure FreeGLResources; override;
procedure GLRelease; override;
public
constructor Create(ACtl: TVisCtl3D); override;
destructor Destroy; override;
procedure Configure(ASettings: TAlgosimStructure); override;
property Size: Single read FSize write SetSize;
end;
TSimpleScatterPlot = class(TScatterPlot)
private
FPoints: TArray<GLfloat3>;
private
procedure Setup; override;
procedure Draw(const AGlobalTime: Double); override;
procedure SetPoints(const Value: TArray<GLfloat3>); overload;
procedure SetPoints(const Value: TArray<TASR3>); overload;
public
constructor Create(ACtl: TVisCtl3D); override;
property Data: TArray<GLfloat3> write SetPoints;
property DataAsDoubles: TArray<TASR3> write SetPoints;
end;
TAdvScatterPlot = class(TScatterPlot)
private
FPoints: TArray<GLfloat7>;
private
procedure Setup; override;
procedure Draw(const AGlobalTime: Double); override;
procedure SetPoints(const Value: TArray<GLfloat7>); overload;
procedure SetPoints(const Value: TArray<Double>); overload;
public
constructor Create(ACtl: TVisCtl3D); override;
property Data: TArray<GLfloat7> write SetPoints;
property DataAsDoubles: TArray<Double> write SetPoints;
end;
TVectorField = class(TGeometricObject3D)
private class var
FVertexCount: Integer;
var
FVertexData: GLuint;
FVAO: GLuint;
FInstanceData: GLuint;
FSize: Single;
FVectors: TArray<GLr3v3c3v>;
FMaxNorm: Single;
FAttribColors: Boolean;
FAnchorPoint: Single;
procedure MakeBaseArrow;
class function MakeMatrix(const AVector: rglv): rglm; static;
class function Prepare(const AVectors: TArray<GLr3v3c3v>;
out AMaxNorm: Single): TArray<GLfloat15>; static;
procedure SetSize(const Value: Single);
procedure SetVectors(const Value: TArray<GLr3v3c3v>);
procedure SetAttribColors(const Value: Boolean);
procedure SetAnchorPoint(const Value: Single);
private
procedure Setup; override;
procedure Draw(const AGlobalTime: Double); override;
procedure Recreate; override;
protected
procedure FreeGLResources; override;
procedure GLRelease; override;
public
constructor Create(ACtl: TVisCtl3D); override;
destructor Destroy; override;
procedure Configure(ASettings: TAlgosimStructure); override;
property Size: Single read FSize write SetSize;
property Data: TArray<GLr3v3c3v> write SetVectors;
property PerVertexColors: Boolean read FAttribColors write SetAttribColors;
property AnchorPoint: Single read FAnchorPoint write SetAnchorPoint;
end;
TTransparentColorMode = (tcmOff, tcmEqual, tcmDistance, tcmBipolar);
TTransparentColorModeHelper = record helper for TTransparentColorMode
function ToString: string;
class function FromString(const S: string): TTransparentColorMode; static;
end;
TImageRect = class(TGeometricObject3D)
private
FTexture: GLuint;
FVertexData: GLuint;
FVAO: GLuint;
FBitmap: TBitmap;
FTransparentColor: TColor;
FOpaqueColor: TColor;
FTransparentColorMode: TTransparentColorMode;
private
procedure Setup; override;
procedure Draw(const AGlobalTime: Double); override;
procedure Recreate; override;
procedure BitmapChanged(Sender: TObject);
procedure SetBitmap(const Value: TBitmap);
procedure SetTransparentColor(const Value: TColor);
procedure SetOpaqueColor(const Value: TColor);
procedure SetTransparentColorMode(const Value: TTransparentColorMode);
protected
procedure FreeGLResources; override;
procedure GLRelease; override;
public
constructor Create(ACtl: TVisCtl3D); override;
destructor Destroy; override;
procedure Configure(ASettings: TAlgosimStructure); override;
property Bitmap: TBitmap read FBitmap write SetBitmap;
property TransparentColor: TColor read FTransparentColor write SetTransparentColor;
property OpaqueColor: TColor read FOpaqueColor write SetOpaqueColor;
property TransparentColorMode: TTransparentColorMode read FTransparentColorMode
write SetTransparentColorMode;
end;
TTextRect = class(TGeometricObject3D)
private
FTexture: GLuint;
FVertexData: GLuint;
FVAO: GLuint;
FText: string;
FFont: TFont;
FAspect: Double;
FTextResFactor: Double;
FHighQuality: Boolean;
FOpacity: Double;
FAnchorPoint: TAnchorPoint;
FDisplacement: rglv2;
FFaceScreen: Boolean;
procedure SetAnchorPoint(const Value: TAnchorPoint);
procedure SetText(const Value: string);
procedure SetFont(const Value: TFont);
procedure SetOpacity(const Value: Double);
procedure SetDisplacement(const Value: rglv2);
procedure SetFaceScreen(const Value: Boolean);
procedure FontChanged(Sender: TObject);
procedure SetTextResFactor(const Value: Double);
procedure SetHighQuality(const Value: Boolean);
function MakeBitmap: TBitmap;
private
procedure Setup; override;
procedure Draw(const AGlobalTime: Double); override;
procedure Recreate; override;
protected
procedure FreeGLResources; override;
procedure GLRelease; override;
public
constructor Create(ACtl: TVisCtl3D); override;
destructor Destroy; override;
procedure Configure(ASettings: TAlgosimStructure); override;
property AnchorPoint: TAnchorPoint read FAnchorPoint write SetAnchorPoint;
property Font: TFont read FFont write SetFont;
property Text: string read FText write SetText;
property Aspect: Double read FAspect;
property TextResFactor: Double read FTextResFactor write SetTextResFactor;
property HighQuality: Boolean read FHighQuality write SetHighQuality;
property Opacity: Double read FOpacity write SetOpacity;
property FaceScreen: Boolean read FFaceScreen write SetFaceScreen;
property Displacement: rglv2 read FDisplacement write SetDisplacement;
end;
TAxis = class(TGeometricObject3D)
private
const
PTAG_AXISLABEL = 1;
var
FCylinder: TCylinder;
FLabels: Boolean;
FLabelFont: TFont;
FLabelDelta: Double;
FNegativeLength: Double;
FLength: Double;
FRadius: Double;
FLabelFormat: string;
procedure FontChange(Sender: TObject);
procedure SetLabelDelta(const Value: Double);
procedure SetLabelFont(const Value: TFont);
procedure SetLabels(const Value: Boolean);
procedure SetLength(const Value: Double);
procedure SetNegativeLength(const Value: Double);
procedure SetRadius(const Value: Double);
procedure SetLabelFormat(const Value: string);
procedure SetupLabels;
function GetColor: TColor; override;
procedure SetColor(const Value: TColor); override;
private
FIndex: Integer;
function AxisName: string;
procedure Setup; override;
procedure Recreate; override;
procedure ProjectionChanged; override;
public
constructor Create(ACtl: TVisCtl3D); override;
function CreateReference: TAlgosimReference; override;
procedure Configure(ASettings: TAlgosimStructure); override;
destructor Destroy; override;
function FormatAxisLabel(const AFormat: string; const AValue: Double): string;
property Labels: Boolean read FLabels write SetLabels;
property LabelFont: TFont read FLabelFont write SetLabelFont;
property LabelFormat: string read FLabelFormat write SetLabelFormat;
property LabelDelta: Double read FLabelDelta write SetLabelDelta;
property Length: Double read FLength write SetLength;
property NegativeLength: Double read FNegativeLength write SetNegativeLength;
property Radius: Double read FRadius write SetRadius;
end;
TGrid = class(TGeometricObject3D)
private
const
PTAG_GRIDLABEL = 2;
var
FVertexData: GLuint;
FCount: Integer;
FVAO: GLuint;
FXMin, FXMax, FXDelta: Double;
FYMin, FYMax, FYDelta: Double;
private
FIndex: Integer;
procedure Setup; override;
procedure Draw(const AGlobalTime: Double); override;
procedure Recreate; override;
procedure SetXDelta(const Value: Double);
procedure SetXMax(const Value: Double);
procedure SetXMin(const Value: Double);
procedure SetYDelta(const Value: Double);
procedure SetYMax(const Value: Double);
procedure SetYMin(const Value: Double);
protected
procedure FreeGLResources; override;
procedure GLRelease; override;
public
constructor Create(ACtl: TVisCtl3D); override;
destructor Destroy; override;
procedure Configure(ASettings: TAlgosimStructure); override;
property XMin: Double read FXMin write SetXMin;
property XMax: Double read FXMax write SetXMax;
property XDelta: Double read FXDelta write SetXDelta;
property YMin: Double read FYMin write SetYMin;
property YMax: Double read FYMax write SetYMax;
property YDelta: Double read FYDelta write SetYDelta;
end;
TAxes = class(TGeometricObject3D)
private
FXAxis,
FYAxis,
FZAxis: TAxis;
private
procedure AxisChanged(Sender: TObject);
procedure GridChanged(Sender: TObject);
private
procedure SetXAxis(const Value: TAxis);
procedure SetYAxis(const Value: TAxis);
procedure SetZAxis(const Value: TAxis);
function GetGridCount: Integer;
procedure SetGridCount(const Value: Integer);
public
constructor Create(ACtl: TVisCtl3D); override;
function CreateReference: TAlgosimReference; override;
procedure Configure(ASettings: TAlgosimStructure); override;
property X: TAxis read FXAxis write SetXAxis;
property Y: TAxis read FYAxis write SetYAxis;
property Z: TAxis read FZAxis write SetZAxis;
property GridCount: Integer read GetGridCount write SetGridCount;
end;
TSolidModel = class abstract(TGeometricObject3D)
private
FVertexData: GLuint;
FCount: Integer;
FVAO: GLuint;
class var FSolidClasses: TDictionary<string, TDrawable3DClass>;
class procedure RegisterClass(const AClass: TDrawable3DClass;
const AName: string); static;
class constructor ClassCreate;
class destructor ClassDestroy;
private
procedure Setup; override;
procedure Recreate; override;
procedure Draw(const AGlobalTime: Double); override;
procedure MakeBaseBuffer; virtual;
protected
Stored: Boolean;
function ModelClass: TSolidModelClass;
protected
procedure FreeGLResources; override;
procedure GLRelease; override;
public
constructor Create(ACtl: TVisCtl3D); override;
destructor Destroy; override;
class function FromString(const S: string): TDrawable3DClass; static;
class function TryFromString(const S: string;
out AClass: TDrawable3DClass): Boolean; static;
end;
TObjModel = class(TSolidModel)
private
FSource: string;
FBuf: TArray<GLfloat6>;
procedure MakeBaseBuffer; override;
public
constructor Create(ACtl: TVisCtl3D); override;
procedure Configure(ASettings: TAlgosimStructure); override;
procedure LoadModel(const AData: string); overload;
procedure LoadModel(const AData: TArray<string>); overload;
procedure LoadModelFromFile(const AFileName: TFileName); overload;
procedure LoadModelFromFile(const AFileName: TFileName;
const Encoding: TEncoding); overload;
property Source: string read FSource write LoadModel;
end;
TRawModel = class abstract(TSolidModel)
private
procedure MakeBaseBuffer; override; final;
protected
function GetRawData: TArray<GLfloat6>; virtual;
end;
TSolidCube = class(TRawModel)
protected
function GetRawData: TArray<GLfloat6>; override;
public
constructor Create(ACtl: TVisCtl3D); override;
end;
TSolidCylinder = class(TGeometricObject3D)
private
type
TBufferStoreKey = packed record
InnerRadius: Double;
Angle: Double;
end;
TBufferStoreItem = record
InnerRadius: Double;
Angle: Double;
VertexData: GLuint;
Counts: TArray<Integer>;
TwoSides: Boolean;
RefCnt: Integer;
end;
var
FBSK: TBufferStoreKey;
FVertexData: GLuint;
FCounts: TArray<Integer>;
FTwoSides: Boolean;
FVAO: GLuint;
FAngle: Double;
FInnerRadius: Double;
function GetAxisLengths: rglv2;
function GetHeight: Single;
procedure SetAxisLengths(const Value: rglv2);
procedure SetHeight(const Value: Single);
function GetRadius: Single;
procedure SetRadius(const Value: Single);
procedure SetAngle(const Value: Double);
procedure SetInnerRadiusFraction(const Value: Double);
procedure ConstructBufferSinHole;
procedure ConstructBufferConHole;
procedure GetBufferData;
procedure ReleaseBuffer;
private
procedure Setup; override;
procedure Recreate; override;
procedure Draw(const AGlobalTime: Double); override;
protected
procedure FreeGLResources; override;
procedure GLRelease; override;
public
constructor Create(ACtl: TVisCtl3D); override;
destructor Destroy; override;
procedure Configure(ASettings: TAlgosimStructure); override;
property Angle: Double read FAngle write SetAngle;
property AxisLengths: rglv2 read GetAxisLengths write SetAxisLengths;
property Height: Single read GetHeight write SetHeight;
property Radius: Single read GetRadius write SetRadius;
property InnerRadiusFraction: Double read FInnerRadius write SetInnerRadiusFraction;
end;
TSolidCone = class(TGeometricObject3D)
private
FVertexData: GLuint;
FCount: Integer;
FVAO: GLuint;
function GetAxisLengths: rglv2;
function GetHeight: Single;
procedure SetAxisLengths(const Value: rglv2);
procedure SetHeight(const Value: Single);
function GetRadius: Single;
procedure SetRadius(const Value: Single);
procedure MakeBaseBuffer;
private
procedure Setup; override;
procedure Recreate; override;
procedure Draw(const AGlobalTime: Double); override;
protected
procedure FreeGLResources; override;
procedure GLRelease; override;
public
constructor Create(ACtl: TVisCtl3D); override;
destructor Destroy; override;
procedure Configure(ASettings: TAlgosimStructure); override;
property AxisLengths: rglv2 read GetAxisLengths write SetAxisLengths;
property Height: Single read GetHeight write SetHeight;
property Radius: Single read GetRadius write SetRadius;
end;
TSolidTetrahedron = class(TRawModel)
protected
function GetRawData: TArray<GLfloat6>; override;
public
constructor Create(ACtl: TVisCtl3D); override;
end;
TSolidOctahedron = class(TRawModel)
protected
function GetRawData: TArray<GLfloat6>; override;
public
constructor Create(ACtl: TVisCtl3D); override;
end;
TSolidDodecahedron = class(TRawModel)
protected
function GetRawData: TArray<GLfloat6>; override;
public
constructor Create(ACtl: TVisCtl3D); override;
end;
TSolidIcosahedron = class(TRawModel)
protected
function GetRawData: TArray<GLfloat6>; override;
public
constructor Create(ACtl: TVisCtl3D); override;
end;
TSolidPyramid = class(TRawModel)
protected
function GetRawData: TArray<GLfloat6>; override;
public
constructor Create(ACtl: TVisCtl3D); override;
end;
TArrow = class(TGeometricObject3D)
private
v: rglv;
FLine: TSolidCylinder;
FHead: TSolidCone;
Q: Single;
FHeadSize: Single;
FSetup: Boolean;
function GetColor: TColor; override;
procedure SetColor(const Value: TColor); override;
procedure SetVector(const Value: rglv);
procedure SetHeadSize(const Value: Single);
procedure SetAspect(const Value: Single);
protected
function GetLineWidth: Single; override;
procedure SetLineWidth(const Value: Single); override;
procedure Setup; override;
procedure Recreate; override;
public
constructor Create(ACtl: TVisCtl3D); override;
procedure Configure(ASettings: TAlgosimStructure); override;
function CreateReference: TAlgosimReference; override;
property Aspect: Single read Q write SetAspect;
property HeadSize: Single read FHeadSize write SetHeadSize;
property Vector: rglv read v write SetVector;
end;
TLightSourceDummy = class(TSphere)
public
constructor Create(ACtl: TVisCtl3D); override;
end;
TProjection = (Orthographic, Perspective);
TProjectionHelper = record helper for TProjection
function ToString: string;
class function FromString(const S: string): TProjection; static;
end;
TAnimationTimer = class(TTimer)
private
FControl: TVisCtl3D;
class var FAppEvents: TApplicationEvents;
class var FInstances: TList<TAnimationTimer>;
class procedure AppIdle(Sender: TObject; var Done: Boolean);
class constructor ClassCreate;
class destructor ClassDestroy;
class var FPrioritize: Boolean;
class procedure SetPrioritize(const Value: Boolean); static;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property Control: TVisCtl3D read FControl write FControl;
class property Prioritize: Boolean read FPrioritize write SetPrioritize;
end;
TView3D = class(TDrawable3D)
strict private
const
AnimationDurationSec = 1.0;
AnimationFramerateFPS = 30;
AnimationFrameCount =
Round(AnimationDurationSec * AnimationFramerateFPS);
AFC = AnimationFrameCount;
var
FAnimationTimer: TAnimationTimer;
FAnimationBegin: TDateTime;
FAnimationEnd: TDateTime;
FAnimation: array[0..AFC - 1] of TSphericalCoordinates;
procedure AnimationTimerTimer(Sender: TObject);
private
function GetCameraPosition: rglv;
function GetCameraPositionSp: TSphericalCoordinates;
function GetPhi: Double;
function GetR: Double;
function GetTheta: Double;
procedure SetCameraPosition(const Value: rglv);
procedure SetCameraPositionSp(const Value: TSphericalCoordinates);
procedure SetPhi(const Value: Double);
procedure SetR(const Value: Double);
procedure SetTheta(const Value: Double);
public
constructor Create(ACtl: TVisCtl3D); override;
destructor Destroy; override;
procedure Configure(ASettings: TAlgosimStructure); override;
property r: Double read GetR write SetR;
property Theta: Double read GetTheta write SetTheta;
property Phi: Double read GetPhi write SetPhi;
property CameraPosition: rglv read GetCameraPosition write SetCameraPosition;
property CameraPositionSp: TSphericalCoordinates read GetCameraPositionSp write SetCameraPositionSp;
procedure AnimateTo(const ATarget: rglv);
end;
TManagedProgram = class
strict private
FName: string;
FProgram: TRglProgram;
FUMVP: TRglUniformFloatMat4;
FUEye: TRglUniformFloatVec3;
FULightPos: TRglUniformFloatVec3;
FUColor: TRglUniformFloatVec3;
FUSize: TRglUniformFloat;
FUAnchorPoint: TRglUniformInt;
FUFaceScreen: TRglUniformBool;
FUAttribColors: TRglUniformBool;
FUAspect: TRglUniformFloat;
FUDisplacement: TRglUniformFloatVec2;
FUObjectMatrix: TRglUniformFloatMat4;
FUNormalMatrix: TRglUniformFloatMat3;
FUt: TRglUniformFloat;
FUTranspColor: TRglUniformFloatVec3;
FUOpaqueColor: TRglUniformFloatVec3;
FUTranspColorMode: TRglUniformInt;
FUOpacity: TRglUniformFloat;
FUPP_Greyscale: TRglUniformBool;
FUPP_Invert: TRglUniformBool;
FUPP_FlipV: TRglUniformBool;
FUPP_FlipH: TRglUniformBool;
FUPP_Binary: TRglUniformBool;
FUPP_Spectra: TRglUniformBool;
FUPP_EdgeDetect: TRglUniformBool;
FUPP_Sharpen: TRglUniformBool;
FUPP_Blur: TRglUniformBool;
FUPP_Underwater: TRglUniformBool;
public
constructor Create(const AName: string; AProgram: TRglProgram);
destructor Destroy; override;
property Name: string read FName;
property &Program: TRglProgram read FProgram;
property UMVP: TRglUniformFloatMat4 read FUMVP;
property UEye: TRglUniformFloatVec3 read FUEye;
property ULightPos: TRglUniformFloatVec3 read FULightPos;
property UColor: TRglUniformFloatVec3 read FUColor;
property USize: TRglUniformFloat read FUSize;
property UAnchorPoint: TRglUniformInt read FUAnchorPoint;
property UFaceScreen: TRglUniformBool read FUFaceScreen;
property UAttribColors: TRglUniformBool read FUAttribColors;
property UAspect: TRglUniformFloat read FUAspect;
property UDisplacement: TRglUniformFloatVec2 read FUDisplacement;
property UObjectMatrix: TRglUniformFloatMat4 read FUObjectMatrix;
property UNormalMatrix: TRglUniformFloatMat3 read FUNormalMatrix;
property Ut: TRglUniformFloat read FUt;
property UTranspColor: TRglUniformFloatVec3 read FUTranspColor;
property UOpaqueColor: TRglUniformFloatVec3 read FUOpaqueColor;
property UTranspColorMode: TRglUniformInt read FUTranspColorMode;
property UOpacity: TRglUniformFloat read FUOpacity;
property UPP_Greyscale: TRglUniformBool read FUPP_Greyscale;
property UPP_Invert: TRglUniformBool read FUPP_Invert;
property UPP_FlipV: TRglUniformBool read FUPP_FlipV;
property UPP_FlipH: TRglUniformBool read FUPP_FlipH;
property UPP_Binary: TRglUniformBool read FUPP_Binary;
property UPP_Spectra: TRglUniformBool read FUPP_Spectra;
property UPP_EdgeDetect: TRglUniformBool read FUPP_EdgeDetect;
property UPP_Sharpen: TRglUniformBool read FUPP_Sharpen;
property UPP_Blur: TRglUniformBool read FUPP_Blur;
property UPP_Underwater: TRglUniformBool read FUPP_Underwater;
end;
TProgramMgr = class
strict private
FControl: TVisCtl3D;
FPrograms: TObjectList<TManagedProgram>;
FCurrentProgram: TManagedProgram;
FTimeDependent: Boolean;
function LoadProgramResource(const AName: string; AData: TStringList): TManagedProgram;
public
constructor Create(AControl: TVisCtl3D);
destructor Destroy; override;
function GetProgram(const AName: string): TManagedProgram;
procedure UseProgram(const AName: string);
procedure BeginMonitorTime;
function EndMonitorTime: Boolean;
property CurrentProgram: TManagedProgram read FCurrentProgram;
end;
TMSAAValue = (msaa0 = 0, msaa2 = 2, msaa4 = 4, msaa8 = 8, msaa16 = 16,
msaa32 = 32, msaa64 = 64, msaa128 = 128);
TVisCtlObjectMenuItem = class(TMenuItem)
private
FObjRef: TGUID;
public
property ObjRef: TGUID read FObjRef;
end;
TVisCtl3D = class(TRglControl)
strict private
type
TRenderOutputData = record
Width, Height: Integer;
MSAA: TMSAAValue;
PostProc: Boolean;
Offscreen: Boolean;
function Aspect: Double;
class operator Equal(const Left, Right: TRenderOutputData): Boolean; static;
class operator NotEqual(const Left, Right: TRenderOutputData): Boolean; static;
end;
var
FRenderOutputData: TRenderOutputData;
FPrevRenderOutputData: TRenderOutputData;
FRenderToBitmap: Boolean;
FRenderToClipboard: Boolean;
FRenderFileName: string;
FFOV: Double;
FProjection: TProjection;
M, V, P: rglm4;
MVP: rglm4;
Eye: rglv;
FObjs: TDrawableList3D;
FCustomMenuItems: TList<TMenuItem>;
FOnBeforeContextPopup: TNotifyEvent;
FBackgroundPaintLevel: Integer;
FInvalidationTimer: TTimer;
FAnimationTimer: TAnimationTimer;
FProgramMgr: TProgramMgr;
FNewObjects: TList<TDrawable3D>;
FPrevMousePoint: TPoint;
FLightPos: rglv;
FMSAAbuf: GLuint;
FMSAAbuf_coloratt: GLuint;
FMSAAbuf_dsatt: GLuint;
Fauxbuf: GLuint;
Fauxbuf_coloratt: GLuint;
Fauxbuf_dsatt: GLuint;
Fosbuf: GLuint;
Fosbuf_coloratt: GLuint;
FScreenVAO: GLuint;
FScreenQuad: GLuint;
FMSAAValue: TMSAAValue;
FPostProcessing: Boolean;
FPopupMenu: TPopupMenu;
FToggleAxesMnuItem: TMenuItem;
FRemoveMnuItem: TVisCtlObjectMenuItem;
FProjSubmenu: TMenuItem;
FOrthogonalMnuItem,
FPerspectiveMnuItem: TMenuItem;
FMSAASubmenu: TMenuItem;
FPPSubmenu: TMenuItem;
FImplInfoMnuItem: TMenuItem;
FExtInfoMnuItem: TMenuItem;
FEffects: TPPEs;
FMaxSamples: Integer;
FPrevTick: Int64;
FGlobalTime: Double;
FImplData: TGLImplInfo;
FExts: TArray<string>;
FStencil: Boolean;
FScene: TScene;
FView: TView3D;
FAxes: TAxes;
procedure SetFov(const Value: Double);
procedure SetProjection(const Value: TProjection);
procedure ViewChanged(Sender: TObject);
procedure ComputeM;
procedure ComputeV;
procedure ComputeP(const ARenderOutputData: TRenderOutputData);
procedure ObjChanged(Sender: TObject);
procedure LowPriorityInvalidate;
procedure InvalidationTimerTimer(Sender: TObject);
procedure AnimationTimerTimer(Sender: TObject);
function GetObjectCount: Integer;
function GetObject(Index: Integer): TDrawable3D;
procedure SetupNewObjects;
procedure SetLightPos(const Value: rglv);
procedure MakeContextMenu;
procedure UpdateContextMenuStates(ASelObj: TDrawable3D);
procedure MnuSceneSettings(Sender: TObject);
procedure MnuObjectSettings(Sender: TObject);
procedure MnuToggleAxes(Sender: TObject);
procedure MnuRemoveObject(Sender: TObject);
procedure MnuSaveSceneToFile(Sender: TObject);
procedure MnuCopySceneToClipboard(Sender: TObject);
procedure MnuSetProj(Sender: TObject);
procedure MnuSetMSAA(Sender: TObject);
procedure MnuSetPP(Sender: TObject);
procedure MnuImplInfo(Sender: TObject);
procedure MnuExtInfo(Sender: TObject);
procedure SaveSceneToBitmap(const ARenderOutputData: TRenderOutputData;
ACleanUp, ARenderToClipboard: Boolean; const AFileName: string);
procedure SetMSAAValue(const Value: TMSAAValue);
procedure SetEffects(const Value: TPPEs);
function GetShowAxes: Boolean;
procedure SetShowAxes(const Value: Boolean);
procedure CustomizeMenu(AMenu: TMenu);
procedure FreeGLResources;
private
r, φ, θ: Double;
procedure RemoveObjectOrChild(AObject: TDrawable3D);
protected
procedure GLInit; override;
procedure FramebufferSetup(const ARenderOutputData: TRenderOutputData);
procedure Paint; override;
procedure Resize; override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer); override;
procedure MouseMove(Shift: TShiftState; X: Integer; Y: Integer); override;
function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean; override;
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
procedure KeyPress(var Key: Char); override;
procedure CreateWnd; override;
procedure DestroyWnd; override;
procedure WMContextMenu(var Message: TWMContextMenu); message WM_CONTEXTMENU;
procedure WMDestroy(var Message: TWMDestroy); message WM_DESTROY;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property Scene: TScene read FScene;
function NewObject<T: TDrawable3D>: T;
procedure AddObject(AObject: TDrawable3D);
property ObjectCount: Integer read GetObjectCount;
property Objects[Index: Integer]: TDrawable3D read GetObject;
procedure RemoveObject(AObject: TDrawable3D);
function HitTest(X, Y: Integer): TDrawable3D;
procedure ZoomIn(const Delta: Double; Shift: TShiftState);
procedure ZoomOut(const Delta: Double; Shift: TShiftState);
procedure Zoom(const Delta: Double; Shift: TShiftState);
procedure AddMenuItem(AMenuItem: TMenuItem);
procedure AddMenuItems(AMenu: TMenuItem);
procedure RemoveMenuItem(AMenuItem: TMenuItem);
procedure BeginBackgroundPaint;
procedure EndBackgroundPaint;
procedure SaveToBitmap(const AFileName: string; AWidth, AHeight: Integer);
procedure ClearScene;
property FOV: Double read FFOV write SetFov;
property Projection: TProjection read FProjection write SetProjection default Perspective;
property ObjectMgr: TDrawableList3D read FObjs;
property ProgramMgr: TProgramMgr read FProgramMgr;
property CurrentMatrix: rglm4 read MVP;
property CameraPos: rglv read Eye;
property LightPos: rglv read FLightPos write SetLightPos;
property GlobalTime: Double read FGlobalTime write FGlobalTime;
property ImplData: TGLImplInfo read FImplData;
property Stencil: Boolean read FStencil;
property Mat_M: rglm4 read M;
property Mat_V: rglm4 read V;
property Mat_P: rglm4 read P;
property Mat_MVP: rglm4 read MVP;
property View: TView3D read FView;
property Axes: TAxes read FAxes;
published
property Anchors;
property Align;
property AlignWithMargins;
property Color;
property Cursor;
property Effects: TPPEs read FEffects write SetEffects;
property Enabled;
property Font;
property MSAA: TMSAAValue read FMSAAValue write SetMSAAValue;
property ShowAxes: Boolean read GetShowAxes write SetShowAxes;
property TabStop default True;
property Visible;
property OnBeforeContextPopup: TNotifyEvent read FOnBeforeContextPopup
write FOnBeforeContextPopup;
property OnClick;
property OnDblClick;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnMouseEnter;
property OnMouseLeave;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
end;
procedure rglEnableDebugLog;
procedure rglLog(const S: string); overload;
procedure rglLog(const S: string; const AArgs: array of const); overload;
implementation
uses
StrUtils, Math, DateUtils, ASKernelDefs, ASPixmap, ImageSizeForm, IOUtils,
ObjFile, TDMB, Clipbrd, Vis3D_GeoObjSettings, ASColors, Vis3D_DrawableSettings,
Vis3D_SurfaceSettings, Vis3D_DrawableListSettings, Vis3D_ScatterPlotSettings,
Vis3D_VectorFieldSettings, Vis3D_ImageRectSettings, Vis3D_TextRectSettings,
Vis3D_AxisSettings, Vis3D_AxesSettings, Vis3D_GridSettings,
Vis3D_ModelSettings, Vis3D_CylinderSettings, Vis3D_SceneSettings,
Vis3D_ViewSettings, Vis3D_ArrowSettings;
var
InvFS: TFormatSettings;
RglDebugLog: Boolean;
procedure rglEnableDebugLog;
begin
RglDebugLog := RglDebugLog or AllocConsole;
end;
procedure rglLog(const S: string);
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);
begin
try
rglLog(Format(S, Aargs));
except
var ArgsStr := '';
try
for var LArg in AArgs do
case LArg.VType of
vtInteger:
ArgsStr := ArgsStr + IfThen(not ArgsStr.IsEmpty, ', ') + LArg.VInteger.ToString;
vtInt64:
ArgsStr := ArgsStr + IfThen(not ArgsStr.IsEmpty, ', ') + LArg.VInt64^.ToString;
vtBoolean:
ArgsStr := ArgsStr + IfThen(not ArgsStr.IsEmpty, ', ') + LArg.VBoolean.ToString(TUseBoolStrs.True);
vtExtended:
ArgsStr := ArgsStr + IfThen(not ArgsStr.IsEmpty, ', ') + LArg.VExtended^.ToString;
vtString:
ArgsStr := ArgsStr + IfThen(not ArgsStr.IsEmpty, ', ') + QuotedStr(string(LArg.VString^));
vtAnsiString:
ArgsStr := ArgsStr + IfThen(not ArgsStr.IsEmpty, ', ') + QuotedStr(string(AnsiString(LArg.VAnsiString)));
vtUnicodeString:
ArgsStr := ArgsStr + IfThen(not ArgsStr.IsEmpty, ', ') + QuotedStr(string(UnicodeString(LArg.VUnicodeString)));
vtWideString:
ArgsStr := ArgsStr + IfThen(not ArgsStr.IsEmpty, ', ') + QuotedStr(string(WideString(LArg.VWideString)));
vtChar:
ArgsStr := ArgsStr + IfThen(not ArgsStr.IsEmpty, ', ') + QuotedStr(string(LArg.VChar));
vtWideChar:
ArgsStr := ArgsStr + IfThen(not ArgsStr.IsEmpty, ', ') + QuotedStr(string(LArg.VWideChar));
vtPointer:
ArgsStr := ArgsStr + IfThen(not ArgsStr.IsEmpty, ', ') + NativeUInt(LArg.VPointer).ToHexString;
vtObject:
ArgsStr := ArgsStr + IfThen(not ArgsStr.IsEmpty, ', ') + NativeUInt(LArg.VObject).ToHexString;
vtClass:
ArgsStr := ArgsStr + IfThen(not ArgsStr.IsEmpty, ', ') + NativeUInt(LArg.VClass).ToHexString;
else
ArgsStr := ArgsStr + IfThen(not ArgsStr.IsEmpty, ', ') + '?';
end;
except
ArgsStr := '<argument error>';
end;
rglLog('rglLog: Format failed on ' + QuotedStr(S) + ' with arguments ' + ArgsStr + '.');
end;
end;
class operator rglv.Add(const Left, Right: rglv): rglv;
begin
Result.x := Left.x + Right.x;
Result.y := Left.y + Right.y;
Result.z := Left.z + Right.z;
end;
constructor rglv.Create(const x, y, z: Single);
begin
Self.x := x;
Self.y := y;
Self.z := z;
end;
class operator rglv.Divide(const Left: rglv; const Right: Single): rglv;
begin
Result.x := Left.x / Right;
Result.y := Left.y / Right;
Result.z := Left.z / Right;
end;
class operator rglv.Equal(const Left, Right: rglv): Boolean;
begin
Result := (Left.x = Right.x) and (Left.y = Right.y) and (Left.z = Right.z);
end;
class operator rglv.Implicit(const v: TRealVector): rglv;
begin
if v.Dimension <> 3 then
raise Exception.Create('Vector must be three-dimensional.');
Result.x := v[0];
Result.y := v[1];
Result.z := v[2];
end;
class operator rglv.Implicit(const c: TColor): rglv;
begin
Result.r := GetRValue(c) / 255;
Result.g := GetGValue(c) / 255;
Result.b := GetBValue(c) / 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;
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;
class operator rglv2.Add(const Left, Right: rglv2): rglv2;
begin
Result.x := Left.x + Right.x;
Result.y := Left.y + Right.y;
end;
constructor rglv2.Create(const x, y: Single);
begin
Self.x := x;
Self.y := y;
end;
class operator rglv2.Divide(const Left: rglv2; const Right: Single): rglv2;
begin
Result.x := Left.x / Right;
Result.y := Left.y / Right;
end;
class operator rglv2.Equal(const Left, Right: rglv2): Boolean;
begin
Result := (Left.x = Right.x) and (Left.y = Right.y);
end;
class operator rglv2.Implicit(const v: rglv2): GLfloat2;
begin
Result := v.elem;
end;
class operator rglv2.Implicit(const arr: GLfloat2): rglv2;
begin
Result.elem := arr;
end;
class operator rglv2.Multiply(const Left: Single; const Right: rglv2): rglv2;
begin
Result.x := Left * Right.x;
Result.y := Left * Right.y;
end;
class operator rglv2.Multiply(const Left: rglv2; const Right: Single): rglv2;
begin
Result.x := Left.x * Right;
Result.y := Left.y * Right;
end;
class operator rglv2.Multiply(const Left, Right: rglv2): Single;
begin
Result := Left.x * Right.x + Left.y * Right.y;
end;
function rglv2.Norm: Single;
begin
Result := Sqrt(Self * Self);
end;
function rglv2.Normalized: rglv2;
begin
Result := (1 / Norm) * Self;
end;
function rglv2.NormSquare: Single;
begin
Result := Self * Self;
end;
class operator rglv2.NotEqual(const Left, Right: rglv2): Boolean;
begin
Result := not (Left = Right);
end;
function rglv2.ptr: PGLfloat;
begin
Result := PGLfloat(@Self);
end;
class operator rglv2.Subtract(const Left, Right: rglv2): rglv2;
begin
Result.x := Left.x - Right.x;
Result.y := Left.y - Right.y;
end;
class function rglv2.Zero: rglv2;
const Z: rglv2 =
(
elem:
(
0, 0
)
);
begin
Result := Z;
end;
function vec2(const x, y: Single): rglv2;
begin
Result.x := x;
Result.y := y;
end;
class operator rglv2.Implicit(const v: TRealVector): rglv2;
begin
if v.Dimension <> 2 then
raise Exception.Create('Vector must be two-dimensional.');
Result.x := v[0];
Result.y := v[1];
end;
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;
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;
class function TPPEHelper.FromString(const S: string): TPPE;
begin
for var e := Low(TPPE) to High(TPPE) do
if SameText(e.Name, S) then
Exit(e);
raise ERglError.CreateFmt('Unknown effect: "%s".', [S]);
end;
function TPPEHelper.ID: Integer;
begin
Result := 1 shl Ord(Self);
end;
function TPPEHelper.Name: string;
begin
case Self of
ppIdentity:
Result := 'Identity';
ppGreyscale:
Result := 'Greyscale';
ppInvert:
Result := 'Invert';
ppFlipH:
Result := 'Horizontal flip';
ppFlipV:
Result := 'Vertical flip';
ppBinary:
Result := 'Binarize';
ppSpectra:
Result := 'Spectra';
ppEdgeDetect:
Result := 'Edge detection';
ppBlur:
Result := 'Blur';
ppSharpen:
Result := 'Sharpen';
ppUnderwater:
Result := 'Underwater';
else
Result := '';
end;
end;
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;
begin
if Assigned(FContext) and FContext.TryMakeCurrent then
begin
glDeleteShader(FHandle);
FHandle := 0;
end
else
rglLog('TRglShader.Destroy error');
inherited;
end;
constructor TRglVertexShader.Create(AContext: TRglContext; const ASource: string);
begin
FKind := GL_VERTEX_SHADER;
inherited;
end;
constructor TRglFragmentShader.Create(AContext: TRglContext; const ASource: string);
begin
FKind := GL_FRAGMENT_SHADER;
inherited;
end;
constructor TRglGeometryShader.Create(AContext: TRglContext; const ASource: string);
begin
FKind := GL_GEOMETRY_SHADER;
inherited;
end;
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;
procedure TRglUniformFloat.SetValue(const AValue: GLfloat);
begin
if Self <> nil then
begin
Context.MakeCurrent('TRglUniformFloat.SetValue');
glUniform1f(Handle, AValue);
end;
end;
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;
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;
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;
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;
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;
procedure TRglUniformInt.SetValue(const AValue: GLint);
begin
if Self <> nil then
begin
Context.MakeCurrent('TRglUniformInt.SetValue');
glUniform1i(Handle, AValue);
end;
end;
procedure TRglUniformUInt.SetValue(const AValue: GLuint);
begin
if Self <> nil then
begin
Context.MakeCurrent('TRglUniformUInt.SetValue');
glUniform1ui(Handle, AValue);
end;
end;
procedure TRglUniformDouble.SetValue(const AValue: Double);
begin
if Self <> nil then
begin
Context.MakeCurrent('TRglUniformDouble.SetValue');
glUniform1d(Handle, AValue);
end;
end;
procedure TRglUniformBool.SetValue(const AValue: Boolean);
begin
if Self <> nil then
begin
Context.MakeCurrent('TRglUniformBool.SetValue');
glUniform1i(Handle, Ord(AValue <> False));
end;
end;
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;
type
wglCreateContextAttribsARB = function(DC: HDC; hShareContext: HGLRC; attribList: PInteger): HGLRC; stdcall;
class constructor TRglContext.ClassCreate;
begin
FInstances := TList<TRglContext>.Create;
end;
class destructor TRglContext.ClassDestroy;
begin
FreeAndNil(FInstances);
end;
constructor TRglContext.Create(AWnd: HWND);
const
pfd: TPixelFormatDescriptor = (
nSize: SizeOf(TPixelFormatDescriptor);
nVersion: 1;
dwFlags: PFD_SUPPORT_OPENGL or PFD_DRAW_TO_WINDOW or PFD_DOUBLEBUFFER;
iPixelType: PFD_TYPE_RGBA;
cColorBits: 32;
cRedBits: 0; cRedShift: 0;
cGreenBits: 0; cGreenShift: 0;
cBlueBits: 0; cBlueShift: 0;
cAlphaBits: 0; cAlphaShift: 0;
cAccumBits: 0;
cAccumRedBits: 0;
cAccumGreenBits: 0;
cAccumBlueBits: 0;
cAccumAlphaBits: 0;
cDepthBits: 24;
cStencilBits: 0;
cAuxBuffers: 0;
iLayerType: PFD_MAIN_PLANE;
bReserved: 0;
dwLayerMask: 0;
dwVisibleMask: 0;
dwDamageMask: 0;
);
WGL_CONTEXT_MAJOR_VERSION_ARB = $2091;
WGL_CONTEXT_MINOR_VERSION_ARB = $2092;
WGL_CONTEXT_LAYER_PLANE_ARB = $2093;
WGL_CONTEXT_FLAGS_ARB = $2094;
WGL_CONTEXT_PROFILE_MASK_ARB = $9126;
WGL_CONTEXT_DEBUG_BIT_ARB = $0001;
WGL_CONTEXT_FORWARD_COMPATIBLE_BIT_ARB = $0002;
WGL_CONTEXT_CORE_PROFILE_BIT_ARB = $00000001;
WGL_CONTEXT_COMPATIBILITY_PROFILE_BIT_ARB = $00000002;
attribs: array[0..6] of Integer =
(
WGL_CONTEXT_MAJOR_VERSION_ARB,
3,
WGL_CONTEXT_MINOR_VERSION_ARB,
3,
WGL_CONTEXT_FLAGS_ARB,
{$IFDEF DEBUG}
WGL_CONTEXT_DEBUG_BIT_ARB
{$ELSE}
0
{$ENDIF},
0
);
begin
rglLog('TRglContext.Create');
if Assigned(FInstances) then
begin
FInstances.Add(Self);
rglLog('RGL context count: ' + FInstances.Count.ToString);
end;
FStockSurfaces := TDictionary<TStockSurfaceIndex, TStockSurfaceData>.Create;
FStoredSolids := TDictionary<TDrawable3DClass, TSolidStoreRec>.Create;
FCustomBuffers := TObjectDictionary<TDrawable3DClass, TObject>.Create([doOwnsValues]);
FWnd := AWnd;
FDC := GetDC(AWnd);
if FDC = 0 then
raise ERglError.Create('Couldn''t obtain device context during GL context creation.');
var PixelFormat := ChoosePixelFormat(FDC, @pfd);
if PixelFormat = 0 then
RaiseLastOSError;
if not SetPixelFormat(FDC, PixelFormat, @pfd) then
RaiseLastOSError;
FRC := wglCreateContext(FDC);
if FRC = 0 then
RaiseLastOSError;
TRglContext.MakeCurrent(FDC, FRC, 'TRglContext.Create[1]');
InitOpenGLext;
var LwglCreateContextAttribsARB: wglCreateContextAttribsARB := wglGetProcAddress('wglCreateContextAttribsARB');
if Assigned(LwglCreateContextAttribsARB) then
begin
TRglContext.MakeCurrent(0, 0, 'TRglContext.Create[2]');
wglDeleteContext(FRC);
FRC := LwglCreateContextAttribsARB(FDC, 0, @attribs);
if FRC = 0 then
RaiseLastOSError;
TRglContext.MakeCurrent(FDC, FRC, 'TRglContext.Create[3]');
end;
end;
destructor TRglContext.Destroy;
begin
rglLog('TRglContext.Destroy');
if wglGetCurrentContext = FRC then
begin
if not TRglContext.TryMakeCurrent(0, 0) then
rglLog('TRglContext.Destroy: TryMakeCurrent failed');
end;
if FDC <> 0 then
begin
ReleaseDC(FWnd, FDC);
FDC := 0;
end;
if FRC <> 0 then
begin
if not wglDeleteContext(FRC) then
rglLog('TRglContext.Destroy: wglDeleteContext failed');
FRC := 0;
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;
procedure TRglControl.ApplyClearColor;
begin
if Assigned(FContext) then
begin
FContext.MakeCurrent('TRglControl.ApplyClearColor');
glClearColor(FGlCtlColor.r, FGlCtlColor.g, FGlCtlColor.b, 1.0);
end;
end;
procedure TRglControl.CMColorChanged(var Message: TMessage);
begin
var C := ColorToRGB(Color);
FGlCtlColor := vec(GetRValue(C) / $FF, GetGValue(C) / $FF, GetBValue(C) / $FF);
ApplyClearColor;
Invalidate;
end;
constructor TRglControl.Create(AOwner: TComponent);
begin
inherited;
QueryPerformanceFrequency(FPerfFreq);
Color := clWhite;
FGlCtlColor := vec(1.0, 1.0, 1.0);
FClearMask := GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT;
end;
procedure TRglControl.CreateParams(var Params: TCreateParams);
begin
inherited;
Params.WindowClass.Style := Params.WindowClass.Style or CS_OWNDC;
end;
procedure TRglControl.CreateWnd;
begin
inherited;
FreeAndNil(FContext);
FContext := TRglContext.Create(Handle);
ApplyClearColor;
GlInit;
end;
destructor TRglControl.Destroy;
begin
inherited;
end;
procedure TRglControl.DestroyWnd;
begin
FreeAndNil(FContext);
inherited;
end;
function TRglControl.GetAspectRatio: Double;
begin
var W := ClientWidth;
var H := ClientHeight;
if (W <> 0) and (H <> 0) then
Result := W/H
else
Result := 1.0;
end;
procedure TRglControl.GLInit;
begin
end;
procedure TRglControl.Resize;
begin
if Assigned(FContext) then
begin
FContext.MakeCurrent('TRglControl.Resize');
glViewport(0, 0, ClientWidth, ClientHeight);
end;
Invalidate;
inherited;
end;
procedure TRglControl.WMDestroy(var Message: TWMDestroy);
begin
FreeAndNil(FContext);
inherited;
end;
procedure TRglControl.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
Message.Result := 1;
end;
procedure TRglControl.WMGetDlgCode(var Message: TWMGetDlgCode);
begin
inherited;
Message.Result := Message.Result or DLGC_WANTARROWS;
end;
procedure TRglControl.WMPaint(var Message: TWMPaint);
var
PaintStruct: TPaintStruct;
begin
var LThisTick: Int64;
QueryPerformanceCounter(LThisTick);
if (FPrevTick <> 0) and (LThisTick > FPrevTick) then
FFPS := FPerfFreq / (LThisTick - FPrevTick);
FPrevTick := LThisTick;
BeginPaint(Handle, PaintStruct);
try
if Assigned(FContext) then
begin
FContext.MakeCurrent('TRglControl.WMPaint');
if FClearMask <> 0 then
glClear(FClearMask);
Paint;
if not ((Self is TVisCtl3D) and TVisCtl3D(Self).Stencil) then
FContext.SwapBuffers;
end
else
begin
Canvas.Brush.Color := clWhite;
Canvas.Font.Assign(Font);
Canvas.Font.Color := clBlack;
var R := ClientRect;
var S := 'OpenGL context not set up.';
Canvas.TextRect(R, S, [tfSingleLine, tfCenter, tfVerticalCenter, tfEndEllipsis]);
end;
finally
EndPaint(Handle, PaintStruct);
end;
end;
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;
procedure TVisCtl3D.SaveSceneToBitmap(const ARenderOutputData: TRenderOutputData;
ACleanUp, ARenderToClipboard: Boolean; const AFileName: string);
begin
try
var bm := TBitmap.Create(ARenderOutputData.Width, ARenderOutputData.Height);
try
bm.PixelFormat := pf24bit;
var p := bm.ScanLine[bm.Height - 1];
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;
end;
procedure TVisCtl3D.SaveToBitmap(const AFileName: string; AWidth,
AHeight: Integer);
begin
FRenderToBitmap := True;
FRenderToClipboard := False;
FRenderFileName := AFileName;
FRenderOutputData.Offscreen := (AWidth <> ClientWidth) or (AHeight <> ClientHeight);
FRenderOutputData.Width := AWidth;
FRenderOutputData.Height := AHeight;
Invalidate;
end;
procedure TVisCtl3D.SetEffects(const Value: TPPEs);
begin
if FEffects <> Value then
begin
FEffects := Value;
FPostProcessing := FEffects <> [];
Invalidate;
end;
end;
procedure TVisCtl3D.SetFov(const Value: Double);
begin
if FFov <> Value then
begin
FFov := Value;
if FProjection = Perspective then
begin
ComputeP(FRenderOutputData);
Invalidate;
end;
end;
end;
procedure TVisCtl3D.SetLightPos(const Value: rglv);
begin
if FLightPos <> Value then
begin
FLightPos := Value;
Invalidate;
end;
end;
procedure TVisCtl3D.SetMSAAValue(const Value: TMSAAValue);
begin
if FMSAAValue <> Value then
begin
FMSAAValue := Value;
Invalidate;
end;
end;
procedure TVisCtl3D.SetProjection(const Value: TProjection);
begin
if FProjection <> Value then
begin
FProjection := Value;
ComputeP(FRenderOutputData);
for var obj in FObjs.List do
obj.ProjectionChanged;
Invalidate;
end;
end;
procedure TVisCtl3D.SetShowAxes(const Value: Boolean);
begin
if Assigned(FAxes) then
FAxes.Visible := Value;
end;
procedure TVisCtl3D.SetupNewObjects;
begin
if Assigned(FNewObjects) and (FNewObjects.Count > 0) then
begin
Screen.Cursor := crHourGlass;
try
for var NewObject in FNewObjects do
try
NewObject.Setup;
except
NewObject.FVisible := False;
end;
FNewObjects.Clear;
finally
Screen.Cursor := crDefault;
end;
end;
end;
procedure TVisCtl3D.UpdateContextMenuStates(ASelObj: TDrawable3D);
begin
if Assigned(FPopupMenu) then
begin
if Assigned(FToggleAxesMnuItem) then
FToggleAxesMnuItem.Checked := ShowAxes;
if Assigned(FMSAASubmenu) then
for var i := 0 to FMSAASubmenu.Count - 1 do
begin
FMSAASubmenu.Items[i].Checked := FMSAASubmenu.Items[i].Tag = Ord(FMSAAValue);
FMSAASubmenu.Items[i].Visible := FMSAASubmenu.Items[i].Tag <= FMaxSamples;
end;
if Assigned(FPPSubmenu) then
for var i := 0 to FPPSubmenu.Count - 1 do
FPPSubmenu.Items[i].Checked := TPPE(FPPSubmenu.Items[i].Tag) in FEffects;
if Assigned(FOrthogonalMnuItem) then
FOrthogonalMnuItem.Checked := Projection = Orthographic;
if Assigned(FPerspectiveMnuItem) then
FPerspectiveMnuItem.Checked := Projection = Perspective;
if Assigned(FRemoveMnuItem) then
begin
FRemoveMnuItem.Enabled := Assigned(ASelObj);
if Assigned(ASelObj) then
FRemoveMnuItem.FObjRef := ASelObj.GUID
else
FRemoveMnuItem.FObjRef := TGUID.Empty;
end;
for var i := FPopupMenu.Items.Count - 1 downto 0 do
if (FPopupMenu.Items[i] is TVisCtlObjectMenuItem) and (FPopupMenu.Items[i] <> FRemoveMnuItem) then
FPopupMenu.Items.Delete(i);
if Assigned(ASelObj) then
begin
var i := 0;
var LCurObj := ASelObj;
repeat
var MI := TVisCtlObjectMenuItem.Create(FPopupMenu);
MI.Caption := Format('%s settings', [LCurObj.Name]);
MI.Hint := Format('Displays the settings dialog for this %s object.', [LCurObj.Name]);
MI.FObjRef := LCurObj.GUID;
MI.OnClick := MnuObjectSettings;
FPopupMenu.Items.Insert(i, MI);
LCurObj := LCurObj.FParent;
Inc(i);
until LCurObj = nil;
end;
var ShiftKeyDown := GetKeyState(VK_SHIFT) < 0;
if Assigned(FImplInfoMnuItem) then
FImplInfoMnuItem.Visible := ShiftKeyDown;
if Assigned(FExtInfoMnuItem) then
FExtInfoMnuItem.Visible := ShiftKeyDown;
end;
end;
procedure TVisCtl3D.ViewChanged(Sender: TObject);
begin
ComputeV;
if FProjection = Orthographic then
ComputeP(FRenderOutputData);
Invalidate;
end;
procedure TVisCtl3D.WMContextMenu(var Message: TWMContextMenu);
var
P: TPoint;
begin
if Assigned(FPopupMenu) then
begin
var LObj := TDrawable3D(nil);
if Message.Pos = Point(-1, -1) then
P := ClientToScreen(BoundsRect.CenterPoint)
else
begin
P := Message.Pos;
with ScreenToClient(P) do
LObj := HitTest(X, Y);
end;
UpdateContextMenuStates(LObj);
CustomizeMenu(FPopupMenu);
if Assigned(FOnBeforeContextPopup) then
FOnBeforeContextPopup(Self);
FPopupMenu.Popup(P.X, P.Y);
end
else
inherited;
end;
procedure TVisCtl3D.WMDestroy(var Message: TWMDestroy);
begin
FreeGLResources;
inherited;
end;
procedure TVisCtl3D.Zoom(const Delta: Double; Shift: TShiftState);
begin
var F := 1.0;
if ssCtrl in Shift then
F := 10
else if ssShift in Shift then
F := 0.1;
var q: Double := Pow(1.1, -F * Delta);
r := q * r;
r := EnsureRange(r, 0.01, 900);
ComputeV;
if FProjection = Orthographic then
ComputeP(FRenderOutputData);
Invalidate;
end;
procedure TVisCtl3D.ZoomIn(const Delta: Double; Shift: TShiftState);
begin
Zoom(Abs(Delta), Shift);
end;
procedure TVisCtl3D.ZoomOut(const Delta: Double; Shift: TShiftState);
begin
Zoom(-Abs(Delta), Shift);
end;
procedure TVisCtl3D.ClearScene;
begin
var LObjects := TList<TDrawable3D>.Create;
try
for var i := 0 to FObjs.ItemCount - 1 do
begin
var LObj := FObjs.Items[i];
if Assigned(LObj) and (LObj.Parent = nil) and not LObj.FProtected and (LObj <> FAxes) then
LObjects.Add(LObj);
end;
for var LObj in LObjects do
RemoveObject(LObj);
finally
LObjects.Free;
end;
end;
procedure TVisCtl3D.ComputeM;
begin
M :=
rglRotate(-90, 0, 0, 1)
*
rglRotate(-90, 0, 1, 0);
end;
procedure TVisCtl3D.ComputeP(const ARenderOutputData: TRenderOutputData);
begin
var AR: Single;
if
((ARenderOutputData.Width = 0) or (ARenderOutputData.Height = 0)) and not ARenderOutputData.Offscreen
then
begin
if (ClientWidth <> 0) and (ClientHeight <> 0) then
AR := ClientWidth / ClientHeight
else
AR := 1.0;
end
else
AR := ARenderOutputData.Aspect;
case FProjection of
Orthographic:
P := rglOrtho(-r, r, -r / AR, r / AR, 0.1, 1000);
Perspective:
P := rglPerspective(FFOV, AR, 0.1, 1000)
else
P := rglm4.Identity;
end;
end;
procedure TVisCtl3D.ComputeV;
begin
eye.x := r*Sin(θ)*Cos(φ);
eye.y := r*Sin(θ)*Sin(φ);
eye.z := r*Cos(θ);
var z := eye.x;
var x := eye.y;
var y := eye.z;
var u: rglv;
if IsZero(θ, 1E-7) then
u := vec(-Sin(φ), 0, -Cos(φ))
else if IsZero(θ - Pi, 1E-7) then
u := vec(Sin(φ), 0, Cos(φ))
else
u := vec(0, 1, 0);
V := rglLookAt(x, y, z, 0.0, 0.0, 0.0, u.x, u.y, u.z);
end;
constructor TVisCtl3D.Create(AOwner: TComponent);
begin
inherited;
FMSAAValue := msaa8;
ClearMask := 0;
r := 25;
θ := Pi/4;
φ := Pi/4;
ComputeM;
ComputeV;
FFOV := 45;
FLightPos := vec(10.0, 12.0, 8.0);
FProjection := Perspective;
FNewObjects := TList<TDrawable3D>.Create;
FScene := TScene.Create(Self);
FView := TView3D.Create(Self);
FView.OnChange := ViewChanged;
FObjs := TDrawableList3D.Create(Self);
FObjs.OnChange := ObjChanged;
FAxes := NewObject<TAxes>;
FAxes.FProtected := True;
FInvalidationTimer := TTimer.Create(Self);
FInvalidationTimer.Interval := 50;
FInvalidationTimer.OnTimer := InvalidationTimerTimer;
FInvalidationTimer.Enabled := False;
FAnimationTimer := TAnimationTimer.Create(Self);
FAnimationTimer.Control := Self;
FAnimationTimer.OnTimer := AnimationTimerTimer;
FAnimationTimer.Enabled := False;
TabStop := True;
FCustomMenuItems := TList<TMenuItem>.Create;
MakeContextMenu;
{$IFDEF DEBUG}
var DBG := TTextRect.Create(Self);
Self.AddObject(DBG);
DBG.Text := 'debugging mode';
DBG.Opacity := 0.25;
DBG.Position := vec(-0.001, 0.1, 0.1);
DBG.Direction := vec(1, 0, 0);
DBG.Scale := DBG.Scale * 0.2;
DBG.AnchorPoint := apBottomLeft;
DBG.TextResFactor := 0.4;
DBG.FProtected := True;
{$ENDIF}
end;
procedure TVisCtl3D.CreateWnd;
begin
inherited;
end;
procedure TVisCtl3D.CustomizeMenu(AMenu: TMenu);
begin
if FCustomMenuItems = nil then
Exit;
if AMenu = nil then
Exit;
for var i := 0 to FCustomMenuItems.Count - 1 do
begin
if Assigned(FCustomMenuItems[i].Parent) then
FCustomMenuItems[i].Parent.Remove(FCustomMenuItems[i]);
AMenu.Items.Add(FCustomMenuItems[i]);
end;
end;
procedure TVisCtl3D.ObjChanged(Sender: TObject);
begin
LowPriorityInvalidate;
end;
procedure TVisCtl3D.AnimationTimerTimer(Sender: TObject);
begin
Invalidate;
end;
procedure TVisCtl3D.BeginBackgroundPaint;
begin
Inc(FBackgroundPaintLevel);
end;
procedure TVisCtl3D.EndBackgroundPaint;
begin
Dec(FBackgroundPaintLevel);
end;
procedure TVisCtl3D.FramebufferSetup(const ARenderOutputData: TRenderOutputData);
const
ScreenQuad: array[0..2*2*2*3-1] of GLfloat =
(
-1.0, +1.0, 0.0, 1.0,
-1.0, -1.0, 0.0, 0.0,
+1.0, -1.0, 1.0, 0.0,
-1.0, +1.0, 0.0, 1.0,
+1.0, -1.0, 1.0, 0.0,
+1.0, +1.0, 1.0, 1.0
);
begin
if Context = nil then
Exit;
Context.MakeCurrent('TVisCtl3D.FramebufferSetup');
var LMaxSamples: GLint;
glGetIntegerv(GL_MAX_SAMPLES, @LMaxSamples);
if Ord(FMSAAValue) > LMaxSamples then
FMSAAValue := TMSAAValue(LMaxSamples);
FMaxSamples := LMaxSamples;
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;
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;
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;
if ARenderOutputData.Offscreen then
begin
if Fosbuf = 0 then
glGenFramebuffers(1, @Fosbuf);
glBindFramebuffer(GL_FRAMEBUFFER, Fosbuf);
if Fosbuf_coloratt = 0 then
glGenTextures(1, @Fosbuf_coloratt);
glBindTexture(GL_TEXTURE_2D, Fosbuf_coloratt);
glTexImage2D(GL_TEXTURE_2D, 0, GL_RGB, ARenderOutputData.Width, ARenderOutputData.Height,
0, GL_RGB, GL_UNSIGNED_BYTE, nil);
glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR);
glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR);
glFramebufferTexture2D(GL_FRAMEBUFFER, GL_COLOR_ATTACHMENT0, GL_TEXTURE_2D,
Fosbuf_coloratt, 0);
if glCheckFramebufferStatus(GL_FRAMEBUFFER) <> GL_FRAMEBUFFER_COMPLETE then
DebugBreak;
end
else
begin
if Fosbuf_coloratt <> 0 then
begin
glDeleteTextures(1, @Fosbuf_coloratt);
Fosbuf_coloratt := 0;
end;
if Fosbuf <> 0 then
begin
glDeleteFramebuffers(1, @Fosbuf);
Fosbuf := 0;
end;
end;
end;
procedure TVisCtl3D.FreeGLResources;
begin
if HandleAllocated and Assigned(Context) then
begin
if Context.TryMakeCurrent then
begin
if Assigned(FObjs) then
FObjs.FreeGLResources;
glDeleteBuffers (1, @FScreenQuad); FScreenQuad := 0;
glDeleteTextures (1, @Fosbuf_coloratt); Fosbuf_coloratt := 0;
glDeleteFramebuffers (1, @Fosbuf); Fosbuf := 0;
glDeleteRenderbuffers (1, @Fauxbuf_dsatt); Fauxbuf_dsatt := 0;
glDeleteTextures (1, @Fauxbuf_coloratt); Fauxbuf_coloratt := 0;
glDeleteFramebuffers (1, @Fauxbuf); Fauxbuf := 0;
glDeleteVertexArrays (1, @FScreenVAO); FScreenVAO := 0;
glDeleteRenderbuffers (1, @FMSAAbuf_dsatt); FMSAAbuf_dsatt := 0;
glDeleteTextures (1, @FMSAAbuf_coloratt); FMSAAbuf_coloratt := 0;
glDeleteFramebuffers (1, @FMSAAbuf); FMSAAbuf := 0;
end
else
rglLog('TVisCtl3D.FreeGLResources: TryMakeCurrent failed');
FreeAndNil(FProgramMgr);
end;
end;
procedure TVisCtl3D.InvalidationTimerTimer(Sender: TObject);
begin
FInvalidationTimer.Enabled := False;
Invalidate;
end;
procedure TVisCtl3D.KeyDown(var Key: Word; Shift: TShiftState);
begin
inherited;
case Key of
VK_LEFT:
begin
φ := rmod(φ - Pi/50, 2*Pi);
ComputeV;
Invalidate;
end;
VK_RIGHT:
begin
φ := rmod(φ + Pi/50, 2*Pi);
ComputeV;
Invalidate;
end;
VK_UP:
begin
θ := EnsureRange(θ - Pi/50, 0, Pi);
ComputeV;
Invalidate;
end;
VK_DOWN:
begin
θ := EnsureRange(θ + Pi/50, 0, Pi);
ComputeV;
Invalidate;
end;
VK_OEM_MINUS, VK_SUBTRACT:
ZoomOut(1, Shift);
VK_OEM_PLUS, VK_ADD:
ZoomIn(1, Shift);
end;
end;
procedure TVisCtl3D.KeyPress(var Key: Char);
begin
inherited;
case Key of
^A:
MnuToggleAxes(Self);
^C:
MnuCopySceneToClipboard(Self);
^S:
MnuSaveSceneToFile(Self);
end;
end;
procedure TVisCtl3D.LowPriorityInvalidate;
begin
if FBackgroundPaintLevel <= 0 then
Invalidate
else
FInvalidationTimer.Enabled := True;
end;
procedure TVisCtl3D.MakeContextMenu;
begin
if Assigned(FPopupMenu) then
Exit;
FPopupMenu := TPopupMenu.Create(Self);
var mi := TMenuItem.Create(FPopupMenu);
mi.Caption := 'Scene settings';
mi.Hint := 'Opens the scene''s settings dialog.';
mi.OnClick := MnuSceneSettings;
FPopupMenu.Items.Add(mi);
FPopupMenu.Items.NewBottomLine;
mi := TVisCtlObjectMenuItem.Create(FPopupMenu);
mi.Caption := 'Remove this object';
mi.Hint := 'Removes the selected object.';
mi.OnClick := MnuRemoveObject;
FPopupMenu.Items.Add(mi);
FRemoveMnuItem := mi as TVisCtlObjectMenuItem;
FPopupMenu.Items.NewBottomLine;
mi := TMenuItem.Create(FPopupMenu);
mi.Caption := 'Show axes'#9'Ctrl+A';
mi.Hint := 'Shows or hides the coordinate axes.';
mi.OnClick := MnuToggleAxes;
FPopupMenu.Items.Add(mi);
FToggleAxesMnuItem := mi;
FPopupMenu.Items.NewBottomLine;
mi := TMenuItem.Create(FPopupMenu);
mi.Caption := 'Save image to file...'#9'Ctrl+S';
mi.Hint := 'Saves the current scene to a bitmap picture file.';
mi.OnClick := MnuSaveSceneToFile;
FPopupMenu.Items.Add(mi);
mi := TMenuItem.Create(FPopupMenu);
mi.Caption := 'Copy image to clipboard...'#9'Ctrl+C';
mi.Hint := 'Copies the current scene to the clipboard.';
mi.OnClick := MnuCopySceneToClipboard;
FPopupMenu.Items.Add(mi);
FPopupMenu.Items.NewBottomLine;
mi := TMenuItem.Create(FPopupMenu);
mi.Caption := 'Projection';
mi.Hint := 'Contains the available projections.';
FPopupMenu.Items.Add(mi);
FProjSubmenu := mi;
var smi := TMenuItem.Create(mi);
smi.Caption := 'Orthographic';
smi.Hint := 'Displays the scene using orthographic projection.';
smi.Tag := 0;
smi.OnClick := MnuSetProj;
smi.RadioItem := True;
mi.Add(smi);
FOrthogonalMnuItem := smi;
smi := TMenuItem.Create(mi);
smi.Caption := 'Perspective';
smi.Hint := 'Displays the scene using perspective projection.';
smi.Tag := 1;
smi.OnClick := MnuSetProj;
smi.RadioItem := True;
mi.Add(smi);
FPerspectiveMnuItem := smi;
mi := TMenuItem.Create(FPopupMenu);
mi.Caption := 'Anti-aliasing';
mi.Hint := 'Contains the anti-aliasing options.';
FPopupMenu.Items.Add(mi);
FMSAASubmenu := mi;
smi := TMenuItem.Create(mi);
smi.Caption := 'No anti-aliasing';
smi.Hint := 'Disables all anti-aliasing.';
smi.Tag := Ord(msaa0);
smi.OnClick := MnuSetMSAA;
smi.RadioItem := True;
mi.Add(smi);
var LMSAAValue := 2;
while LMSAAValue <= Ord(High(TMSAAValue)) do
begin
smi := TMenuItem.Create(mi);
smi.Caption := Format('%d× MSAA', [LMSAAValue]);
smi.Hint := Format('Enables %d× MSAA.', [LMSAAValue]);
smi.Tag := LMSAAValue;
smi.OnClick := MnuSetMSAA;
smi.RadioItem := True;
mi.Add(smi);
LMSAAValue := 2 * LMSAAValue;
end;
mi := TMenuItem.Create(FPopupMenu);
mi.Caption := 'Effects';
mi.Hint := 'Contains available post-processing effects.';
FPopupMenu.Items.Add(mi);
FPPSubmenu := mi;
for var ppe := Low(TPPE) to High(TPPE) do
begin
smi := TMenuItem.Create(mi);
smi.Caption := ppe.Name;
smi.Hint := Format('Enables or disables the %s post-processing effect.', [ppe.Name]);
smi.Tag := Ord(ppe);
smi.OnClick := MnuSetPP;
mi.Add(smi);
end;
FPopupMenu.Items.NewBottomLine;
mi := TMenuItem.Create(FPopupMenu);
mi.Caption := 'OpenGL info';
mi.Hint := 'Displays information about your system''s OpenGL implementation.';
mi.OnClick := MnuImplInfo;
FPopupMenu.Items.Add(mi);
FImplInfoMnuItem := mi;
mi := TMenuItem.Create(FPopupMenu);
mi.Caption := 'OpenGL extensions';
mi.Hint := 'Displays information about your system''s OpenGL extensions.';
mi.OnClick := MnuExtInfo;
FPopupMenu.Items.Add(mi);
FExtInfoMnuItem := mi;
mi := TMenuItem.Create(FPopupMenu);
mi.Caption := '-';
FPopupMenu.Items.Add(mi);
end;
procedure TVisCtl3D.MnuCopySceneToClipboard(Sender: TObject);
begin
var W: Integer := Max(ClientWidth, 1);
var H: Integer := Max(ClientHeight, 1);
var Aspect: Double := 0.0;
if ImageSizeDialog(GetParentForm(Self), W, H, Aspect) then
begin
FRenderToBitmap := True;
FRenderToClipboard := True;
FRenderOutputData.Offscreen := (W <> ClientWidth) or (H <> ClientHeight);
FRenderOutputData.Width := W;
FRenderOutputData.Height := H;
Invalidate;
end;
end;
procedure TVisCtl3D.MnuImplInfo(Sender: TObject);
begin
TTableDialog.ShowTable(
GetParentForm(Self),
'OpenGL Info',
'OpenGL implementation data',
[
'Version',
'Vendor',
'Renderer',
'GLSL version',
'Context profile mask',
'Context flags',
'Line widths (aliased)',
'Line widths (smooth)',
'Max MSAA samples',
'Max texture size',
'Max texture anisotropy'
],
[
FImplData.VersionString + #32'(' + FImplData.Version.Major.ToString + '.' + FImplData.Version.Minor.ToString + ')',
FImplData.Vendor,
FImplData.Renderer,
FImplData.GLSL,
FImplData.ContextProfileMask.ToHexString,
FImplData.ContextFlags.ToHexString,
FImplData.LineWidths.Aliased.Min.ToString + '..' + FImplData.LineWidths.Aliased.Max.ToString,
FImplData.LineWidths.Smooth.Min.ToString + '..' + FImplData.LineWidths.Smooth.Max.ToString,
FImplData.MaxSamples.ToString,
FImplData.MaxTextureSize.ToString,
FImplData.MaxTextureAnisotropy.ToString
],
TMsgDlgType.mtCustom
);
end;
procedure TVisCtl3D.MnuExtInfo(Sender: TObject);
begin
if
TD
.Text('Do you want to copy the list of OpenGL extensions to clipboard?')
.YesNoCancel
.Execute = mrYes
then
Clipboard.AsText := string.Join(#13#10, FExts);
end;
procedure TVisCtl3D.MnuObjectSettings(Sender: TObject);
begin
if Sender is TVisCtlObjectMenuItem then
begin
var MI := TVisCtlObjectMenuItem(Sender);
var Obj := TDrawable3D(nil);
if
Assigned(FObjs) and not MI.ObjRef.IsEmpty
and FObjs.TryGetDrawableByGUID(MI.ObjRef, Obj) and Assigned(Obj)
then
Obj.ShowOptionsForm
end;
end;
procedure TVisCtl3D.MnuRemoveObject(Sender: TObject);
begin
if Sender is TVisCtlObjectMenuItem then
begin
var MI := TVisCtlObjectMenuItem(Sender);
var Obj := TDrawable3D(nil);
if
Assigned(FObjs) and not MI.ObjRef.IsEmpty
and FObjs.TryGetDrawableByGUID(MI.ObjRef, Obj) and Assigned(Obj)
then
begin
var LParent := Obj;
while Assigned(LParent.Parent) do
LParent := LParent.Parent;
if
TD
.TextFmt('Do you want to remove this %s object?', [LParent.Name])
.YesNoCancel
.Execute = mrYes
then
begin
if LParent = FAxes then
ShowAxes := False
else
RemoveObject(LParent);
end;
end;
end;
end;
procedure TVisCtl3D.MnuSaveSceneToFile(Sender: TObject);
begin
var W: Integer := Max(ClientWidth, 1);
var H: Integer := Max(ClientHeight, 1);
var Aspect: Double := 0.0;
if ImageSizeDialog(GetParentForm(Self), W, H, Aspect) then
SaveToBitmap('', W, H);
end;
procedure TVisCtl3D.MnuSceneSettings(Sender: TObject);
begin
if Assigned(FScene) then
FScene.ShowOptionsForm;
end;
procedure TVisCtl3D.MnuSetMSAA(Sender: TObject);
begin
if Sender is TMenuItem then
MSAA := TMSAAValue(TMenuItem(Sender).Tag);
end;
procedure TVisCtl3D.MnuSetPP(Sender: TObject);
begin
if Sender is TMenuItem then
begin
var PPE := TPPE(TMenuItem(Sender).Tag);
if PPE in FEffects then
Effects := FEffects - [PPE]
else
Effects := FEffects + [PPE];
end;
end;
procedure TVisCtl3D.MnuSetProj(Sender: TObject);
begin
if Sender is TMenuItem then
case TMenuItem(Sender).Tag of
0:
Projection := Orthographic;
1:
Projection := Perspective;
end;
end;
procedure TVisCtl3D.MnuToggleAxes(Sender: TObject);
begin
ShowAxes := not ShowAxes;
end;
procedure TVisCtl3D.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
begin
inherited;
FPrevMousePoint := Point(X, Y);
if CanFocus then
SetFocus;
end;
procedure TVisCtl3D.MouseMove(Shift: TShiftState; X, Y: Integer);
function rmod(const x, y: Double): Double;
begin
Result := x - Floor64(x / y) * y;
end;
begin
inherited;
if csLButtonDown in ControlState then
begin
var ∆X := X - FPrevMousePoint.X;
var ∆Y := Y - FPrevMousePoint.Y;
θ := EnsureRange(θ - ∆Y / 1000, 0, Pi);
φ := rmod(φ - ∆X / 2000, 2*Pi);
FPrevMousePoint := Point(X, Y);
ComputeV;
Invalidate;
end;
end;
function TVisCtl3D.NewObject<T>: T;
begin
Result := T.Create(Self);
AddObject(Result);
end;
destructor TVisCtl3D.Destroy;
begin
FreeGLResources;
FreeAndNil(FObjs);
FreeAndNil(FProgramMgr);
FreeAndNil(FView);
FreeAndNil(FScene);
FreeAndNil(FNewObjects);
if Assigned(FPopupMenu) then
FPopupMenu.CloseMenu;
FreeAndNil(FPopupMenu);
FreeAndNil(FCustomMenuItems);
inherited;
end;
procedure TVisCtl3D.DestroyWnd;
begin
FreeGLResources;
inherited;
end;
function TVisCtl3D.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
MousePos: TPoint): Boolean;
begin
Zoom(WheelDelta / 120, Shift);
Result := True;
end;
function TVisCtl3D.GetObject(Index: Integer): TDrawable3D;
begin
if FObjs = nil then
Result := nil
else
Result := FObjs[Index];
end;
function TVisCtl3D.GetObjectCount: Integer;
begin
if FObjs = nil then
Result := 0
else
Result := FObjs.ItemCount;
end;
function TVisCtl3D.GetShowAxes: Boolean;
begin
Result := Assigned(FAxes) and FAxes.Visible;
end;
procedure debugproc(source: GLenum; _type: GLenum; id: GLuint; severity: GLenum;
length: GLsizei; const _message: PGLchar; userParam: Pointer); stdcall;
begin
OutputDebugStringA(_message);
if severity = GL_DEBUG_SEVERITY_HIGH then
DebugBreak;
end;
procedure TVisCtl3D.GLInit;
begin
inherited;
Context.MakeCurrent('TVisCtl3D.GLInit');
{$IFDEF DEBUG}
glEnable(GL_DEBUG_OUTPUT);
glEnable(GL_DEBUG_OUTPUT_SYNCHRONOUS_ARB);
glDebugMessageCallback(debugproc, nil);
{$ENDIF}
glEnable(GL_DEPTH_TEST);
glEnable(GL_BLEND);
glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA);
glPolygonOffset(1, 1);
glEnable(GL_POLYGON_OFFSET_FILL);
FImplData := Context.GetImplInfo;
FExts := Context.GetExtensionNames;
FreeAndNil(FProgramMgr);
FProgramMgr := TProgramMgr.Create(Self);
if Assigned(FObjs) then
begin
FObjs.GLRelease;
if Assigned(FNewObjects) then
for var obj in FObjs.List do
if Assigned(obj) then
FNewObjects.Add(obj);
end;
end;
procedure TVisCtl3D.Paint;
begin
if (Context = nil) or (FProgramMgr = nil) then
Exit;
Context.MakeCurrent('TVisCtl3D.Paint');
var LRenderToBitmap := FRenderToBitmap;
FRenderToBitmap := False;
var LRenderToClipboard := FRenderToClipboard;
FRenderToClipboard := False;
var LRenderFileName := FRenderFileName;
FRenderFileName := '';
var LRenderOutputData := FRenderOutputData;
FRenderOutputData := Default(TRenderOutputData);
LRenderOutputData.MSAA := FMSAAValue;
LRenderOutputData.PostProc := FPostProcessing;
if not LRenderOutputData.Offscreen then
begin
LRenderOutputData.Width := ClientWidth;
LRenderOutputData.Height := ClientHeight;
end;
if (FScreenVAO = 0) or (LRenderOutputData <> FPrevRenderOutputData) then
begin
FramebufferSetup(LRenderOutputData);
ComputeP(LRenderOutputData);
end;
FPrevRenderOutputData := LRenderOutputData;
glViewport(0, 0, LRenderOutputData.Width, LRenderOutputData.Height);
if FMSAAValue <> msaa0 then
glBindFramebuffer(GL_FRAMEBUFFER, FMSAAbuf)
else if FPostProcessing then
glBindFramebuffer(GL_FRAMEBUFFER, Fauxbuf)
else
glBindFramebuffer(GL_FRAMEBUFFER, 0);
ApplyClearColor;
if FStencil then
glClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT or GL_STENCIL_BUFFER_BIT)
else
glClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT);
glEnable(GL_DEPTH_TEST);
if FStencil then
begin
glEnable(GL_STENCIL_TEST);
glStencilFunc(GL_ALWAYS, 0, 0);
glStencilOp(GL_KEEP, GL_KEEP, GL_REPLACE);
end
else
glDisable(GL_STENCIL_TEST);
SetupNewObjects;
MVP := P*V*M;
ProgramMgr.BeginMonitorTime;
FObjs.Draw(FGlobalTime);
var LTimeDependent := ProgramMgr.EndMonitorTime or FObjs.TimeDependent;
var LOutputFramebuffer: GLuint;
if LRenderOutputData.Offscreen then
LOutputFramebuffer := Fosbuf
else
LOutputFramebuffer := 0;
if FMSAAValue <> msaa0 then
begin
glBindFramebuffer(GL_READ_FRAMEBUFFER, FMSAAbuf);
if FPostProcessing then
glBindFramebuffer(GL_DRAW_FRAMEBUFFER, Fauxbuf)
else
glBindFramebuffer(GL_DRAW_FRAMEBUFFER, LOutputFramebuffer);
glBlitFramebuffer(0, 0, LRenderOutputData.Width, LRenderOutputData.Height,
0, 0, LRenderOutputData.Width, LRenderOutputData.Height, GL_COLOR_BUFFER_BIT,
GL_NEAREST);
end;
if FPostProcessing then
begin
glBindFramebuffer(GL_FRAMEBUFFER, LOutputFramebuffer);
ProgramMgr.UseProgram(P_Tex);
ProgramMgr.CurrentProgram.UPP_Greyscale.SetValue(ppGreyscale in FEffects);
ProgramMgr.CurrentProgram.UPP_Invert.SetValue(ppInvert in FEffects);
ProgramMgr.CurrentProgram.UPP_FlipV.SetValue(ppFlipV in FEffects);
ProgramMgr.CurrentProgram.UPP_FlipH.SetValue(ppFlipH in FEffects);
ProgramMgr.CurrentProgram.UPP_Binary.SetValue(ppBinary in FEffects);
ProgramMgr.CurrentProgram.UPP_Spectra.SetValue(ppSpectra in FEffects);
ProgramMgr.CurrentProgram.UPP_EdgeDetect.SetValue(ppEdgeDetect in FEffects);
ProgramMgr.CurrentProgram.UPP_Sharpen.SetValue(ppSharpen in FEffects);
ProgramMgr.CurrentProgram.UPP_Blur.SetValue(ppBlur in FEffects);
ProgramMgr.CurrentProgram.UPP_Underwater.SetValue(ppUnderwater in FEffects);
ProgramMgr.CurrentProgram.Ut.SetValue(FGlobalTime);
glClear(GL_COLOR_BUFFER_BIT);
glDisable(GL_DEPTH_TEST);
glBindTexture(GL_TEXTURE_2D, Fauxbuf_coloratt);
glBindVertexArray(FScreenVAO);
glDrawArrays(GL_TRIANGLES, 0, 6);
glBindVertexArray(0);
LTimeDependent := LTimeDependent or (FEffects * AnimatedEffects <> []);
end;
if LRenderToBitmap then
begin
glBindFramebuffer(GL_FRAMEBUFFER, LOutputFramebuffer);
SaveSceneToBitmap(LRenderOutputData, True, LRenderToClipboard, LRenderFileName);
end;
if not LRenderToBitmap and LTimeDependent then
begin
var LTick: Int64;
if QueryPerformanceCounter(LTick) and (FPerfFreq <> 0) then
begin
if FPrevTick <> 0 then
FGlobalTime := FGlobalTime + (LTick - FPrevTick) / FPerfFreq;
FPrevTick := LTick;
FAnimationTimer.Enabled := True;
end;
end
else
begin
FPrevTick := 0;
FAnimationTimer.Enabled := False;
end;
end;
procedure TVisCtl3D.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 (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
raise ERglError.Create('Cannot remove child object.');
for var Child in AObject.FChildren do
Self.RemoveObjectOrChild(Child);
FObjs.List.Remove(AObject);
if Assigned(FNewObjects) then
FNewObjects.Remove(AObject);
end;
procedure TVisCtl3D.RemoveObjectOrChild(AObject: TDrawable3D);
begin
if (FObjs = nil) or (FObjs.List = nil) then
Exit;
if AObject = nil then
Exit;
if AObject.FProtected then
raise ERglError.Create('Cannot remove protected object.');
for var Child in AObject.FChildren do
Self.RemoveObjectOrChild(Child);
FObjs.List.Remove(AObject);
if Assigned(FNewObjects) then
FNewObjects.Remove(AObject);
end;
function TVisCtl3D.HitTest(X: Integer; Y: Integer): TDrawable3D;
begin
Context.MakeCurrent('TVisCtl3D.HitTest');
var LOldMSAA := Self.MSAA;
var LOldEffects := Self.Effects;
try
FStencil := True;
Self.MSAA := msaa0;
Self.Effects := [ppIdentity];
Repaint;
glBindFramebuffer(GL_FRAMEBUFFER, Fauxbuf);
var b: Byte := 0;
glReadPixels(X, ClientHeight - Y, 1, 1, GL_STENCIL_INDEX, GL_UNSIGNED_BYTE, @b);
glBindFramebuffer(GL_FRAMEBUFFER, 0);
Result := FObjs.GetObjFromStencilID(b);
finally
FStencil := False;
Self.MSAA := LOldMSAA;
Self.Effects := LOldEffects;
end
end;
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;
procedure TDrawable3D.Changed(Sender: TObject);
begin
if Assigned(FOnChange) then
FOnChange(Self);
end;
procedure TDrawable3D.Changed;
begin
if Assigned(FOnChange) then
FOnChange(Self);
end;
class constructor TDrawable3D.ClassCreate;
begin
FInstances := TDictionary<TGUID, TDrawable3D>.Create;
FInstances.OnKeyNotify := InstanceListChanged;
end;
class destructor TDrawable3D.ClassDestroy;
begin
FreeAndNil(FInstances);
end;
procedure TDrawable3D.Configure(ASettings: TAlgosimStructure);
begin
inherited;
for var i := 1 to ASettings.MemberCount do
begin
var S := ASettings.Members[i].Name;
var V := ASettings.Members[i].Value;
if S = 'title' then
Title := V.ToString
else if S = 'description' then
Description := V.ToString
else if S = 'windowwidth' then
FCtl.SetWindowWidth(V.ToInt32)
else if S = 'windowheight' then
FCtl.SetWindowHeight(V.ToInt32)
else if S = 'linewidth' then
LineWidth := V.ToRealNumber
else if S = 'visible' then
Visible := V.ToBoolean
else if S = 'animationspeed' then
AnimationSpeed := V.ToRealNumber
else if S = 'detached' then
FCtl.SetDetached(V.ToBoolean);
end;
end;
constructor TDrawable3D.Create(ACtl: TVisCtl3D);
begin
FVisible := True;
FCtl := ACtl;
FLineWidth := 1.5;
if Succeeded(CreateGUID(FGUID)) and Assigned(FInstances) then
FInstances.Add(FGUID, Self);
FDefaultProgram := P_Default;
FChildren := TList<TDrawable3D>.Create;
OptionsFormClass := TVis3D_DrawableSettingsFrm;
end;
function TDrawable3D.CreateReference: TAlgosimReference;
begin
Result := TAlgosimReference.CreateWithValue(FGUID);
end;
function TDrawable3D.CreateChild<T>: T;
begin
if FCtl = nil then
Exit(nil);
if FChildren = nil then
Exit;
Result := T.Create(FCtl);
FCtl.AddObject(Result);
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);
if Assigned(Control) and Assigned(Control.Context) then
FreeGLResources;
if Assigned(FInstances) then
FInstances.Remove(FGUID);
inherited;
end;
procedure TDrawable3D.Draw(const AGlobalTime: Double);
begin
end;
procedure TDrawable3D.FreeGLResources;
begin
end;
function TDrawable3D.GetChild(Index: Integer): TDrawable3D;
begin
Result := FChildren[Index];
end;
function TDrawable3D.GetChildCount: Integer;
begin
if Assigned(Self) and Assigned(FChildren) then
Result := FChildren.Count
else
Result := 0;
end;
function TDrawable3D.GetDisplayed: Boolean;
begin
Result := Visible and ((FParent = nil) or FParent.Displayed);
end;
function TDrawable3D.GetLineWidth: Single;
begin
Result := FLineWidth;
end;
class function TDrawable3D.GetRealm: string;
begin
Result := 'ℝ³';
end;
procedure TDrawable3D.GLRelease;
begin
end;
class procedure TDrawable3D.InstanceListChanged(Sender: TObject;
const Item: TGUID; Action: TCollectionNotification);
begin
if Assigned(VisObjListChanged) then
VisObjListChanged(Sender);
end;
procedure TDrawable3D.ProjectionChanged;
begin
end;
procedure TDrawable3D.Recreate;
begin
end;
procedure TDrawable3D.SetAnimationSpeed(const Value: Double);
begin
if FAnimationSpeed <> Value then
begin
FAnimationSpeed := Value;
Changed;
end;
end;
procedure TDrawable3D.SetLineWidth(const Value: Single);
begin
if FLineWidth <> Value then
begin
FLineWidth := Value;
Changed;
end;
end;
procedure TDrawable3D.Setup;
begin
end;
procedure TDrawable3D.SetVisible(const Value: Boolean);
begin
if FVisible <> Value then
begin
FVisible := Value;
Changed;
end;
end;
procedure TDrawable3D.ShowOptionsForm(AParent: TCustomForm);
var
LOptionsFrm: TDrawableOptionsFrm3D;
begin
if Assigned(OptionsFormClass) then
begin
if AParent = nil then
AParent := GetParentForm(FCtl);
LOptionsFrm := OptionsFormClass.Create(AParent, Self);
try
Inc(FModalLevel);
try
LOptionsFrm.ShowModal;
finally
Dec(FModalLevel);
end;
finally
LOptionsFrm.Free;
end;
end
else
ShowMessage('This object has no configurable properties.');
end;
function TDrawable3D.TryContextCurrent: Boolean;
begin
Result := Assigned(Control) and Assigned(Control.Context)
and Control.Context.TryMakeCurrent;
end;
class function TDrawable3D.TryGetDrawableByGUID(const AGUID: TGUID;
out ADrawable: TDrawable3D): Boolean;
begin
Result := Assigned(FInstances) and FInstances.TryGetValue(AGUID, ADrawable);
end;
class function TDrawable3D.Verify(ADrawable: TDrawable3D): Boolean;
begin
Result := Assigned(FInstances) and FInstances.ContainsValue(ADrawable);
end;
constructor TDrawableList3D.Create(ACtl: TVisCtl3D);
begin
inherited;
FList := TObjectList<TDrawable3D>.Create;
FList.OnNotify := ObjsNotify;
FSortedList := TList<TDrawable3D>.Create;
Name := 'Collection';
OptionsFormClass := TVis3D_DrawableListSettingsFrm;
end;
destructor TDrawableList3D.Destroy;
begin
FreeAndNil(FSortedList);
FreeAndNil(FList);
inherited;
end;
procedure TDrawableList3D.Draw(const AGlobalTime: Double);
begin
if FSortOrderDirty or FAlphaBlending and (FPrevCameraPos <> Control.CameraPos) then
Resort;
FTimeDependent := False;
glDepthMask(GL_TRUE);
var DepthWriteDisabled := False;
try
var FStencilID: Byte := 0;
if Assigned(FSortedList) then
for var obj in FSortedList do
if Assigned(obj) and obj.Displayed then
begin
if Control.Stencil and (FStencilID < $FF) then
begin
Inc(FStencilID);
FStencilIDs[FStencilID] := Pointer(obj);
end;
if not obj.DefaultProgram.IsEmpty then
begin
Control.ProgramMgr.UseProgram(obj.DefaultProgram);
if not DepthWriteDisabled and (obj.DefaultProgram[1] = 'z') then
begin
glDepthMask(GL_FALSE);
DepthWriteDisabled := True;
end;
end;
if Control.Stencil then
glStencilFunc(GL_ALWAYS, FStencilID, 0);
obj.Draw(AGlobalTime);
FTimeDependent := FTimeDependent or (obj.AnimationSpeed <> 0);
end;
FPrevCameraPos := Control.CameraPos;
finally
if DepthWriteDisabled then
glDepthMask(GL_TRUE);
end;
end;
procedure TDrawableList3D.FreeGLResources;
begin
if Assigned(FList) then
for var obj in FList do
if Assigned(obj) then
obj.FreeGLResources;
inherited;
end;
function TDrawableList3D.GetItem(Index: Integer): TDrawable3D;
begin
Result := FList[Index];
end;
function TDrawableList3D.GetItemCount: Integer;
begin
if Assigned(FList) then
Result := FList.Count
else
Result := 0;
end;
function TDrawableList3D.GetObjFromStencilID(AStencilID: Byte): TDrawable3D;
begin
for var obj in FList do
if Pointer(obj) = FStencilIDs[AStencilID] then
Exit(obj);
Result := nil;
end;
procedure TDrawableList3D.GLRelease;
begin
if Assigned(FList) then
for var obj in FList do
if Assigned(obj) then
obj.GLRelease;
inherited;
end;
procedure TDrawableList3D.MoveDown(ADrawable: TDrawable3D);
begin
var Idx := FList.IndexOf(ADrawable);
if Idx <> -1 then
begin
FList.Move(Idx, Succ(Idx));
Changed;
end;
end;
procedure TDrawableList3D.MoveUp(ADrawable: TDrawable3D);
begin
var Idx := FList.IndexOf(ADrawable);
if Idx <> -1 then
begin
FList.Move(Idx, Pred(Idx));
Changed;
end;
end;
procedure TDrawableList3D.ObjsNotify(Sender: TObject; const Item: TDrawable3D;
Action: TCollectionNotification);
begin
FAlphaBlending := False;
if Assigned(FList) then
begin
for var Obj in FList do
if Obj.DefaultProgram.StartsWith('z') then
begin
FAlphaBlending := True;
Break;
end;
end;
Changed;
FSortOrderDirty := True;
end;
procedure TDrawableList3D.Resort;
begin
if Assigned(FList) and Assigned(FSortedList) then
begin
FSortOrderDirty := False;
FSortedList.Clear;
FSortedList.AddRange(FList);
FSortedList.Sort(
TComparer<TDrawable3D>.Construct(
function(const Left, Right: TDrawable3D): Integer
begin
var LeftAlpha := (Left.DefaultProgram.Length > 0) and (Left.DefaultProgram[1] = 'z');
var RightAlpha := (Right.DefaultProgram.Length > 0) and (Right.DefaultProgram[1] = 'z');
if not LeftAlpha and not RightAlpha then
Result := CompareStr(Left.DefaultProgram, Right.DefaultProgram)
else if LeftAlpha and not RightAlpha then
Result := 1
else if RightAlpha and not LeftAlpha then
Result := -1
else
begin
if (Left is TGeometricObject3D) and (Right is TGeometricObject3D) then
begin
Result := -CompareValue(
(TGeometricObject3D(Left).Position - Control.CameraPos).NormSquare,
(TGeometricObject3D(Right).Position - Control.CameraPos).NormSquare
)
end
else
Result := 0;
end;
end
)
);
end;
end;
procedure TDrawableList3D.SetItem(Index: Integer; const Value: TDrawable3D);
begin
FList[Index] := Value;
end;
constructor TManagedProgram.Create(const AName: string; AProgram: TRglProgram);
begin
FName := AName;
FProgram := AProgram;
FUMVP := FProgram.TryAddUniform<TRglUniformFloatMat4>('MVP');
FUEye := FProgram.TryAddUniform<TRglUniformFloatVec3>('eye');
FULightPos := FProgram.TryAddUniform<TRglUniformFloatVec3>('lightpos');
FUColor := FProgram.TryAddUniform<TRglUniformFloatVec3>('color');
FUSize := FProgram.TryAddUniform<TRglUniformFloat>('size');
FUAnchorPoint := FProgram.TryAddUniform<TRglUniformInt>('AnchorPoint');
FUFaceScreen := FProgram.TryAddUniform<TRglUniformBool>('FaceScreen');
FUAttribColors := FProgram.TryAddUniform<TRglUniformBool>('AttribColors');
FUAspect := FProgram.TryAddUniform<TRglUniformFloat>('aspect');
FUDisplacement := FProgram.TryAddUniform<TRglUniformFloatVec2>('displacement');
FUObjectMatrix := FProgram.TryAddUniform<TRglUniformFloatMat4>('OM');
FUNormalMatrix := FProgram.TryAddUniform<TRglUniformFloatMat3>('NormalMatrix');
FUt := FProgram.TryAddUniform<TRglUniformFloat>('t');
FUTranspColor := FProgram.TryAddUniform<TRglUniformFloatVec3>('transpcolor');
FUOpaqueColor := FProgram.TryAddUniform<TRglUniformFloatVec3>('opaquecolor');
FUTranspColorMode := FProgram.TryAddUniform<TRglUniformInt>('transpmode');
FUOpacity := FProgram.TryAddUniform<TRglUniformFloat>('opacity');
FUPP_Greyscale := FProgram.TryAddUniform<TRglUniformBool>('ppgreyscale');
FUPP_Invert := FProgram.TryAddUniform<TRglUniformBool>('ppinvert');
FUPP_FlipV := FProgram.TryAddUniform<TRglUniformBool>('ppflipv');
FUPP_FlipH := FProgram.TryAddUniform<TRglUniformBool>('ppfliph');
FUPP_Binary := FProgram.TryAddUniform<TRglUniformBool>('ppbinary');
FUPP_Spectra := FProgram.TryAddUniform<TRglUniformBool>('ppspectra');
FUPP_EdgeDetect := FProgram.TryAddUniform<TRglUniformBool>('ppedgedetect');
FUPP_Sharpen := FProgram.TryAddUniform<TRglUniformBool>('ppsharpen');
FUPP_Blur := FProgram.TryAddUniform<TRglUniformBool>('ppblur');
FUPP_Underwater := FProgram.TryAddUniform<TRglUniformBool>('ppunderwater');
end;
destructor TManagedProgram.Destroy;
begin
FreeAndNil(FProgram);
inherited;
end;
procedure TProgramMgr.BeginMonitorTime;
begin
FTimeDependent := False;
end;
constructor TProgramMgr.Create(AControl: TVisCtl3D);
begin
FControl := AControl;
FPrograms := TObjectList<TManagedProgram>.Create;
end;
destructor TProgramMgr.Destroy;
begin
FCurrentProgram := nil;
FreeAndNil(FPrograms);
inherited;
end;
function TProgramMgr.EndMonitorTime: Boolean;
begin
Result := FTimeDependent;
end;
function TProgramMgr.GetProgram(const AName: string): TManagedProgram;
begin
for var NP in FPrograms do
if NP.Name = AName then
Exit(NP);
var SL := TStringList.Create;
try
var RS := TResourceStream.Create(HInstance, AName, RT_RCDATA);
try
SL.LoadFromStream(RS, TEncoding.ASCII);
Result := LoadProgramResource(AName, SL);
finally
RS.Free;
end;
finally
SL.Free;
end;
end;
function TProgramMgr.LoadProgramResource(const AName: string; AData: TStringList): TManagedProgram;
var
Sources: array[TShaderKind] of string;
Shaders: array[TShaderKind] of TRglShader;
begin
for var NP in FPrograms do
if NP.Name = AName then
raise Exception.Create('A program named "%s" is already loaded.');
var ShaderKind := Vertex;
for var S in AData do
begin
var GLSL := True;
if (Length(S) >= 1) and (S[1] = '#') then
for var sk := Low(TShaderKind) to High(TShaderKind) do
if S.StartsWith('#' + sk.ToString) then
begin
ShaderKind := sk;
GLSL := False;
Break;
end;
if GLSL then
Sources[ShaderKind] := Sources[ShaderKind] + #13#10 + S;
end;
var &Program := TRglProgram.Create(FControl.Context);
try
FillChar(Shaders, SizeOf(Shaders), 0);
try
for var sk := Low(TShaderKind) to High(TShaderKind) do
if not Sources[sk].IsEmpty then
begin
Shaders[sk] := sk.RglClass.Create(FControl.Context, Sources[sk]);
Shaders[sk].Compile;
&Program.AttachShader(Shaders[sk]);
end;
&Program.Link;
finally
for var sk := Low(TShaderKind) to High(TShaderKind) do
Shaders[sk].Free;
end;
except
&Program.Free;
raise;
end;
Result := TManagedProgram.Create(AName, &Program);
FPrograms.Add(Result);
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;
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;
procedure TScene.Configure(ASettings: TAlgosimStructure);
begin
inherited;
for var i := 1 to ASettings.MemberCount do
begin
var S := ASettings.Members[i].Name;
var V := ASettings.Members[i].Value;
if S = 'antialiasing' then
Control.MSAA := TMSAAValue(V.ToInt32)
else if S = 'lightpos' then
Control.LightPos := V.ToRealVector
else if S = 'effects' then
begin
var LPPEs: TPPEs := [];
for var j := 1 to V.ElementCount do
Include(LPPEs, TPPE.FromString(V.Elements[j].ToString));
Control.Effects := LPPEs;
end;
end;
end;
constructor TScene.Create(ACtl: TVisCtl3D);
begin
inherited;
Name := 'Scene';
OptionsFormClass := TVis3D_SceneSettingsFrm;
end;
function TScene.CreateReference: TAlgosimReference;
begin
Result := inherited;
Result.AddSubref('view', FCtl.View.CreateReference);
Result.AddSubref('axes', FCtl.Axes.CreateReference);
Result.AddSubref('objects', FCtl.ObjectMgr.CreateReference);
end;
constructor TRefAxes.Create(ACtl: TVisCtl3D);
begin
inherited;
FDefaultProgram := P_Lighting;
Name := 'Reference axes';
end;
destructor TRefAxes.Destroy;
begin
inherited;
end;
procedure TRefAxes.Draw(const AGlobalTime: Double);
begin
glBindVertexArray(FVAO);
glDrawArrays(GL_TRIANGLE_STRIP, 0, 2*N);
glDrawArrays(GL_TRIANGLE_STRIP, 2*N, 2*N);
glDrawArrays(GL_TRIANGLE_STRIP, 4*N, 2*N);
glBindVertexArray(0);
end;
procedure TRefAxes.FreeGLResources;
begin
if TryContextCurrent then
begin
glDeleteBuffers(1, @FVertexData); FVertexData := 0;
glDeleteVertexArrays(1, @FVAO); FVAO := 0;
end
else
rglLog('TRefAxes.FreeGLResources: TryContextCurrent returned false');
inherited;
end;
procedure TRefAxes.GLRelease;
begin
FVertexData := 0;
FVAO := 0;
inherited;
end;
procedure TRefAxes.Setup;
var
VertexData: array[0..3*2*N - 1] of GLfloat9;
S, C: Single;
Sʹ, Cʹ: Single;
const
R: array[0..2] of Double = (1.0, 0.0, 0.0);
G: array[0..2] of Double = (0.0, 1.0, 0.0);
B: array[0..2] of Double = (0.0, 0.0, 1.0);
begin
if (Control = nil) or (Control.Context = nil) then
Exit;
Control.Context.MakeCurrent('TRefAxes.Setup');
for var i := 0 to N - 1 do
begin
SinCos(i * 2*Pi / (N - 1), S, C);
SinCos((i + 0.5) * 2*Pi / (N - 1), Sʹ, Cʹ);
for var j := 0 to 2 do
begin
var k := Succ(j) mod 3;
var l := Succ(k) mod 3;
VertexData[2*N*j + 2*i ][j] := 0.0;
VertexData[2*N*j + 2*i ][k] := 0.1 * C;
VertexData[2*N*j + 2*i ][l] := 0.1 * S;
VertexData[2*N*j + 2*i ][3] := R[j];
VertexData[2*N*j + 2*i ][4] := G[j];
VertexData[2*N*j + 2*i ][5] := B[j];
VertexData[2*N*j + 2*i ][j+6] := 0;
VertexData[2*N*j + 2*i ][k+6] := C;
VertexData[2*N*j + 2*i ][l+6] := S;
VertexData[2*N*j + 2*i + 1][j] := 10.0;
VertexData[2*N*j + 2*i + 1][k] := 0.1 * Cʹ;
VertexData[2*N*j + 2*i + 1][l] := 0.1 * Sʹ;
VertexData[2*N*j + 2*i + 1][3] := R[j];
VertexData[2*N*j + 2*i + 1][4] := G[j];
VertexData[2*N*j + 2*i + 1][5] := B[j];
VertexData[2*N*j + 2*i + 1][j+6] := 0;
VertexData[2*N*j + 2*i + 1][k+6] := C;
VertexData[2*N*j + 2*i + 1][l+6] := S;
end;
end;
if FVAO = 0 then glGenVertexArrays(1, @FVAO);
glBindVertexArray(FVAO);
try
if FVertexData = 0 then glGenBuffers(1, @FVertexData);
glBindBuffer(GL_ARRAY_BUFFER, FVertexData);
glBufferData(GL_ARRAY_BUFFER, SizeOf(VertexData), @VertexData[0], GL_STATIC_DRAW);
glEnableVertexAttribArray(0);
glEnableVertexAttribArray(1);
glEnableVertexAttribArray(2);
glVertexAttribPointer(0, 3, GL_FLOAT, GL_FALSE, 9*SizeOf(GLfloat), nil);
glVertexAttribPointer(1, 3, GL_FLOAT, GL_FALSE, 9*SizeOf(GLfloat), Pointer(3*SizeOf(GLfloat)));
glVertexAttribPointer(2, 3, GL_FLOAT, GL_FALSE, 9*SizeOf(GLfloat), Pointer(6*SizeOf(GLfloat)));
finally
glBindVertexArray(0);
end;
end;
procedure TGeometricObject3D.Assign(Source: TPersistent);
begin
if Source is TGeometricObject3D then
begin
FColor := TGeometricObject3D(Source).FColor;
FPosition := TGeometricObject3D(Source).FPosition;
FDirection := TGeometricObject3D(Source).FDirection;
FScale := TGeometricObject3D(Source).FScale;
FRotation := TGeometricObject3D(Source).FRotation;
FLineWidth := TGeometricObject3D(Source).FLineWidth;
FAnimationSpeed := TGeometricObject3D(Source).FAnimationSpeed;
ComputeOM;
Changed;
end
else
inherited;
end;
procedure TGeometricObject3D.ComputeOM;
begin
if FUseManualMatrix then
FObjectMatrix := FManualMatrix
else
begin
var R: rglm4;
if IsZero(FDirection.x) and IsZero(FDirection.y) then
begin
R := rglm4.Identity;
if FDirection.z < 0 then
R.m[2, 2] := -1.0;
end
else
R := rglRotate(180*ArcCos(FDirection.Normalized.z)/Pi, vec(0, 0, 1) xor FDirection);
FObjectMatrix :=
rglTranslate(FPosition)
*
R
*
rglRotate(FRotation, vec(0, 0, 1))
*
rglScale(FScale.x, FScale.y, FScale.z);
end;
if FParent is TGeometricObject3D then
FObjectMatrix := TGeometricObject3D(FParent).FObjectMatrix * FObjectMatrix;
FNormalMatrix := rglm(FObjectMatrix).Transpose.Inverse;
if Assigned(FChildren) then
for var Child in FChildren do
if Child is TGeometricObject3D then
TGeometricObject3D(Child).ComputeOM;
end;
procedure TGeometricObject3D.Configure(ASettings: TAlgosimStructure);
begin
inherited;
for var i := 1 to ASettings.MemberCount do
begin
var S := ASettings.Members[i].Name;
var V := ASettings.Members[i].Value;
if S = 'color' then
Color := V.ToColor
else if S = 'position' then
Position := V.AsRealVector
else if S = 'direction' then
Direction := V.AsRealVector
else if S = 'scale' then
Scale := V.AsRealVector
else if S = 'rotation' then
Rotation := 180 * V.ToRealNumber / Pi;
end;
end;
constructor TGeometricObject3D.Create(ACtl: TVisCtl3D);
begin
inherited;
FDefaultProgram := P_UniformColorLighting;
FDirection := vec(0, 0, 1);
FScale := vec(1, 1, 1);
FManualMatrix := rglm4.Identity;
ComputeOM;
Name := 'Geometric object';
OptionsFormClass := TVis3D_GeoObjSettingsFrm;
end;
procedure TGeometricObject3D.Draw(const AGlobalTime: Double);
begin
inherited;
if FAnimationSpeed <> 0.0 then
begin
FRotation := AGlobalTime * FAnimationSpeed;
ComputeOM;
end;
Control.ProgramMgr.CurrentProgram.UColor.SetValue(FColor);
Control.ProgramMgr.CurrentProgram.UObjectMatrix.SetValue(FObjectMatrix);
Control.ProgramMgr.CurrentProgram.UNormalMatrix.SetValue(FNormalMatrix);
end;
function TGeometricObject3D.GetColor: TColor;
begin
Result := FColor;
end;
procedure TGeometricObject3D.SetColor(const Value: TColor);
begin
if FColor <> Value then
begin
FColor := Value;
Changed;
end;
end;
procedure TGeometricObject3D.SetDirection(const Value: rglv);
begin
if FDirection <> Value then
begin
FDirection := Value;
ComputeOM;
Changed;
end;
end;
procedure TGeometricObject3D.SetManualMatrix;
begin
var R: rglm4;
if IsZero(FDirection.x) and IsZero(FDirection.y) then
begin
R := rglm4.Identity;
if FDirection.z < 0 then
R.m[2, 2] := -1.0;
end
else
R := rglRotate(180*ArcCos(FDirection.Normalized.z)/Pi, vec(0, 0, 1) xor FDirection);
FManualMatrix :=
rglTranslate(FPosition)
*
R
*
rglRotate(FRotation, vec(0, 0, 1))
*
rglScale(FScale.x, FScale.y, FScale.z);
end;
procedure TGeometricObject3D.SetManualMatrix(const Value: rglm4);
begin
if FManualMatrix <> Value then
begin
FManualMatrix := Value;
if FUseManualMatrix then
begin
ComputeOM;
Changed;
end;
end;
end;
procedure TGeometricObject3D.SetPosition(const Value: rglv);
begin
if FPosition <> Value then
begin
FPosition := Value;
ComputeOM;
Changed;
end;
end;
procedure TGeometricObject3D.SetRotation(const Value: Single);
begin
if FRotation <> Value then
begin
FRotation := Value;
ComputeOM;
Changed;
end;
end;
procedure TGeometricObject3D.SetScale(const Value: rglv);
begin
if FScale <> Value then
begin
FScale := Value;
ComputeOM;
Changed;
end;
end;
procedure TGeometricObject3D.SetUseManualMatrix(const Value: Boolean);
begin
if FUseManualMatrix <> Value then
begin
FUseManualMatrix := Value;
ComputeOM;
Changed;
end;
end;
procedure TAbstractSurface3D.Assign(Source: TPersistent);
begin
if Source is TAbstractSurface3D then
begin
inherited;
ShowSurface := TAbstractSurface3D(Source).FShowSurface;
ShowParameterCurves := TAbstractSurface3D(Source).FShowParameterCurves;
ParamCurveCounts := TAbstractSurface3D(Source).FParamCurveCounts;
FLineColor := TAbstractSurface3D(Source).FLineColor;
Changed;
end
else
inherited;
end;
procedure TAbstractSurface3D.Configure(ASettings: TAlgosimStructure);
begin
inherited;
for var i := 1 to ASettings.MemberCount do
begin
var S := ASettings.Members[i].Name;
var V := ASettings.Members[i].Value;
if S = 'showsurface' then
ShowSurface := V.ToBoolean
else if S = 'showparametercurves' then
ShowParameterCurves := V.ToBoolean
else if S = 'linecolor' then
LineColor := V.ToColor
else if S = 'parametercurvecounts' then
ParamCurveCounts := rglv2(V.AsRealVector())
else if S = 'unisided' then
Unisided := V.ToBoolean;
end;
end;
constructor TAbstractSurface3D.Create(ACtl: TVisCtl3D);
begin
inherited;
FShowSurface := True;
FParamCurveCounts.nx := 64;
FParamCurveCounts.ny := 64;
Name := 'Surface';
OptionsFormClass := TVis3D_SurfaceSettingsFrm;
end;
procedure TAbstractSurface3D.RecreateParamCurves;
begin
end;
procedure TAbstractSurface3D.SetLineColor(const Value: TColor);
begin
if FLineColor <> Value then
begin
FLineColor := Value;
Changed;
end;
end;
procedure TAbstractSurface3D.SetParamCurveCounts(
const Value: TParamCurveFamilySize);
begin
if FParamCurveCounts <> Value then
begin
FParamCurveCounts := Value;
RecreateParamCurves;
Changed;
end;
end;
procedure TAbstractSurface3D.SetShowParameterCurves(const Value: Boolean);
begin
if FShowParameterCurves <> Value then
begin
FShowParameterCurves := Value;
UpdateDefProgram;
Changed;
end;
end;
procedure TAbstractSurface3D.SetShowSurface(const Value: Boolean);
begin
if FShowSurface <> Value then
begin
FShowSurface := Value;
UpdateDefProgram;
Changed;
end;
end;
procedure TAbstractSurface3D.SetUnisided(const Value: Boolean);
begin
if FUnisided <> Value then
begin
FUnisided := Value;
UpdateDefProgram;
Changed;
end;
end;
procedure TAbstractSurface3D.UpdateDefProgram;
begin
end;
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;
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
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;
procedure TEllipsoid.Configure(ASettings: TAlgosimStructure);
begin
inherited;
for var i := 1 to ASettings.MemberCount do
begin
var S := ASettings.Members[i].Name;
var V := ASettings.Members[i].Value;
if S = 'axislengths' then
AxisLengths := V.AsRealVector
else if S = 'radius' then
begin
var r := V.ToASR;
AxisLengths := vec(r, r, r);
end
end;
end;
constructor TEllipsoid.Create(ACtl: TVisCtl3D);
begin
inherited;
FSurfProc := rglSpherePolar;
FStockSurface := True;
FStockID := STOCKSURF_SPHERE;
Name := 'Ellipsoid';
end;
procedure TEllipsoid.SetScale(const Value: rglv);
begin
Scale := Value;
end;
constructor TSphere.Create(ACtl: TVisCtl3D);
begin
inherited;
Name := 'Sphere';
end;
function TSphere.GetRadius: Single;
begin
Result := Scale.x;
end;
procedure TSphere.SetRadius(const Value: Single);
begin
Scale := vec(Value, Value, Value);
end;
procedure TCylinder.Configure(ASettings: TAlgosimStructure);
begin
inherited;
for var i := 1 to ASettings.MemberCount do
begin
var S := ASettings.Members[i].Name;
var V := ASettings.Members[i].Value;
if S = 'axislengths' then
AxisLengths := V.AsRealVector
else if S = 'radius' then
Radius := V.ToASR
else if S = 'height' then
Height := V.ToASR;
end;
end;
constructor TCylinder.Create(ACtl: TVisCtl3D);
begin
inherited;
FSurfProc := rglCylinder;
FStockSurface := True;
FStockID := STOCKSURF_CYLINDER;
Name := 'Cylinder';
end;
function TCylinder.GetAxisLengths: rglv2;
begin
Result.x := Scale.x;
Result.y := Scale.y;
end;
function TCylinder.GetHeight: Single;
begin
Result := Scale.z;
end;
function TCylinder.GetRadius: Single;
begin
Result := FScale.x;
end;
procedure TCylinder.SetAxisLengths(const Value: rglv2);
begin
Scale := vec(Value.x, Value.y, FScale.z);
end;
procedure TCylinder.SetHeight(const Value: Single);
begin
Scale := vec(FScale.x, FScale.y, Value);
end;
procedure TCylinder.SetRadius(const Value: Single);
begin
Scale := vec(Value, Value, FScale.z);
end;
procedure TCone.Configure(ASettings: TAlgosimStructure);
begin
inherited;
for var i := 1 to ASettings.MemberCount do
begin
var S := ASettings.Members[i].Name;
var V := ASettings.Members[i].Value;
if S = 'axislengths' then
AxisLengths := V.AsRealVector
else if S = 'radius' then
begin
var r := V.ToASR;
AxisLengths := vec2(r, r);
end
else if S = 'height' then
Height := V.ToASR;
end;
end;
constructor TCone.Create(ACtl: TVisCtl3D);
begin
inherited;
FSurfProc := rglCone;
Name := 'Cone';
end;
function TCone.GetAxisLengths: rglv2;
begin
Result.x := Scale.x;
Result.y := Scale.y;
end;
function TCone.GetHeight: Single;
begin
Result := Scale.z;
end;
procedure TCone.SetAxisLengths(const Value: rglv2);
begin
Scale := vec(Value.x, Value.y, FScale.z);
end;
procedure TCone.SetHeight(const Value: Single);
begin
Scale := vec(FScale.x, FScale.y, Value);
end;
constructor TPlane.Create(ACtl: TVisCtl3D);
begin
inherited;
FSurfProc := rglPlane;
FStockSurface := True;
FStockID := STOCKSURF_PLANE;
Name := 'Plane';
end;
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;
constructor TInfinitePlane.Create(ACtl: TVisCtl3D);
begin
inherited;
FDefaultProgram := P_UniformColorInfinity;
FShowSurface := True;
Name := 'Infinite plane';
end;
destructor TInfinitePlane.Destroy;
begin
inherited;
end;
procedure TInfinitePlane.Draw(const AGlobalTime: Double);
begin
if not FShowSurface and not FShowParameterCurves then
Exit;
inherited;
glBindVertexArray(FVAO);
if FShowSurface then
begin
Control.ProgramMgr.CurrentProgram.UColor.SetValue(FColor);
glBindBuffer(GL_ELEMENT_ARRAY_BUFFER, FIndexData);
glDrawElements(GL_TRIANGLES, FIndexCount, GL_UNSIGNED_INT, nil);
end;
if FShowParameterCurves then
begin
Control.ProgramMgr.CurrentProgram.UColor.SetValue(FLineColor);
glBindBuffer(GL_ELEMENT_ARRAY_BUFFER, FPCIData);
if FLineWidth <> 1.0 then glLineWidth(FLineWidth);
glDrawElements(GL_LINES, FPCICount, GL_UNSIGNED_INT, nil);
if FLineWidth <> 1.0 then glLineWidth(1);
end;
glBindVertexArray(0);
end;
procedure TInfinitePlane.FreeGLResources;
begin
if TryContextCurrent then
begin
glDeleteBuffers(1, @FPCIData); FPCIData := 0;
glDeleteBuffers(1, @FIndexData); FIndexData := 0;
glDeleteBuffers(1, @FVertexData); FVertexData := 0;
glDeleteVertexArrays(1, @FVAO); FVAO := 0;
end
else
rglLog('TInfinitePlane.FreeGLResources: TryContextCurrent returned false');
inherited;
end;
procedure TInfinitePlane.GLRelease;
begin
FVertexData := 0;
FIndexData := 0;
FPCIData := 0;
FIndexCount := 0;
FVAO := 0;
inherited;
end;
procedure TInfinitePlane.Recreate;
begin
if FVertexData <> 0 then
Setup;
end;
procedure TInfinitePlane.Setup;
begin
if (Control = nil) or (Control.Context = nil) then
Exit;
Control.Context.MakeCurrent('TInfinitePlane.Setup');
if FVAO = 0 then glGenVertexArrays(1, @FVAO);
glBindVertexArray(FVAO);
try
var LVertices: TArray<GLfloat6>;
var LIndices: TArray<GLuint>;
var LPCIs: TArray<GLuint>;
const Wh = 500;
const Hh = 500;
var A, B: Integer;
A := 2 * Wh + 1;
B := 2 * Hh + 1;
TriangulateSurface(__planefcn, __planenormalfcn, -Wh, Wh, -Hh, Hh, A, B,
A, B, False, LVertices, LIndices, LPCIs, False, nil);
FIndexCount := Length(LIndices);
FPCICount := Length(LPCIs);
if FVertexData = 0 then glGenBuffers(1, @FVertexData);
glBindBuffer(GL_ARRAY_BUFFER, FVertexData);
glBufferData(GL_ARRAY_BUFFER, Length(LVertices) * SizeOf(GLfloat6), Pointer(LVertices), GL_STATIC_DRAW);
if FIndexData = 0 then glGenBuffers(1, @FIndexData);
glBindBuffer(GL_ELEMENT_ARRAY_BUFFER, FIndexData);
glBufferData(GL_ELEMENT_ARRAY_BUFFER, Length(LIndices) * SizeOf(GLuint), Pointer(LIndices), GL_STATIC_DRAW);
if FPCIData = 0 then glGenBuffers(1, @FPCIData);
glBindBuffer(GL_ELEMENT_ARRAY_BUFFER, FPCIData);
glBufferData(GL_ELEMENT_ARRAY_BUFFER, Length(LPCIs) * SizeOf(GLuint), Pointer(LPCIs), GL_STATIC_DRAW);
glEnableVertexAttribArray(0);
glEnableVertexAttribArray(2);
glBindBuffer(GL_ARRAY_BUFFER, FVertexData);
glVertexAttribPointer(0, 3, GL_FLOAT, GL_FALSE, 6*SizeOf(GLfloat), nil);
glVertexAttribPointer(2, 3, GL_FLOAT, GL_FALSE, 6*SizeOf(GLfloat), Pointer(3*SizeOf(GLfloat)));
finally
glBindVertexArray(0);
end;
end;
constructor TLightSourceDummy.Create(ACtl: TVisCtl3D);
begin
inherited;
Radius := 0.5;
Color := clWhite;
Name := 'Light source dummy';
end;
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;
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;
constructor TBasicSurface3D.Create(ACtl: TVisCtl3D);
begin
inherited;
FSurfProgram := P_UniformColorLighting;
FSurfProgramUnisided := P_UniformColorLightingUnisided;
FCurveProgram := P_UniformColorDefault;
FDefaultProgram := FSurfProgram;
end;
constructor TColoredSurface3D.Create(ACtl: TVisCtl3D);
begin
inherited;
FSurfProgram := P_Lighting;
FSurfProgramUnisided := P_Lighting;
FCurveProgram := P_Default;
FDefaultProgram := FSurfProgram;
Name := 'Coloured surface';
FColorNotApplicable := True;
end;
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;
procedure TDisk.Configure(ASettings: TAlgosimStructure);
begin
inherited;
for var i := 1 to ASettings.MemberCount do
begin
var S := ASettings.Members[i].Name;
var V := ASettings.Members[i].Value;
if S = 'radius' then
Radius := V.ToASR;
end;
end;
constructor TDisk.Create(ACtl: TVisCtl3D);
begin
inherited;
FSurfProc := rglDisk;
FStockSurface := True;
FStockID := STOCKSURF_DISK;
Name := 'Disk';
end;
function TDisk.GetRadius: Single;
begin
Result := Scale.x;
end;
procedure TDisk.SetRadius(const Value: Single);
begin
Scale := vec(Value, Value, Value);
end;
constructor TCurve3D.Create(ACtl: TVisCtl3D);
begin
inherited;
FDefaultProgram := P_UniformColorDefault;
Name := 'Curve';
end;
destructor TCurve3D.Destroy;
begin
inherited;
end;
procedure TCurve3D.Draw(const AGlobalTime: Double);
begin
inherited;
glBindVertexArray(FVAO);
if FLineWidth <> 1.0 then glLineWidth(FLineWidth);
glDrawArrays(GL_LINE_STRIP, 0, FCount);
if FLineWidth <> 1.0 then glLineWidth(1);
glBindVertexArray(0);
end;
procedure TCurve3D.FreeGLResources;
begin
if TryContextCurrent then
begin
glDeleteBuffers(1, @FVertexData); FVertexData := 0;
glDeleteVertexArrays(1, @FVAO); FVAO := 0;
end
else
rglLog('TCurve3D.FreeGLResources: TryContextCurrent returned false');
inherited;
end;
procedure TCurve3D.GLRelease;
begin
FVertexData := 0;
FCount := 0;
FVAO := 0;
inherited;
end;
procedure TCurve3D.Recreate;
begin
if FVertexData <> 0 then
Setup;
end;
procedure TCurve3D.Sample(out Vertices: TArray<rglv>);
begin
Vertices := nil;
if @FCurveFunction = nil then
Exit;
if FDomain.b = FDomain.a then
Exit;
var dt := (FDomain.b - FDomain.a) / 1000;
SetLength(Vertices, 1000);
for var i := 0 to High(Vertices) do
begin
var t := FDomain.a + dt * i;
Vertices[i] := FCurveFunction(t);
end;
end;
procedure TCurve3D.SetCurveFunction(const Value: TCurveParamFcn);
begin
if @FCurveFunction <> @Value then
begin
@FCurveFunction := @Value;
if Assigned(Value) then
FData := nil;
Recreate;
Changed;
end;
end;
procedure TCurve3D.SetData(const Value: TArray<rglv>);
begin
if FData <> Value then
begin
FData := Value;
if Length(Value) > 0 then
FCurveFunction := nil;
Recreate;
Changed;
end;
end;
procedure TCurve3D.SetDomain(const Value: TInterval);
begin
if FDomain <> Value then
begin
FDomain := Value;
Recreate;
Changed;
end;
end;
procedure TCurve3D.Setup;
begin
if (Control = nil) or (Control.Context = nil) then
Exit;
Control.Context.MakeCurrent('TCurve3D.Setup');
if FVAO = 0 then glGenVertexArrays(1, @FVAO);
glBindVertexArray(FVAO);
try
var LVertices: TArray<rglv>;
if Assigned(FData) then
LVertices := FData
else
Sample(LVertices);
FCount := Length(LVertices);
if FVertexData = 0 then glGenBuffers(1, @FVertexData);
glBindBuffer(GL_ARRAY_BUFFER, FVertexData);
glBufferData(GL_ARRAY_BUFFER, Length(LVertices) * SizeOf(GLfloat3), Pointer(LVertices), GL_STATIC_DRAW);
glEnableVertexAttribArray(0);
glBindBuffer(GL_ARRAY_BUFFER, FVertexData);
glVertexAttribPointer(0, 3, GL_FLOAT, GL_FALSE, 3*SizeOf(GLfloat), nil);
finally
glBindVertexArray(0);
end;
end;
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;
constructor TColoredCurve3D.Create(ACtl: TVisCtl3D);
begin
inherited;
FDefaultProgram := P_Default;
Name := 'Coloured curve';
FColorNotApplicable := True;
end;
destructor TColoredCurve3D.Destroy;
begin
inherited;
end;
procedure TColoredCurve3D.Draw(const AGlobalTime: Double);
begin
inherited;
glBindVertexArray(FVAO);
if FLineWidth <> 1.0 then glLineWidth(FLineWidth);
glDrawArrays(GL_LINE_STRIP, 0, FCount);
if FLineWidth <> 1.0 then glLineWidth(1);
glBindVertexArray(0);
end;
procedure TColoredCurve3D.FreeGLResources;
begin
if TryContextCurrent then
begin
glDeleteBuffers(1, @FVertexData); FVertexData := 0;
glDeleteVertexArrays(1, @FVAO); FVAO := 0;
end
else
rglLog('TColoredCurve3D.FreeGLResources: TryContextCurrent returned false');
inherited;
end;
procedure TColoredCurve3D.GLRelease;
begin
FVertexData := 0;
FCount := 0;
FVAO := 0;
inherited;
end;
procedure TColoredCurve3D.Recreate;
begin
if FVertexData <> 0 then
Setup;
end;
procedure TColoredCurve3D.Sample(out Vertices: TArray<GLr3c3v>);
begin
Vertices := nil;
if @FCurveFunction = nil then
Exit;
if FDomain.b = FDomain.a then
Exit;
var dt := (FDomain.b - FDomain.a) / 1000;
SetLength(Vertices, 1000);
for var i := 0 to High(Vertices) do
begin
var t := FDomain.a + dt * i;
Vertices[i].r := FCurveFunction(t);
if Assigned(FCurveColorFunction) then
Vertices[i].c := FCurveColorFunction(t);
end;
end;
procedure TColoredCurve3D.SetCurveColorFunction(
const Value: TCurveParamColorFcn);
begin
if @FCurveColorFunction <> @Value then
begin
@FCurveColorFunction := @Value;
if Assigned(Value) then
FData := nil;
Recreate;
Changed;
end;
end;
procedure TColoredCurve3D.SetCurveFunction(const Value: TCurveParamFcn);
begin
if @FCurveFunction <> @Value then
begin
@FCurveFunction := @Value;
if Assigned(Value) then
FData := nil;
Recreate;
Changed;
end;
end;
procedure TColoredCurve3D.SetData(const Value: TArray<GLr3c3v>);
begin
if FData <> Value then
begin
FData := Value;
if Length(Value) > 0 then
begin
FCurveFunction := nil;
FCurveColorFunction := nil;
end;
Recreate;
Changed;
end;
end;
procedure TColoredCurve3D.SetDomain(const Value: TInterval);
begin
if FDomain <> Value then
begin
FDomain := Value;
Recreate;
Changed;
end;
end;
procedure TColoredCurve3D.Setup;
begin
if (Control = nil) or (Control.Context = nil) then
Exit;
Control.Context.MakeCurrent('TColoredCurve3D.Setup');
if FVAO = 0 then glGenVertexArrays(1, @FVAO);
glBindVertexArray(FVAO);
try
var LVertices: TArray<GLr3c3v>;
if Assigned(FData) then
LVertices := FData
else
Sample(LVertices);
FCount := Length(LVertices);
if FVertexData = 0 then glGenBuffers(1, @FVertexData);
glBindBuffer(GL_ARRAY_BUFFER, FVertexData);
glBufferData(GL_ARRAY_BUFFER, Length(LVertices) * SizeOf(GLfloat6), Pointer(LVertices), GL_STATIC_DRAW);
glEnableVertexAttribArray(0);
glEnableVertexAttribArray(1);
glBindBuffer(GL_ARRAY_BUFFER, FVertexData);
glVertexAttribPointer(0, 3, GL_FLOAT, GL_FALSE, 6*SizeOf(GLfloat), nil);
glVertexAttribPointer(1, 3, GL_FLOAT, GL_FALSE, 6*SizeOf(GLfloat), Pointer(3*SizeOf(GLfloat)));
finally
glBindVertexArray(FVAO);
end;
end;
procedure TScatterPlot.Configure(ASettings: TAlgosimStructure);
begin
inherited;
for var i := 1 to ASettings.MemberCount do
begin
var S := ASettings.Members[i].Name;
var V := ASettings.Members[i].Value;
if S = 'size' then
Size := V.ToASR;
end;
end;
constructor TScatterPlot.Create(ACtl: TVisCtl3D);
begin
inherited;
FSize := 0.1;
Name := 'Scatter plot';
OptionsFormClass := TVis3D_ScatterPlotSettingsFrm;
end;
destructor TScatterPlot.Destroy;
begin
inherited;
end;
procedure TScatterPlot.Draw(const AGlobalTime: Double);
begin
inherited;
Control.ProgramMgr.CurrentProgram.USize.SetValue(FSize);
end;
procedure TScatterPlot.FreeGLResources;
begin
if TryContextCurrent then
begin
glDeleteBuffers(1, @FInstanceData); FInstanceData := 0;
glDeleteVertexArrays(1, @FVAO); FVAO := 0;
end
else
rglLog('TScatterPlot.FreeGLResources: TryContextCurrent returned false');
inherited;
end;
procedure TScatterPlot.GLRelease;
begin
FVertexData := 0;
FIndexData := 0;
FIndexCount := 0;
FVAO := 0;
FInstanceData := 0;
inherited;
end;
procedure TScatterPlot.MakeBaseMarker;
begin
var LVertices: TArray<GLfloat6>;
var LIndices: TArray<GLuint>;
var LPCIs: TArray<GLuint>;
rglSpherePolar(LVertices, LIndices, LPCIs, 33, 33, 0, 0, False, nil);
FIndexCount := Length(LIndices);
if FVertexData = 0 then glGenBuffers(1, @FVertexData);
glBindBuffer(GL_ARRAY_BUFFER, FVertexData);
glBufferData(GL_ARRAY_BUFFER, Length(LVertices) * SizeOf(GLfloat6), Pointer(LVertices), GL_STATIC_DRAW);
if FIndexData = 0 then glGenBuffers(1, @FIndexData);
glBindBuffer(GL_ELEMENT_ARRAY_BUFFER, FIndexData);
glBufferData(GL_ELEMENT_ARRAY_BUFFER, Length(LIndices) * SizeOf(GLuint), Pointer(LIndices), GL_STATIC_DRAW);
end;
procedure TScatterPlot.Recreate;
begin
if FVAO <> 0 then
Setup;
end;
procedure TScatterPlot.SetSize(const Value: Single);
begin
if FSize <> Value then
begin
FSize := Value;
Changed;
end;
end;
constructor TSimpleScatterPlot.Create(ACtl: TVisCtl3D);
begin
inherited;
FDefaultProgram := P_Scatter;
FColor := clRed;
end;
procedure TSimpleScatterPlot.Draw(const AGlobalTime: Double);
begin
inherited;
glBindVertexArray(FVAO);
glDrawElementsInstanced(GL_TRIANGLES, FIndexCount, GL_UNSIGNED_INT, nil,
Length(FPoints));
glBindVertexArray(0);
end;
procedure TSimpleScatterPlot.SetPoints(const Value: TArray<GLfloat3>);
begin
if FPoints <> Value then
begin
FPoints := Value;
Recreate;
Changed;
end;
end;
procedure TSimpleScatterPlot.SetPoints(const Value: TArray<TASR3>);
begin
SetLength(FPoints, Length(Value));
for var i := 0 to High(FPoints) do
begin
FPoints[i][0] := Value[i].X;
FPoints[i][1] := Value[i].Y;
FPoints[i][2] := Value[i].Z;
end;
Recreate;
Changed;
end;
procedure TSimpleScatterPlot.Setup;
begin
if (Control = nil) or (Control.Context = nil) then
Exit;
Control.Context.MakeCurrent('TSimpleScatterPlot.Setup');
if FVAO = 0 then glGenVertexArrays(1, @FVAO);
glBindVertexArray(FVAO);
try
var SSD := Default(TStockSurfaceData);
if Control.Context.FStockSurfaces.TryGetValue(STOCKSURF_SPHERELET, SSD) then
begin
FVertexData := SSD.VertexData;
FIndexData := SSD.IndexData;
FIndexCount := SSD.IndexCount;
end
else
begin
MakeBaseMarker;
SSD.VertexData := FVertexData;
SSD.IndexData := FIndexData;
SSD.IndexCount := FIndexCount;
Control.Context.FStockSurfaces.Add(STOCKSURF_SPHERELET, SSD);
end;
glBindBuffer(GL_ARRAY_BUFFER, FVertexData);
glBindBuffer(GL_ELEMENT_ARRAY_BUFFER, FIndexData);
if FInstanceData = 0 then glGenBuffers(1, @FInstanceData);
glBindBuffer(GL_ARRAY_BUFFER, FInstanceData);
glBufferData(GL_ARRAY_BUFFER, Length(FPoints) * SizeOf(GLfloat3), Pointer(FPoints), GL_STATIC_DRAW);
glEnableVertexAttribArray(0);
glEnableVertexAttribArray(2);
glEnableVertexAttribArray(3);
glBindBuffer(GL_ARRAY_BUFFER, FVertexData);
glVertexAttribPointer(0, 3, GL_FLOAT, GL_FALSE, 6*SizeOf(GLfloat), nil);
glVertexAttribPointer(2, 3, GL_FLOAT, GL_FALSE, 6*SizeOf(GLfloat), Pointer(3*SizeOf(GLfloat)));
glBindBuffer(GL_ARRAY_BUFFER, FInstanceData);
glVertexAttribPointer(3, 3, GL_FLOAT, GL_FALSE, 3*SizeOf(GLfloat), nil);
glVertexAttribDivisor(3, 1);
finally
glBindVertexArray(0);
end;
end;
constructor TAdvScatterPlot.Create(ACtl: TVisCtl3D);
begin
inherited;
FDefaultProgram := P_AdvScatter;
FColorNotApplicable := True;
Name := 'Advanced scatter plot';
end;
procedure TAdvScatterPlot.Draw(const AGlobalTime: Double);
begin
inherited;
glBindVertexArray(FVAO);
glDrawElementsInstanced(GL_TRIANGLES, FIndexCount, GL_UNSIGNED_INT, nil,
Length(FPoints));
glBindVertexArray(0);
end;
procedure TAdvScatterPlot.SetPoints(const Value: TArray<GLfloat7>);
begin
if FPoints <> Value then
begin
FPoints := Value;
Recreate;
Changed;
end;
end;
procedure TAdvScatterPlot.SetPoints(const Value: TArray<Double>);
begin
SetLength(FPoints, Length(Value) div 5);
for var i := 0 to High(FPoints) do
begin
FPoints[i][0] := Value[5*i + 0];
FPoints[i][1] := Value[5*i + 1];
FPoints[i][2] := Value[5*i + 2];
var Color := TRGB(TColor(RBSwap(Round(Value[5*i + 3]))));
FPoints[i][3] := Color.Red;
FPoints[i][4] := Color.Green;
FPoints[i][5] := Color.Blue;
FPoints[i][6] := Value[5*i + 4];
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;
procedure TVectorField.Configure(ASettings: TAlgosimStructure);
begin
inherited;
for var i := 1 to ASettings.MemberCount do
begin
var S := ASettings.Members[i].Name;
var V := ASettings.Members[i].Value;
if S = 'size' then
Size := V.ToASR
else if S = 'pervertexcolors' then
PerVertexColors := V.ToBoolean
else if S = 'anchorpoint' then
AnchorPoint := V.ToRealNumber;
end;
end;
constructor TVectorField.Create(ACtl: TVisCtl3D);
begin
inherited;
FDefaultProgram := P_VectorField;
FSize := 1.0;
FColor := clRed;
FAnchorPoint := 0.5;
Name := 'Vector field';
OptionsFormClass := TVis3D_VectorFieldSettingsFrm;
end;
destructor TVectorField.Destroy;
begin
inherited;
end;
procedure TVectorField.Draw(const AGlobalTime: Double);
begin
inherited;
if IsZero(FMaxNorm) then
Control.ProgramMgr.CurrentProgram.USize.SetValue(FSize)
else
Control.ProgramMgr.CurrentProgram.USize.SetValue(FSize / FMaxNorm);
Control.ProgramMgr.CurrentProgram.UAttribColors.SetValue(FAttribColors);
Control.ProgramMgr.CurrentProgram.UDisplacement.SetValue(FAnchorPoint - 0.5, 0.0);
glBindVertexArray(FVAO);
glDrawArraysInstanced(GL_TRIANGLES, 0, FVertexCount, Length(FVectors));
glBindVertexArray(0);
end;
procedure TVectorField.FreeGLResources;
begin
if TryContextCurrent then
begin
glDeleteBuffers(1, @FInstanceData); FInstanceData := 0;
glDeleteVertexArrays(1, @FVAO); FVAO := 0;
end
else
rglLog('TVectorField.FreeGLResources: TryContextCurrent returned false');
inherited;
end;
procedure TVectorField.GLRelease;
begin
FVertexData := 0;
FVAO := 0;
FInstanceData := 0;
inherited;
end;
procedure TVectorField.SetAnchorPoint(const Value: Single);
begin
if FAnchorPoint <> Value then
begin
FAnchorPoint := Value;
Changed;
end;
end;
procedure TVectorField.SetAttribColors(const Value: Boolean);
begin
if FAttribColors <> Value then
begin
FAttribColors := Value;
FColorNotApplicable := FAttribColors;
Changed;
end;
end;
procedure TVectorField.SetSize(const Value: Single);
begin
if FSize <> Value then
begin
FSize := Value;
Changed;
end;
end;
procedure TVectorField.SetVectors(const Value: TArray<GLr3v3c3v>);
begin
if FVectors <> Value then
begin
FVectors := Value;
Recreate;
Changed;
end;
end;
procedure TVectorField.MakeBaseArrow;
const
N = 32;
R = 0.03;
L = 1.00;
Q = 0.10;
f = 0.35;
Geometry: record
Disk,
Cylinder,
Septum,
Cone: Integer;
end
=
(
Disk: 3*N;
Cylinder: 6*N;
Septum: 3*N;
Cone: 3*N;
);
var
Sines, Cosines: array[0..N] of Single;
begin
var LVertices: TArray<GLfloat6>;
FVertexCount :=
Geometry.Disk +
Geometry.Cylinder +
Geometry.Septum +
Geometry.Cone;
SetLength(LVertices, FVertexCount);
var Idx := 0;
for var i := 0 to N do
SinCos(Single(i * 2*Pi/N), Sines[i], Cosines[i]);
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;
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;
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;
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;
procedure TImageRect.BitmapChanged(Sender: TObject);
begin
Recreate;
Changed;
end;
procedure TImageRect.Configure(ASettings: TAlgosimStructure);
begin
inherited;
for var i := 1 to ASettings.MemberCount do
begin
var S := ASettings.Members[i].Name;
var V := ASettings.Members[i].Value;
if S = 'bitmap' then
begin
var bm := (V as TAlgosimPixmap).Value.CreateGDIBitmap;
try
Bitmap := bm;
finally
bm.Free;
end;
end
else if S = 'transparentcolor' then
TransparentColor := V.ToColor
else if S = 'opaquecolor' then
OpaqueColor := V.ToColor
else if S = 'transparencymode' then
TransparentColorMode := TTransparentColorMode.FromString(V.ToString);
end;
end;
constructor TImageRect.Create(ACtl: TVisCtl3D);
begin
inherited;
FDefaultProgram := P_Image;
FBitmap := TBitmap.Create;
FBitmap.OnChange := BitmapChanged;
Name := 'Pixmap';
OptionsFormClass := TVis3D_ImageRectSettingsFrm;
end;
destructor TImageRect.Destroy;
begin
FreeAndNil(FBitmap);
inherited;
end;
procedure TImageRect.Draw(const AGlobalTime: Double);
begin
inherited;
Control.ProgramMgr.CurrentProgram.UTranspColor.SetValue(FTransparentColor);
Control.ProgramMgr.CurrentProgram.UOpaqueColor.SetValue(FOpaqueColor);
Control.ProgramMgr.CurrentProgram.UTranspColorMode.SetValue(Ord(FTransparentColorMode));
glBindVertexArray(FVAO);
glBindTexture(GL_TEXTURE_2D, FTexture);
glDrawArrays(GL_TRIANGLES, 0, 6);
glBindVertexArray(0);
end;
procedure TImageRect.FreeGLResources;
begin
if TryContextCurrent then
begin
glDeleteTextures(1, @FTexture); FTexture := 0;
glDeleteBuffers(1, @FVertexData); FVertexData := 0;
glDeleteVertexArrays(1, @FVAO); FVAO := 0;
end
else
rglLog('TImageRect.FreeGLResources: TryContextCurrent returned false');
inherited;
end;
procedure TImageRect.GLRelease;
begin
FTexture := 0;
FVertexData := 0;
FVAO := 0;
inherited;
end;
procedure TImageRect.Recreate;
begin
if FVAO <> 0 then
Setup;
end;
procedure TImageRect.SetBitmap(const Value: TBitmap);
begin
if FBitmap <> Value then
begin
FBitmap.Assign(Value);
Recreate;
end;
end;
procedure TImageRect.SetTransparentColor(const Value: TColor);
begin
if FTransparentColor <> Value then
begin
FTransparentColor := Value;
Changed;
end;
end;
procedure TImageRect.SetOpaqueColor(const Value: TColor);
begin
if FOpaqueColor <> Value then
begin
FOpaqueColor := Value;
Changed;
end;
end;
procedure TImageRect.SetTransparentColorMode(
const Value: TTransparentColorMode);
begin
if FTransparentColorMode <> Value then
begin
FTransparentColorMode := Value;
Changed;
end;
end;
procedure TImageRect.Setup;
const
FrameQuad: array[0..29] of GLfloat =
(
0.0, 0.0, 0.0, 0.0, 0.0,
0.0, 1.0, 0.0, 1.0, 0.0,
0.0, 1.0, 1.0, 1.0, 1.0,
0.0, 0.0, 0.0, 0.0, 0.0,
0.0, 1.0, 1.0, 1.0, 1.0,
0.0, 0.0, 1.0, 0.0, 1.0
);
begin
if (Control = nil) or (Control.Context = nil) then
Exit;
Control.Context.MakeCurrent('TImageRect.Setup');
if FVAO = 0 then glGenVertexArrays(1, @FVAO);
glBindVertexArray(FVAO);
try
if FVertexData = 0 then glGenBuffers(1, @FVertexData);
glBindBuffer(GL_ARRAY_BUFFER, FVertexData);
glBufferData(GL_ARRAY_BUFFER, Length(FrameQuad) * SizeOf(GLfloat5),
@FrameQuad, GL_STATIC_DRAW);
glEnableVertexAttribArray(0);
glEnableVertexAttribArray(1);
glBindBuffer(GL_ARRAY_BUFFER, FVertexData);
glVertexAttribPointer(0, 3, GL_FLOAT, GL_FALSE, 5*SizeOf(GLfloat), nil);
glVertexAttribPointer(1, 2, GL_FLOAT, GL_FALSE, 5*SizeOf(GLfloat), Pointer(3*SizeOf(GLfloat)));
if FTexture = 0 then glGenTextures(1, @FTexture);
glBindTexture(GL_TEXTURE_2D, FTexture);
if Assigned(FBitmap) and (FBitmap.Height >= 1) then
begin
FBitmap.PixelFormat := pf24bit;
glTexImage2D(GL_TEXTURE_2D, 0, GL_RGB, FBitmap.Width, FBitmap.Height,
0, GL_BGR, GL_UNSIGNED_BYTE, FBitmap.ScanLine[FBitmap.Height - 1]);
end;
glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR);
glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR);
finally
glBindVertexArray(0);
end;
end;
procedure TTextRect.Configure(ASettings: TAlgosimStructure);
begin
inherited;
for var i := 1 to ASettings.MemberCount do
begin
var S := ASettings.Members[i].Name;
var V := ASettings.Members[i].Value;
if S = 'text' then
Text := V.ToString
else if S = 'fontname' then
Font.Name := V.ToString
else if S = 'fontsize' then
Font.Size := V.ToInt32
else if S = 'bold' then
if V.ToBoolean then
Font.Style := Font.Style + [fsBold]
else
Font.Style := Font.Style - [fsBold]
else if S = 'italic' then
if V.ToBoolean then
Font.Style := Font.Style + [fsItalic]
else
Font.Style := Font.Style - [fsItalic]
else if S = 'underline' then
if V.ToBoolean then
Font.Style := Font.Style + [fsUnderline]
else
Font.Style := Font.Style - [fsUnderline]
else if S = 'strikethrough' then
if V.ToBoolean then
Font.Style := Font.Style + [fsStrikeout]
else
Font.Style := Font.Style - [fsStrikeout]
else if S = 'textcolor' then
Font.Color := V.ToColor
else if S = 'textanchorpoint' then
AnchorPoint := TAnchorPoint.FromString(V.ToString)
else if S = 'opacity' then
Opacity := V.ToASR
else if S = 'textresfactor' then
TextResFactor := V.ToASR
else if S = 'highquality' then
HighQuality := V.ToBoolean
else if S = 'facescreen' then
FaceScreen := V.ToBoolean
else if S = 'displacement' then
Displacement := V.AsRealVector;
end;
end;
constructor TTextRect.Create(ACtl: TVisCtl3D);
begin
inherited;
FDefaultProgram := P_Text;
FTextResFactor := 1.0;
FHighQuality := True;
FAnchorPoint := apTopLeft;
FOpacity := 1.0;
FFont := TFont.Create;
FFont.OnChange := FontChanged;
Name := 'Text';
OptionsFormClass := TVis3D_TextRectSettingsFrm;
end;
destructor TTextRect.Destroy;
begin
FreeAndNil(FFont);
inherited;
end;
procedure TTextRect.Draw(const AGlobalTime: Double);
begin
inherited;
Control.ProgramMgr.CurrentProgram.UAnchorPoint.SetValue(Ord(FAnchorPoint));
Control.ProgramMgr.CurrentProgram.UFaceScreen.SetValue(FFaceScreen);
Control.ProgramMgr.CurrentProgram.UAspect.SetValue(FAspect / Control.AspectRatio);
Control.ProgramMgr.CurrentProgram.UDisplacement.SetValue(FDisplacement);
Control.ProgramMgr.CurrentProgram.UOpacity.SetValue(FOpacity);
Control.ProgramMgr.CurrentProgram.USize.SetValue(FFont.Size / 24.0);
glBindVertexArray(FVAO);
glBindTexture(GL_TEXTURE_2D, FTexture);
glDrawArrays(GL_TRIANGLES, 0, 6);
glBindVertexArray(0);
end;
procedure TTextRect.FontChanged(Sender: TObject);
begin
Recreate;
Changed;
end;
procedure TTextRect.FreeGLResources;
begin
if TryContextCurrent then
begin
glDeleteTextures(1, @FTexture); FTexture := 0;
glDeleteBuffers(1, @FVertexData); FVertexData := 0;
glDeleteVertexArrays(1, @FVAO); FVAO := 0;
end
else
rglLog('TTextRect.FreeGLResources: TryContextCurrent returned false');
inherited;
end;
procedure TTextRect.GLRelease;
begin
FTexture := 0;
FVertexData := 0;
FVAO := 0;
inherited;
end;
procedure TTextRect.SetAnchorPoint(const Value: TAnchorPoint);
begin
if FAnchorPoint <> Value then
begin
FAnchorPoint := Value;
Changed;
end;
end;
procedure TTextRect.SetDisplacement(const Value: rglv2);
begin
if FDisplacement <> Value then
begin
FDisplacement := Value;
Changed;
end;
end;
procedure TTextRect.SetFaceScreen(const Value: Boolean);
begin
if FFaceScreen <> Value then
begin
FFaceScreen := Value;
Changed;
end;
end;
procedure TTextRect.SetFont(const Value: TFont);
begin
FFont.Assign(Value);
end;
procedure TTextRect.SetHighQuality(const Value: Boolean);
begin
if FHighQuality <> Value then
begin
FHighQuality := Value;
Recreate;
Changed;
end;
end;
procedure TTextRect.SetOpacity(const Value: Double);
begin
var LOpacity := EnsureRange(Value, 0.0, 1.0);
if FOpacity <> LOpacity then
begin
FOpacity := LOpacity;
Changed;
end;
end;
function TTextRect.MakeBitmap: TBitmap;
const
eps = 2;
begin
Result := TBitmap.Create;
try
Result.Canvas.Font := FFont;
var OptimalHeight: Integer;
if FText.Length <= 4 then
OptimalHeight := Round(1.5 * Screen.Height)
else if FText.Length <= 12 then
OptimalHeight := Screen.Height
else
OptimalHeight := Screen.Height div 2;
OptimalHeight := Round(FTextResFactor * OptimalHeight);
Result.Canvas.Font.Height := EnsureRange(OptimalHeight, 100, 2500);
var LSize := Result.Canvas.TextExtent(FText) + TSize.Create(2*eps, 2*eps);
var LArea := UInt64(LSize.Width) * UInt64(LSize.Height);
const MaxArea = 7372800;
const MaxLength = IfThen(Control.ImplData.MaxTextureSize > 0,
Control.ImplData.MaxTextureSize, 4096);
var Factor := Max(Max(LSize.cx / MaxLength, LSize.cy / MaxLength), Sqrt(LArea / MaxArea));
if Factor > 1.0 then
begin
Result.Canvas.Font.Height := EnsureRange(Round(Result.Canvas.Font.Height / Factor), 32, 2500);
LSize := Result.Canvas.TextExtent(FText) + TSize.Create(2*eps, 2*eps);
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;
procedure TAxes.AxisChanged(Sender: TObject);
begin
Changed;
end;
function TAxes.GetGridCount: Integer;
begin
Result := 0;
for var Child in FChildren do
if Child is TGrid then
Inc(Result);
end;
procedure TAxes.GridChanged(Sender: TObject);
begin
Changed;
end;
procedure TAxes.Configure(ASettings: TAlgosimStructure);
begin
inherited;
for var i := 1 to<