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

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