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;
(* Describe a polyhedron. *)
TPolyhedron = class (TModel3D)
private
fVertices, fNormals: TVector3DList;
fPolygons: TPolygonList;
fMaterials: TMaterialList;
function GetNumVertices: Integer; inline;
function GetVertex (const aNdx: Integer): TVector3D; inline;
procedure SetVertex (const aNdx: Integer; aValue: TVector3D); inline;
function GetNumNormals: Integer; inline;
function GetNormal (const aNdx: Integer): TVector3D; inline;
procedure SetNormal (const aNdx: Integer; aValue: TVector3D); inline;
function GetNumPolygons: Integer; inline;
function GetPolygon (const aNdx: Integer): TPolygon; inline;
procedure SetPolygon (const aNdx: Integer; aValue: TPolygon); inline;
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;
public
(* Constructor. *)
constructor Create; override;
(* Destructor. *)
destructor Destroy; override;
(* Set number of vertices of the polyhedron. *)
procedure SetNumVertices (const aNum: Integer);
(* Assign a list of vertices. *)
procedure SetVertexList (aVectors: TVector3DList);
(* Set number of normals used by the polyhedron. *)
procedure SetNumNormals (const aNum: Integer);
(* Assign a list of normals. *)
procedure SetNormalList (aVectors: TVector3DList);
(* Set number of polygons of the polyhedron. *)
procedure SetNumPolygons (const aNum: Integer);
(* Assign a list of polygons. *)
procedure SetPolygonList (aPolygons: TPolygonList);
(* Calculate the bounding sphere radius of the model. *)
function BoundingSphereRadius: Single; override;
(* Renders the polyedron. *)
PROCEDURE Render (CONST aObject: TObject3D); OVERRIDE;
(* Number of vertices in the mesh. *)
property NumVertices: Integer read GetNumVertices;
(* Provides access to the vertices. *)
property Vertices[const aNdx: Integer]: TVector3D
read GetVertex write SetVertex;
(* Number of normals. *)
property NumNormals: Integer read GetNumNormals;
(* Provides access to the normals. *)
property Normals[const aNdx: Integer]: TVector3D
read GetNormal write SetNormal;
(* Number of polygons. *)
property NumPolygons: Integer read GetNumPolygons;
(* Provides access to the polygons. *)
property Polygons[const aNdx: Integer]: TPolygon
read GetPolygon write SetPolygon;
(* Materials used by the model. *)
property Materials: TMaterialList read fMaterials;
end;
(* A textured polyhedron. *)
TTexturedPolyhedron = class (TPolyhedron)
private
fTextureCoordinates: TTexCoordList;
function GetNumTexCoords: Integer; inline;
function GetTexCoord (const aNdx: Integer): TTexCoord; inline;
procedure SetTexCoord (const aNdx: Integer; aValue: TTexCoord); inline;
protected
(* Get a copy of the texture coordinates. *)
function GetTexCoordList: TTexCoordList;
PUBLIC
(* Set number of texture coordinates used by the polyhedron. *)
procedure SetNumTexCoords (const aNum: Integer);
(* Assign a list of texture coordinates. *)
procedure SetTexCoordList (aCoords: TTexCoordList);
(* Renders the model. *)
PROCEDURE Render (CONST aObject: TObject3D); OVERRIDE;
(* Number of texture coordinates. *)
property NumTexCoords: Integer read GetNumTexCoords;
(* Provides access to the texture coordinates. *)
property TexCoords[const aNdx: integer]: TTexCoord
read GetTexCoord write SetTexCoord;
END;
(* A billboard object. *)
TBillboard = class (TModel3D)
private
fOwnsTexture: Boolean;
fTextureId: GLuint;
fNumFrames: Integer;
fTexture: ALLEGRO_BITMAPptr;
fWidth, fHeight, fFrameWidth: GLfloat;
function GetWidth: GLfloat; inline;
procedure SetWidth (const aValue: GLfloat); inline;
function GetHeight: GLfloat; inline;
procedure SetHeight (const aValue: GLfloat); inline;
procedure SetTexture (aBmp: ALLEGRO_BITMAPptr);
procedure SetNumFrames (aValue: Integer);
public
(* Constructor. *)
constructor Create; override;
(* Destructor. *)
destructor Destroy; override;
(* Calculate the bounding sphere radius of the model. *)
function BoundingSphereRadius: Single; override;
(* Renders the model. *)
procedure Render (const aObject: TObject3D); override;
(* Billboard width. *)
property Width: GLfloat read GetWidth write SetWidth;
(* Billboard height. *)
property Height: GLfloat read GetHeight write SetHeight;
(* 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;
(* Set the number of frames. *)
property NumFrames: Integer read fNumFrames write SetNumFrames;
end;
(* Used by @link(RegisterModelLoader). *)
TModelLoader = function (const aFilename: AnsiString): TModel3D;
(* Register a 3D model loader. *)
procedure RegisterModelLoader (
const aExtension: AnsiString;
aLoader: TModelLoader
);
(* Load 3D model. *)
function LoadModel (const aFilename: AnsiString): TModel3D;
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): TModel3D;
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;
(*
* TPolyhedron
************************************************************************)
function TPolyhedron.GetNumVertices: Integer;
begin
Result := Length (fVertices)
end;
function TPolyhedron.GetVertex (const aNdx: Integer): TVector3D;
begin
Result := fVertices[aNdx]
end;
procedure TPolyhedron.SetVertex (const aNdx: Integer; aValue: TVector3D);
begin
fVertices[aNdx] := aValue
end;
function TPolyhedron.GetNumNormals: Integer;
begin
Result := Length (fNormals)
end;
function TPolyhedron.GetNormal (const aNdx: Integer): TVector3D;
begin
Result := fNormals[aNdx]
end;
procedure TPolyhedron.SetNormal (const aNdx: Integer; aValue: TVector3D);
begin
fNormals[aNdx] := aValue
end;
function TPolyhedron.GetNumPolygons: Integer;
begin
Result := Length (fPolygons)
end;
function TPolyhedron.GetPolygon (const aNdx: Integer): TPolygon;
begin
Result := fPolygons[aNdx]
end;
procedure TPolyhedron.SetPolygon (const aNdx: Integer; aValue: TPolygon);
begin
fPolygons[aNdx] := aValue
end;
function TPolyhedron.GetVertexList: TVector3DList;
begin
Result := fVertices
end;
function TPolyhedron.GetNormalList: TVector3DList;
begin
Result := fNormals
end;
function TPolyhedron.GetPolygonList: TPolygonList;
begin
Result := fPolygons
end;
constructor TPolyhedron.Create;
begin
inherited Create;
fMaterials := TMaterialList.Create
end;
destructor TPolyhedron.Destroy;
begin
fMaterials.Free;
inherited Destroy
end;
procedure TPolyhedron.SetNumVertices (const aNum: Integer);
begin
{ This should help to avoid memory framentation as the whole block is reserved
at once. The problem is it may increase the risk of cache exception as it
may move the block far away.
}
SetLength (fVertices, 0);
if aNum > 0 then SetLength (fVertices, aNum)
end;
procedure TPolyhedron.SetVertexList (aVectors: TVector3DList);
begin
{ Be sure it's copied, not referenced. It also helps to avoid memory
framentation as the whole block is reserved at once.
}
SetLength (fVertices, 0);
fVertices := Copy (aVectors, 0)
end;
procedure TPolyhedron.SetNumNormals (const aNum: Integer);
begin
SetLength (fNormals, 0);
if aNum > 0 then SetLength (fNormals, aNum)
end;
procedure TPolyhedron.SetNormalList (aVectors: TVector3DList);
begin
SetLength (fNormals, 0);
fNormals := Copy (aVectors, 0)
end;
procedure TPolyhedron.SetNumPolygons (const aNum: Integer);
begin
SetLength (fPolygons, 0);
if aNum > 0 then SetLength (fPolygons, aNum)
end;
procedure TPolyhedron.SetPolygonList (aPolygons: TPolygonList);
begin
SetLength (fPolygons, 0);
fPolygons := Copy (aPolygons, 0)
end;
function TPolyhedron.BoundingSphereRadius: Single;
begin
Result := GetBoundingSphereRadius (SELF.GetVertexList)
end;
PROCEDURE TPolyhedron.Render (CONST aObject: TObject3D);
procedure RenderPoint (const aFacet: TPolygon); inline;
begin
glBegin (GL_POINT);
try
glVertex3fv (@(fVertices[aFacet.Vertices[0]]))
finally
glEnd
end
end;
procedure RenderLine (const aFacet: TPolygon); inline;
begin
{ dash/dot/dash }
glBegin (GL_LINES);
try
glVertex3fv (@(fVertices[aFacet.Vertices[0]]));
glVertex3fv (@(fVertices[aFacet.Vertices[1]]))
finally
glEnd
end
end;
procedure RenderPoly (const aFacet: TPolygon); inline;
var
lNdx: Integer;
begin
TRY
IF aFacet.UsePlaneNormal THEN
BEGIN
glNormal3fv (@(aFacet.PlaneNormal));
FOR lNdx in aFacet.Vertices DO glVertex3fv (@(fVertices[lNdx]));
END
ELSE
FOR lNdx in aFacet.Vertices DO
BEGIN
glNormal3fv (@(fNormals[lNdx]));
glVertex3fv (@(fVertices[lNdx]));
END;
FINALLY
glEnd;
END;
end;
VAR
CurrentMaterial: INTEGER;
Facet: TPolygon;
BEGIN
CurrentMaterial := -1;
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);
3:
begin
glBegin (GL_TRIANGLES);
RenderPoly (Facet)
end
{$IfDef FPC} otherwise {$Else} else {$EndIf}
begin
glBegin (GL_POLYGON);
RenderPoly (Facet)
end
end
END;
glEnable (GL_TEXTURE_2D);
END;
(*
* TTexturedPolyhedron
************************************************************************)
function TTexturedPolyhedron.GetNumTexCoords: Integer;
begin
Result := Length (fTextureCoordinates)
end;
function TTexturedPolyhedron.GetTexCoord (const aNdx: Integer): TTexCoord;
begin
Result := fTextureCoordinates[aNdx]
end;
procedure TTexturedPolyhedron.SetTexCoord (const aNdx: Integer; aValue: TTexCoord);
begin
fTextureCoordinates[aNdx] := aValue
end;
function TTexturedPolyhedron.GetTexCoordList: TTexCoordList;
begin
Result := fTextureCoordinates
end;
procedure TTexturedPolyhedron.SetNumTexCoords (const aNum: Integer);
begin
SetLength (fTextureCoordinates, 0);
if aNum > 0 then SetLength (fTextureCoordinates, aNum)
end;
procedure TTexturedPolyhedron.SetTexCoordList (aCoords: TTexCoordList);
begin
SetLength (fTextureCoordinates, 0);
fTextureCoordinates := Copy (aCoords, 0)
end;
PROCEDURE TTexturedPolyhedron.Render (CONST aObject: TObject3D);
procedure RenderPoint (const aFacet: TPolygon); inline;
begin
glBegin (GL_POINT);
try
glVertex3fv (@(fVertices[aFacet.Vertices[0]]))
finally
glEnd
end
end;
procedure RenderLine (const aFacet: TPolygon); inline;
begin
{ dash/dot/dash }
glBegin (GL_LINES);
try
glVertex3fv (@(fVertices[aFacet.Vertices[0]]));
glVertex3fv (@(fVertices[aFacet.Vertices[1]]))
finally
glEnd
end
end;
procedure RenderPoly (const aFacet: TPolygon); inline;
var
lNdx: Integer;
begin
TRY
IF aFacet.UsePlaneNormal THEN
BEGIN
glNormal3fv (@(aFacet.PlaneNormal));
FOR lNdx := Low (aFacet.Vertices) to High (aFacet.Vertices) do
begin
glTexCoord2f (
fTextureCoordinates[aFacet.TexCoords[lNdx]].u,
fTextureCoordinates[aFacet.TexCoords[lNdx]].v
);
glVertex3fv (@(fVertices[aFacet.Vertices[lNdx]]));
end
END
ELSE
FOR lNdx := Low (aFacet.Vertices) to High (aFacet.Vertices) do
BEGIN
glTexCoord2f (
fTextureCoordinates[aFacet.TexCoords[lNdx]].u,
fTextureCoordinates[aFacet.TexCoords[lNdx]].v
);
glNormal3fv (@(fNormals[aFacet.VertexNormals[lNdx]]));
glVertex3fv (@(fVertices[aFacet.Vertices[lNdx]]));
END;
FINALLY
glEnd;
END;
end;
VAR
CurrentMaterial: INTEGER;
Facet: TPolygon;
BEGIN
CurrentMaterial := -1;
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);
3:
begin
glBegin (GL_TRIANGLES);
RenderPoly (Facet)
end
{$IfDef FPC} otherwise {$Else} else {$EndIf}
begin
glBegin (GL_POLYGON);
RenderPoly (Facet)
end
end
END;
glEnable (GL_TEXTURE_2D);
END;
(*
* TBillboard
************************************************************************)
function TBillboard.GetWidth: GLfloat;
begin
Result := fWidth * 2
end;
procedure TBillboard.SetWidth (const aValue: GLfloat);
begin
fWidth := aValue /2
end;
function TBillboard.GetHeight: GLfloat;
begin
Result := fHeight * 2
end;
procedure TBillboard.SetHeight (const aValue: GLfloat);
begin
fHeight := aValue /2
end;
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;
procedure TBillboard.SetNumFrames (aValue: Integer);
begin
if fNumFrames = aValue then Exit;
if aValue < 1 then
begin
a3dge.Application.Log (
etWarning,
'Wrong number of frames for billboard: %d.',
[aValue]
);
aValue := 1
end;
fNumFrames := aValue;
fFrameWidth := 1 / fNumFrames
end;
constructor TBillboard.Create;
begin
inherited Create;
fWidth := 0.5; fHeight := 0.5;
fFrameWidth := 1;
fOwnsTexture := True
end;
destructor TBillboard.Destroy;
begin
if fOwnsTexture and Assigned (fTexture) then
al_destroy_bitmap (fTexture);
inherited Destroy
end;
function TBillboard.BoundingSphereRadius: Single;
begin
Result := fWidth
end;
procedure TBillboard.Render (const aObject: TObject3D);
procedure RenderSingle; inline;
begin
glBegin (GL_QUADS);
glTexCoord2f (1, 0); glVertex3f ( fWidth, -fHeight, 0);
glTexCoord2f (1, 1); glVertex3f ( fWidth, fHeight, 0);
glTexCoord2f (0, 1); glVertex3f (-fWidth, fHeight, 0);
glTexCoord2f (0, 0); glVertex3f (-fWidth, -fHeight, 0);
glEnd
end;
procedure RenderAnimated; inline;
var
lFramePos: GLfloat;
begin
lFramePos := Trunc (aObject.Frame) * fFrameWidth;
glBegin (GL_QUADS);
glTexCoord2f (lFramePos, 1); glVertex3f (-fWidth, fHeight, 0);
glTexCoord2f (lFramePos, 0); glVertex3f (-fWidth, -fHeight, 0);
lFramePos := lFramePos + fFrameWidth;
glTexCoord2f (lFramePos, 0); glVertex3f ( fWidth, -fHeight, 0);
glTexCoord2f (lFramePos, 1); glVertex3f ( fWidth, fHeight, 0);
glEnd
end;
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);
{ Fix rotation. }
glPopMatrix; { Undo object transformations. }
glPushMatrix; { Redo object translation and scalation. }
glTranslatef (
aObject.Position[Vx],
aObject.Position[Vy],
aObject.Position[Vz]
);
if aObject.Scaled then
glScalef (aObject.Scale[Vx], aObject.Scale[Vy], aObject.Scale[Vz]);
{ Don't call "glPopMatrix". Will be done after returning. }
TheWorld.Camera.ApplyInverseRotationMatrix;
{ Render. }
glBindTexture (GL_TEXTURE_2D, fTextureId);
glColor4fv (@clrWhite);
if fFrameWidth = 1 then RenderSingle else RenderAnimated;
{ Restore OpenGL context. }
if not lBlendEnabled then glDisable (GL_BLEND);
if lLightingEnabled then glEnable (GL_LIGHTING);
glDepthMask(GL_TRUE)
end;
END.
