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

opengl: Work on multi-texturing.

Browse Source
This commit is contained in:
Rod Kay
2023-05-09 18:04:18 +10:00
parent d3e4119172
commit 1beb8e1140
12 changed files with 212 additions and 26 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -5,6 +5,7 @@ with
openGL.Attribute,
openGL.Texture,
openGL.Palette,
openGL.Model,
openGL.Tasks,
openGL.Errors,
@@ -312,6 +313,10 @@ is
is
use openGL.Geometry.texturing;
begin
Self.Textures.Textures (1).Fade := Self.Model.Fade_1;
Self.Textures.Textures (2).Fade := Self.Model.Fade_2;
enable (Self.Textures, Self.Program);
end enable_Texture;

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

@@ -6,6 +6,8 @@ with
ada.Strings.fixed;
with ada.Text_IO; use ada.Text_IO;
package body openGL.Geometry.texturing
is
@@ -156,6 +158,8 @@ is
uniform_Name : constant String := "Fade[" & Trim (Natural'Image (i - 1), Left) & "]";
Uniform : constant openGL.Variable.uniform.float := Program.uniform_Variable (uniform_Name);
begin
-- put_Line ("Fade:" & the_Textures.Textures (texture_Id (i)).Fade'Image);
Uniform.Value_is (Real (the_Textures.Textures (texture_Id (i)).Fade));
end;
end loop;

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

@@ -50,6 +50,15 @@ is
-- Attributes
--
procedure Model_is (Self : in out Item; Now : in Model_view)
is
begin
Self.Model := Now;
end Model_is;
function Label (Self : in Item'Class) return String
is
begin

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

@@ -4,6 +4,9 @@ with
openGL.Program,
openGL.Texture;
limited
with
openGL.Model;
private
with
@@ -38,6 +41,11 @@ is
-- Attributes
--
type Model_view is access all openGL.Model.item'Class;
procedure Model_is (Self : in out Item; Now : in Model_view);
procedure Label_is (Self : in out Item'Class; Now : in String);
function Label (Self : in Item'Class) return String;
@@ -90,16 +98,16 @@ is
Sites : in openGL.Sites) return access Normals;
private
use ada.Strings.unbounded;
type Textures is array (texture_Id) of openGL.Texture.Object;
type Item is abstract tagged limited
record
Model : Model_view;
Label : unbounded_String;
Program : openGL.Program.view;
Vertices : Buffer.view;

75
3-mid/opengl/source/lean/model/opengl-model-hexagon-lit_textured_x2.adb
View File

@@ -27,23 +27,6 @@ is
--- Attributes
--
procedure Texture_1_is (Self : in out Item; Now : in openGL.asset_Name)
is
begin
Self.Face.Texture_1 := Now;
end Texture_1_is;
procedure Texture_2_is (Self : in out Item; Now : in openGL.asset_Name)
is
begin
Self.Face.Texture_2 := Now;
end Texture_2_is;
overriding
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
@@ -116,8 +99,66 @@ is
upper_Face := new_Face (Vertices => the_Vertices);
end;
upper_Face.Model_is (Self.all'unchecked_Access);
return (1 => upper_Face.all'Access);
end to_GL_Geometries;
------------
-- Texturing
--
procedure Texture_1_is (Self : in out Item; Now : in openGL.asset_Name)
is
begin
Self.Face.Texture_1 := Now;
end Texture_1_is;
procedure Texture_2_is (Self : in out Item; Now : in openGL.asset_Name)
is
begin
Self.Face.Texture_2 := Now;
end Texture_2_is;
overriding
procedure Fade_1_is (Self : in out Item; Now : in openGL.Geometry.texturing.fade_Level)
is
begin
Self.Face.Fade_1 := Now;
end Fade_1_is;
overriding
procedure Fade_2_is (Self : in out Item; Now : in openGL.Geometry.texturing.fade_Level)
is
begin
Self.Face.Fade_2 := Now;
end Fade_2_is;
overriding
function Fade_1 (Self : in Item) return Geometry.Texturing.fade_Level
is
begin
return Self.Face.Fade_1;
end Fade_1;
overriding
function Fade_2 (Self : in Item) return Geometry.Texturing.fade_Level
is
begin
return Self.Face.Fade_2;
end Fade_2;
end openGL.Model.hexagon.lit_textured_x2;

23
3-mid/opengl/source/lean/model/opengl-model-hexagon-lit_textured_x2.ads
View File

@@ -32,13 +32,32 @@ is
--- Attributes
--
overriding
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;
------------
-- Texturing
--
procedure Texture_1_is (Self : in out Item; Now : in openGL.asset_Name);
procedure Texture_2_is (Self : in out Item; Now : in openGL.asset_Name);
overriding
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;
procedure Fade_1_is (Self : in out Item; Now : in openGL.Geometry.texturing.fade_Level);
overriding
procedure Fade_2_is (Self : in out Item; Now : in openGL.Geometry.texturing.fade_Level);
overriding
function Fade_1 (Self : in Item) return Geometry.Texturing.fade_Level;
overriding
function Fade_2 (Self : in Item) return Geometry.Texturing.fade_Level;
private

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

@@ -211,4 +211,44 @@ is
Self.needs_Rebuild := True;
end needs_Rebuild;
------------
-- Texturing
--
procedure Fade_1_is (Self : in out Item; Now : in Geometry.Texturing.fade_Level)
is
begin
raise program_Error with "Model does not support texturing.";
end Fade_1_is;
procedure Fade_2_is (Self : in out Item; Now : in Geometry.Texturing.fade_Level)
is
begin
raise program_Error with "Model does not support texturing.";
end Fade_2_is;
function Fade_1 (Self : in Item) return Geometry.Texturing.fade_Level
is
begin
raise program_Error with "Model does not support texturing.";
return 0.0;
end Fade_1;
function Fade_2 (Self : in Item) return Geometry.Texturing.fade_Level
is
begin
raise program_Error with "Model does not support texturing.";
return 0.0;
end Fade_2;
end openGL.Model;

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

@@ -2,7 +2,7 @@ with
openGL.remote_Model,
openGL.Font,
openGL.Texture,
openGL.Geometry;
openGL.Geometry.texturing;
package openGL.Model
@@ -68,6 +68,19 @@ is
Fonts : in Font.font_id_Map_of_font);
------------
-- Texturing
--
procedure Fade_1_is (Self : in out Item; Now : in Geometry.Texturing.fade_Level);
procedure Fade_2_is (Self : in out Item; Now : in Geometry.Texturing.fade_Level);
function Fade_1 (Self : in Item) return Geometry.Texturing.fade_Level;
function Fade_2 (Self : in Item) return Geometry.Texturing.fade_Level;
private
type Item is abstract new remote_Model.item with

1
3-mid/opengl/source/lean/renderer/opengl-renderer-lean.adb
View File

@@ -549,6 +549,7 @@ is
and the_Visual.Model. lucid_Geometries = null)
then
the_Visual.Model.create_GL_Geometries (Self.Textures'Access, Self.Fonts);
-- put_Line ("Rebuild");
elsif the_Visual.Model.is_Modified
then