nichkara/lace
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

opengl.model.polygon.lit_textured: Use model texturing mixin.

Browse Source
This commit is contained in:
Rod Kay
2025-09-07 06:27:46 +10:00
parent eb12d98f65
commit b766155987
6 changed files with 243 additions and 216 deletions
Download Patch File Download Diff File Expand all files Collapse all files

4
3-mid/opengl/source/demo/opengl-demo.adb
View File

@@ -213,7 +213,7 @@ is
the_textured_hexagon_Model : constant Model.hexagon.lit_textured.view the_textured_hexagon_Model : constant Model.hexagon.lit_textured.view
:= Model.hexagon.lit_textured.new_Hexagon (Radius => 0.5, := Model.hexagon.lit_textured.new_Hexagon (Radius => 0.5,
Face => (Fades => [1 => 0.0, others => <>], Face => (Fades => [1 => 0.0, others => <>],
Textures => (1 => the_Texture, others => <>), Textures => [1 => the_Texture, others => <>],
texture_Count => 1, texture_Count => 1,
texture_Applies => <>, texture_Applies => <>,
Animation => null)); Animation => null));
@@ -263,7 +263,7 @@ is
-- Textures => (1 => the_Texture, others => <>), -- Textures => (1 => the_Texture, others => <>),
-- texture_Tiling => <>, -- texture_Tiling => <>,
-- texture_Count => 1)); -- texture_Count => 1));
Face => (Texture_Details => (openGL.texture_Set.to_Details ([1 => the_Texture])))); texture_Details => (openGL.texture_Set.to_Details ([1 => the_Texture])));
the_text_Model : constant Model.Text.lit_colored.view the_text_Model : constant Model.Text.lit_colored.view
:= Model.Text.lit_colored.new_Text (Text => "Once upon a midnight dreary ...", := Model.Text.lit_colored.new_Text (Text => "Once upon a midnight dreary ...",

186
3-mid/opengl/source/lean/model/opengl-model-polygon-lit_textured.adb
View File

@@ -10,15 +10,29 @@ is
--- Forge --- Forge
-- --
function new_polygon (vertex_Sites : in Vector_2_array; -- function new_polygon (vertex_Sites : in Vector_2_array;
Face : in Face_t) return View -- Face : in Face_t) return View
-- is
-- Self : constant View := new Item;
-- begin
-- Self.vertex_Sites (1 .. vertex_Sites'Length) := vertex_Sites;
-- Self.vertex_Count := vertex_Sites'Length;
--
-- Self.Face := Face;
--
-- return Self;
-- end new_polygon;
function new_polygon (vertex_Sites : in Vector_2_array;
texture_Details : in texture_Set.Details) return View
is is
Self : constant View := new Item; Self : constant View := new Item;
begin begin
Self.vertex_Sites (1 .. vertex_Sites'Length) := vertex_Sites; Self.vertex_Sites (1 .. vertex_Sites'Length) := vertex_Sites;
Self.vertex_Count := vertex_Sites'Length; Self.vertex_Count := vertex_Sites'Length;
Self.Face := Face; Self.texture_Details_is (texture_Details);
return Self; return Self;
end new_polygon; end new_polygon;
@@ -30,11 +44,11 @@ is
--- Attributes --- --- Attributes ---
------------------ ------------------
function Face (Self : in Item) return Face_t -- function texture_Details (Self : in Item) return texture_Set.Details
is -- is
begin -- begin
return Self.Face; -- return Self.texture_Details;
end Face; -- end texture_Details;
@@ -42,77 +56,77 @@ is
-- Texturing -- Texturing
-- --
overriding -- overriding
procedure Fade_is (Self : in out Item; Which : in texture_Set.texture_Id; -- procedure Fade_is (Self : in out Item; Which : in texture_Set.texture_Id;
Now : in texture_Set.fade_Level) -- Now : in texture_Set.fade_Level)
is -- is
begin -- begin
Self.Face.texture_Details.Fades (which) := Now; -- Self.Face.texture_Details.Fades (which) := Now;
end Fade_is; -- end Fade_is;
--
--
--
overriding -- overriding
function Fade (Self : in Item; Which : in texture_Set.texture_Id) return texture_Set.fade_Level -- function Fade (Self : in Item; Which : in texture_Set.texture_Id) return texture_Set.fade_Level
is -- is
begin -- begin
return Self.Face.texture_Details.Fades (which); -- return Self.Face.texture_Details.Fades (which);
end Fade; -- end Fade;
--
--
--
procedure Texture_is (Self : in out Item; Which : in texture_Set.texture_Id; -- procedure Texture_is (Self : in out Item; Which : in texture_Set.texture_Id;
Now : in openGL.asset_Name) -- Now : in openGL.asset_Name)
is -- is
begin -- begin
Self.Face.texture_Details.Textures (Positive (which)) := Now; -- Self.Face.texture_Details.Textures (Positive (which)) := Now;
end Texture_is; -- end Texture_is;
--
--
--
--
overriding -- overriding
function texture_Count (Self : in Item) return Natural -- function texture_Count (Self : in Item) return Natural
is -- is
begin -- begin
return Self.Face.texture_Details.texture_Count; -- return Self.Face.texture_Details.texture_Count;
end texture_Count; -- end texture_Count;
--
--
--
overriding -- overriding
function texture_Applied (Self : in Item; Which : in texture_Set.texture_Id) return Boolean -- function texture_Applied (Self : in Item; Which : in texture_Set.texture_Id) return Boolean
is -- is
begin -- begin
return Self.Face.texture_Details.texture_Applies (Which); -- return Self.Face.texture_Details.texture_Applies (Which);
end texture_Applied; -- end texture_Applied;
--
--
--
overriding -- overriding
procedure texture_Applied_is (Self : in out Item; Which : in texture_Set.texture_Id; -- procedure texture_Applied_is (Self : in out Item; Which : in texture_Set.texture_Id;
Now : in Boolean) -- Now : in Boolean)
is -- is
begin -- begin
Self.Face.texture_Details.texture_Applies (Which) := Now; -- Self.Face.texture_Details.texture_Applies (Which) := Now;
end texture_Applied_is; -- end texture_Applied_is;
--
--
--
--
overriding -- overriding
procedure animate (Self : in out Item) -- procedure animate (Self : in out Item)
is -- is
use type texture_Set.Animation_view; -- use type texture_Set.Animation_view;
begin -- begin
if Self.Face.texture_Details.Animation = null -- if Self.Face.texture_Details.Animation = null
then -- then
return; -- return;
end if; -- end if;
--
texture_Set.animate (Self.Face.texture_Details.Animation.all, -- texture_Set.animate (Self.Face.texture_Details.Animation.all,
Self.Face.texture_Details.texture_Applies); -- Self.Face.texture_Details.texture_Applies);
end animate; -- end animate;
@@ -164,15 +178,15 @@ is
the_Geometry.Vertices_are (Vertices); the_Geometry.Vertices_are (Vertices);
the_Geometry.add (Primitive.view (the_Primitive)); the_Geometry.add (Primitive.view (the_Primitive));
for i in 1 .. Self.Face.texture_Details.texture_Count for i in 1 .. Self.texture_Details.texture_Count
loop loop
Id := texture_Id (i); Id := texture_Id (i);
the_Geometry.Fade_is (which => Id, the_Geometry.Fade_is (which => Id,
now => Self.Face.texture_Details.Fades (Id)); now => Self.texture_Details.Fades (Id));
the_Geometry.Texture_is (which => Id, the_Geometry.Texture_is (which => Id,
now => Textures.fetch (Self.Face.texture_Details.Textures (i))); now => Textures.fetch (Self.texture_Details.Textures (i)));
the_Geometry.is_Transparent (now => the_Geometry.Texture.is_Transparent); the_Geometry.is_Transparent (now => the_Geometry.Texture.is_Transparent);
end loop; end loop;
@@ -198,15 +212,15 @@ is
loop loop
the_Vertices (Index_t (i)) := (Site => Vector_3 (the_Sites (i) & 0.0), the_Vertices (Index_t (i)) := (Site => Vector_3 (the_Sites (i) & 0.0),
Normal => Normal, Normal => Normal,
Coords => (Coords_and_Centroid.Coords (Index_t (i)).S * Self.Face.texture_Details.texture_Tiling.S, Coords => (Coords_and_Centroid.Coords (Index_t (i)).S * Self.texture_Details.texture_Tiling.S,
Coords_and_Centroid.Coords (Index_t (i)).T * Self.Face.texture_Details.texture_Tiling.T), Coords_and_Centroid.Coords (Index_t (i)).T * Self.texture_Details.texture_Tiling.T),
Shine => default_Shine); Shine => default_Shine);
end loop; end loop;
the_Vertices (the_Vertices'Last) := (Site => Vector_3 (Coords_and_Centroid.Centroid & 0.0), the_Vertices (the_Vertices'Last) := (Site => Vector_3 (Coords_and_Centroid.Centroid & 0.0),
Normal => Normal, Normal => Normal,
Coords => (S => 0.5 * Self.Face.texture_Details.texture_Tiling.S, Coords => (S => 0.5 * Self.texture_Details.texture_Tiling.S,
T => 0.5 * Self.Face.texture_Details.texture_Tiling.T), T => 0.5 * Self.texture_Details.texture_Tiling.T),
Shine => default_Shine); Shine => default_Shine);
face_Geometry := new_Geometry (Vertices => the_Vertices); face_Geometry := new_Geometry (Vertices => the_Vertices);

76
3-mid/opengl/source/lean/model/opengl-model-polygon-lit_textured.ads
View File

@@ -1,6 +1,7 @@
with with
openGL.texture_Set, openGL.texture_Set,
openGL.Texture; openGL.Texture,
openGL.Model.texturing;
package openGL.Model.polygon.lit_textured package openGL.Model.polygon.lit_textured
@@ -8,7 +9,9 @@ package openGL.Model.polygon.lit_textured
-- Models a lit and textured polygon. -- Models a lit and textured polygon.
-- --
is is
type Item is new Model.item with private; package textured_Model is new texturing.Mixin;
type Item is new textured_Model.item with private;
type View is access all Item'Class; type View is access all Item'Class;
@@ -17,25 +20,30 @@ is
--- Face --- Face
-- --
type Face_t is -- type Face_t is
record -- record
texture_Details : texture_Set.Details; -- texture_Details : texture_Set.Details;
end record; -- end record;
--------- ---------
--- Forge --- Forge
-- --
function new_Polygon (vertex_Sites : in Vector_2_array; -- function new_Polygon (vertex_Sites : in Vector_2_array;
Face : in lit_textured.Face_t) return View; -- Face : in lit_textured.Face_t) return View;
function new_Polygon (vertex_Sites : in Vector_2_array;
texture_Details : in texture_Set.Details) return View;
-------------- --------------
--- Attributes --- Attributes
-- --
function Face (Self : in Item) return Face_t; -- function Face (Self : in Item) return Face_t;
-- overriding
-- function texture_Details (Self : in Item) return texture_Set.Details;
overriding overriding
function to_GL_Geometries (Self : access Item; Textures : access Texture.name_Map_of_texture'Class; function to_GL_Geometries (Self : access Item; Textures : access Texture.name_Map_of_texture'Class;
@@ -45,40 +53,40 @@ is
-- Texturing -- Texturing
-- --
overriding -- overriding
function Fade (Self : in Item; Which : in texture_Set.texture_Id) return texture_Set.fade_Level; -- function Fade (Self : in Item; Which : in texture_Set.texture_Id) return texture_Set.fade_Level;
--
overriding -- overriding
procedure Fade_is (Self : in out Item; Which : in texture_Set.texture_Id; -- procedure Fade_is (Self : in out Item; Which : in texture_Set.texture_Id;
Now : in texture_Set.fade_Level); -- Now : in texture_Set.fade_Level);
--
procedure Texture_is (Self : in out Item; Which : in texture_Set.texture_Id; -- procedure Texture_is (Self : in out Item; Which : in texture_Set.texture_Id;
Now : in asset_Name); -- Now : in asset_Name);
--
overriding -- overriding
function texture_Count (Self : in Item) return Natural; -- function texture_Count (Self : in Item) return Natural;
--
--
overriding -- overriding
function texture_Applied (Self : in Item; Which : in texture_Set.texture_Id) return Boolean; -- function texture_Applied (Self : in Item; Which : in texture_Set.texture_Id) return Boolean;
--
overriding -- overriding
procedure texture_Applied_is (Self : in out Item; Which : in texture_Set.texture_Id; -- procedure texture_Applied_is (Self : in out Item; Which : in texture_Set.texture_Id;
Now : in Boolean); -- Now : in Boolean);
--
overriding -- overriding
procedure animate (Self : in out Item); -- procedure animate (Self : in out Item);
private private
type Item is new Model.polygon.item with type Item is new textured_Model.item with
record record
vertex_Sites : Vector_2_array (1 .. 8); vertex_Sites : Vector_2_array (1 .. 8);
vertex_Count : Positive; vertex_Count : Positive;
Face : lit_textured.Face_t; -- Face : lit_textured.Face_t;
end record; end record;

130
3-mid/opengl/source/lean/model/opengl-model-texturing.adb
View File

@@ -29,23 +29,23 @@ is
GL_TEXTURE12, GL_TEXTURE12,
GL_TEXTURE13, GL_TEXTURE13,
GL_TEXTURE14, GL_TEXTURE14,
GL_TEXTURE15, GL_TEXTURE15];
GL_TEXTURE16, -- GL_TEXTURE16,
GL_TEXTURE17, -- GL_TEXTURE17,
GL_TEXTURE18, -- GL_TEXTURE18,
GL_TEXTURE19, -- GL_TEXTURE19,
GL_TEXTURE20, -- GL_TEXTURE20,
GL_TEXTURE21, -- GL_TEXTURE21,
GL_TEXTURE22, -- GL_TEXTURE22,
GL_TEXTURE23, -- GL_TEXTURE23,
GL_TEXTURE24, -- GL_TEXTURE24,
GL_TEXTURE25, -- GL_TEXTURE25,
GL_TEXTURE26, -- GL_TEXTURE26,
GL_TEXTURE27, -- GL_TEXTURE27,
GL_TEXTURE28, -- GL_TEXTURE28,
GL_TEXTURE29, -- GL_TEXTURE29,
GL_TEXTURE30, -- GL_TEXTURE30,
GL_TEXTURE31]; -- GL_TEXTURE31];
@@ -106,90 +106,94 @@ is
--- Mixin --- --- Mixin ---
------------- -------------
-- generic
package body Mixin package body Mixin
is is
use openGL.texture_Set;
texture_Uniforms : texturing.Uniforms;
procedure create_Uniforms (for_Program : in openGL.Program.view)
is
begin
create (texture_Uniforms, for_Program);
end create_Uniforms;
overriding overriding
procedure Fade_is (Self : in out Item; Now : in texture_Set.fade_Level; procedure Fade_is (Self : in out Item; Which : in texture_Set.texture_Id;
Which : in texture_Set.texture_ID := 1) Now : in texture_Set.fade_Level)
is is
begin begin
Self.texture_Set.Textures (Which).Fade := Now; Self.texture_Details.Fades (which) := Now;
end Fade_is; end Fade_is;
overriding overriding
function Fade (Self : in Item; Which : in texture_Set.texture_ID := 1) return texture_Set.fade_Level function Fade (Self : in Item; Which : in texture_Set.texture_Id) return texture_Set.fade_Level
is is
begin begin
return Self.texture_Set.Textures (Which).Fade; return Self.texture_Details.Fades (which);
end Fade; end Fade;
overriding procedure Texture_is (Self : in out Item; Which : in texture_Set.texture_Id;
procedure Texture_is (Self : in out Item; Now : in openGL.Texture.Object; Now : in openGL.asset_Name)
Which : in texture_Set.texture_ID := 1)
is is
begin begin
Texture_is (in_Set => Self.texture_Set, Self.texture_Details.Textures (Positive (which)) := Now;
Which => Which,
Now => Now);
end Texture_is; end Texture_is;
overriding overriding
function Texture (Self : in Item; Which : texture_Set.texture_ID := 1) return openGL.Texture.Object function texture_Count (Self : in Item) return Natural
is is
begin begin
return openGL.texture_Set.Texture (in_Set => Self.texture_Set, return Self.texture_Details.texture_Count;
Which => Which); end texture_Count;
end Texture;
overriding overriding
procedure texture_Applied_is (Self : in out Item; Now : in Boolean; function texture_Applied (Self : in Item; Which : in texture_Set.texture_Id) return Boolean
Which : in texture_Set.texture_ID := 1)
is is
begin begin
Self.texture_Set.Textures (Which).Applied := Now; return Self.texture_Details.texture_Applies (Which);
end texture_Applied_is;
overriding
function texture_Applied (Self : in Item; Which : in texture_Set.texture_ID := 1) return Boolean
is
begin
return Self.texture_Set.Textures (Which).Applied;
end texture_Applied; end texture_Applied;
overriding overriding
procedure enable_Textures (Self : in out Item) procedure texture_Applied_is (Self : in out Item; Which : in texture_Set.texture_Id;
Now : in Boolean)
is is
begin begin
texturing.enable (for_Model => Self.Model.all'Access, Self.texture_Details.texture_Applies (Which) := Now;
Uniforms => texture_Uniforms, end texture_Applied_is;
texture_Set => Self.texture_Set);
end enable_Textures;
overriding
procedure animate (Self : in out Item)
is
use type texture_Set.Animation_view;
begin
if Self.texture_Details.Animation = null
then
return;
end if;
texture_Set.animate (Self.texture_Details.Animation.all,
Self.texture_Details.texture_Applies);
end animate;
function texture_Details (Self : in Item) return openGL.texture_Set.Details
is
begin
return Self.texture_Details;
end texture_Details;
procedure texture_Details_is (Self : in out Item; Now : in openGL.texture_Set.Details)
is
begin
Self.texture_Details := Now;
end texture_Details_is;
end Mixin; end Mixin;

49
3-mid/opengl/source/lean/model/opengl-model-texturing.ads
View File

@@ -4,7 +4,7 @@ with
openGL.Program; openGL.Program;
private -- private
package openGL.Model.texturing package openGL.Model.texturing
-- --
-- Provides texturing support for models. -- Provides texturing support for models.
@@ -54,44 +54,45 @@ is
generic generic
package Mixin package Mixin
is is
type Item is new Geometry.item with private; type Item is abstract new Model.item with private;
procedure create_Uniforms (for_Program : in openGL.Program.view);
overriding
procedure Fade_is (Self : in out Item; Now : in texture_Set.fade_Level;
Which : in texture_Set.texture_ID := 1);
overriding
function Fade (Self : in Item; Which : in texture_Set.texture_ID := 1) return texture_Set.fade_Level;
overriding overriding
procedure Texture_is (Self : in out Item; Now : in openGL.Texture.Object; function Fade (Self : in Item; Which : in texture_Set.texture_Id) return texture_Set.fade_Level;
Which : in texture_Set.texture_ID := 1);
overriding overriding
function Texture (Self : in Item; Which : in texture_Set.texture_ID := 1) return openGL.Texture.Object; procedure Fade_is (Self : in out Item; Which : in texture_Set.texture_Id;
Now : in texture_Set.fade_Level);
procedure Texture_is (Self : in out Item; Which : in texture_Set.texture_Id;
Now : in asset_Name);
overriding
function texture_Count (Self : in Item) return Natural;
overriding overriding
procedure texture_Applied_is (Self : in out Item; Now : in Boolean; function texture_Applied (Self : in Item; Which : in texture_Set.texture_Id) return Boolean;
Which : in texture_Set.texture_ID := 1);
overriding
function texture_Applied (Self : in Item; Which : in texture_Set.texture_ID := 1) return Boolean;
overriding overriding
procedure enable_Textures (Self : in out Item); procedure texture_Applied_is (Self : in out Item; Which : in texture_Set.texture_Id;
Now : in Boolean);
overriding
procedure animate (Self : in out Item);
function texture_Details (Self : in Item) return openGL.texture_Set.Details;
procedure texture_Details_is (Self : in out Item; Now : in openGL.texture_Set.Details);
private private
type Item is new Geometry.item with type Item is abstract new Model.item with
record record
texture_Set : openGL.texture_Set.item; texture_Details : openGL.texture_Set.Details;
end record; end record;
end Mixin; end Mixin;

14
4-high/gel/source/forge/gel-forge.adb
View File

@@ -217,13 +217,13 @@ is
the_graphics_Model := openGL.Model.polygon.lit_colored.new_Polygon (openGL.Vector_2_array (Vertices), the_graphics_Model := openGL.Model.polygon.lit_colored.new_Polygon (openGL.Vector_2_array (Vertices),
(Color, openGL.Opaque)).all'Access; (Color, openGL.Opaque)).all'Access;
else else
the_graphics_Model := openGL.Model.polygon.lit_textured.new_Polygon (vertex_Sites => openGL.Vector_2_array (Vertices), the_graphics_Model := openGL.Model.polygon.lit_textured.new_Polygon (vertex_Sites => openGL.Vector_2_array (Vertices),
Face => (texture_Details => ((Fades => [1 => 0.0, others => <>], texture_Details => (Fades => [1 => 0.0, others => <>],
Textures => [1 => Texture, others => <>], Textures => [1 => Texture, others => <>],
texture_Count => 1, texture_Count => 1,
texture_Tiling => texture_Tiling, texture_Tiling => texture_Tiling,
texture_Applies => [others => True], texture_Applies => [others => True],
Animation => null)))).all'Access; Animation => null)).all'Access;
end if; end if;
return gel.Sprite.Forge.new_Sprite (Name, return gel.Sprite.Forge.new_Sprite (Name,