/
stud_22-365
/
GLXEngine
Обзор
Документация
Войти
/
stud_22-365
/
GLXEngine
Код
Запросы
0
Задачи
Вики
Пакеты
0
Релизы
0
Аналитика
Безопасность
v2.2
Source/CUDA.Graphics.pas
1 137 строк
30 KB
GLScene
Merged duplicate assets
28 дек 2022, 15:50
28 дек 2022, 15:50
537f47c
Код
Авторство
О чём код?
// // The graphics platform GLScene https://github.com/glscene // unit CUDA.Graphics; (* CUDA Graphics for GLScene *) interface {$I GLScene.inc} uses Winapi.OpenGL, Winapi.OpenGLext, System.Classes, System.SysUtils, CUDA.Import, CUDA.APIComps, GLS.Context, GLS.State, GLS.Scene, GLS.Graphics, GLS.Material, GLS.Strings, GLS.TextureFormat, GLS.Texture, GLSL.Shader, GLSL.ShaderParameter, GLS.PersistentClasses, GLS.RenderContextInfo; type TGLVertexAttribute = class; TGLVertexAttributes = class; TOnBeforeKernelLaunch = procedure(Sender: TGLVertexAttribute) of object; TGLVertexAttribute = class(TCollectionItem) private FName: string; FType: TGLSLDataType; FFunc: TCUDAFunction; FLocation: Integer; FOnBeforeKernelLaunch: TOnBeforeKernelLaunch; procedure SetName(const AName: string); procedure SetType(AType: TGLSLDataType); procedure SetFunc(AFunc: TCUDAFunction); function GetLocation: Integer; function GetOwner: TGLVertexAttributes; reintroduce; public constructor Create(ACollection: TCollection); override; procedure NotifyChange(Sender: TObject); property Location: Integer read GetLocation; published property Name: string read FName write SetName; property GLSLType: TGLSLDataType read FType write SetType; property KernelFunction: TCUDAFunction read FFunc write SetFunc; property OnBeforeKernelLaunch: TOnBeforeKernelLaunch read FOnBeforeKernelLaunch write FOnBeforeKernelLaunch; end; TGLVertexAttributes = class(TOwnedCollection) private procedure SetItems(Index: Integer; const AValue: TGLVertexAttribute); function GetItems(Index: Integer): TGLVertexAttribute; public constructor Create(AOwner: TComponent); procedure NotifyChange(Sender: TObject); function MakeUniqueName(const ANameRoot: string): string; function GetAttributeByName(const AName: string): TGLVertexAttribute; function Add: TGLVertexAttribute; property Attributes[Index: Integer]: TGLVertexAttribute read GetItems write SetItems; default; end; TFeedBackMeshPrimitive = (fbmpPoint, fbmpLine, fbmpTriangle); TFeedBackMeshLaunching = (fblCommon, fblOnePerAtttribute); TCUDACustomFeedBackMesh = class(TGLBaseSceneObject) private FGeometryResource: TCUDAGraphicResource; FAttributes: TGLVertexAttributes; FVAO: TGLVertexArrayHandle; FVBO: TGLVBOArrayBufferHandle; FEBO: TGLVBOElementArrayHandle; FPrimitiveType: TFeedBackMeshPrimitive; FVertexNumber: Integer; FElementNumber: Integer; FShader: TGLSLShader; FCommonFunc: TCUDAFunction; FLaunching: TFeedBackMeshLaunching; FBlend: Boolean; procedure SetAttributes(AValue: TGLVertexAttributes); procedure SetPrimitiveType(AValue: TFeedBackMeshPrimitive); procedure SetVertexNumber(AValue: Integer); procedure SetElementNumber(AValue: Integer); procedure SetShader(AShader: TGLSLShader); procedure SetCommonFunc(AFunc: TCUDAFunction); protected procedure Notification(AComponent: TComponent; Operation: TOperation); override; procedure RefreshAttributes; procedure AllocateHandles; procedure LaunchKernels; protected property Attributes: TGLVertexAttributes read FAttributes write SetAttributes; // GLSL shader as material. If it absent or disabled - nothing be drawen. property Shader: TGLSLShader read FShader write SetShader; // Primitive type. property PrimitiveType: TFeedBackMeshPrimitive read FPrimitiveType write SetPrimitiveType default fbmpPoint; // Number of vertexes in array buffer. property VertexNumber: Integer read FVertexNumber write SetVertexNumber default 1; // Number of indexes in element buffer. Zero to disable. property ElementNumber: Integer read FElementNumber write SetElementNumber default 0; (* Used for all attributes and elements if Launching = fblCommon otherwise used own attribute function and this for elements. *) property CommonKernelFunction: TCUDAFunction read FCommonFunc write SetCommonFunc; (* Define mode of manufacturer launching: fblCommon - single launch for all, flOnePerAtttribute - one launch per attribute and elements *) property Launching: TFeedBackMeshLaunching read FLaunching write FLaunching default fblCommon; //Defines if the object uses blending for object sorting purposes. property Blend: Boolean read FBlend write FBlend default False; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure DoRender(var ARci: TGLRenderContextInfo; ARenderSelf, ARenderChildren: Boolean); override; property ArrayBufferHandle: TGLVBOArrayBufferHandle read FVBO; property ElementArrayHandle: TGLVBOElementArrayHandle read FEBO; end; TCUDAFeedbackMesh = class(TCUDACustomFeedBackMesh) published property Attributes; property Shader; property PrimitiveType; property VertexNumber; property ElementNumber; property CommonKernelFunction; property Launching; property Blend; property ObjectsSorting; property VisibilityCulling; property Direction; property PitchAngle; property Position; property RollAngle; property Scale; property ShowAxes; property TurnAngle; property Up; property Visible; property Pickable; property OnProgress; property OnPicked; property Behaviours; property Effects; end; TCUDAImageResource = class(TCUDAGraphicResource) private fMaterialLibrary: TGLMaterialLibrary; fTextureName: TGLLibMaterialName; procedure SetMaterialLibrary(const Value: TGLMaterialLibrary); procedure SetTextureName(const Value: TGLLibMaterialName); protected procedure AllocateHandles; override; procedure DestroyHandles; override; procedure Notification(AComponent: TComponent; Operation: TOperation); override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure MapResources; override; procedure UnMapResources; override; procedure BindArrayToTexture(var cudaArray: TCUDAMemData; ALeyer, ALevel: LOngWord); override; published property TextureName: TGLLibMaterialName read fTextureName write SetTextureName; property MaterialLibrary: TGLMaterialLibrary read fMaterialLibrary write SetMaterialLibrary; property Mapping; end; TCUDAGeometryResource = class(TCUDAGraphicResource) private FFeedBackMesh: TCUDACustomFeedBackMesh; procedure SetFeedBackMesh(const Value: TCUDACustomFeedBackMesh); function GetAttribArraySize(AAttr: TGLVertexAttribute): LongWord; protected procedure AllocateHandles; override; procedure DestroyHandles; override; procedure Notification(AComponent: TComponent; Operation: TOperation); override; function GetAttributeArraySize(const AName: string): LongWord; override; function GetAttributeArrayAddress(const AName: string): Pointer; override; function GetElementArrayDataSize: LongWord; override; function GetElementArrayAddress: Pointer; override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure MapResources; override; procedure UnMapResources; override; property AttributeDataSize[const AttribName: string]: LongWord read GetAttributeArraySize; property AttributeDataAddress[const AttribName: string]: Pointer read GetAttributeArrayAddress; property IndexDataSize: LongWord read GetElementArrayDataSize; property IndexDataAddress: Pointer read GetElementArrayAddress; published property FeedBackMesh: TCUDACustomFeedBackMesh read FFeedBackMesh write SetFeedBackMesh; property Mapping; end; //--------------------------------------------------------------------------- implementation //--------------------------------------------------------------------------- // ------------------ // ------------------ TCUDAImageResource ------------------ // ------------------ constructor TCUDAImageResource.Create(AOwner: TComponent); begin inherited Create(AOwner); fHandle[0] := nil; fResourceType := rtTexture; FGLContextHandle := TGLVirtualHandle.Create; FGLContextHandle.OnAllocate := OnGLHandleAllocate; FGLContextHandle.OnDestroy := OnGLHandleDestroy; end; destructor TCUDAImageResource.Destroy; begin FGLContextHandle.Destroy; inherited; end; procedure TCUDAImageResource.SetMaterialLibrary(const Value: TGLMaterialLibrary); begin if fMaterialLibrary <> Value then begin if Assigned(fMaterialLibrary) then fMaterialLibrary.RemoveFreeNotification(Self); fMaterialLibrary := Value; if Assigned(fMaterialLibrary) then begin fMaterialLibrary.FreeNotification(Self); if fMaterialLibrary.TextureByName(fTextureName) <> nil then DestroyHandles; end; end; end; procedure TCUDAImageResource.SetTextureName(const Value: TGLLibMaterialName); begin if fTextureName <> Value then begin fTextureName := Value; DestroyHandles; end; end; procedure TCUDAImageResource.UnMapResources; begin if FMapCounter > 0 then Dec(FMapCounter); if FMapCounter = 0 then begin if Assigned(FHandle[0]) then begin Context.Requires; FStatus := cuGraphicsUnMapResources(1, @FHandle[0], nil); Context.Release; if FStatus <> CUDA_SUCCESS then Abort; end; end; end; procedure TCUDAImageResource.AllocateHandles; const cMapping: array[TCUDAMapping] of TCUgraphicsMapResourceFlags = ( CU_GRAPHICS_MAP_RESOURCE_FLAGS_NONE, CU_GRAPHICS_MAP_RESOURCE_FLAGS_READ_ONLY, CU_GRAPHICS_MAP_RESOURCE_FLAGS_WRITE_DISCARD); var LTexture: TGLTexture; glHandle: Cardinal; begin FGLContextHandle.AllocateHandle; if FGLContextHandle.IsDataNeedUpdate and Assigned(FMaterialLibrary) and (Length(FTextureName) > 0) then begin inherited; LTexture := FMaterialLibrary.TextureByName(FTextureName); if Assigned(LTexture) then begin glHandle := LTexture.AllocateHandle; if glHandle = 0 then Abort; Context.Requires; DestroyHandles; FStatus := cuGraphicsGLRegisterImage( FHandle[0], glHandle, DecodeTextureTarget(LTexture.Image.NativeTextureTarget), cMapping[fMapping]); Context.Release; if FStatus <> CUDA_SUCCESS then Abort; FGLContextHandle.NotifyDataUpdated; end; end; end; procedure TCUDAImageResource.DestroyHandles; begin if Assigned(FHandle[0]) then begin inherited; Context.Requires; FStatus := cuGraphicsUnregisterResource(FHandle[0]); Context.Release; FHandle[0] := nil; FGLContextHandle.NotifyChangesOfData; end; end; procedure TCUDAImageResource.MapResources; begin AllocateHandles; if FMapCounter = 0 then begin if Assigned(FHandle[0]) then begin Context.Requires; FStatus := cuGraphicsMapResources(1, @FHandle[0], nil); Context.Release; if FStatus <> CUDA_SUCCESS then Abort; end; end; Inc(FMapCounter); end; procedure TCUDAImageResource.Notification(AComponent: TComponent; Operation: TOperation); begin inherited; if (AComponent = fMaterialLibrary) and (Operation = opRemove) then begin fMaterialLibrary := nil; fTextureName := ''; DestroyHandles; end; end; procedure TCUDAImageResource.BindArrayToTexture(var cudaArray: TCUDAMemData; ALeyer, ALevel: LOngWord); var LTexture: TGLTexture; newArray: PCUarray; begin if FMapCounter = 0 then begin {$IFDEF USE_LOGGING} LogError(strFailToBindArrayToTex); {$ENDIF} Abort; end; Context.Requires; FStatus := cuGraphicsSubResourceGetMappedArray( newArray, FHandle[0], ALeyer, ALevel); Context.Release; if FStatus <> CUDA_SUCCESS then Abort; LTexture := FMaterialLibrary.TextureByName(FTextureName); SetArray(cudaArray, newArray, True, LTexture.TexDepth > 0); end; // ------------------ // ------------------ TCUDAGeometryResource ------------------ // ------------------ constructor TCUDAGeometryResource.Create(AOwner: TComponent); begin inherited Create(AOwner); FHandle[0] := nil; FHandle[1] := nil; FResourceType := rtBuffer; FMapCounter := 0; FGLContextHandle := TGLVirtualHandle.Create; FGLContextHandle.OnAllocate := OnGLHandleAllocate; FGLContextHandle.OnDestroy := OnGLHandleDestroy; end; destructor TCUDAGeometryResource.Destroy; begin FeedBackMesh := nil; FGLContextHandle.Destroy; inherited; end; procedure TCUDAGeometryResource.SetFeedBackMesh(const Value: TCUDACustomFeedBackMesh); begin if FFeedBackMesh <> Value then begin if Assigned(FFeedBackMesh) then begin FFeedBackMesh.RemoveFreeNotification(Self); FFeedBackMesh.FGeometryResource := nil; end; FFeedBackMesh := Value; if Assigned(FFeedBackMesh) then begin FFeedBackMesh.FreeNotification(Self); FFeedBackMesh.FGeometryResource := Self; end; DestroyHandles; end; end; procedure TCUDAGeometryResource.AllocateHandles; const cMapping: array[TCUDAMapping] of TCUgraphicsMapResourceFlags = ( CU_GRAPHICS_MAP_RESOURCE_FLAGS_NONE, CU_GRAPHICS_MAP_RESOURCE_FLAGS_READ_ONLY, CU_GRAPHICS_MAP_RESOURCE_FLAGS_WRITE_DISCARD); begin inherited; FGLContextHandle.AllocateHandle; if FGLContextHandle.IsDataNeedUpdate then begin if FFeedBackMesh.FVBO.IsDataNeedUpdate then FFeedBackMesh.AllocateHandles; Context.Requires; DestroyHandles; // Register vertex array FStatus := cuGraphicsGLRegisterBuffer( FHandle[0], FFeedBackMesh.FVBO.Handle, cMapping[FMapping]); // Register element array if FFeedBackMesh.ElementNumber > 0 then CollectStatus( cuGraphicsGLRegisterBuffer( FHandle[1], FFeedBackMesh.FEBO.Handle, cMapping[FMapping])); Context.Release; if FStatus <> CUDA_SUCCESS then Abort; FGLContextHandle.NotifyDataUpdated; end; end; procedure TCUDAGeometryResource.DestroyHandles; begin if Assigned(fHandle[0]) or Assigned(fHandle[1]) then begin inherited; Context.Requires; while FMapCounter > 0 do UnMapResources; FStatus := CUDA_SUCCESS; if Assigned(fHandle[0]) then begin CollectStatus(cuGraphicsUnregisterResource(fHandle[0])); fHandle[0] := nil; end; if Assigned(fHandle[1]) then begin CollectStatus(cuGraphicsUnregisterResource(fHandle[1])); fHandle[1] := nil; end; Context.Release; FGLContextHandle.NotifyChangesOfData; end; end; procedure TCUDAGeometryResource.Notification(AComponent: TComponent; Operation: TOperation); begin inherited; if (AComponent = FFeedBackMesh) and (Operation = opRemove) then begin FeedBackMesh := nil; DestroyHandles; end; end; procedure TCUDAGeometryResource.MapResources; var count: Integer; begin AllocateHandles; if FMapCounter = 0 then begin if Assigned(FHandle[0]) then begin count := 1; if Assigned(FHandle[1]) then Inc(count); Context.Requires; FStatus := cuGraphicsMapResources(count, @FHandle[0], nil); Context.Release; if FStatus <> CUDA_SUCCESS then Abort; end; end; Inc(FMapCounter); end; procedure TCUDAGeometryResource.UnMapResources; var count: Integer; begin if FMapCounter > 0 then Dec(FMapCounter); if FMapCounter = 0 then begin if Assigned(FHandle[0]) then begin count := 1; if Assigned(FHandle[1]) then Inc(count); Context.Requires; FStatus := cuGraphicsUnMapResources(count, @FHandle[0], nil); Context.Release; if FStatus <> CUDA_SUCCESS then Abort; end; end; end; function TCUDAGeometryResource.GetAttribArraySize(AAttr: TGLVertexAttribute): LongWord; var typeSize: LongWord; begin case AAttr.GLSLType of GLSLType1F: typeSize := SizeOf(Single); GLSLType2F: typeSize := 2 * SizeOf(Single); GLSLType3F: typeSize := 3 * SizeOf(Single); GLSLType4F: typeSize := 4 * SizeOf(Single); GLSLType1I: typeSize := SizeOf(Integer); GLSLType2I: typeSize := 2 * SizeOf(Integer); GLSLType3I: typeSize := 3 * SizeOf(Integer); GLSLType4I: typeSize := 4 * SizeOf(Integer); GLSLType1UI: typeSize := SizeOf(Integer); GLSLType2UI: typeSize := 2 * SizeOf(Integer); GLSLType3UI: typeSize := 3 * SizeOf(Integer); GLSLType4UI: typeSize := 4 * SizeOf(Integer); GLSLTypeMat2F: typeSize := 4 * SizeOf(Single); GLSLTypeMat3F: typeSize := 9 * SizeOf(Single); GLSLTypeMat4F: typeSize := 16 * SizeOf(Single); else begin Assert(False, strErrorEx + strUnknownType); typeSize := 0; end; end; Result := Cardinal(FFeedBackMesh.VertexNumber) * typeSize; end; function TCUDAGeometryResource.GetAttributeArraySize( const AName: string): LongWord; var LAttr: TGLVertexAttribute; begin Result := 0; LAttr := FFeedBackMesh.Attributes.GetAttributeByName(AName); if not Assigned(LAttr) then exit; if LAttr.GLSLType = GLSLTypeUndefined then exit; Result := GetAttribArraySize(LAttr); end; function TCUDAGeometryResource.GetAttributeArrayAddress( const AName: string): Pointer; var i: Integer; Size: Cardinal; MapPtr: Pointer; LAttr: TGLVertexAttribute; begin Result := nil; if FMapCounter = 0 then exit; LAttr := FFeedBackMesh.Attributes.GetAttributeByName(AName); if not Assigned(LAttr) then exit; for i := 0 to LAttr.Index - 1 do Inc(PByte(Result), GetAttribArraySize(FFeedBackMesh.Attributes[i])); Context.Requires; MapPtr := nil; FStatus := cuGraphicsResourceGetMappedPointer( MapPtr, Size, FHandle[0]); Context.Release; if FStatus <> CUDA_SUCCESS then Abort; if Cardinal(Result) + GetAttribArraySize(LAttr) > Size then begin {$IFDEF USE_LOGGING} LogError(strOutOfAttribSize); {$ENDIF} Abort; end; Inc(Pbyte(Result), Cardinal(MapPtr)); end; function TCUDAGeometryResource.GetElementArrayDataSize: LongWord; begin Result := FFeedBackMesh.ElementNumber * SizeOf(Cardinal); end; function TCUDAGeometryResource.GetElementArrayAddress: Pointer; var Size: Cardinal; MapPtr: Pointer; begin Result := nil; if (FHandle[1] = nil) and (FMapCounter = 0) then exit; Context.Requires; MapPtr := nil; FStatus := cuGraphicsResourceGetMappedPointer(MapPtr, Size, FHandle[1]); Context.Release; if FStatus <> CUDA_SUCCESS then Abort; if GetElementArrayDataSize > Size then begin {$IFDEF USE_LOGGING} LogError(strOutOfElementSize); {$ENDIF} Abort; end; Inc(Pbyte(Result), Cardinal(MapPtr)); end; // ----------------------- // ----------------------- TGLVertexAttribute ------------------- // ----------------------- constructor TGLVertexAttribute.Create(ACollection: TCollection); begin inherited; FName := GetOwner.MakeUniqueName('Attrib'); FType := GLSLTypeUndefined; FLocation := -1; end; procedure TGLVertexAttribute.SetFunc(AFunc: TCUDAFunction); var LMesh: TCUDACustomFeedBackMesh; begin LMesh := TCUDACustomFeedBackMesh(GetOwner.GetOwner); if Assigned(FFunc) then FFunc.RemoveFreeNotification(LMesh); FFunc := AFunc; if Assigned(FFunc) then FFunc.FreeNotification(LMesh); end; procedure TGLVertexAttribute.SetName(const AName: string); begin if AName <> FName then begin FName := ''; FName := GetOwner.MakeUniqueName(AName); NotifyChange(Self); end; end; procedure TGLVertexAttribute.SetType(AType: TGLSLDataType); begin if AType <> FType then begin FType := AType; NotifyChange(Self); end; end; function TGLVertexAttribute.GetLocation: Integer; begin if FLocation < 0 then FLocation := gl.GetAttribLocation( CurrentGLContext.GLStates.CurrentProgram, PAnsiChar(AnsiString(FName))); Result := FLocation; end; function TGLVertexAttribute.GetOwner: TGLVertexAttributes; begin Result := TGLVertexAttributes(Collection); end; procedure TGLVertexAttribute.NotifyChange(Sender: TObject); begin GetOwner.NotifyChange(Self); end; // ----------------------- // ----------------------- TGLVertexAttributes ------------------- // ----------------------- function TGLVertexAttributes.Add: TGLVertexAttribute; begin Result := (inherited Add) as TGLVertexAttribute; end; constructor TGLVertexAttributes.Create(AOwner: TComponent); begin inherited Create(AOwner, TGLVertexAttribute); end; function TGLVertexAttributes.GetAttributeByName( const AName: string): TGLVertexAttribute; var I: Integer; A: TGLVertexAttribute; begin // Brute-force, there no need optimization for I := 0 to Count - 1 do begin A := TGLVertexAttribute(Items[i]); if A.Name = AName then Exit(A); end; Result := nil; end; function TGLVertexAttributes.GetItems(Index: Integer): TGLVertexAttribute; begin Result := TGLVertexAttribute(inherited Items[index]); end; function TGLVertexAttributes.MakeUniqueName(const ANameRoot: string): string; var I: Integer; begin Result := ANameRoot; I := 1; while GetAttributeByName(Result) <> nil do begin Result := ANameRoot + IntToStr(I); Inc(I); end; end; procedure TGLVertexAttributes.NotifyChange(Sender: TObject); begin TCUDACustomFeedBackMesh(GetOwner).NotifyChange(Self); end; procedure TGLVertexAttributes.SetItems(Index: Integer; const AValue: TGLVertexAttribute); begin inherited Items[index] := AValue; end; // ----------------------- // ----------------------- TCUDACustomFeedBackMesh ------------------- // ----------------------- procedure TCUDACustomFeedBackMesh.AllocateHandles; var I, L: Integer; Size, Offset: Cardinal; GR: TCUDAGeometryResource; EnabledLocations: array[0..GLS_VERTEX_ATTR_NUM - 1] of Boolean; begin FVAO.AllocateHandle; FVBO.AllocateHandle; FEBO.AllocateHandle; if Assigned(FGeometryResource) then begin GR := TCUDAGeometryResource(FGeometryResource); size := 0; for I := 0 to Attributes.Count - 1 do Inc(size, GR.GetAttribArraySize(Attributes[I])); FVAO.Bind; FVBO.BindBufferData(nil, size, GL_STREAM_DRAW); if FElementNumber > 0 then FEBO.BindBufferData(nil, GR.GetElementArrayDataSize, GL_STREAM_DRAW) else FEBO.UnBind; // Just in case // Predisable attributes for I := 0 to GLS_VERTEX_ATTR_NUM - 1 do EnabledLocations[I] := false; Offset := 0; for I := 0 to Attributes.Count - 1 do begin L := Attributes[I].Location; if L > -1 then begin EnabledLocations[I] := True; case Attributes[I].GLSLType of GLSLType1F: gl.VertexAttribPointer(L, 1, GL_FLOAT, false, 0, pointer(Offset)); GLSLType2F: gl.VertexAttribPointer(L, 2, GL_FLOAT, false, 0, pointer(Offset)); GLSLType3F: gl.VertexAttribPointer(L, 3, GL_FLOAT, false, 0, pointer(Offset)); GLSLType4F: gl.VertexAttribPointer(L, 4, GL_FLOAT, false, 0, pointer(Offset)); GLSLType1I: gl.VertexAttribIPointer(L, 1, GL_INT, 0, pointer(Offset)); GLSLType2I: gl.VertexAttribIPointer(L, 2, GL_INT, 0, pointer(Offset)); GLSLType3I: gl.VertexAttribIPointer(L, 3, GL_INT, 0, pointer(Offset)); GLSLType4I: gl.VertexAttribIPointer(L, 4, GL_INT, 0, pointer(Offset)); GLSLType1UI: gl.VertexAttribIPointer(L, 1, GL_UNSIGNED_INT, 0, pointer(Offset)); GLSLType2UI: gl.VertexAttribIPointer(L, 2, GL_UNSIGNED_INT, 0, pointer(Offset)); GLSLType3UI: gl.VertexAttribIPointer(L, 3, GL_UNSIGNED_INT, 0, pointer(Offset)); GLSLType4UI: gl.VertexAttribIPointer(L, 4, GL_UNSIGNED_INT, 0, pointer(Offset)); GLSLTypeMat2F: gl.VertexAttribPointer(L, 4, GL_FLOAT, false, 0, pointer(Offset)); GLSLTypeMat3F: gl.VertexAttribPointer(L, 9, GL_FLOAT, false, 0, pointer(Offset)); GLSLTypeMat4F: gl.VertexAttribPointer(L, 16, GL_FLOAT, false, 0, pointer(Offset)); end; // of case end; Inc(Offset, GR.GetAttribArraySize(Attributes[I])); end; // Enable engagement attributes array begin for I := GLS_VERTEX_ATTR_NUM - 1 downto 0 do if EnabledLocations[I] then gl.EnableVertexAttribArray(I) else gl.DisableVertexAttribArray(I); end; FVAO.UnBind; FVAO.NotifyDataUpdated; end; end; constructor TCUDACustomFeedBackMesh.Create(AOwner: TComponent); begin inherited; ObjectStyle := ObjectStyle + [osDirectDraw]; FAttributes := TGLVertexAttributes.Create(Self); FVAO := TGLVertexArrayHandle.Create; FVBO := TGLVBOArrayBufferHandle.Create; FEBO := TGLVBOElementArrayHandle.Create; FPrimitiveType := fbmpPoint; FLaunching := fblCommon; FVertexNumber := 1; FElementNumber := 0; FBlend := False; end; destructor TCUDACustomFeedBackMesh.Destroy; begin Shader := nil; FAttributes.Destroy; FVAO.Destroy; FVBO.Destroy; FEBO.Destroy; inherited; end; procedure TCUDACustomFeedBackMesh.LaunchKernels; var i: Integer; GeomRes: TCUDAGeometryResource; //IR: TCUDAImageResource; begin if Assigned(FGeometryResource) then begin // Produce geometry resource GeomRes := TCUDAGeometryResource(FGeometryResource); GeomRes.MapResources; // Produce vertex attributes case Launching of fblCommon: begin for I := 0 to FAttributes.Count - 1 do with FAttributes.Attributes[I] do if Assigned(OnBeforeKernelLaunch) then OnBeforeKernelLaunch(FAttributes.Attributes[I]); if Assigned(FCommonFunc) then FCommonFunc.Launch; end; fblOnePerAtttribute: begin for I := 0 to FAttributes.Count - 1 do with FAttributes.Attributes[I] do begin if Assigned(OnBeforeKernelLaunch) then OnBeforeKernelLaunch(FAttributes.Attributes[I]); if Assigned(KernelFunction) then KernelFunction.Launch; end; end; else Assert(False, strErrorEx + strUnknownType); end; // Produce indexes if (GeomRes.GetElementArrayDataSize > 0) and Assigned(FCommonFunc) then FCommonFunc.Launch; GeomRes.UnMapResources; end; end; // // Produce image resource // else if FGLResource is TCUDAImageResource then // begin // IR := TCUDAImageResource(FGLResource); // IR.MapResources; // if Assigned(FBeforeLaunch) then // FBeforeLaunch(Self, 0); // if Assigned(FManufacturer) then // FManufacturer.Launch; // IR.UnMapResources; // end; procedure TCUDACustomFeedBackMesh.DoRender(var ARci: TGLRenderContextInfo; ARenderSelf, ARenderChildren: Boolean); const cPrimitives: array[TFeedBackMeshPrimitive] of Cardinal = (GL_POINTS, GL_LINES, GL_TRIANGLES); begin if ARenderSelf and not (csDesigning in ComponentState) and Assigned(FShader) and Assigned(FGeometryResource) then try FShader.Apply(ARci, Self); if FVAO.IsDataNeedUpdate then AllocateHandles; // Produce mesh data LaunchKernels; // Draw mesh FVAO.Bind; // Multipass Shader Loop repeat // Render mesh if FElementNumber > 0 then begin gl.DrawElements( cPrimitives[FPrimitiveType], FElementNumber, GL_UNSIGNED_INT, nil); end else begin gl.DrawArrays( cPrimitives[FPrimitiveType], 0, FVertexNumber); end; until not FShader.UnApply(ARci); FVAO.UnBind; except Visible := False; end; if ARenderChildren then Self.RenderChildren(0, Count - 1, ARci); end; procedure TCUDACustomFeedBackMesh.Notification(AComponent: TComponent; Operation: TOperation); var I: Integer; begin if Operation = opRemove then begin if AComponent = Shader then Shader := nil else if AComponent = FCommonFunc then CommonKernelFunction := nil else if AComponent is TCUDAFunction then begin for I := 0 to FAttributes.Count - 1 do if FAttributes[I].KernelFunction = AComponent then FAttributes[I].KernelFunction := nil; end; end; inherited; end; procedure TCUDACustomFeedBackMesh.RefreshAttributes; var I: Integer; AttribInfo: TGLActiveAttribArray; begin if Assigned(FShader) and FShader.Enabled then begin FShader.FailedInitAction := fiaSilentDisable; Scene.CurrentBuffer.RenderingContext.Activate; try AttribInfo := FShader.GetActiveAttribs; except FShader.Enabled := False; Scene.CurrentBuffer.RenderingContext.Deactivate; exit; end; Scene.CurrentBuffer.RenderingContext.Deactivate; FAttributes.Clear; for I := 0 to High(AttribInfo) do begin with FAttributes.Add do begin Name := AttribInfo[I].Name; GLSLType := AttribInfo[I].AType; FLocation := AttribInfo[I].Location; end; end; FVAO.NotifyChangesOfData; end; end; procedure TCUDACustomFeedBackMesh.SetAttributes(AValue: TGLVertexAttributes); begin FAttributes.Assign(AValue); end; procedure TCUDACustomFeedBackMesh.SetCommonFunc(AFunc: TCUDAFunction); begin if AFunc <> FCommonFunc then begin if Assigned(FCommonFunc) then FCommonFunc.RemoveFreeNotification(Self); FCommonFunc := AFunc; if Assigned(FCommonFunc) then FCommonFunc.FreeNotification(Self); end; end; procedure TCUDACustomFeedBackMesh.SetElementNumber(AValue: Integer); begin if AValue < 0 then AValue := 0; FElementNumber := AValue; FVAO.NotifyChangesOfData; end; procedure TCUDACustomFeedBackMesh.SetPrimitiveType(AValue: TFeedBackMeshPrimitive); begin FPrimitiveType := AValue; end; procedure TCUDACustomFeedBackMesh.SetShader(AShader: TGLSLShader); begin if AShader <> FShader then begin if Assigned(FShader) then FShader.RemoveFreeNotification(Self); FShader := AShader; if Assigned(FShader) then FShader.FreeNotification(Self); if not (csLoading in ComponentState) then RefreshAttributes; end; end; procedure TCUDACustomFeedBackMesh.SetVertexNumber(AValue: Integer); begin if AValue < 1 then AValue := 1; FVertexNumber := AValue; FVAO.NotifyChangesOfData; end; //------------------------------------------ initialization //------------------------------------------ RegisterClasses([TCUDAImageResource, TCUDAGeometryResource, TCUDACustomFeedBackMesh, TCUDAFeedbackMesh]); end.