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

opengl: Add tiling for multi-textures.

Browse Source
This commit is contained in:
Rod Kay
2025-09-24 12:14:44 +10:00
parent 9469acaf91
commit 4dc7e235f0
20 changed files with 274 additions and 62 deletions
Download Patch File Download Diff File Expand all files Collapse all files

25
3-mid/opengl/applet/demo/renderer/render_models/launch_render_models.adb
View File

@@ -38,28 +38,6 @@ begin
end;
-- Set the lights initial position to far behind and far to the left.
--
-- declare
-- use openGL.Palette;
--
-- initial_Site : constant openGL.Vector_3 := (0.0, 0.0, 15.0);
-- cone_Direction : constant openGL.Vector_3 := (0.0, 0.0, -1.0);
--
-- Light : openGL.Light.diffuse.item := Demo.Renderer.Light (Id => 1);
-- begin
-- Light.Color_is (Ambient => (Grey, Opaque),
-- Diffuse => (White, Opaque));
-- -- Specular => (White, Opaque));
--
-- Light.Position_is (initial_Site);
-- Light.cone_Direction_is (cone_Direction);
--
-- Demo.Renderer.Light_is (Id => 1, Now => Light);
-- end;
declare
-- The models.
--
@@ -78,10 +56,9 @@ begin
the_Visuals (i) := new_Visual (the_Models (i));
end loop;
the_Visuals (4).Site_is ([0.0, 0.0, -50.0]);
the_Visuals (1).Scale_is ([0.2, 0.2, 1.0]); -- Text visual.
-- Main loop.
--
while not Demo.Done

84
3-mid/opengl/applet/demo/textures/tiling/launch_tiling_demo.adb Normal file
View File

@@ -0,0 +1,84 @@
with
openGL.Model.polygon.lit_textured,
openGL.texture_Set,
openGL.Visual,
openGL.Light,
openGL.Palette,
openGL.Demo;
procedure launch_tiling_Demo
--
-- Exercise the renderer with an example of all the models.
--
is
use openGL,
openGL.Math,
openGL.linear_Algebra_3D,
openGL.Palette;
begin
Demo.print_Usage ("Use space ' ' to cycle through models.");
Demo.define ("openGL 'Render Models' Demo");
Demo.Camera.Position_is ([0.0, 0.0, 2.0],
y_Rotation_from (to_Radians (0.0)));
declare
use openGL.Light;
the_Light : openGL.Light.item := Demo.Renderer.new_Light;
begin
the_Light.Site_is ([0.0, 0.0, 5.0]);
the_Light.Color_is (White);
Demo.Renderer.set (the_Light);
end;
declare
the_Texture : constant asset_Name := to_Asset ("assets/opengl/texture/Face1.bmp");
Details : openGL.texture_Set.Details := openGL.texture_Set.to_Details ([1 => the_Texture]);
the_Model : Model.polygon.lit_textured.view;
-- := Model.polygon.lit_textured.new_Polygon (vertex_Sites => [[-1.0, -1.0], [1.0, -1.0], [1.0, 1.0], [-1.0, 1.0]],
-- texture_Details => openGL.texture_Set.to_Details ([1 => the_Texture]));
-- The visuals.
--
use openGL.Visual.Forge;
the_Visual : openGL.Visual.view;
begin
Details.texture_Tilings (1) := (S => 5.0, T => 4.0);
the_Model := Model.polygon.lit_textured.new_Polygon (vertex_Sites => [[-1.0, -1.0], [1.0, -1.0], [1.0, 1.0], [-1.0, 1.0]],
texture_Details => Details);
the_Visual := new_Visual (the_Model.all'Access);
-- Main loop.
--
while not Demo.Done
loop
Demo.Dolly.evolve;
Demo.Done := Demo.Dolly.quit_Requested;
-- Render all visuals.
--
Demo.Camera.render ([1 => the_Visual]);
while not Demo.Camera.cull_Completed
loop
delay Duration'Small;
end loop;
Demo.Renderer.render;
Demo.FPS_Counter.increment; -- Frames per second display.
delay 1.0 / 60.0;
end loop;
end;
Demo.destroy;
end launch_tiling_Demo;

17
3-mid/opengl/applet/demo/textures/tiling/tiling_demo.gpr Normal file
View File

@@ -0,0 +1,17 @@
with
"opengl_demo",
"lace_shared";
project tiling_Demo
is
for Object_Dir use "build";
for Exec_Dir use ".";
for Main use ("launch_tiling_demo.adb");
package Ide renames Lace_shared.Ide;
package Builder renames Lace_shared.Builder;
package Compiler renames Lace_shared.Compiler;
package Binder renames Lace_shared.Binder;
end tiling_Demo;

16
3-mid/opengl/assets/shader/lit_colored_text.frag
View File

@@ -5,9 +5,10 @@
// Texturing snippet.
//
uniform int texture_Count;
uniform sampler2D Textures [16];
uniform float Fade [16];
uniform sampler2D Textures [16];
uniform float Fade [16];
uniform bool texture_Applies [16];
uniform vec2 Tiling [16];
vec4
apply_Texturing (vec2 Coords)
@@ -18,12 +19,17 @@ apply_Texturing (vec2 Coords)
{
if (texture_Applies [i])
{
Color.rgb += texture (Textures [i], Coords).rgb
* texture (Textures [i], Coords).a
vec2 tiled_Coords;
tiled_Coords.s = Coords.s * Tiling [i].s;
tiled_Coords.t = Coords.t * Tiling [i].t;
Color.rgb += texture (Textures [i], tiled_Coords).rgb
* texture (Textures [i], tiled_Coords).a
* (1.0 - Fade [i]);
Color.a = max (Color.a, texture (Textures [i],
Coords).a);
tiled_Coords).a);
}
}

17
3-mid/opengl/assets/shader/texturing-frag.snippet
View File

@@ -2,6 +2,7 @@ uniform int texture_Count;
uniform sampler2D Textures [16];
uniform float Fade [16];
uniform bool texture_Applies [16];
uniform vec2 Tiling [16];
vec4
@@ -14,17 +15,17 @@ apply_Texturing (vec2 Coords)
{
if (texture_Applies [i])
{
Color.rgb += texture (Textures [i], Coords).rgb
* texture (Textures [i], Coords).a
vec2 tiled_Coords;
tiled_Coords.s = Coords.s * Tiling [i].s;
tiled_Coords.t = Coords.t * Tiling [i].t;
Color.rgb += texture (Textures [i], tiled_Coords).rgb
* texture (Textures [i], tiled_Coords).a
* (1.0 - Fade [i]);
// Color.a += texture (Textures [i], Coords).a * (1.0 - Fade [1]);
Color.a = max (Color.a,
texture (Textures [i],Coords).a * (1.0 - Fade [i]));
// Color.a = max (Color.a,
// texture (Textures [i],Coords).a);
texture (Textures [i], tiled_Coords).a * (1.0 - Fade [i]));
}
}

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

@@ -62,8 +62,10 @@ is
then
for i in 1 .. openGL.texture_Set.texture_Id (for_Model.texture_Count)
loop
Uniforms.Textures (i).fade_Uniform .Value_is (Real (for_Model.Fade (Which => i)));
Uniforms.Textures (i).texture_applied_Uniform.Value_is (for_Model.texture_Applied (Which => i));
Uniforms.Textures (i).tiling_Uniform .Value_is (Vector_2' ((for_Model.Tiling (Which => i).S,
for_Model.Tiling (Which => i).T)));
Uniforms.Textures (i).fade_Uniform .Value_is (Real (for_Model.Fade (Which => i)));
Uniforms.Textures (i).texture_applied_Uniform.Value_is (for_Model.texture_Applied (Which => i));
glUniform1i (Uniforms.Textures (i).texture_Uniform.gl_Variable,
GLint (i) - 1);
@@ -92,10 +94,12 @@ is
texture_uniform_Name : constant String := "Textures[" & trim (Natural'Image (i - 1), Left) & "]";
fade_uniform_Name : constant String := "Fade[" & trim (Natural'Image (i - 1), Left) & "]";
texture_applies_uniform_Name : constant String := "texture_Applies[" & trim (Natural'Image (i - 1), Left) & "]";
tiling_uniform_Name : constant String := "Tiling[" & trim (Natural'Image (i - 1), Left) & "]";
begin
Uniforms.Textures (Id). texture_Uniform := for_Program.uniform_Variable (Named => texture_uniform_Name);
Uniforms.Textures (Id). fade_Uniform := for_Program.uniform_Variable (Named => fade_uniform_Name);
Uniforms.Textures (Id).texture_applied_Uniform := for_Program.uniform_Variable (Named => texture_applies_uniform_Name);
Uniforms.Textures (Id).tiling_Uniform := for_Program.uniform_Variable (Named => tiling_uniform_Name);
end;
end loop;
@@ -139,7 +143,7 @@ is
function Fade (Self : in Item; Which : in texture_Set.texture_ID := 1) return texture_Set.fade_Level
is
begin
return Self.texture_Set.Textures (which).Fade;
return Self.texture_Set.Textures (Which).Fade;
end Fade;
@@ -180,11 +184,34 @@ is
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_Set.Textures (Which).Applied;
end texture_Applied;
overriding
procedure Tiling_is (Self : in out Item; Now : in texture_Set.Tiling;
Which : in texture_Set.texture_ID := 1)
is
begin
Self.texture_Set.Textures (Which).Tiling := Now;
end Tiling_is;
overriding
function Tiling (Self : in Item; Which : in texture_Set.texture_ID := 1) return texture_Set.Tiling
is
begin
return Self.texture_Set.Textures (Which).Tiling;
end Tiling;
overriding
procedure enable_Textures (Self : in out Item)
is

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

@@ -22,6 +22,7 @@ is
texture_Uniform : openGL.Variable.uniform.sampler2D;
fade_Uniform : openGL.Variable.uniform.float;
texture_applied_Uniform : openGL.Variable.uniform.bool;
tiling_Uniform : openGL.Variable.uniform.vec2;
end record;
@@ -50,7 +51,6 @@ is
-------------
--- Mixin ---
-------------
@@ -64,7 +64,6 @@ is
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);
@@ -85,6 +84,11 @@ is
overriding
function texture_Applied (Self : in Item; Which : in texture_Set.texture_ID := 1) return Boolean;
overriding
procedure Tiling_is (Self : in out Item; Now : in texture_Set.Tiling;
Which : in texture_Set.texture_ID := 1);
overriding
function Tiling (Self : in Item; Which : in texture_Set.texture_ID := 1) return texture_Set.Tiling;
overriding

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

@@ -136,6 +136,17 @@ is
function Tiling (Self : in Item; Which : in texture_Set.texture_ID := 1) return texture_Set.Tiling
is
begin
raise program_Error with "Geometry has no texture.";
return (S => 0.0,
T => 0.0);
end Tiling;
procedure Program_is (Self : in out Item; Now : in openGL.Program.view)
is
begin

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

@@ -66,6 +66,10 @@ is
Which : in texture_Set.texture_ID := 1) is null;
function texture_Applied (Self : in Item; Which : in texture_Set.texture_ID := 1) return Boolean;
procedure Tiling_is (Self : in out Item; Now : in texture_Set.Tiling;
Which : in texture_Set.texture_ID := 1) is null;
function Tiling (Self : in Item; Which : in texture_Set.texture_ID := 1) return texture_Set.Tiling;
procedure Bounds_are (Self : in out Item'Class; Now : in Bounds);

8
3-mid/opengl/source/lean/model/opengl-model-polygon-lit_textured.adb
View File

@@ -107,15 +107,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.texture_Details.texture_Tiling.S,
Coords_and_Centroid.Coords (Index_t (i)).T * Self.texture_Details.texture_Tiling.T),
Coords => (Coords_and_Centroid.Coords (Index_t (i)).S,
Coords_and_Centroid.Coords (Index_t (i)).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.texture_Details.texture_Tiling.S,
T => 0.5 * Self.texture_Details.texture_Tiling.T),
Coords => (S => 0.5,
T => 0.5),
Shine => default_Shine);
face_Geometry := new_Geometry (Vertices => the_Vertices);

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

@@ -7,12 +7,13 @@ is
package body Mixin
is
overriding
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;
Self.texture_Details.Fades (Which) := Now;
end Fade_is;
@@ -21,16 +22,36 @@ is
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);
return Self.texture_Details.Fades (Which);
end Fade;
overriding
procedure Tiling_is (Self : in out textured_Item; Which : in texture_Set.texture_Id;
Now : in texture_Set.Tiling)
is
begin
Self.texture_Details.texture_Tilings (Which) := Now;
end Tiling_is;
overriding
function Tiling (Self : in textured_Item; Which : in texture_Set.texture_Id) return texture_Set.Tiling
is
begin
return Self.texture_Details.texture_Tilings (Which);
end Tiling;
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;
Self.texture_Details.Textures (Positive (Which)) := Now;
end Texture_is;

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

@@ -26,6 +26,13 @@ is
procedure Fade_is (Self : in out textured_Item; Which : in texture_Set.texture_Id;
Now : in texture_Set.fade_Level);
overriding
function Tiling (Self : in textured_Item; Which : in texture_Set.texture_Id) return texture_Set.Tiling;
overriding
procedure Tiling_is (Self : in out textured_Item; Which : in texture_Set.texture_Id;
Now : in texture_Set.Tiling);
procedure Texture_is (Self : in out textured_Item; Which : in texture_Set.texture_Id;
Now : in asset_Name);

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

@@ -240,6 +240,25 @@ is
procedure Tiling_is (Self : in out Item; Which : in texture_Set.texture_Id;
Now : in texture_Set.Tiling)
is
begin
raise program_Error with External_Tag (Model.item'Class (Self)'Tag) & " Model does not support texturing.";
end Tiling_is;
function Tiling (Self : in Item; Which : in texture_Set.texture_Id) return texture_Set.Tiling
is
begin
raise program_Error with External_Tag (Model.item'Class (Self)'Tag) & " Model does not support texturing.";
return (S => 0.0,
T => 0.0);
end Tiling;
function texture_Count (Self : in Item) return Natural
is
begin

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

@@ -78,6 +78,10 @@ is
procedure Fade_is (Self : in out Item; Which : in texture_Set.texture_Id;
Now : in texture_Set.fade_Level);
function Tiling (Self : in Item; Which : in texture_Set.texture_Id) return texture_Set.Tiling;
procedure Tiling_is (Self : in out Item; Which : in texture_Set.texture_Id;
Now : in texture_Set.Tiling);
function texture_Count (Self : in Item) return Natural;
function texture_Applied (Self : in Item; Which : in texture_Set.texture_Id) return Boolean;

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

@@ -24,15 +24,14 @@ is
is
use ada.Calendar;
Now : constant ada.Calendar.Time := Clock;
Now : constant ada.Calendar.Time := Clock;
begin
if Now >= the_Animation.next_frame_Time
then
declare
next_frame_Id : constant frame_Id := (if the_Animation.Current < the_Animation.frame_Count then the_Animation.Current + 1
else 1);
else 1);
old_Frame : Frame renames the_Animation.Frames (the_Animation.Current);
new_Frame : Frame renames the_Animation.Frames (next_frame_Id);
begin

19
3-mid/opengl/source/lean/opengl-texture_set.ads
View File

@@ -25,6 +25,14 @@ is
type texture_Ids is array (Positive range <>) of texture_Id;
type Tiling is -- The number of times the texture should be wrapped.
record
S : Real;
T : Real;
end record;
type Tilings is array (texture_Id) of Tiling;
--------
--- Fade
@@ -44,6 +52,7 @@ is
Fade : fade_Level := 0.0;
Object : openGL.Texture.Object := openGL.Texture.null_Object;
Applied : Boolean := True; -- Whether this texture is painted on or not.
Tiling : texture_Set.Tiling := (1.0, 1.0);
end record;
type fadeable_Textures is array (texture_Id range 1 .. max_Textures) of fadeable_Texture;
@@ -89,19 +98,13 @@ is
--- Details
--
type Tiling is -- The number of times the texture should be wrapped.
record
S : Real;
T : Real;
end record;
type Details is
record
Fades : fade_Levels (texture_Id) := [others => 0.0];
Textures : asset_Names (1 .. Positive (texture_Id'Last)) := [others => null_Asset]; -- The textures to be applied to the visual.
texture_Count : Natural := 0;
texture_Tiling : Tiling := (S => 1.0,
T => 1.0);
texture_Tilings : Tilings := [others => (S => 1.0,
T => 1.0)];
texture_Applies : texture_Apply_array := [1 => True, others => False];
Animation : Animation_view;
end record;

10
3-mid/opengl/source/lean/shader/opengl-program.adb
View File

@@ -226,6 +226,16 @@ is
function uniform_Variable (Self : access Item'Class; Named : in String) return Variable.uniform.vec2
is
the_Variable : Variable.uniform.vec2;
begin
the_Variable.define (Self, Named);
return the_Variable;
end uniform_Variable;
function uniform_Variable (Self : access Item'Class; Named : in String) return Variable.uniform.vec3
is
the_Variable : Variable.uniform.vec3;

1
3-mid/opengl/source/lean/shader/opengl-program.ads
View File

@@ -61,6 +61,7 @@ is
function uniform_Variable (Self : access Item'Class; Named : in String) return Variable.uniform.bool;
function uniform_Variable (Self : access Item'Class; Named : in String) return Variable.uniform.int;
function uniform_Variable (Self : access Item'Class; Named : in String) return Variable.uniform.float;
function uniform_Variable (Self : access Item'Class; Named : in String) return Variable.uniform.vec2;
function uniform_Variable (Self : access Item'Class; Named : in String) return Variable.uniform.vec3;
function uniform_Variable (Self : access Item'Class; Named : in String) return Variable.uniform.vec4;
function uniform_Variable (Self : access Item'Class; Named : in String) return Variable.uniform.mat3;

14
3-mid/opengl/source/lean/shader/opengl-variable-uniform.adb
View File

@@ -97,6 +97,20 @@ is
-- vec2
--
procedure Value_is (Self : in vec2; Now : in Vector_2)
is
begin
Tasks.check;
glUniform2fv (Self.gl_Variable,
1,
Now (1)'Address);
Errors.log;
end Value_is;
-- vec3
--
procedure Value_is (Self : in vec3; Now : in Vector_3)

5
3-mid/opengl/source/lean/shader/opengl-variable-uniform.ads
View File

@@ -15,7 +15,7 @@ is
-- Forge
--
procedure define (Self : in out Item; Program : access openGL.Program.item'class;
procedure define (Self : in out Item; Program : access openGL.Program.item'Class;
Name : in String);
overriding
procedure destroy (Self : in out Item);
@@ -33,6 +33,7 @@ is
type bool is new Variable.uniform.item with private;
type int is new Variable.uniform.item with private;
type float is new Variable.uniform.item with private;
type vec2 is new Variable.uniform.item with private;
type vec3 is new Variable.uniform.item with private;
type vec4 is new Variable.uniform.item with private;
type mat3 is new Variable.uniform.item with private;
@@ -43,6 +44,7 @@ is
procedure Value_is (Self : in bool; Now : in Boolean);
procedure Value_is (Self : in int; Now : in Integer);
procedure Value_is (Self : in float; Now : in Real);
procedure Value_is (Self : in vec2; Now : in Vector_2);
procedure Value_is (Self : in vec3; Now : in Vector_3);
procedure Value_is (Self : in vec4; Now : in Vector_4);
procedure Value_is (Self : in mat3; Now : in Matrix_3x3);
@@ -58,6 +60,7 @@ private
type int is new Variable.uniform.item with null record;
type float is new Variable.uniform.item with null record;
type vec2 is new Variable.uniform.item with null record;
type vec3 is new Variable.uniform.item with null record;
type vec4 is new Variable.uniform.item with null record;