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

opengl.geometry.texturing: Add 'Mixin' generic.

Browse Source
This commit is contained in:
Rod Kay
2023-05-31 10:54:59 +10:00
parent bb6df0ba31
commit ec4a9b357a
6 changed files with 282 additions and 92 deletions
Download Patch File Download Diff File Expand all files Collapse all files

154
3-mid/opengl/source/lean/geometry/opengl-geometry-lit_textured.adb
View File

@@ -52,7 +52,7 @@ is
Attribute_3_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_3_Name'Access); Attribute_3_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_3_Name'Access);
Attribute_4_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_4_Name'Access); Attribute_4_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_4_Name'Access);
texture_Uniforms : texturing.Uniforms; -- texture_Uniforms : texturing.Uniforms;
@@ -153,22 +153,24 @@ is
--- Set up the texturing uniforms. --- Set up the texturing uniforms.
-- --
for Id in texture_Id'Range -- for Id in texture_Id'Range
loop -- loop
declare -- declare
use ada.Strings, -- use ada.Strings,
ada.Strings.fixed; -- ada.Strings.fixed;
--
-- i : constant Positive := Positive (Id);
-- texture_uniform_Name : constant String := "Textures[" & trim (Natural'Image (i - 1), Left) & "]";
-- fade_uniform_Name : constant String := "Fade[" & trim (Natural'Image (i - 1), Left) & "]";
-- begin
-- texture_Uniforms.Textures (Id).texture_Uniform := the_Program.uniform_Variable (named => texture_uniform_Name);
-- texture_Uniforms.Textures (Id). fade_Uniform := the_Program.uniform_Variable (named => fade_uniform_Name);
-- end;
-- end loop;
--
-- texture_Uniforms.Count := the_Program.uniform_Variable ("texture_Count");
i : constant Positive := Positive (Id); textured_Geometry.create_Uniforms (for_Program => the_Program.all'Access);
texture_uniform_Name : constant String := "Textures[" & trim (Natural'Image (i - 1), Left) & "]";
fade_uniform_Name : constant String := "Fade[" & trim (Natural'Image (i - 1), Left) & "]";
begin
texture_Uniforms.Textures (Id).texture_Uniform := the_Program.uniform_Variable (named => texture_uniform_Name);
texture_Uniforms.Textures (Id). fade_Uniform := the_Program.uniform_Variable (named => fade_uniform_Name);
end;
end loop;
texture_Uniforms.Count := the_Program.uniform_Variable ("texture_Count");
end create_Program; end create_Program;
@@ -294,69 +296,69 @@ is
--- Texturing --- Texturing
-- --
procedure Fade_is (Self : in out Item; Which : texture_ID; Now : in texture_Set.fade_Level) -- procedure Fade_is (Self : in out Item; Which : texture_ID; Now : in texture_Set.fade_Level)
is -- is
begin -- begin
Self.texture_Set.Textures (which).Fade := Now; -- Self.texture_Set.Textures (which).Fade := Now;
end Fade_is; -- end Fade_is;
--
--
--
-- function Fade (Self : in Item; Which : texture_Set.texture_ID) return texture_Set.fade_Level
-- is
-- begin
-- return Self.texture_Set.Textures (which).Fade;
-- end Fade;
--
--
--
-- procedure Texture_is (Self : in out Item; Which : texture_ID; Now : in openGL.Texture.Object)
-- is
-- begin
-- Texture_is (in_Set => Self.texture_Set,
-- Which => Which,
-- Now => Now);
-- end Texture_is;
--
--
--
-- function Texture (Self : in Item; Which : texture_ID) return openGL.Texture.Object
-- is
-- begin
-- return openGL.texture_Set.Texture (in_Set => Self.texture_Set,
-- Which => Which);
-- end Texture;
--
--
--
-- overriding
-- procedure Texture_is (Self : in out Item; Now : in openGL.Texture.Object)
-- is
-- begin
-- Texture_is (in_Set => Self.texture_Set,
-- Now => Now);
-- end Texture_is;
--
--
--
-- overriding
-- function Texture (Self : in Item) return openGL.Texture.Object
-- is
-- begin
-- return texture_Set.Texture (in_Set => Self.texture_Set,
-- Which => 1);
-- end Texture;
function Fade (Self : in Item; Which : texture_Set.texture_ID) return texture_Set.fade_Level -- overriding
is -- procedure enable_Textures (Self : in out Item)
begin -- is
return Self.texture_Set.Textures (which).Fade; -- begin
end Fade; -- texturing.enable (for_Model => Self.Model.all'Access,
-- Uniforms => texture_Uniforms,
-- texture_Set => Self.texture_Set);
-- end enable_Textures;
procedure Texture_is (Self : in out Item; Which : texture_ID; Now : in openGL.Texture.Object)
is
begin
Texture_is (in_Set => Self.texture_Set,
Which => Which,
Now => Now);
end Texture_is;
function Texture (Self : in Item; Which : texture_ID) return openGL.Texture.Object
is
begin
return openGL.texture_Set.Texture (in_Set => Self.texture_Set,
Which => Which);
end Texture;
overriding
procedure Texture_is (Self : in out Item; Now : in openGL.Texture.Object)
is
begin
Texture_is (in_Set => Self.texture_Set,
Now => Now);
end Texture_is;
overriding
function Texture (Self : in Item) return openGL.Texture.Object
is
begin
return texture_Set.Texture (in_Set => Self.texture_Set,
Which => 1);
end Texture;
overriding
procedure enable_Textures (Self : in out Item)
is
begin
texturing.enable (for_Model => Self.Model.all'Access,
Uniforms => texture_Uniforms,
texture_Set => Self.texture_Set);
end enable_Textures;
end openGL.Geometry.lit_textured; end openGL.Geometry.lit_textured;

41
3-mid/opengl/source/lean/geometry/opengl-geometry-lit_textured.ads
View File

@@ -1,6 +1,10 @@
with with
openGL.texture_Set; openGL.texture_Set;
private
with
openGL.Geometry.texturing;
package openGL.Geometry.lit_textured package openGL.Geometry.lit_textured
-- --
@@ -45,30 +49,35 @@ is
--- Texturing. --- Texturing.
-- --
procedure Fade_is (Self : in out Item; Which : texture_Set.texture_ID; Now : in texture_Set.fade_Level); -- procedure Fade_is (Self : in out Item; Which : texture_Set.texture_ID; Now : in texture_Set.fade_Level);
function Fade (Self : in Item; Which : texture_Set.texture_ID) return texture_Set.fade_Level; -- function Fade (Self : in Item; Which : texture_Set.texture_ID) return texture_Set.fade_Level;
--
--
procedure Texture_is (Self : in out Item; Which : texture_Set.texture_ID; Now : in openGL.Texture.Object); -- procedure Texture_is (Self : in out Item; Which : texture_Set.texture_ID; Now : in openGL.Texture.Object);
function Texture (Self : in Item; Which : texture_Set.texture_ID) return openGL.Texture.Object; -- function Texture (Self : in Item; Which : texture_Set.texture_ID) return openGL.Texture.Object;
--
overriding -- overriding
procedure Texture_is (Self : in out Item; Now : in openGL.Texture.Object); -- procedure Texture_is (Self : in out Item; Now : in openGL.Texture.Object);
--
overriding -- overriding
function Texture (Self : in Item) return openGL.Texture.Object; -- function Texture (Self : in Item) return openGL.Texture.Object;
private private
type Item is new Geometry.item with package textured_Geometry is new texturing.Mixin;
-- type Item is new Geometry.item with
type Item is new textured_Geometry.item with
record record
texture_Set : openGL.texture_Set.Item; null;
-- texture_Set : openGL.texture_Set.Item;
end record; end record;
overriding -- overriding
procedure enable_Textures (Self : in out Item); -- procedure enable_Textures (Self : in out Item);
end openGL.Geometry.lit_textured; end openGL.Geometry.lit_textured;

100
3-mid/opengl/source/lean/geometry/opengl-geometry-texturing.adb
View File

@@ -98,4 +98,104 @@ is
end create; end create;
-------------
--- Mixin ---
-------------
-- generic
package body Mixin
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
procedure Fade_is (Self : in out Item; Which : in texture_Set.texture_ID;
Now : in texture_Set.fade_Level)
is
begin
Self.texture_Set.Textures (which).Fade := 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.texture_Set.Textures (which).Fade;
end Fade;
overriding
procedure Texture_is (Self : in out Item; Which : in texture_Set.texture_ID;
Now : in openGL.Texture.Object)
is
begin
Texture_is (in_Set => Self.texture_Set,
Which => Which,
Now => Now);
end Texture_is;
overriding
function Texture (Self : in Item; Which : texture_Set.texture_ID) return openGL.Texture.Object
is
begin
return openGL.texture_Set.Texture (in_Set => Self.texture_Set,
Which => Which);
end Texture;
overriding
procedure Texture_is (Self : in out Item; Now : in openGL.Texture.Object)
is
begin
Texture_is (in_Set => Self.texture_Set,
Now => Now);
end Texture_is;
overriding
function Texture (Self : in Item) return openGL.Texture.Object
is
begin
return texture_Set.Texture (in_Set => Self.texture_Set,
Which => 1);
end Texture;
overriding
procedure enable_Textures (Self : in out Item)
is
begin
texturing.enable (for_Model => Self.Model.all'Access,
Uniforms => texture_Uniforms,
texture_Set => Self.texture_Set);
end enable_Textures;
end Mixin;
end openGL.Geometry.texturing; end openGL.Geometry.texturing;

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

@@ -49,4 +49,53 @@ is
for_Program : in openGL.Program.view); for_Program : in openGL.Program.view);
-------------
--- Mixin ---
-------------
generic
package Mixin
is
type Item is new Geometry.item with private;
procedure create_Uniforms (for_Program : in openGL.Program.view);
overriding
procedure Fade_is (Self : in out Item; Which : texture_Set.texture_ID; Now : in texture_Set.fade_Level);
overriding
function Fade (Self : in Item; Which : texture_Set.texture_ID) return texture_Set.fade_Level;
overriding
procedure Texture_is (Self : in out Item; Which : texture_Set.texture_ID; Now : in openGL.Texture.Object);
overriding
function Texture (Self : in Item; Which : texture_Set.texture_ID) return openGL.Texture.Object;
overriding
procedure Texture_is (Self : in out Item; Now : in openGL.Texture.Object);
overriding
function Texture (Self : in Item) return openGL.Texture.Object;
overriding
procedure enable_Textures (Self : in out Item);
private
type Item is new Geometry.item with
record
texture_Set : openGL.texture_Set.item;
end record;
end Mixin;
end openGL.Geometry.texturing; end openGL.Geometry.texturing;

18
3-mid/opengl/source/lean/geometry/opengl-geometry.adb
View File

@@ -103,6 +103,15 @@ is
function Fade (Self : in Item; Which : texture_Set.texture_ID) return texture_Set.fade_Level
is
begin
raise program_Error with "Geometry has no texture.";
return texture_Set.fade_Level'Last;
end Fade;
function Texture (Self : in Item) return openGL.Texture.Object function Texture (Self : in Item) return openGL.Texture.Object
is is
begin begin
@@ -112,6 +121,15 @@ is
function Texture (Self : in Item; Which : in texture_Set.texture_ID) return openGL.Texture.Object
is
begin
raise program_Error with "Geometry has no texture.";
return openGL.Texture.null_Object;
end Texture;
procedure Program_is (Self : in out Item; Now : in openGL.Program.view) procedure Program_is (Self : in out Item; Now : in openGL.Program.view)
is is
begin begin

12
3-mid/opengl/source/lean/geometry/opengl-geometry.ads
View File

@@ -50,9 +50,21 @@ is
procedure Label_is (Self : in out Item'Class; Now : in String); procedure Label_is (Self : in out Item'Class; Now : in String);
function Label (Self : in Item'Class) return String; function Label (Self : in Item'Class) return String;
--- Texturing
--
procedure Fade_is (Self : in out Item; Which : in texture_Set.texture_ID; Now : in texture_Set.fade_Level) is null;
function Fade (Self : in Item; Which : in texture_Set.texture_ID) return texture_Set.fade_Level;
procedure Texture_is (Self : in out Item; Which : in texture_Set.texture_ID; Now : in openGL.Texture.Object) is null;
function Texture (Self : in Item; Which : in texture_Set.texture_ID) return openGL.Texture.Object;
procedure Texture_is (Self : in out Item; Now : in openGL.Texture.Object) is null; procedure Texture_is (Self : in out Item; Now : in openGL.Texture.Object) is null;
function Texture (Self : in Item) return openGL.Texture.Object; function Texture (Self : in Item) return openGL.Texture.Object;
procedure Bounds_are (Self : in out Item'Class; Now : in Bounds); procedure Bounds_are (Self : in out Item'Class; Now : in Bounds);
function Bounds (self : in Item'Class) return Bounds; -- Returns the bounds in object space. function Bounds (self : in Item'Class) return Bounds; -- Returns the bounds in object space.