From b7661559873c8e77aa568b7b7bf7be19704a0eef Mon Sep 17 00:00:00 2001 From: Rod Kay Date: Sun, 7 Sep 2025 06:27:46 +1000 Subject: [PATCH] opengl.model.polygon.lit_textured: Use model texturing mixin. --- 3-mid/opengl/source/demo/opengl-demo.adb | 4 +- .../opengl-model-polygon-lit_textured.adb | 186 ++++++++++-------- .../opengl-model-polygon-lit_textured.ads | 76 +++---- .../lean/model/opengl-model-texturing.adb | 130 ++++++------ .../lean/model/opengl-model-texturing.ads | 49 ++--- 4-high/gel/source/forge/gel-forge.adb | 14 +- 6 files changed, 243 insertions(+), 216 deletions(-) diff --git a/3-mid/opengl/source/demo/opengl-demo.adb b/3-mid/opengl/source/demo/opengl-demo.adb index 7139224..6166f87 100644 --- a/3-mid/opengl/source/demo/opengl-demo.adb +++ b/3-mid/opengl/source/demo/opengl-demo.adb @@ -213,7 +213,7 @@ is the_textured_hexagon_Model : constant Model.hexagon.lit_textured.view := Model.hexagon.lit_textured.new_Hexagon (Radius => 0.5, Face => (Fades => [1 => 0.0, others => <>], - Textures => (1 => the_Texture, others => <>), + Textures => [1 => the_Texture, others => <>], texture_Count => 1, texture_Applies => <>, Animation => null)); @@ -263,7 +263,7 @@ is -- Textures => (1 => the_Texture, others => <>), -- texture_Tiling => <>, -- texture_Count => 1)); - Face => (Texture_Details => (openGL.texture_Set.to_Details ([1 => the_Texture])))); + texture_Details => (openGL.texture_Set.to_Details ([1 => the_Texture]))); the_text_Model : constant Model.Text.lit_colored.view := Model.Text.lit_colored.new_Text (Text => "Once upon a midnight dreary ...", diff --git a/3-mid/opengl/source/lean/model/opengl-model-polygon-lit_textured.adb b/3-mid/opengl/source/lean/model/opengl-model-polygon-lit_textured.adb index c6d9df2..b959ca5 100644 --- a/3-mid/opengl/source/lean/model/opengl-model-polygon-lit_textured.adb +++ b/3-mid/opengl/source/lean/model/opengl-model-polygon-lit_textured.adb @@ -10,15 +10,29 @@ is --- Forge -- - function new_polygon (vertex_Sites : in Vector_2_array; - Face : in Face_t) return View + -- function new_polygon (vertex_Sites : in Vector_2_array; + -- Face : in Face_t) return View + -- is + -- Self : constant View := new Item; + -- begin + -- Self.vertex_Sites (1 .. vertex_Sites'Length) := vertex_Sites; + -- Self.vertex_Count := vertex_Sites'Length; + -- + -- Self.Face := Face; + -- + -- return Self; + -- end new_polygon; + + + function new_polygon (vertex_Sites : in Vector_2_array; + texture_Details : in texture_Set.Details) return View is Self : constant View := new Item; begin Self.vertex_Sites (1 .. vertex_Sites'Length) := vertex_Sites; Self.vertex_Count := vertex_Sites'Length; - Self.Face := Face; + Self.texture_Details_is (texture_Details); return Self; end new_polygon; @@ -30,11 +44,11 @@ is --- Attributes --- ------------------ - function Face (Self : in Item) return Face_t - is - begin - return Self.Face; - end Face; + -- function texture_Details (Self : in Item) return texture_Set.Details + -- is + -- begin + -- return Self.texture_Details; + -- end texture_Details; @@ -42,77 +56,77 @@ is -- Texturing -- - overriding - procedure Fade_is (Self : in out Item; Which : in texture_Set.texture_Id; - Now : in texture_Set.fade_Level) - is - begin - Self.Face.texture_Details.Fades (which) := 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.Face.texture_Details.Fades (which); - end Fade; - - - - procedure Texture_is (Self : in out Item; Which : in texture_Set.texture_Id; - Now : in openGL.asset_Name) - is - begin - Self.Face.texture_Details.Textures (Positive (which)) := Now; - end Texture_is; - - - - - overriding - function texture_Count (Self : in Item) return Natural - is - begin - return Self.Face.texture_Details.texture_Count; - end texture_Count; - - - - overriding - function texture_Applied (Self : in Item; Which : in texture_Set.texture_Id) return Boolean - is - begin - return Self.Face.texture_Details.texture_Applies (Which); - end texture_Applied; - - - - overriding - procedure texture_Applied_is (Self : in out Item; Which : in texture_Set.texture_Id; - Now : in Boolean) - is - begin - Self.Face.texture_Details.texture_Applies (Which) := Now; - end texture_Applied_is; - - - - - overriding - procedure animate (Self : in out Item) - is - use type texture_Set.Animation_view; - begin - if Self.Face.texture_Details.Animation = null - then - return; - end if; - - texture_Set.animate (Self.Face.texture_Details.Animation.all, - Self.Face.texture_Details.texture_Applies); - end animate; + -- overriding + -- procedure Fade_is (Self : in out Item; Which : in texture_Set.texture_Id; + -- Now : in texture_Set.fade_Level) + -- is + -- begin + -- Self.Face.texture_Details.Fades (which) := 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.Face.texture_Details.Fades (which); + -- end Fade; + -- + -- + -- + -- procedure Texture_is (Self : in out Item; Which : in texture_Set.texture_Id; + -- Now : in openGL.asset_Name) + -- is + -- begin + -- Self.Face.texture_Details.Textures (Positive (which)) := Now; + -- end Texture_is; + -- + -- + -- + -- + -- overriding + -- function texture_Count (Self : in Item) return Natural + -- is + -- begin + -- return Self.Face.texture_Details.texture_Count; + -- end texture_Count; + -- + -- + -- + -- overriding + -- function texture_Applied (Self : in Item; Which : in texture_Set.texture_Id) return Boolean + -- is + -- begin + -- return Self.Face.texture_Details.texture_Applies (Which); + -- end texture_Applied; + -- + -- + -- + -- overriding + -- procedure texture_Applied_is (Self : in out Item; Which : in texture_Set.texture_Id; + -- Now : in Boolean) + -- is + -- begin + -- Self.Face.texture_Details.texture_Applies (Which) := Now; + -- end texture_Applied_is; + -- + -- + -- + -- + -- overriding + -- procedure animate (Self : in out Item) + -- is + -- use type texture_Set.Animation_view; + -- begin + -- if Self.Face.texture_Details.Animation = null + -- then + -- return; + -- end if; + -- + -- texture_Set.animate (Self.Face.texture_Details.Animation.all, + -- Self.Face.texture_Details.texture_Applies); + -- end animate; @@ -164,15 +178,15 @@ is the_Geometry.Vertices_are (Vertices); the_Geometry.add (Primitive.view (the_Primitive)); - for i in 1 .. Self.Face.texture_Details.texture_Count + for i in 1 .. Self.texture_Details.texture_Count loop Id := texture_Id (i); the_Geometry.Fade_is (which => Id, - now => Self.Face.texture_Details.Fades (Id)); + now => Self.texture_Details.Fades (Id)); the_Geometry.Texture_is (which => Id, - now => Textures.fetch (Self.Face.texture_Details.Textures (i))); + now => Textures.fetch (Self.texture_Details.Textures (i))); the_Geometry.is_Transparent (now => the_Geometry.Texture.is_Transparent); end loop; @@ -198,15 +212,15 @@ is loop the_Vertices (Index_t (i)) := (Site => Vector_3 (the_Sites (i) & 0.0), Normal => Normal, - Coords => (Coords_and_Centroid.Coords (Index_t (i)).S * Self.Face.texture_Details.texture_Tiling.S, - Coords_and_Centroid.Coords (Index_t (i)).T * Self.Face.texture_Details.texture_Tiling.T), + Coords => (Coords_and_Centroid.Coords (Index_t (i)).S * Self.texture_Details.texture_Tiling.S, + Coords_and_Centroid.Coords (Index_t (i)).T * Self.texture_Details.texture_Tiling.T), Shine => default_Shine); end loop; the_Vertices (the_Vertices'Last) := (Site => Vector_3 (Coords_and_Centroid.Centroid & 0.0), Normal => Normal, - Coords => (S => 0.5 * Self.Face.texture_Details.texture_Tiling.S, - T => 0.5 * Self.Face.texture_Details.texture_Tiling.T), + Coords => (S => 0.5 * Self.texture_Details.texture_Tiling.S, + T => 0.5 * Self.texture_Details.texture_Tiling.T), Shine => default_Shine); face_Geometry := new_Geometry (Vertices => the_Vertices); diff --git a/3-mid/opengl/source/lean/model/opengl-model-polygon-lit_textured.ads b/3-mid/opengl/source/lean/model/opengl-model-polygon-lit_textured.ads index 4f85c29..1a64f46 100644 --- a/3-mid/opengl/source/lean/model/opengl-model-polygon-lit_textured.ads +++ b/3-mid/opengl/source/lean/model/opengl-model-polygon-lit_textured.ads @@ -1,6 +1,7 @@ with openGL.texture_Set, - openGL.Texture; + openGL.Texture, + openGL.Model.texturing; package openGL.Model.polygon.lit_textured @@ -8,7 +9,9 @@ package openGL.Model.polygon.lit_textured -- Models a lit and textured polygon. -- is - type Item is new Model.item with private; + package textured_Model is new texturing.Mixin; + + type Item is new textured_Model.item with private; type View is access all Item'Class; @@ -17,25 +20,30 @@ is --- Face -- - type Face_t is - record - texture_Details : texture_Set.Details; - end record; + -- type Face_t is + -- record + -- texture_Details : texture_Set.Details; + -- end record; --------- --- Forge -- - function new_Polygon (vertex_Sites : in Vector_2_array; - Face : in lit_textured.Face_t) return View; + -- function new_Polygon (vertex_Sites : in Vector_2_array; + -- Face : in lit_textured.Face_t) return View; + + function new_Polygon (vertex_Sites : in Vector_2_array; + texture_Details : in texture_Set.Details) return View; -------------- --- Attributes -- - function Face (Self : in Item) return Face_t; + -- function Face (Self : in Item) return Face_t; + -- overriding + -- function texture_Details (Self : in Item) return texture_Set.Details; overriding function to_GL_Geometries (Self : access Item; Textures : access Texture.name_Map_of_texture'Class; @@ -45,40 +53,40 @@ is -- Texturing -- - overriding - function Fade (Self : in Item; Which : in texture_Set.texture_Id) return texture_Set.fade_Level; - - overriding - procedure Fade_is (Self : in out Item; Which : in texture_Set.texture_Id; - Now : in texture_Set.fade_Level); - - procedure Texture_is (Self : in out Item; Which : in texture_Set.texture_Id; - Now : in asset_Name); - - overriding - function texture_Count (Self : in Item) return Natural; - - - overriding - function texture_Applied (Self : in Item; Which : in texture_Set.texture_Id) return Boolean; - - overriding - procedure texture_Applied_is (Self : in out Item; Which : in texture_Set.texture_Id; - Now : in Boolean); - - overriding - procedure animate (Self : in out Item); + -- overriding + -- function Fade (Self : in Item; Which : in texture_Set.texture_Id) return texture_Set.fade_Level; + -- + -- overriding + -- procedure Fade_is (Self : in out Item; Which : in texture_Set.texture_Id; + -- Now : in texture_Set.fade_Level); + -- + -- procedure Texture_is (Self : in out Item; Which : in texture_Set.texture_Id; + -- Now : in asset_Name); + -- + -- overriding + -- function texture_Count (Self : in Item) return Natural; + -- + -- + -- overriding + -- function texture_Applied (Self : in Item; Which : in texture_Set.texture_Id) return Boolean; + -- + -- overriding + -- procedure texture_Applied_is (Self : in out Item; Which : in texture_Set.texture_Id; + -- Now : in Boolean); + -- + -- overriding + -- procedure animate (Self : in out Item); private - type Item is new Model.polygon.item with + type Item is new textured_Model.item with record vertex_Sites : Vector_2_array (1 .. 8); vertex_Count : Positive; - Face : lit_textured.Face_t; + -- Face : lit_textured.Face_t; end record; diff --git a/3-mid/opengl/source/lean/model/opengl-model-texturing.adb b/3-mid/opengl/source/lean/model/opengl-model-texturing.adb index 5f393a1..2813f7d 100644 --- a/3-mid/opengl/source/lean/model/opengl-model-texturing.adb +++ b/3-mid/opengl/source/lean/model/opengl-model-texturing.adb @@ -29,23 +29,23 @@ is GL_TEXTURE12, GL_TEXTURE13, GL_TEXTURE14, - GL_TEXTURE15, - GL_TEXTURE16, - GL_TEXTURE17, - GL_TEXTURE18, - GL_TEXTURE19, - GL_TEXTURE20, - GL_TEXTURE21, - GL_TEXTURE22, - GL_TEXTURE23, - GL_TEXTURE24, - GL_TEXTURE25, - GL_TEXTURE26, - GL_TEXTURE27, - GL_TEXTURE28, - GL_TEXTURE29, - GL_TEXTURE30, - GL_TEXTURE31]; + GL_TEXTURE15]; + -- GL_TEXTURE16, + -- GL_TEXTURE17, + -- GL_TEXTURE18, + -- GL_TEXTURE19, + -- GL_TEXTURE20, + -- GL_TEXTURE21, + -- GL_TEXTURE22, + -- GL_TEXTURE23, + -- GL_TEXTURE24, + -- GL_TEXTURE25, + -- GL_TEXTURE26, + -- GL_TEXTURE27, + -- GL_TEXTURE28, + -- GL_TEXTURE29, + -- GL_TEXTURE30, + -- GL_TEXTURE31]; @@ -106,90 +106,94 @@ is --- 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; Now : in texture_Set.fade_Level; - Which : in texture_Set.texture_ID := 1) + 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; + Self.texture_Details.Fades (which) := Now; end Fade_is; overriding - function Fade (Self : in Item; Which : in texture_Set.texture_ID := 1) return texture_Set.fade_Level + 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; + return Self.texture_Details.Fades (which); end Fade; - overriding - procedure Texture_is (Self : in out Item; Now : in openGL.Texture.Object; - Which : in texture_Set.texture_ID := 1) + procedure Texture_is (Self : in out Item; Which : in texture_Set.texture_Id; + Now : in openGL.asset_Name) is begin - Texture_is (in_Set => Self.texture_Set, - Which => Which, - Now => Now); + Self.texture_Details.Textures (Positive (which)) := Now; end Texture_is; + overriding - function Texture (Self : in Item; Which : texture_Set.texture_ID := 1) return openGL.Texture.Object + function texture_Count (Self : in Item) return Natural is begin - return openGL.texture_Set.Texture (in_Set => Self.texture_Set, - Which => Which); - end Texture; + return Self.texture_Details.texture_Count; + end texture_Count; overriding - procedure texture_Applied_is (Self : in out Item; Now : in Boolean; - Which : in texture_Set.texture_ID := 1) + function texture_Applied (Self : in Item; Which : in texture_Set.texture_Id) return Boolean is begin - Self.texture_Set.Textures (Which).Applied := Now; - end texture_Applied_is; - - - - overriding - function texture_Applied (Self : in Item; Which : in texture_Set.texture_ID := 1) return Boolean - is - begin - return Self.texture_Set.Textures (Which).Applied; + return Self.texture_Details.texture_Applies (Which); end texture_Applied; overriding - procedure enable_Textures (Self : in out Item) + procedure texture_Applied_is (Self : in out Item; Which : in texture_Set.texture_Id; + Now : in Boolean) is begin - texturing.enable (for_Model => Self.Model.all'Access, - Uniforms => texture_Uniforms, - texture_Set => Self.texture_Set); - end enable_Textures; + Self.texture_Details.texture_Applies (Which) := Now; + end texture_Applied_is; + + + + + overriding + procedure animate (Self : in out Item) + is + use type texture_Set.Animation_view; + begin + if Self.texture_Details.Animation = null + then + return; + end if; + + texture_Set.animate (Self.texture_Details.Animation.all, + Self.texture_Details.texture_Applies); + end animate; + + + + function texture_Details (Self : in Item) return openGL.texture_Set.Details + is + begin + return Self.texture_Details; + end texture_Details; + + + procedure texture_Details_is (Self : in out Item; Now : in openGL.texture_Set.Details) + is + begin + Self.texture_Details := Now; + end texture_Details_is; end Mixin; diff --git a/3-mid/opengl/source/lean/model/opengl-model-texturing.ads b/3-mid/opengl/source/lean/model/opengl-model-texturing.ads index 72b71c0..f975c96 100644 --- a/3-mid/opengl/source/lean/model/opengl-model-texturing.ads +++ b/3-mid/opengl/source/lean/model/opengl-model-texturing.ads @@ -4,7 +4,7 @@ with openGL.Program; -private +-- private package openGL.Model.texturing -- -- Provides texturing support for models. @@ -54,44 +54,45 @@ is 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; Now : in texture_Set.fade_Level; - Which : in texture_Set.texture_ID := 1); - overriding - function Fade (Self : in Item; Which : in texture_Set.texture_ID := 1) return texture_Set.fade_Level; + type Item is abstract new Model.item with private; overriding - procedure Texture_is (Self : in out Item; Now : in openGL.Texture.Object; - Which : in texture_Set.texture_ID := 1); + function Fade (Self : in Item; Which : in texture_Set.texture_Id) return texture_Set.fade_Level; + overriding - function Texture (Self : in Item; Which : in texture_Set.texture_ID := 1) return openGL.Texture.Object; + procedure Fade_is (Self : in out Item; Which : in texture_Set.texture_Id; + Now : in texture_Set.fade_Level); + + procedure Texture_is (Self : in out Item; Which : in texture_Set.texture_Id; + Now : in asset_Name); + + overriding + function texture_Count (Self : in Item) return Natural; overriding - procedure texture_Applied_is (Self : in out Item; Now : in Boolean; - Which : in texture_Set.texture_ID := 1); - overriding - function texture_Applied (Self : in Item; Which : in texture_Set.texture_ID := 1) return Boolean; - + function texture_Applied (Self : in Item; Which : in texture_Set.texture_Id) return Boolean; overriding - procedure enable_Textures (Self : in out Item); + procedure texture_Applied_is (Self : in out Item; Which : in texture_Set.texture_Id; + Now : in Boolean); + + overriding + procedure animate (Self : in out Item); + + + function texture_Details (Self : in Item) return openGL.texture_Set.Details; + + procedure texture_Details_is (Self : in out Item; Now : in openGL.texture_Set.Details); private - type Item is new Geometry.item with + type Item is abstract new Model.item with record - texture_Set : openGL.texture_Set.item; + texture_Details : openGL.texture_Set.Details; end record; end Mixin; diff --git a/4-high/gel/source/forge/gel-forge.adb b/4-high/gel/source/forge/gel-forge.adb index 462057c..df05ee5 100644 --- a/4-high/gel/source/forge/gel-forge.adb +++ b/4-high/gel/source/forge/gel-forge.adb @@ -217,13 +217,13 @@ is the_graphics_Model := openGL.Model.polygon.lit_colored.new_Polygon (openGL.Vector_2_array (Vertices), (Color, openGL.Opaque)).all'Access; else - the_graphics_Model := openGL.Model.polygon.lit_textured.new_Polygon (vertex_Sites => openGL.Vector_2_array (Vertices), - Face => (texture_Details => ((Fades => [1 => 0.0, others => <>], - Textures => [1 => Texture, others => <>], - texture_Count => 1, - texture_Tiling => texture_Tiling, - texture_Applies => [others => True], - Animation => null)))).all'Access; + the_graphics_Model := openGL.Model.polygon.lit_textured.new_Polygon (vertex_Sites => openGL.Vector_2_array (Vertices), + texture_Details => (Fades => [1 => 0.0, others => <>], + Textures => [1 => Texture, others => <>], + texture_Count => 1, + texture_Tiling => texture_Tiling, + texture_Applies => [others => True], + Animation => null)).all'Access; end if; return gel.Sprite.Forge.new_Sprite (Name,