From 5707b1783fd6233f02baff3b36db94e7ca177487 Mon Sep 17 00:00:00 2001 From: Rod Kay Date: Sun, 7 Sep 2025 12:28:53 +1000 Subject: [PATCH] opengl.model.circle.lit_textured: Use model texturing mixin. --- 3-mid/opengl/source/demo/opengl-demo.adb | 9 +- .../opengl-model-circle-lit_textured.adb | 98 ++----------------- .../opengl-model-circle-lit_textured.ads | 58 ++--------- .../opengl-model-polygon-lit_textured.ads | 6 +- .../lean/model/opengl-model-texturing.adb | 25 +++-- .../lean/model/opengl-model-texturing.ads | 46 ++++----- 4-high/gel/source/forge/gel-forge.adb | 12 +-- 7 files changed, 63 insertions(+), 191 deletions(-) diff --git a/3-mid/opengl/source/demo/opengl-demo.adb b/3-mid/opengl/source/demo/opengl-demo.adb index 6166f87..ca992e3 100644 --- a/3-mid/opengl/source/demo/opengl-demo.adb +++ b/3-mid/opengl/source/demo/opengl-demo.adb @@ -194,10 +194,7 @@ is the_lit_textured_circle_Model : constant Model.circle.lit_textured.view := Model.circle.lit_textured.new_Circle (Radius => 1.5, - -- Face => (Texture_Details => (Fades => (1 => 0.0, others => <>), - -- Textures => (1 => the_Texture, others => <>), - -- texture_Count => 1)), - Face => (Texture_Details => (openGL.texture_Set.to_Details ([1 => the_Texture]))), + Texture_Details => (openGL.texture_Set.to_Details ([1 => the_Texture])), Sides => 24); the_grid_Model : constant Model.grid.view @@ -259,10 +256,6 @@ is the_lit_textured_polygon_Model : constant Model.polygon.lit_textured.view := Model.polygon.lit_textured.new_Polygon (vertex_Sites => [Origin_2D, [1.0, 0.0], [1.0, 1.0], [-1.0, 0.5]], - -- Face => (Fades => (1 => 0.0, others => <>), - -- Textures => (1 => the_Texture, others => <>), - -- texture_Tiling => <>, - -- texture_Count => 1)); texture_Details => (openGL.texture_Set.to_Details ([1 => the_Texture]))); the_text_Model : constant Model.Text.lit_colored.view diff --git a/3-mid/opengl/source/lean/model/opengl-model-circle-lit_textured.adb b/3-mid/opengl/source/lean/model/opengl-model-circle-lit_textured.adb index d9d3665..998c52d 100644 --- a/3-mid/opengl/source/lean/model/opengl-model-circle-lit_textured.adb +++ b/3-mid/opengl/source/lean/model/opengl-model-circle-lit_textured.adb @@ -10,14 +10,14 @@ is --- Forge -- - function new_circle (Radius : in Real; - Face : in lit_textured.Face_t; - Sides : in Positive := 24) return View + function new_circle (Radius : in Real; + texture_Details : in texture_Set.Details; + Sides : in Positive := 24) return View is Self : constant View := new Item; begin Self.Radius := Radius; - Self.Face := Face; + Self.texture_Details_is (texture_Details); Self.Sides := Sides; return Self; @@ -29,90 +29,6 @@ is --- Attributes --- ------------------ - function Face (Self : in Item) return Face_t - is - begin - return Self.Face; - end Face; - - - - ------------ - -- 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; - - --------------------- --- openGL Geometries @@ -165,15 +81,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; diff --git a/3-mid/opengl/source/lean/model/opengl-model-circle-lit_textured.ads b/3-mid/opengl/source/lean/model/opengl-model-circle-lit_textured.ads index 7fdd5c8..181dac0 100644 --- a/3-mid/opengl/source/lean/model/opengl-model-circle-lit_textured.ads +++ b/3-mid/opengl/source/lean/model/opengl-model-circle-lit_textured.ads @@ -1,78 +1,40 @@ with openGL.texture_Set, - openGL.Texture; + openGL.Texture, + openGL.Model.texturing; package openGL.Model.circle.lit_textured -- --- Models a lit, colored and textured hexagon. +-- Models a lit and textured circle. -- is - type Item is new Model.item with private; + package textured_Model is new texturing.Mixin (Model.circle.item); + + type Item is new textured_Model.textured_Item with private; type View is access all Item'Class; - type Face_t is - record - texture_Details : texture_Set.Details; - end record; - - --------- --- Forge -- - function new_circle (Radius : in Real; - Face : in lit_textured.Face_t; - Sides : in Positive := 24) return View; + function new_circle (Radius : in Real; + texture_Details : in texture_Set.Details; + Sides : in Positive := 24) return View; -------------- --- Attributes -- - function Face (Self : in Item) return Face_t; - - 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 - -- - - 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.circle.item with - record - Face : lit_textured.Face_t; - end record; + type Item is new textured_Model.textured_Item with null record; end openGL.Model.circle.lit_textured; 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 3715251..112a9fe 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 @@ -9,9 +9,9 @@ package openGL.Model.polygon.lit_textured -- Models a lit and textured polygon. -- is - package textured_Model is new texturing.Mixin; + package textured_Model is new texturing.Mixin (openGL.Model.polygon.item); - type Item is new textured_Model.item with private; + type Item is new textured_Model.textured_item with private; type View is access all Item'Class; @@ -33,7 +33,7 @@ is private - type Item is new textured_Model.item with + type Item is new textured_Model.textured_item with record vertex_Sites : Vector_2_array (1 .. 8); vertex_Count : Positive; 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 4da61d7..093d363 100644 --- a/3-mid/opengl/source/lean/model/opengl-model-texturing.adb +++ b/3-mid/opengl/source/lean/model/opengl-model-texturing.adb @@ -92,7 +92,6 @@ is end; end loop; - Uniforms.Count := for_Program.uniform_Variable ("texture_Count"); end create; @@ -106,8 +105,8 @@ is package body Mixin 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 textured_Item; Which : in texture_Set.texture_Id; + Now : in texture_Set.fade_Level) is begin Self.texture_Details.Fades (which) := Now; @@ -116,7 +115,7 @@ is overriding - function Fade (Self : in Item; Which : in texture_Set.texture_Id) return texture_Set.fade_Level + function Fade (Self : in textured_Item; Which : in texture_Set.texture_Id) return texture_Set.fade_Level is begin return Self.texture_Details.Fades (which); @@ -124,8 +123,8 @@ is - procedure Texture_is (Self : in out Item; Which : in texture_Set.texture_Id; - Now : in openGL.asset_Name) + procedure Texture_is (Self : in out textured_Item; Which : in texture_Set.texture_Id; + Now : in openGL.asset_Name) is begin Self.texture_Details.Textures (Positive (which)) := Now; @@ -135,7 +134,7 @@ is overriding - function texture_Count (Self : in Item) return Natural + function texture_Count (Self : in textured_Item) return Natural is begin return Self.texture_Details.texture_Count; @@ -144,7 +143,7 @@ is overriding - function texture_Applied (Self : in Item; Which : in texture_Set.texture_Id) return Boolean + function texture_Applied (Self : in textured_Item; Which : in texture_Set.texture_Id) return Boolean is begin return Self.texture_Details.texture_Applies (Which); @@ -153,8 +152,8 @@ is overriding - procedure texture_Applied_is (Self : in out Item; Which : in texture_Set.texture_Id; - Now : in Boolean) + procedure texture_Applied_is (Self : in out textured_Item; Which : in texture_Set.texture_Id; + Now : in Boolean) is begin Self.texture_Details.texture_Applies (Which) := Now; @@ -164,7 +163,7 @@ is overriding - procedure animate (Self : in out Item) + procedure animate (Self : in out textured_Item) is use type texture_Set.Animation_view; begin @@ -179,14 +178,14 @@ is - function texture_Details (Self : in Item) return openGL.texture_Set.Details + function texture_Details (Self : in textured_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) + procedure texture_Details_is (Self : in out textured_Item; Now : in openGL.texture_Set.Details) is begin Self.texture_Details := Now; 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 0cc1db5..ff7a3d7 100644 --- a/3-mid/opengl/source/lean/model/opengl-model-texturing.ads +++ b/3-mid/opengl/source/lean/model/opengl-model-texturing.ads @@ -48,45 +48,47 @@ is ------------- generic - package Mixin - is type Item is abstract new Model.item with private; - - 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; + package Mixin + is + type textured_Item is abstract new Item with private; overriding - function texture_Applied (Self : in Item; Which : in texture_Set.texture_Id) return Boolean; + function Fade (Self : in textured_Item; Which : in texture_Set.texture_Id) return texture_Set.fade_Level; overriding - procedure texture_Applied_is (Self : in out Item; Which : in texture_Set.texture_Id; - Now : in Boolean); + procedure Fade_is (Self : in out textured_Item; Which : in texture_Set.texture_Id; + Now : in texture_Set.fade_Level); + + procedure Texture_is (Self : in out textured_Item; Which : in texture_Set.texture_Id; + Now : in asset_Name); overriding - procedure animate (Self : in out Item); + function texture_Count (Self : in textured_Item) return Natural; - function texture_Details (Self : in Item) return openGL.texture_Set.Details; + overriding + function texture_Applied (Self : in textured_Item; Which : in texture_Set.texture_Id) return Boolean; - procedure texture_Details_is (Self : in out Item; Now : in openGL.texture_Set.Details); + overriding + procedure texture_Applied_is (Self : in out textured_Item; Which : in texture_Set.texture_Id; + Now : in Boolean); + + overriding + procedure animate (Self : in out textured_Item); + + + function texture_Details (Self : in textured_Item) return openGL.texture_Set.Details; + + procedure texture_Details_is (Self : in out textured_Item; Now : in openGL.texture_Set.Details); private - type Item is abstract new Model.item with + type textured_Item is abstract new Item with record texture_Details : openGL.texture_Set.Details; end record; diff --git a/4-high/gel/source/forge/gel-forge.adb b/4-high/gel/source/forge/gel-forge.adb index df05ee5..7018349 100644 --- a/4-high/gel/source/forge/gel-forge.adb +++ b/4-high/gel/source/forge/gel-forge.adb @@ -164,12 +164,12 @@ is else the_graphics_Model := openGL.Model.circle.lit_textured.new_Circle (Radius, - Face => (texture_Details => (Fades => [1 => 0.0, others => <>], - texture_Applies => [1 => True, others => <>], - Textures => [1 => Texture, others => <>], - texture_Count => 1, - texture_Tiling => (S => 1.0, T => 1.0), - Animation => null))).all'Access; + texture_Details => (Fades => [1 => 0.0, others => <>], + texture_Applies => [1 => True, others => <>], + Textures => [1 => Texture, others => <>], + texture_Count => 1, + texture_Tiling => (S => 1.0, T => 1.0), + Animation => null)).all'Access; end if; return gel.Sprite.Forge.new_Sprite (Name,