UNIT a3dge.Model3D;
(*<Implements common models for games.
@include(../docs/a3dge.model3d.pds)
*)
(*
Copyright (c) 2012, 2025 Guillermo Martínez J.
This software is provided 'as-is', without any express or implied
warranty. In no event will the authors be held liable for any damages
arising from the use of this software.
Permission is granted to anyone to use this software for any purpose,
including commercial applications, and to alter it and redistribute it
freely, subject to the following restrictions:
1. The origin of this software must not be misrepresented; you must not
claim that you wrote the original software. If you use this software
in a product, an acknowledgment in the product documentation would be
appreciated but is not required.
2. Altered source versions must be plainly marked as such, and must not be
misrepresented as being the original software.
3. This notice may not be removed or altered from any source
distribution.
*)
{$Include a3dge.cfg}
INTERFACE
USES
Types,
allegro5,
a3dge.Material, a3dge.Math3D, a3dge.World3D,
{$IfDef FPC}
GL
{$Else}
OpenGL
{$EndIf}
;
TYPE
(* Defines a polygon. *)
TPolygon = record
(* Polygon vertices. *)
Vertices,
(* Vertex normals. *)
VertexNormals,
(* Texture coordenates. *)
TexCoords: TIntegerDynArray;
(* Plane normal. *)
PlaneNormal: TVector3D;
(* Use plane normal? *)
UsePlaneNormal: Boolean;
(* Material used by polygon. *)
Material: integer
end;
(* List of polygons. *)
TPolygonList = array of TPolygon;
(* Texture coordinates. *)
TTexCoord = record
u, v: GLfloat;
end;
(* List of texture coordinates. *)
TTexCoordList = array of TTexCoord;
(* Base class for 3D models. *)
TMesh3D = class (TBaseModel3D)
private
fVertices,
fNormals: TVector3DList;
fPolygons: TPolygonList;
fTextureCoordinates: TTexCoordList;
fMaterials: TMaterialList;
function GetNumVertices: Integer;
procedure SetNumVertices (const aNum: Integer);
function GetVertex (const aNdx: Integer): TVector3D;
procedure SetVertex (const aNdx: Integer; aValue: TVector3D);
function GetNumNormals: Integer;
procedure SetNumNormals (const aNum: Integer);
function GetNormal (const aNdx: Integer): TVector3D;
procedure SetNormal (const aNdx: Integer; aValue: TVector3D);
function GetNumPolygons: Integer;
procedure SetNumPolygons (const aNum: Integer);
function GetPolygon (const aNdx: Integer): TPolygon;
procedure SetPolygon (const aNdx: Integer; aValue: TPolygon);
function GetNumTexCoords: Integer;
procedure SetNumTexCoords (const aNum: Integer);
function GetTexCoord (const aNdx: Integer): TTexCoord;
procedure SetTexCoord (const aNdx: Integer; aValue: TTexCoord);
protected
(* Get a copy of the vertices. *)
function GetVertexList: TVector3DList;
(* Get a copy of the normals. *)
function GetNormalList: TVector3DList;
(* Get a copy of the polygons. *)
function GetPolygonList: TPolygonList;
(* Get a copy of the texture coordinates. *)
function GetTexCoordList: TTexCoordList;
public
(* Constructor. *)
constructor Create; override;
(* Destructor. *)
destructor Destroy; override;
(* Assign a list of vertices. *)
procedure SetVertexList (aVectors: TVector3DList);
(* Assign a list of normals. *)
procedure SetNormalList (aVectors: TVector3DList);
(* Assign a list of polygons. *)
procedure SetPolygonList (aPolygons: TPolygonList);
(* Assign a list of texture coordinates. *)
procedure SetTexCoordList (aCoords: TTexCoordList);
(* Calculate the bounding sphere radius of the model. *)
function BoundingSphereRadius: Single; override;
(* Number of vertices in the mesh. *)
property NumVertices: Integer read GetNumVertices write SetNumVertices;
(* Provides access to the vertices. *)
property Vertices[const aNdx: Integer]: TVector3D
read GetVertex write SetVertex;
(* Number of normals. *)
property NumNormals: Integer read GetNumNormals write SetNumNormals;
(* Provides access to the normals. *)
property Normals[const aNdx: Integer]: TVector3D
read GetNormal write SetNormal;
(* Number of polygons. *)
property NumPolygons: Integer read GetNumPolygons write SetNumPolygons;
(* Provides access to the polygons. *)
property Polygons[const aNdx: Integer]: TPolygon
read GetPolygon write SetPolygon;
(* Number of texture coordinates. *)
property NumTexCoords: Integer read GetNumTexCoords write SetNumTexCoords;
(* Provides access to the texture coordinates. *)
property TexCoords[const aNdx: integer]: TTexCoord
read GetTexCoord write SetTexCoord;
(* Materials. *)
property Materials: TMaterialList read fMaterials;
end;
(* A polyhedron. *)
TPolyhedron = CLASS (TMesh3D)
PUBLIC
(* Renders the polyedron. *)
PROCEDURE Render (CONST aObject: TObject3D); OVERRIDE;
END;
(* A polyhedron that can be textured. *)
TTexturedPolyhedron = class (TMesh3D)
PUBLIC
(* Renders the model. *)
PROCEDURE Render (CONST aObject: TObject3D); OVERRIDE;
END;
(* A billboard object. *)
TBillboard = class (TBaseModel3D)
private
fOwnsTexture: Boolean;
fTextureId: GLuint;
fTexture: ALLEGRO_BITMAPptr;
procedure SetTexture (aBmp: ALLEGRO_BITMAPptr);
public
(* Constructor. *)
constructor Create; override;
(* Destructor. *)
destructor Destroy; override;
(* Renders the model. *)
procedure Render (const aObject: TObject3D); override;
(* Should the object free the @code(Texture) when it's destroyed? *)
property OwnsTexture: Boolean read fOwnsTexture write fOwnsTexture;
(* The bitmap. *)
property Texture: ALLEGRO_BITMAPptr read fTexture write SetTexture;
end;
(* Used by @link(RegisterModelLoader). *)
TModelLoader = function (const aFilename: AnsiString): TBaseModel3D;
(* Register a 3D model loader. *)
procedure RegisterModelLoader (
const aExtension: AnsiString;
aLoader: TModelLoader
);
(* Load 3D model. *)
function LoadModel (const aFilename: AnsiString): TBaseModel3D;
IMPLEMENTATION
USES
sysutils,
al5opengl,
a3dge, a3dge.Classes;
var
ModelLoaderList: array [0..7] of record
Extension: AnsiString;
Loader: TModelLoader
end;
CntModelLoader: Integer = 0;
(* Helper to find a model loader. Returns index or -1. *)
function FindLoader (const aExtension: AnsiString): Integer;
var
lNdx: Integer;
begin
for lNdx := 0 to High (ModelLoaderList) do
if ModelLoaderList[lNdx].Extension = aExtension then
Exit (lNdx);
Result := -1
end;
procedure RegisterModelLoader (
const aExtension: AnsiString;
aLoader: TModelLoader
);
var
lNdx: Integer;
begin
{ If loader esists for the given extension, it will replace it.
Else it will add it.
}
lNdx := FindLoader (LowerCase (aExtension));
if lNdx < 0 then
begin
if CntModelLoader > High (ModelLoaderList) then
raise A3DGEException.Create ('Too much model loaders registered');
lNdx := CntModelLoader;
Inc (CntModelLoader)
end;
if Assigned (a3dge.Application) then
a3dge.Application.Log (
etDebug, 'Registering loader for "%s" files.', [aExtension]
);
ModelLoaderList[lNdx].Extension := LowerCase (aExtension);
ModelLoaderList[lNdx].Loader := aLoader
end;
function LoadModel (const aFilename: AnsiString): TBaseModel3D;
var
lExtension: AnsiString;
lNdx: Integer;
begin
lExtension := LowerCase (ExtractFileExt (aFilename));
lNdx := FindLoader (lExtension);
if lNdx < 0 then
begin
a3dge.Application.Log (
etError,
'Can''t find loader for "%s" ("%s" files).',
[aFilename, lExtension]
);
Exit (Nil)
end;
try
Result := ModelLoaderList[lNdx].Loader (aFilename)
except
on Error: A3DGEException do
Result := Nil;
on Error: Exception do
begin
a3dge.Application.Log (etError, Error.Message);
Result := Nil
end
end
end;
(*
* TMesh3D
************************************************************************)
function TMesh3D.GetNumVertices: Integer;
begin
Result := Length (fVertices)
end;
procedure TMesh3D.SetNumVertices (const aNum: Integer);
begin
SetLength (fVertices, 0);
if aNum > 0 then SetLength (fVertices, aNum)
end;
function TMesh3D.GetVertex (const aNdx: Integer): TVector3D;
begin
Result := fVertices[aNdx]
end;
procedure TMesh3D.SetVertex (const aNdx: Integer; aValue: TVector3D);
begin
fVertices[aNdx] := aValue
end;
function TMesh3D.GetNumNormals: Integer;
begin
Result := Length (fNormals)
end;
procedure TMesh3D.SetNumNormals (const aNum: Integer);
begin
SetLength (fNormals, 0);
if aNum > 0 then SetLength (fNormals, aNum)
end;
function TMesh3D.GetNormal (const aNdx: Integer): TVector3D;
begin
Result := fNormals[aNdx]
end;
procedure TMesh3D.SetNormal (const aNdx: Integer; aValue: TVector3D);
begin
fNormals[aNdx] := aValue
end;
function TMesh3D.GetNumPolygons: Integer;
begin
Result := Length (fPolygons)
end;
procedure TMesh3D.SetNumPolygons (const aNum: Integer);
begin
SetLength (fPolygons, 0);
if aNum > 0 then SetLength (fPolygons, aNum)
end;
function TMesh3D.GetPolygon (const aNdx: Integer): TPolygon;
begin
Result := fPolygons[aNdx]
end;
procedure TMesh3D.SetPolygon (const aNdx: Integer; aValue: TPolygon);
begin
fPolygons[aNdx] := aValue
end;
function TMesh3D.GetNumTexCoords: Integer;
begin
Result := Length (fTextureCoordinates)
end;
procedure TMesh3D.SetNumTexCoords (const aNum: Integer);
begin
SetLength (fTextureCoordinates, 0);
if aNum > 0 then SetLength (fTextureCoordinates, aNum)
end;
function TMesh3D.GetTexCoord (const aNdx: Integer): TTexCoord;
begin
Result := fTextureCoordinates[aNdx]
end;
procedure TMesh3D.SetTexCoord (const aNdx: Integer; aValue: TTexCoord);
begin
fTextureCoordinates[aNdx] := aValue
end;
function TMesh3D.GetVertexList: TVector3DList;
begin
Result := fVertices
end;
function TMesh3D.GetNormalList: TVector3DList;
begin
Result := fNormals
end;
function TMesh3D.GetPolygonList: TPolygonList;
begin
Result := fPolygons
end;
function TMesh3D.GetTexCoordList: TTexCoordList;
begin
Result := fTextureCoordinates
end;
constructor TMesh3D.Create;
begin
inherited Create;
fMaterials := TMaterialList.Create
end;
destructor TMesh3D.Destroy;
begin
fMaterials.Free;
inherited Destroy
end;
procedure TMesh3D.SetVertexList (aVectors: TVector3DList);
begin
SetLength (fVertices, 0);
fVertices := aVectors
end;
procedure TMesh3D.SetNormalList (aVectors: TVector3DList);
begin
SetLength (fNormals, 0);
fNormals := aVectors
end;
procedure TMesh3D.SetPolygonList (aPolygons: TPolygonList);
begin
SetLength (fPolygons, 0);
fPolygons := aPolygons
end;
procedure TMesh3D.SetTexCoordList (aCoords: TTexCoordList);
begin
SetLength (fTextureCoordinates, 0);
fTextureCoordinates := aCoords
end;
function TMesh3D.BoundingSphereRadius: Single;
begin
Result := GetBoundingSphereRadius (SELF.GetVertexList)
end;
(*
* TPolyhedron
************************************************************************)
PROCEDURE TPolyhedron.Render (CONST aObject: TObject3D);
var
lVertices, lNormals: TVector3DList;
procedure RenderPoint (const aFacet: TPolygon); inline;
begin
glBegin (GL_POINT);
try
glVertex3fv (@(lVertices[aFacet.Vertices[0]]))
finally
glEnd
end
end;
procedure RenderLine (const aFacet: TPolygon); inline;
begin
{ dash/dot/dash }
glBegin (GL_LINES);
try
glVertex3fv (@(lVertices[aFacet.Vertices[0]]));
glVertex3fv (@(lVertices[aFacet.Vertices[1]]))
finally
glEnd
end
end;
procedure RenderPoly (const aFacet: TPolygon); inline;
var
lNdx: Integer;
begin
glBegin (GL_POLYGON);
TRY
IF aFacet.UsePlaneNormal THEN
BEGIN
glNormal3fv (@(aFacet.PlaneNormal));
FOR lNdx in aFacet.Vertices DO glVertex3fv (@(lVertices[lNdx]));
END
ELSE
FOR lNdx in aFacet.Vertices DO
BEGIN
glNormal3fv (@(lNormals[lNdx]));
glVertex3fv (@(lVertices[lNdx]));
END;
FINALLY
glEnd;
END;
end;
VAR
CurrentMaterial: INTEGER;
Facet: TPolygon;
BEGIN
CurrentMaterial := -1;
lVertices := Self.GetVertexList;
lNormals := Self.GetNormalList;
glDisable (GL_TEXTURE_2D);
FOR Facet in Self.GetPolygonList DO
BEGIN
IF CurrentMaterial <> Facet.Material THEN
BEGIN
CurrentMaterial := Facet.Material;
Self.Materials[CurrentMaterial].Apply;
END;
case Length (Facet.Vertices) of
0:
continue;
1:
RenderPoint (Facet);
2:
RenderLine (Facet);
{$IfDef FPC} otherwise {$Else} else {$EndIf}
renderPoly (Facet);
end
END;
glEnable (GL_TEXTURE_2D);
END;
(*
* TTexturedPolyhedron
************************************************************************)
PROCEDURE TTexturedPolyhedron.Render (CONST aObject: TObject3D);
var
lVertices, lNormals: TVector3DList;
lTextCoords: TTexCoordList;
procedure RenderPoint (const aFacet: TPolygon); inline;
begin
glBegin (GL_POINT);
try
glVertex3fv (@(lVertices[aFacet.Vertices[0]]))
finally
glEnd
end
end;
procedure RenderLine (const aFacet: TPolygon); inline;
begin
{ dash/dot/dash }
glBegin (GL_LINES);
try
glVertex3fv (@(lVertices[aFacet.Vertices[0]]));
glVertex3fv (@(lVertices[aFacet.Vertices[1]]))
finally
glEnd
end
end;
procedure RenderPoly (const aFacet: TPolygon); inline;
var
lNdx: Integer;
begin
glBegin (GL_POLYGON);
TRY
IF aFacet.UsePlaneNormal THEN
BEGIN
glNormal3fv (@(aFacet.PlaneNormal));
FOR lNdx := Low (aFacet.Vertices) to High (aFacet.Vertices) do
begin
if Length (aFacet.TexCoords) > 0 then
glTexCoord2f (
lTextCoords[aFacet.TexCoords[lNdx]].u,
lTextCoords[aFacet.TexCoords[lNdx]].v
);
glVertex3fv (@(lVertices[aFacet.Vertices[lNdx]]));
end
END
ELSE
FOR lNdx := Low (aFacet.Vertices) to High (aFacet.Vertices) do
BEGIN
if Length (aFacet.TexCoords) > 0 then
glTexCoord2f (
lTextCoords[aFacet.TexCoords[lNdx]].u,
lTextCoords[aFacet.TexCoords[lNdx]].v
);
glNormal3fv (@(lNormals[aFacet.VertexNormals[lNdx]]));
glVertex3fv (@(lVertices[aFacet.Vertices[lNdx]]));
END;
FINALLY
glEnd;
END;
end;
VAR
CurrentMaterial: INTEGER;
Facet: TPolygon;
BEGIN
CurrentMaterial := -1;
lVertices := Self.GetVertexList;
lNormals := Self.GetNormalList;
lTextCoords := Self.GetTexCoordList;
glDisable (GL_TEXTURE_2D);
FOR Facet in Self.GetPolygonList DO
BEGIN
IF CurrentMaterial <> Facet.Material THEN
BEGIN
CurrentMaterial := Facet.Material;
Self.Materials[CurrentMaterial].Apply;
END;
case Length (Facet.Vertices) of
0:
continue;
1:
RenderPoint (Facet);
2:
RenderLine (Facet);
{$IfDef FPC} otherwise {$Else} else {$EndIf}
renderPoly (Facet);
end
END;
glEnable (GL_TEXTURE_2D);
END;
(*
* TBillboard
************************************************************************)
procedure TBillboard.SetTexture (aBmp: ALLEGRO_BITMAPptr);
begin
if fOwnsTexture and Assigned (fTexture) then
al_destroy_bitmap (fTexture);
fTexture := aBmp;
if Assigned (fTexture) then
fTextureId := al_get_opengl_texture (fTexture)
end;
constructor TBillboard.Create;
begin
inherited Create;
fOwnsTexture := True
end;
destructor TBillboard.Destroy;
begin
if fOwnsTexture and Assigned (fTexture) then
al_destroy_bitmap (fTexture);
inherited Destroy
end;
procedure TBillboard.Render (const aObject: TObject3D);
var
lLightingEnabled, lBlendEnabled: Boolean;
begin
lLightingEnabled := glIsEnabled (GL_LIGHTING) = GL_TRUE;
lBlendEnabled := glIsEnabled (GL_BLEND) = GL_TRUE;
{ Set OpenGL context. }
if lLightingEnabled then glDisable (GL_LIGHTING);
glDepthMask(GL_FALSE);
glBlendFunc (GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); glEnable (GL_BLEND);
{ Render. }
glBindTexture (GL_TEXTURE_2D, fTextureId);
glColor4fv (@clrWhite);
glBegin (GL_QUADS);
glTexCoord2f (1, 0); glVertex3i ( 1, -1, 0);
glTexCoord2f (1, 1); glVertex3i ( 1, 1, 0);
glTexCoord2f (0, 1); glVertex3i (-1, 1, 0);
glTexCoord2f (0, 0); glVertex3i (-1, -1, 0);
glEnd;
{ Restore OpenGL context. }
if not lBlendEnabled then glDisable (GL_BLEND);
if lLightingEnabled then glEnable (GL_LIGHTING);
glDepthMask(GL_TRUE)
end;
END.
