diff --git a/3-mid/opengl/source/lean/geometry/opengl-geometry-lit_textured.adb b/3-mid/opengl/source/lean/geometry/opengl-geometry-lit_textured.adb index 9b2088d..65107a1 100644 --- a/3-mid/opengl/source/lean/geometry/opengl-geometry-lit_textured.adb +++ b/3-mid/opengl/source/lean/geometry/opengl-geometry-lit_textured.adb @@ -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_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. -- - for Id in texture_Id'Range - loop - declare - use ada.Strings, - ada.Strings.fixed; + -- for Id in texture_Id'Range + -- loop + -- declare + -- use ada.Strings, + -- 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); - 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"); + textured_Geometry.create_Uniforms (for_Program => the_Program.all'Access); end create_Program; @@ -294,69 +296,69 @@ is --- Texturing -- - procedure Fade_is (Self : in out Item; Which : texture_ID; Now : in texture_Set.fade_Level) - is - begin - Self.texture_Set.Textures (which).Fade := Now; - end Fade_is; + -- procedure Fade_is (Self : in out Item; Which : texture_ID; Now : in texture_Set.fade_Level) + -- is + -- begin + -- Self.texture_Set.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.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 - 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; - - - - 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; + -- 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; diff --git a/3-mid/opengl/source/lean/geometry/opengl-geometry-lit_textured.ads b/3-mid/opengl/source/lean/geometry/opengl-geometry-lit_textured.ads index 70e8dc6..a4efe47 100644 --- a/3-mid/opengl/source/lean/geometry/opengl-geometry-lit_textured.ads +++ b/3-mid/opengl/source/lean/geometry/opengl-geometry-lit_textured.ads @@ -1,6 +1,10 @@ with openGL.texture_Set; +private +with + openGL.Geometry.texturing; + package openGL.Geometry.lit_textured -- @@ -45,30 +49,35 @@ 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 Geometry.item with + type Item is new textured_Geometry.item with record - texture_Set : openGL.texture_Set.Item; + null; + -- texture_Set : openGL.texture_Set.Item; end record; - overriding - procedure enable_Textures (Self : in out Item); + -- overriding + -- procedure enable_Textures (Self : in out Item); end openGL.Geometry.lit_textured; diff --git a/3-mid/opengl/source/lean/geometry/opengl-geometry-texturing.adb b/3-mid/opengl/source/lean/geometry/opengl-geometry-texturing.adb index b194265..7ac815f 100644 --- a/3-mid/opengl/source/lean/geometry/opengl-geometry-texturing.adb +++ b/3-mid/opengl/source/lean/geometry/opengl-geometry-texturing.adb @@ -98,4 +98,104 @@ is 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; diff --git a/3-mid/opengl/source/lean/geometry/opengl-geometry-texturing.ads b/3-mid/opengl/source/lean/geometry/opengl-geometry-texturing.ads index 264398a..f66a209 100644 --- a/3-mid/opengl/source/lean/geometry/opengl-geometry-texturing.ads +++ b/3-mid/opengl/source/lean/geometry/opengl-geometry-texturing.ads @@ -49,4 +49,53 @@ is 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; diff --git a/3-mid/opengl/source/lean/geometry/opengl-geometry.adb b/3-mid/opengl/source/lean/geometry/opengl-geometry.adb index 048017c..9141999 100644 --- a/3-mid/opengl/source/lean/geometry/opengl-geometry.adb +++ b/3-mid/opengl/source/lean/geometry/opengl-geometry.adb @@ -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 is 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) is begin diff --git a/3-mid/opengl/source/lean/geometry/opengl-geometry.ads b/3-mid/opengl/source/lean/geometry/opengl-geometry.ads index 241cb91..5123255 100644 --- a/3-mid/opengl/source/lean/geometry/opengl-geometry.ads +++ b/3-mid/opengl/source/lean/geometry/opengl-geometry.ads @@ -50,9 +50,21 @@ is procedure Label_is (Self : in out Item'Class; Now : in 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; function Texture (Self : in Item) return openGL.Texture.Object; + + 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.