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

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

Browse Source
This commit is contained in:
Rod Kay
2025-09-07 12:28:53 +10:00
parent 65a5e2c6af
commit 5707b1783f
7 changed files with 63 additions and 191 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -194,10 +194,7 @@ is
the_lit_textured_circle_Model : constant Model.circle.lit_textured.view the_lit_textured_circle_Model : constant Model.circle.lit_textured.view
:= Model.circle.lit_textured.new_Circle (Radius => 1.5, := Model.circle.lit_textured.new_Circle (Radius => 1.5,
-- Face => (Texture_Details => (Fades => (1 => 0.0, others => <>), Texture_Details => (openGL.texture_Set.to_Details ([1 => the_Texture])),
-- Textures => (1 => the_Texture, others => <>),
-- texture_Count => 1)),
Face => (Texture_Details => (openGL.texture_Set.to_Details ([1 => the_Texture]))),
Sides => 24); Sides => 24);
the_grid_Model : constant Model.grid.view the_grid_Model : constant Model.grid.view
@@ -259,10 +256,6 @@ is
the_lit_textured_polygon_Model : constant Model.polygon.lit_textured.view the_lit_textured_polygon_Model : constant Model.polygon.lit_textured.view
:= Model.polygon.lit_textured.new_Polygon (vertex_Sites => [Origin_2D, [1.0, 0.0], [1.0, 1.0], [-1.0, 0.5]], := Model.polygon.lit_textured.new_Polygon (vertex_Sites => [Origin_2D, [1.0, 0.0], [1.0, 1.0], [-1.0, 0.5]],
-- Face => (Fades => (1 => 0.0, others => <>),
-- Textures => (1 => the_Texture, others => <>),
-- texture_Tiling => <>,
-- texture_Count => 1));
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

98
3-mid/opengl/source/lean/model/opengl-model-circle-lit_textured.adb
View File

@@ -10,14 +10,14 @@ is
--- Forge --- Forge
-- --
function new_circle (Radius : in Real; function new_circle (Radius : in Real;
Face : in lit_textured.Face_t; texture_Details : in texture_Set.Details;
Sides : in Positive := 24) return View Sides : in Positive := 24) return View
is is
Self : constant View := new Item; Self : constant View := new Item;
begin begin
Self.Radius := Radius; Self.Radius := Radius;
Self.Face := Face; Self.texture_Details_is (texture_Details);
Self.Sides := Sides; Self.Sides := Sides;
return Self; return Self;
@@ -29,90 +29,6 @@ is
--- Attributes --- --- Attributes ---
------------------ ------------------
function Face (Self : in Item) return Face_t
is
begin
return Self.Face;
end Face;
------------
-- Texturing
--
overriding
procedure Fade_is (Self : in out Item; Which : in texture_Set.texture_Id;
Now : in texture_Set.fade_Level)
is
begin
Self.Face.texture_Details.Fades (which) := Now;
end Fade_is;
overriding
function Fade (Self : in Item; Which : in texture_Set.texture_Id) return texture_Set.fade_Level
is
begin
return Self.Face.texture_Details.Fades (which);
end Fade;
procedure Texture_is (Self : in out Item; Which : in texture_Set.texture_Id;
Now : in openGL.asset_Name)
is
begin
Self.Face.texture_Details.Textures (Positive (which)) := Now;
end Texture_is;
overriding
function texture_Count (Self : in Item) return Natural
is
begin
return Self.Face.texture_Details.texture_Count;
end texture_Count;
overriding
function texture_Applied (Self : in Item; Which : in texture_Set.texture_Id) return Boolean
is
begin
return Self.Face.texture_Details.texture_Applies (Which);
end texture_Applied;
overriding
procedure texture_Applied_is (Self : in out Item; Which : in texture_Set.texture_Id;
Now : in Boolean)
is
begin
Self.Face.texture_Details.texture_Applies (Which) := Now;
end texture_Applied_is;
overriding
procedure animate (Self : in out Item)
is
use type texture_Set.Animation_view;
begin
if Self.Face.texture_Details.Animation = null
then
return;
end if;
texture_Set.animate (Self.Face.texture_Details.Animation.all,
Self.Face.texture_Details.texture_Applies);
end animate;
--------------------- ---------------------
--- openGL Geometries --- openGL Geometries
@@ -165,15 +81,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;

58
3-mid/opengl/source/lean/model/opengl-model-circle-lit_textured.ads
View File

@@ -1,78 +1,40 @@
with with
openGL.texture_Set, openGL.texture_Set,
openGL.Texture; openGL.Texture,
openGL.Model.texturing;
package openGL.Model.circle.lit_textured package openGL.Model.circle.lit_textured
-- --
-- Models a lit, colored and textured hexagon. -- Models a lit and textured circle.
-- --
is is
type Item is new Model.item with private; package textured_Model is new texturing.Mixin (Model.circle.item);
type Item is new textured_Model.textured_Item with private;
type View is access all Item'Class; type View is access all Item'Class;
type Face_t is
record
texture_Details : texture_Set.Details;
end record;
--------- ---------
--- Forge --- Forge
-- --
function new_circle (Radius : in Real; function new_circle (Radius : in Real;
Face : in lit_textured.Face_t; texture_Details : in texture_Set.Details;
Sides : in Positive := 24) return View; Sides : in Positive := 24) return View;
-------------- --------------
--- Attributes --- Attributes
-- --
function Face (Self : in Item) return Face_t;
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;
Fonts : in Font.font_id_Map_of_font) return Geometry.views; Fonts : in Font.font_id_Map_of_font) return Geometry.views;
------------
-- Texturing
--
overriding
function Fade (Self : in Item; Which : in texture_Set.texture_Id) return texture_Set.fade_Level;
overriding
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
function texture_Applied (Self : in Item; Which : in texture_Set.texture_Id) return Boolean;
overriding
procedure texture_Applied_is (Self : in out Item; Which : in texture_Set.texture_Id;
Now : in Boolean);
overriding
procedure animate (Self : in out Item);
private private
type Item is new Model.circle.item with type Item is new textured_Model.textured_Item with null record;
record
Face : lit_textured.Face_t;
end record;
end openGL.Model.circle.lit_textured; end openGL.Model.circle.lit_textured;

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

@@ -9,9 +9,9 @@ package openGL.Model.polygon.lit_textured
-- Models a lit and textured polygon. -- Models a lit and textured polygon.
-- --
is is
package textured_Model is new texturing.Mixin; package textured_Model is new texturing.Mixin (openGL.Model.polygon.item);
type Item is new textured_Model.item with private; type Item is new textured_Model.textured_item with private;
type View is access all Item'Class; type View is access all Item'Class;
@@ -33,7 +33,7 @@ is
private private
type Item is new textured_Model.item with type Item is new textured_Model.textured_item with
record record
vertex_Sites : Vector_2_array (1 .. 8); vertex_Sites : Vector_2_array (1 .. 8);
vertex_Count : Positive; vertex_Count : Positive;

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

@@ -92,7 +92,6 @@ is
end; end;
end loop; end loop;
Uniforms.Count := for_Program.uniform_Variable ("texture_Count"); Uniforms.Count := for_Program.uniform_Variable ("texture_Count");
end create; end create;
@@ -106,8 +105,8 @@ is
package body Mixin package body Mixin
is is
overriding overriding
procedure Fade_is (Self : in out Item; Which : in texture_Set.texture_Id; procedure Fade_is (Self : in out textured_Item; Which : in texture_Set.texture_Id;
Now : in texture_Set.fade_Level) Now : in texture_Set.fade_Level)
is is
begin begin
Self.texture_Details.Fades (which) := Now; Self.texture_Details.Fades (which) := Now;
@@ -116,7 +115,7 @@ is
overriding overriding
function Fade (Self : in Item; Which : in texture_Set.texture_Id) return texture_Set.fade_Level function Fade (Self : in textured_Item; Which : in texture_Set.texture_Id) return texture_Set.fade_Level
is is
begin begin
return Self.texture_Details.Fades (which); return Self.texture_Details.Fades (which);
@@ -124,8 +123,8 @@ is
procedure Texture_is (Self : in out Item; Which : in texture_Set.texture_Id; procedure Texture_is (Self : in out textured_Item; Which : in texture_Set.texture_Id;
Now : in openGL.asset_Name) Now : in openGL.asset_Name)
is is
begin begin
Self.texture_Details.Textures (Positive (which)) := Now; Self.texture_Details.Textures (Positive (which)) := Now;
@@ -135,7 +134,7 @@ is
overriding overriding
function texture_Count (Self : in Item) return Natural function texture_Count (Self : in textured_Item) return Natural
is is
begin begin
return Self.texture_Details.texture_Count; return Self.texture_Details.texture_Count;
@@ -144,7 +143,7 @@ is
overriding overriding
function texture_Applied (Self : in Item; Which : in texture_Set.texture_Id) return Boolean function texture_Applied (Self : in textured_Item; Which : in texture_Set.texture_Id) return Boolean
is is
begin begin
return Self.texture_Details.texture_Applies (Which); return Self.texture_Details.texture_Applies (Which);
@@ -153,8 +152,8 @@ is
overriding overriding
procedure texture_Applied_is (Self : in out Item; Which : in texture_Set.texture_Id; procedure texture_Applied_is (Self : in out textured_Item; Which : in texture_Set.texture_Id;
Now : in Boolean) Now : in Boolean)
is is
begin begin
Self.texture_Details.texture_Applies (Which) := Now; Self.texture_Details.texture_Applies (Which) := Now;
@@ -164,7 +163,7 @@ is
overriding overriding
procedure animate (Self : in out Item) procedure animate (Self : in out textured_Item)
is is
use type texture_Set.Animation_view; use type texture_Set.Animation_view;
begin begin
@@ -179,14 +178,14 @@ is
function texture_Details (Self : in Item) return openGL.texture_Set.Details function texture_Details (Self : in textured_Item) return openGL.texture_Set.Details
is is
begin begin
return Self.texture_Details; return Self.texture_Details;
end texture_Details; end texture_Details;
procedure texture_Details_is (Self : in out Item; Now : in openGL.texture_Set.Details) procedure texture_Details_is (Self : in out textured_Item; Now : in openGL.texture_Set.Details)
is is
begin begin
Self.texture_Details := Now; Self.texture_Details := Now;

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

@@ -48,45 +48,47 @@ is
------------- -------------
generic generic
package Mixin
is
type Item is abstract new Model.item with private; type Item is abstract new Model.item with private;
package Mixin
overriding is
function Fade (Self : in Item; Which : in texture_Set.texture_Id) return texture_Set.fade_Level; type textured_Item is abstract new Item with private;
overriding
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
function texture_Applied (Self : in Item; Which : in texture_Set.texture_Id) return Boolean; function Fade (Self : in textured_Item; Which : in texture_Set.texture_Id) return texture_Set.fade_Level;
overriding overriding
procedure texture_Applied_is (Self : in out Item; Which : in texture_Set.texture_Id; procedure Fade_is (Self : in out textured_Item; Which : in texture_Set.texture_Id;
Now : in Boolean); Now : in texture_Set.fade_Level);
procedure Texture_is (Self : in out textured_Item; Which : in texture_Set.texture_Id;
Now : in asset_Name);
overriding overriding
procedure animate (Self : in out Item); function texture_Count (Self : in textured_Item) return Natural;
function texture_Details (Self : in Item) return openGL.texture_Set.Details; overriding
function texture_Applied (Self : in textured_Item; Which : in texture_Set.texture_Id) return Boolean;
procedure texture_Details_is (Self : in out Item; Now : in openGL.texture_Set.Details); overriding
procedure texture_Applied_is (Self : in out textured_Item; Which : in texture_Set.texture_Id;
Now : in Boolean);
overriding
procedure animate (Self : in out textured_Item);
function texture_Details (Self : in textured_Item) return openGL.texture_Set.Details;
procedure texture_Details_is (Self : in out textured_Item; Now : in openGL.texture_Set.Details);
private private
type Item is abstract new Model.item with type textured_Item is abstract new Item with
record record
texture_Details : openGL.texture_Set.Details; texture_Details : openGL.texture_Set.Details;
end record; end record;

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

@@ -164,12 +164,12 @@ is
else else
the_graphics_Model := openGL.Model.circle.lit_textured.new_Circle (Radius, the_graphics_Model := openGL.Model.circle.lit_textured.new_Circle (Radius,
Face => (texture_Details => (Fades => [1 => 0.0, others => <>], texture_Details => (Fades => [1 => 0.0, others => <>],
texture_Applies => [1 => True, others => <>], texture_Applies => [1 => True, others => <>],
Textures => [1 => Texture, others => <>], Textures => [1 => Texture, others => <>],
texture_Count => 1, texture_Count => 1,
texture_Tiling => (S => 1.0, T => 1.0), texture_Tiling => (S => 1.0, T => 1.0),
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,