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

This commit is contained in:
Rod Kay
2023-05-31 11:39:01 +10:00
parent ec4a9b357a
commit ce41c9afef
15 changed files with 381 additions and 292 deletions

View File

@@ -129,6 +129,8 @@ is
name => +Attribute_3_Name_ptr);
Errors.log;
end;
textured_Geometry.create_Uniforms (for_Program => the_Program.all'Access);
end if;
Self.Program_is (the_Program.all'Access);
@@ -182,6 +184,7 @@ is
end Vertices_are;
overriding
procedure Indices_are (Self : in out Item; Now : in Indices;
for_Facia : in Positive)
@@ -191,23 +194,23 @@ is
end Indices_are;
overriding
procedure enable_Textures (Self : in out Item)
is
use GL,
GL.Binding,
openGL.Texture;
begin
Tasks.check;
glActiveTexture (gl.GL_TEXTURE0);
Errors.log;
if Self.Texture = openGL.Texture.null_Object
then enable (white_Texture);
else enable (Self.Texture);
end if;
end enable_Textures;
-- overriding
-- procedure enable_Textures (Self : in out Item)
-- is
-- use GL,
-- GL.Binding,
-- openGL.Texture;
-- begin
-- Tasks.check;
--
-- glActiveTexture (gl.GL_TEXTURE0);
-- Errors.log;
--
-- if Self.Texture = openGL.Texture.null_Object
-- then enable (white_Texture);
-- else enable (Self.Texture);
-- end if;
-- end enable_Textures;
end openGL.Geometry.colored_textured;

View File

@@ -1,3 +1,12 @@
with
openGL.texture_Set;
private
with
openGL.Geometry.texturing;
package openGL.Geometry.colored_textured
--
-- Supports per-vertex site, color and texture.
@@ -36,13 +45,22 @@ is
private
type Item is new Geometry.item with
package textured_Geometry is new texturing.Mixin;
type Item is new textured_Geometry.item with
record
null;
end record;
overriding
procedure enable_Textures (Self : in out Item);
-- type Item is new Geometry.item with
-- record
-- null;
-- end record;
--
--
-- overriding
-- procedure enable_Textures (Self : in out Item);
end openGL.Geometry.colored_textured;

View File

@@ -180,6 +180,12 @@ is
Index => the_Program.Program.Attribute (named => Name_5).gl_Location,
Name => +Attribute_5_Name_ptr);
Errors.log;
-- TODO: This will fail. Split this package into 'lit_colored_textured' and 'lit_colored_text'.
--
textured_Geometry.create_Uniforms (for_Program => the_Program.Program.all'Access);
end define;
Self : constant Geometry_view := new Geometry.lit_colored_textured.item;
@@ -281,68 +287,68 @@ is
--- Texturing
--
procedure Fade_is (Self : in out Item; Which : texture_Set.texture_ID; Now : in texture_Set.fade_Level)
is
begin
Self.Textures.Textures (Which).Fade := Now;
end Fade_is;
function Fade (Self : in Item; Which : texture_Set.texture_ID) return texture_Set.fade_Level
is
begin
return Self.Textures.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.Textures,
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.Textures,
which => Which);
end Texture;
overriding
procedure Texture_is (Self : in out Item; Now : in openGL.Texture.Object)
is
begin
Texture_is (in_Set => Self.Textures,
Now => Now);
end Texture_is;
overriding
function Texture (Self : in Item) return openGL.Texture.Object
is
begin
return openGL.texture_Set.Texture (in_Set => Self.Textures,
which => 1);
end Texture;
overriding
procedure enable_Textures (Self : in out Item)
is
begin
enable (Self.Textures, Self.Program);
end enable_Textures;
-- procedure Fade_is (Self : in out Item; Which : texture_Set.texture_ID; Now : in texture_Set.fade_Level)
-- is
-- begin
-- Self.Textures.Textures (Which).Fade := Now;
-- end Fade_is;
--
--
-- function Fade (Self : in Item; Which : texture_Set.texture_ID) return texture_Set.fade_Level
-- is
-- begin
-- return Self.Textures.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.Textures,
-- 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.Textures,
-- which => Which);
-- end Texture;
--
--
--
-- overriding
-- procedure Texture_is (Self : in out Item; Now : in openGL.Texture.Object)
-- is
-- begin
-- Texture_is (in_Set => Self.Textures,
-- Now => Now);
-- end Texture_is;
--
--
-- overriding
-- function Texture (Self : in Item) return openGL.Texture.Object
-- is
-- begin
-- return openGL.texture_Set.Texture (in_Set => Self.Textures,
-- which => 1);
-- end Texture;
--
--
--
-- overriding
-- procedure enable_Textures (Self : in out Item)
-- is
-- begin
-- enable (Self.Textures, Self.Program);
-- end enable_Textures;
--
-- overriding

View File

@@ -1,6 +1,10 @@
with
openGL.texture_Set;
private
with
openGL.Geometry.texturing;
package openGL.Geometry.lit_colored_textured
--
@@ -42,30 +46,41 @@ is
--- Texturing.
--
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;
-- procedure Fade_is (Self : in out Item; Now : in texture_Set.fade_Level;
-- Which : in texture_Set.texture_ID := 1);
-- function Fade (Self : in Item; Which : in texture_Set.texture_ID := 1) return texture_Set.fade_Level;
--
--
-- procedure Texture_is (Self : in out Item; Now : in openGL.Texture.Object;
-- Which : in texture_Set.texture_ID);
-- function Texture (Self : in Item; Which : in texture_Set.texture_ID := 1) return 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;
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 Texture_is (Self : in out Item; Now : in openGL.Texture.Object);
--
-- overriding
-- function Texture (Self : in Item) return openGL.Texture.Object;
private
type Item is new Geometry.item with
package textured_Geometry is new texturing.Mixin;
type Item is new textured_Geometry.item with
record
Textures : texture_Set.Item;
null;
end record;
overriding
procedure enable_Textures (Self : in out Item);
-- type Item is new Geometry.item with
-- record
-- Textures : texture_Set.Item;
-- end record;
-- overriding
-- procedure enable_Textures (Self : in out Item);
end openGL.Geometry.lit_colored_textured;

View File

@@ -287,35 +287,35 @@ is
overriding
procedure enable_Textures (Self : in out Item)
is
use GL,
GL.Binding,
openGL.Texture;
begin
Tasks.check;
glActiveTexture (gl.GL_TEXTURE0);
Errors.log;
if Self.Texture = openGL.Texture.null_Object
then
if not white_Texture.is_Defined
then
declare
use Palette;
white_Image : constant openGL.Image := [1 .. 2 => [1 .. 2 => +White]];
begin
white_Texture := openGL.Texture.Forge.to_Texture (white_Image);
end;
end if;
white_Texture.enable;
else
Self.Texture.enable;
end if;
end enable_Textures;
-- overriding
-- procedure enable_Textures (Self : in out Item)
-- is
-- use GL,
-- GL.Binding,
-- openGL.Texture;
-- begin
-- Tasks.check;
--
-- glActiveTexture (gl.GL_TEXTURE0);
-- Errors.log;
--
-- if Self.Texture = openGL.Texture.null_Object
-- then
-- if not white_Texture.is_Defined
-- then
-- declare
-- use Palette;
-- white_Image : constant openGL.Image := [1 .. 2 => [1 .. 2 => +White]];
-- begin
-- white_Texture := openGL.Texture.Forge.to_Texture (white_Image);
-- end;
-- end if;
--
-- white_Texture.enable;
-- else
-- Self.Texture.enable;
-- end if;
-- end enable_Textures;
end openGL.Geometry.lit_colored_textured_skinned;

View File

@@ -1,5 +1,12 @@
with
openGL.Program.lit.colored_textured_skinned;
openGL.Program.lit.colored_textured_skinned,
openGL.texture_Set;
private
with
openGL.Geometry.texturing;
package openGL.Geometry.lit_colored_textured_skinned
@@ -50,9 +57,18 @@ is
private
type Item is new Geometry.item with null record;
package textured_Geometry is new texturing.Mixin;
overriding
procedure enable_Textures (Self : in out Item);
type Item is new textured_Geometry.item with
record
null;
end record;
-- type Item is new Geometry.item with null record;
--
-- overriding
-- procedure enable_Textures (Self : in out Item);
end openGL.Geometry.lit_colored_textured_skinned;

View File

@@ -69,11 +69,9 @@ private
package textured_Geometry is new texturing.Mixin;
-- type Item is new Geometry.item with
type Item is new textured_Geometry.item with
record
null;
-- texture_Set : openGL.texture_Set.Item;
end record;

View File

@@ -261,35 +261,35 @@ is
overriding
procedure enable_Textures (Self : in out Item)
is
use GL,
GL.Binding,
openGL.Texture;
begin
Tasks.check;
glActiveTexture (gl.GL_TEXTURE0);
Errors.log;
if Self.Texture = openGL.Texture.null_Object
then
if not white_Texture.is_Defined
then
declare
use Palette;
white_Image : constant openGL.Image := [1 .. 2 => [1 .. 2 => +White]];
begin
white_Texture := openGL.Texture.Forge.to_Texture (white_Image);
end;
end if;
white_Texture.enable;
else
Self.Texture.enable;
end if;
end enable_Textures;
-- overriding
-- procedure enable_Textures (Self : in out Item)
-- is
-- use GL,
-- GL.Binding,
-- openGL.Texture;
-- begin
-- Tasks.check;
--
-- glActiveTexture (gl.GL_TEXTURE0);
-- Errors.log;
--
-- if Self.Texture = openGL.Texture.null_Object
-- then
-- if not white_Texture.is_Defined
-- then
-- declare
-- use Palette;
-- white_Image : constant openGL.Image := [1 .. 2 => [1 .. 2 => +White]];
-- begin
-- white_Texture := openGL.Texture.Forge.to_Texture (white_Image);
-- end;
-- end if;
--
-- white_Texture.enable;
-- else
-- Self.Texture.enable;
-- end if;
-- end enable_Textures;
end openGL.Geometry.lit_textured_skinned;

View File

@@ -1,5 +1,10 @@
with
openGL.Program.lit.textured_skinned;
openGL.Program.lit.textured_skinned,
openGL.texture_Set;
private
with
openGL.Geometry.texturing;
package openGL.Geometry.lit_textured_skinned
@@ -49,9 +54,18 @@ is
private
type Item is new Geometry.item with null record;
package textured_Geometry is new texturing.Mixin;
overriding
procedure enable_Textures (Self : in out Item);
type Item is new textured_Geometry.item with
record
null;
end record;
-- type Item is new Geometry.item with null record;
--
-- overriding
-- procedure enable_Textures (Self : in out Item);
end openGL.Geometry.lit_textured_skinned;

View File

@@ -110,6 +110,8 @@ is
glBindAttribLocation (program => the_Program.gl_Program,
index => the_Program.Attribute (named => Name_2).gl_Location,
name => +Attribute_2_Name_ptr);
textured_Geometry.create_Uniforms (for_Program => the_Program.all'Access);
end;
end if;
@@ -137,6 +139,7 @@ is
Element => Vertex,
Element_Array => Vertex_array);
procedure Vertices_are (Self : in out Item; Now : in Vertex_array)
is
use openGL_Buffer_of_geometry_Vertices.Forge;
@@ -156,12 +159,13 @@ is
end Vertices_are;
overriding
procedure Indices_are (Self : in out Item; Now : in Indices;
for_Facia : in Positive)
is
begin
raise Error with "opengl gemoetry textured - 'Indices_are' ~ TODO";
raise Error with "opengl geometry textured - 'Indices_are' ~ TODO";
end Indices_are;
@@ -169,67 +173,67 @@ is
--- Texturing
--
procedure Fade_is (Self : in out Item; Which : texture_Set.texture_ID; Now : in texture_Set.fade_Level)
is
begin
Self.Textures.Textures (Which).Fade := Now;
end Fade_is;
function Fade (Self : in Item; Which : texture_Set.texture_ID) return texture_Set.fade_Level
is
begin
return Self.Textures.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.Textures,
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.Textures,
Which => Which);
end Texture;
overriding
procedure Texture_is (Self : in out Item; Now : in openGL.Texture.Object)
is
begin
Texture_is (in_Set => Self.Textures,
Now => Now);
end Texture_is;
overriding
function Texture (Self : in Item) return openGL.Texture.Object
is
begin
return openGL.texture_Set.Texture (in_Set => Self.Textures,
which => 1);
end Texture;
overriding
procedure enable_Textures (Self : in out Item)
is
begin
enable (Self.Textures, Self.Program);
end enable_Textures;
-- procedure Fade_is (Self : in out Item; Which : texture_Set.texture_ID; Now : in texture_Set.fade_Level)
-- is
-- begin
-- Self.Textures.Textures (Which).Fade := Now;
-- end Fade_is;
--
--
--
-- function Fade (Self : in Item; Which : texture_Set.texture_ID) return texture_Set.fade_Level
-- is
-- begin
-- return Self.Textures.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.Textures,
-- 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.Textures,
-- Which => Which);
-- end Texture;
--
--
--
-- overriding
-- procedure Texture_is (Self : in out Item; Now : in openGL.Texture.Object)
-- is
-- begin
-- Texture_is (in_Set => Self.Textures,
-- Now => Now);
-- end Texture_is;
--
--
--
-- overriding
-- function Texture (Self : in Item) return openGL.Texture.Object
-- is
-- begin
-- return openGL.texture_Set.Texture (in_Set => Self.Textures,
-- which => 1);
-- end Texture;
--
--
--
-- overriding
-- procedure enable_Textures (Self : in out Item)
-- is
-- begin
-- enable (Self.Textures, Self.Program);
-- end enable_Textures;

View File

@@ -2,6 +2,11 @@ with
openGL.texture_Set;
private
with
openGL.Geometry.texturing;
package openGL.Geometry.textured
--
-- Supports per-vertex site and texture.
@@ -42,30 +47,39 @@ is
--- Texturing.
--
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;
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;
overriding
procedure Texture_is (Self : in out Item; Now : in openGL.Texture.Object);
overriding
function Texture (Self : in Item) return openGL.Texture.Object;
-- 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;
--
--
-- 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;
--
-- overriding
-- procedure Texture_is (Self : in out Item; Now : in openGL.Texture.Object);
--
-- overriding
-- function Texture (Self : in Item) return openGL.Texture.Object;
private
type Item is new Geometry.item with
package textured_Geometry is new texturing.Mixin;
type Item is new textured_Geometry.item with
record
Textures : texture_Set.Item;
null;
end record;
overriding
procedure enable_Textures (Self : in out Item);
-- type Item is new Geometry.item with
-- record
-- Textures : texture_Set.Item;
-- end record;
--
--
-- overriding
-- procedure enable_Textures (Self : in out Item);
end openGL.Geometry.textured;

View File

@@ -120,12 +120,9 @@ is
overriding
procedure Fade_is (Self : in out Item; Which : in texture_Set.texture_ID;
Now : in texture_Set.fade_Level)
procedure Fade_is (Self : in out Item; Now : in texture_Set.fade_Level;
Which : in texture_Set.texture_ID := 1)
is
begin
Self.texture_Set.Textures (which).Fade := Now;
@@ -134,7 +131,7 @@ is
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 := 1) return texture_Set.fade_Level
is
begin
return Self.texture_Set.Textures (which).Fade;
@@ -143,8 +140,8 @@ is
overriding
procedure Texture_is (Self : in out Item; Which : in texture_Set.texture_ID;
Now : in openGL.Texture.Object)
procedure Texture_is (Self : in out Item; Now : in openGL.Texture.Object;
Which : in texture_Set.texture_ID := 1)
is
begin
Texture_is (in_Set => Self.texture_Set,
@@ -155,7 +152,7 @@ is
overriding
function Texture (Self : in Item; Which : texture_Set.texture_ID) return openGL.Texture.Object
function Texture (Self : in Item; Which : texture_Set.texture_ID := 1) return openGL.Texture.Object
is
begin
return openGL.texture_Set.Texture (in_Set => Self.texture_Set,
@@ -164,23 +161,23 @@ is
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 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;

View File

@@ -66,21 +66,23 @@ is
overriding
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; Now : in texture_Set.fade_Level;
Which : in texture_Set.texture_ID := 1);
overriding
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 := 1) return texture_Set.fade_Level;
overriding
procedure Texture_is (Self : in out Item; Which : texture_Set.texture_ID; Now : in openGL.Texture.Object);
procedure Texture_is (Self : in out Item; Now : in openGL.Texture.Object;
Which : in texture_Set.texture_ID := 1);
overriding
function Texture (Self : in Item; Which : texture_Set.texture_ID) return openGL.Texture.Object;
function Texture (Self : in Item; Which : in texture_Set.texture_ID := 1) 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 Texture_is (Self : in out Item; Now : in openGL.Texture.Object);
--
-- overriding
-- function Texture (Self : in Item) return openGL.Texture.Object;
overriding

View File

@@ -103,7 +103,7 @@ is
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 := 1) return texture_Set.fade_Level
is
begin
raise program_Error with "Geometry has no texture.";
@@ -112,16 +112,16 @@ is
function Texture (Self : in Item) return openGL.Texture.Object
is
begin
raise program_Error with "Geometry has no texture.";
return openGL.Texture.null_Object;
end Texture;
-- function Texture (Self : in Item) return openGL.Texture.Object
-- is
-- begin
-- raise program_Error with "Geometry has no texture.";
-- return openGL.Texture.null_Object;
-- end Texture;
function Texture (Self : in Item; Which : in texture_Set.texture_ID) return openGL.Texture.Object
function Texture (Self : in Item; Which : in texture_Set.texture_ID := 1) return openGL.Texture.Object
is
begin
raise program_Error with "Geometry has no texture.";

View File

@@ -54,14 +54,16 @@ is
--- 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 Fade_is (Self : in out Item; Now : in texture_Set.fade_Level;
Which : in texture_Set.texture_ID := 1) is null;
function Fade (Self : in Item; Which : in texture_Set.texture_ID := 1) 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;
Which : in texture_Set.texture_ID := 1) is null;
function Texture (Self : in Item; Which : in texture_Set.texture_ID := 1) return openGL.Texture.Object;
procedure Texture_is (Self : in out Item; Now : in openGL.Texture.Object) is null;
function Texture (Self : in Item) return openGL.Texture.Object;
-- procedure Texture_is (Self : in out Item; Now : in openGL.Texture.Object) is null;
-- function Texture (Self : in Item) return openGL.Texture.Object;