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

opengl: Cosmetics.

Browse Source
This commit is contained in:
Rod Kay
2025-10-22 14:11:39 +11:00
parent 3e11a52f5d
commit 50821bb787
60 changed files with 304 additions and 520 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -12,6 +12,7 @@ with
Interfaces.C.Strings,
System.storage_Elements;
package body openGL.Geometry.colored
is
use GL.lean, GL.Pointers;

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

@@ -35,9 +35,7 @@ is
private
type Item is new Geometry.item with
record
null;
end record;
type Item is new Geometry.item with null record;
end openGL.Geometry.colored;

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

@@ -13,6 +13,7 @@ with
Interfaces.C.Strings,
System.storage_Elements;
package body openGL.Geometry.colored_textured
is
use GL.lean,
@@ -188,23 +189,4 @@ is
end Indices_are;
-- overriding
-- procedure enable_Textures (Self : in out Item)
-- is
-- use GL,
-- GL.Binding,
-- openGL.Texture;
-- begin
-- Tasks.check;
--
-- glActiveTexture (gl.GL_TEXTURE0);
-- Errors.log;
--
-- if Self.Texture = openGL.Texture.null_Object
-- then enable (white_Texture);
-- else enable (Self.Texture);
-- end if;
-- end enable_Textures;
end openGL.Geometry.colored_textured;

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

@@ -43,11 +43,7 @@ private
package textured_Geometry is new texturing.Mixin;
type Item is new textured_Geometry.item with
record
null;
end record;
type Item is new textured_Geometry.item with null record;
end openGL.Geometry.colored_textured;

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

@@ -37,4 +37,5 @@ private
type Item is new Geometry.item with null record;
end openGL.Geometry.lit_colored;

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

@@ -2,7 +2,6 @@ with
openGL.Shader,
openGL.Attribute,
openGL.Buffer.general,
openGL.Texture,
openGL.Tasks,
openGL.Errors,
@@ -209,6 +208,7 @@ is
end define_Program;
--------------
-- Attributes
--

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

@@ -1,9 +1,10 @@
with
openGL.Program.lit.colored_skinned;
package openGL.Geometry.lit_colored_skinned
--
-- Supports per-vertex site color, texture, lighting and skinning.
-- Supports per-vertex site color, lighting and skinning.
--
is
type Item is new openGL.Geometry.item with private;
@@ -28,8 +29,10 @@ is
bone_Ids : Vector_4;
bone_Weights : Vector_4;
end record;
pragma Convention (C, Vertex);
type Vertex_array is array (long_Index_t range <>) of aliased Vertex;
@@ -55,4 +58,5 @@ private
overriding
procedure enable_Textures (Self : in out Item);
end openGL.Geometry.lit_colored_skinned;

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

@@ -68,6 +68,7 @@ is
type Geometry_view is access all Geometry.lit_colored_textured.item'Class;
function new_Geometry (texture_is_Alpha : in Boolean) return access Geometry.lit_colored_textured.item'Class
is
use type openGL.Program.lit.view;
@@ -195,6 +196,7 @@ is
textured_Geometry.create_Uniforms (for_Program => the_Program.Program.all'Access);
end define;
Self : constant Geometry_view := new Geometry.lit_colored_textured.item;
begin
@@ -225,6 +227,7 @@ is
end new_Geometry;
----------
-- Vertex
--
@@ -241,6 +244,7 @@ is
end is_Transparent;
--------------
-- Attributes
--
@@ -257,7 +261,7 @@ is
begin
if Self.Vertices = null
then
self.Vertices := new openGL_Buffer_of_geometry_Vertices.Object' (Forge.to_Buffer (Now,
Self.Vertices := new openGL_Buffer_of_geometry_Vertices.Object' (Forge.to_Buffer (Now,
usage => Buffer.static_Draw));
else
set (openGL_Buffer_of_geometry_Vertices.Object (Self.Vertices.all),

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

@@ -10,7 +10,6 @@ is
package textured_Geometry is new texturing.Mixin;
-- type Item is new openGL.Geometry.item with private;
type Item is new textured_Geometry.item with private;
type View is access all Item'Class;
@@ -46,10 +45,7 @@ is
private
type Item is new textured_Geometry.item with
record
null;
end record;
type Item is new textured_Geometry.item with null record;
end openGL.Geometry.lit_colored_textured;

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

@@ -70,6 +70,7 @@ is
end is_Transparent;
---------
-- Forge
--
@@ -282,36 +283,4 @@ is
end Vertices_are;
-- overriding
-- procedure enable_Textures (Self : in out Item)
-- is
-- use GL,
-- GL.Binding,
-- openGL.Texture;
-- begin
-- Tasks.check;
--
-- glActiveTexture (gl.GL_TEXTURE0);
-- Errors.log;
--
-- if Self.Texture = openGL.Texture.null_Object
-- then
-- if not white_Texture.is_Defined
-- then
-- declare
-- use Palette;
-- white_Image : constant openGL.Image := [1 .. 2 => [1 .. 2 => +White]];
-- begin
-- white_Texture := openGL.Texture.Forge.to_Texture (white_Image);
-- end;
-- end if;
--
-- white_Texture.enable;
-- else
-- Self.Texture.enable;
-- end if;
-- end enable_Textures;
end openGL.Geometry.lit_colored_textured_skinned;

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

@@ -37,6 +37,7 @@ is
pragma Convention (C, Vertex);
type Vertex_array is array (long_Index_t range <>) of aliased Vertex;
@@ -58,11 +59,7 @@ private
package textured_Geometry is new texturing.Mixin;
type Item is new textured_Geometry.item with
record
null;
end record;
type Item is new textured_Geometry.item with null record;
end openGL.Geometry.lit_colored_textured_skinned;

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

@@ -71,7 +71,7 @@ is
4 => to_Asset ("assets/opengl/shader/lit_textured.frag"))));
the_Program := new openGL.Program.lit.item;
the_Program.define ( vertex_Shader'Access,
fragment_Shader'Access);
fragment_Shader'Access);
the_Program.enable;
Attribute_1 := new_Attribute (Name => Name_1,
@@ -160,7 +160,6 @@ is
----------
-- Vertex
--
@@ -183,7 +182,6 @@ is
--------------
-- Attributes
--

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

@@ -47,11 +47,7 @@ private
package textured_Geometry is new texturing.Mixin;
type Item is new textured_Geometry.item with
record
null;
end record;
type Item is new textured_Geometry.item with null record;
end openGL.Geometry.lit_textured;

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

@@ -106,7 +106,6 @@ is
-- Define the shaders and program.
--
vertex_Shader .define (Shader.Vertex, "assets/opengl/shader/lit_textured_skinned.vert");
-- fragment_Shader.define (Shader.Fragment, "assets/opengl/shader/lit_textured_skinned.frag");
fragment_Shader.define (Shader.Fragment, (asset_Names' (1 => to_Asset ("assets/opengl/shader/version.header"),
2 => to_Asset ("assets/opengl/shader/lighting-frag.snippet"),
3 => to_Asset ("assets/opengl/shader/texturing-frag.snippet"),
@@ -254,36 +253,4 @@ is
end Vertices_are;
-- overriding
-- procedure enable_Textures (Self : in out Item)
-- is
-- use GL,
-- GL.Binding,
-- openGL.Texture;
-- begin
-- Tasks.check;
--
-- glActiveTexture (gl.GL_TEXTURE0);
-- Errors.log;
--
-- if Self.Texture = openGL.Texture.null_Object
-- then
-- if not white_Texture.is_Defined
-- then
-- declare
-- use Palette;
-- white_Image : constant openGL.Image := [1 .. 2 => [1 .. 2 => +White]];
-- begin
-- white_Texture := openGL.Texture.Forge.to_Texture (white_Image);
-- end;
-- end if;
--
-- white_Texture.enable;
-- else
-- Self.Texture.enable;
-- end if;
-- end enable_Textures;
end openGL.Geometry.lit_textured_skinned;

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

@@ -57,11 +57,7 @@ private
package textured_Geometry is new texturing.Mixin;
type Item is new textured_Geometry.item with
record
null;
end record;
type Item is new textured_Geometry.item with null record;
end openGL.Geometry.lit_textured_skinned;

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

@@ -3,11 +3,11 @@ with
openGL.Shader,
openGL.Program,
openGL.Attribute,
openGL.Errors,
openGL.Tasks,
GL.lean,
GL.Pointers,
System,
Interfaces.C.Strings,
System.storage_Elements;
@@ -97,10 +97,12 @@ is
glBindAttribLocation (program => the_Program.gl_Program,
index => the_Program.Attribute (named => Name_1).gl_Location,
name => +Attribute_1_Name_ptr);
Errors.log;
glBindAttribLocation (program => the_Program.gl_Program,
index => the_Program.Attribute (named => Name_2).gl_Location,
name => +Attribute_2_Name_ptr);
Errors.log;
textured_Geometry.create_Uniforms (for_Program => the_Program.all'Access);
end;
@@ -112,7 +114,6 @@ is
--------------
-- Attributes
--
@@ -130,13 +131,12 @@ is
Element => Vertex,
Element_Array => Vertex_array);
procedure Vertices_are (Self : in out Item; Now : in Vertex_array)
is
use openGL_Buffer_of_geometry_Vertices.Forge;
begin
Self.Vertices := new openGL_Buffer_of_geometry_Vertices.Object' (to_Buffer (Now,
usage => Buffer.static_Draw));
Usage => Buffer.static_Draw));
-- Set the bounds.
--
declare

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

@@ -45,11 +45,7 @@ private
package textured_Geometry is new texturing.Mixin;
type Item is new textured_Geometry.item with
record
null;
end record;
type Item is new textured_Geometry.item with null record;
end openGL.Geometry.textured;

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

@@ -1,5 +1,6 @@
with
openGL.Model,
openGL.Errors,
GL.lean,
GL.Binding,
ada.Strings.fixed;
@@ -47,40 +48,6 @@ is
-- procedure enable (for_Model : in openGL.Model.view;
-- Uniforms : in texturing.Uniforms;
-- texture_Set : in openGL.texture_Set.Item)
-- is
-- use GL.Binding,
-- GL.lean;
--
-- use type GLint;
--
-- begin
-- if for_Model.texture_Count > 0
-- then
-- for i in 1 .. openGL.texture_Set.texture_Id (for_Model.texture_Count)
-- loop
-- 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);
-- glActiveTexture (all_texture_Units (i));
-- glBindTexture (GL_TEXTURE_2D,
-- texture_Set.Textures (i).Object.Name);
-- end loop;
-- end if;
--
-- Uniforms.Count.Value_is (for_Model.texture_Count);
-- end enable;
procedure enable (for_Model : in openGL.Model.view;
Uniforms : in texturing.Uniforms)
-- texture_Set : in openGL.texture_Set.Item)
@@ -101,10 +68,10 @@ is
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);
glActiveTexture (all_texture_Units (i));
GLint (i) - 1); Errors.log;
glActiveTexture (all_texture_Units (i)); Errors.log;
glBindTexture (GL_TEXTURE_2D,
for_Model.texture_Object (i).Name);
for_Model.texture_Object (i).Name); Errors.log;
end loop;
end if;
@@ -149,11 +116,9 @@ is
package body Mixin
is
use openGL.texture_Set;
texture_Uniforms : texturing.Uniforms;
procedure create_Uniforms (for_Program : in openGL.Program.view)
is
begin
@@ -167,7 +132,6 @@ is
Which : in texture_Set.texture_ID := 1)
is
begin
-- Self.texture_Set.Textures (Which).Fade := Now;
Self.Model.Fade_is (Which => Which,
Now => Now);
end Fade_is;
@@ -178,7 +142,6 @@ 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.Model.Fade (Which => Which);
end Fade;
@@ -189,9 +152,6 @@ is
Which : in texture_Set.texture_ID := 1)
is
begin
-- Texture_is (in_Set => Self.texture_Set,
-- Which => Which,
-- Now => Now);
Self.Model.texture_Object_is (Which => Which,
Now => Now);
end Texture_is;
@@ -202,8 +162,6 @@ is
function Texture (Self : in Item; Which : texture_Set.texture_ID := 1) return openGL.Texture.Object
is
begin
-- return openGL.texture_Set.Texture (in_Set => Self.texture_Set,
-- Which => Which);
return Self.Model.texture_Object (Which);
end Texture;
@@ -214,17 +172,15 @@ is
Which : in texture_Set.texture_ID := 1)
is
begin
-- Self.texture_Set.Textures (Which).Applied := Now;
Self.Model.texture_Applied_is (Which, Now);
end texture_Applied_is;
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 := 1) return Boolean
is
begin
-- return Self.texture_Set.Textures (Which).Applied;
return Self.Model.texture_Applied (Which);
end texture_Applied;
@@ -235,7 +191,6 @@ is
Which : in texture_Set.texture_ID := 1)
is
begin
-- Self.texture_Set.Textures (Which).Tiling := Now;
Self.Model.Tiling_is (Which => Which,
Now => Now);
end Tiling_is;
@@ -246,23 +201,15 @@ is
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;
return Self.Model.Tiling (Which);
end Tiling;
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);
texturing.enable (for_Model => Self.Model.all'Access,
Uniforms => texture_Uniforms);
end enable_Textures;
@@ -271,5 +218,4 @@ is
end Mixin;
end openGL.Geometry.texturing;

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

@@ -40,15 +40,9 @@ is
--- Operations
--
-- procedure enable (for_Model : in openGL.Model.view;
-- Uniforms : in texturing.Uniforms;
-- texture_Set : in openGL.texture_Set.Item);
procedure enable (for_Model : in openGL.Model.view;
Uniforms : in texturing.Uniforms);
procedure create (Uniforms : out texturing.Uniforms;
for_Program : in openGL.Program.view);
@@ -68,17 +62,17 @@ is
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; Now : in texture_Set.fade_Level;
Which : in texture_Set.texture_ID := 1);
overriding
function Fade (Self : in Item; Which : texture_Set.texture_ID := 1) return texture_Set.fade_Level;
function Fade (Self : in Item; Which : texture_Set.texture_ID := 1) return texture_Set.fade_Level;
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; Now : in openGL.Texture.Object;
Which : in texture_Set.texture_ID := 1);
overriding
function Texture (Self : in Item; Which : in texture_Set.texture_ID := 1) return openGL.Texture.Object;
function Texture (Self : in Item; Which : in texture_Set.texture_ID := 1) return openGL.Texture.Object;
overriding
@@ -100,13 +94,9 @@ is
private
type Item is new Geometry.item with
record
null; --texture_Set : openGL.texture_Set.item;
end record;
type Item is new Geometry.item with null record;
end Mixin;
end openGL.Geometry.texturing;

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

@@ -45,7 +45,6 @@ is
--------------
-- Attributes
--
@@ -112,7 +111,7 @@ is
function Fade (Self : in Item; Which : texture_Set.texture_ID := 1) return texture_Set.fade_Level
is
begin
raise program_Error with "Geometry has no texture.";
raise Error with "Geometry has no texture.";
return texture_Set.fade_Level'Last;
end Fade;
@@ -121,7 +120,7 @@ is
function Texture (Self : in Item; Which : in texture_Set.texture_ID := 1) return openGL.Texture.Object
is
begin
raise program_Error with "Geometry has no texture.";
raise Error with "Geometry has no texture.";
return openGL.Texture.null_Object;
end Texture;
@@ -130,7 +129,7 @@ is
function texture_Applied (Self : in Item; Which : in texture_Set.texture_ID := 1) return Boolean
is
begin
raise program_Error with "Geometry has no texture.";
raise Error with "Geometry has no texture.";
return False;
end texture_Applied;
@@ -139,7 +138,7 @@ 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.";
raise Error with "Geometry has no texture.";
return (S => 0.0,
T => 0.0);
end Tiling;
@@ -162,7 +161,7 @@ is
function Bounds (self : in Item'Class) return openGL.Bounds
function Bounds (Self : in Item'Class) return openGL.Bounds
is
begin
return Self.Bounds;
@@ -197,7 +196,6 @@ is
--------------
-- Operations
--
@@ -232,7 +230,6 @@ is
-----------
-- Normals
--
@@ -309,6 +306,7 @@ is
pragma Unreferenced (facet_Count_in);
----------
-- Facets
--
@@ -329,6 +327,7 @@ is
-- 'Facets_of' returns all non-redundant facets.
function any_Facets_of (face_Kind : in primitive.facet_Kind;
Indices : in any_Indices) return access Facets
is
@@ -361,9 +360,11 @@ is
is
when Triangles
| triangle_Fan =>
the_Facets (Count) := [P1, P2, P3];
when triangle_Strip =>
if Each mod 2 = 0
then -- Is an even facet.
the_Facets (Count) := [P1, P3, P2];
@@ -388,6 +389,7 @@ is
end any_Facets_of;
function Facets_of is new any_Facets_of (Index_t,
Indices);
pragma Unreferenced (Facets_of);
@@ -480,7 +482,7 @@ is
free (the_Facets);
free (the_facet_Normals);
return the_Normals.all'Unchecked_Access;
return the_Normals.all'unchecked_Access;
end any_Normals_of;
@@ -537,7 +539,6 @@ is
---------------
-- Transparency
--

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

@@ -47,20 +47,20 @@ is
procedure Model_is (Self : in out Item; Now : in Model_view);
function Model (Self : in Item) return Model_view;
procedure Label_is (Self : in out Item'Class; Now : in String);
function Label (Self : in Item'Class) return String;
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; Now : in texture_Set.fade_Level;
Which : in texture_Set.texture_ID := 1) is null;
function Fade (Self : in Item; Which : in texture_Set.texture_ID := 1) return texture_Set.fade_Level;
procedure Fade_is (Self : in out Item; Now : in texture_Set.fade_Level;
Which : in texture_Set.texture_ID := 1) is null;
function Fade (Self : in Item; Which : in texture_Set.texture_ID := 1) return texture_Set.fade_Level;
procedure Texture_is (Self : in out Item; Now : in openGL.Texture.Object;
Which : in texture_Set.texture_ID := 1) is null;
function Texture (Self : in Item; Which : in texture_Set.texture_ID := 1) return openGL.Texture.Object;
procedure Texture_is (Self : in out Item; Now : in openGL.Texture.Object;
Which : in texture_Set.texture_ID := 1) is null;
function Texture (Self : in Item; Which : in texture_Set.texture_ID := 1) return openGL.Texture.Object;
procedure texture_Applied_is (Self : in out Item; Now : in Boolean;
Which : in texture_Set.texture_ID := 1) is null;
@@ -135,11 +135,15 @@ private
generic
type any_Index_t is range <>;
with function get_Site (Index : in any_Index_t) return Vector_3;
function get_Bounds (Count : in Natural) return openGL.Bounds;
generic
type any_Index_t is range <>;
with function get_Color (Index : in any_Index_t) return rgba_Color;
function get_Transparency (Count : in Natural) return Boolean;
end openGL.Geometry;

4
3-mid/opengl/source/lean/geometry/opengl-primitive-indexed.adb
View File

@@ -6,6 +6,7 @@ with
GL.Binding,
GL.lean;
package body openGL.Primitive.indexed
is
---------
@@ -48,7 +49,7 @@ is
Self.facet_Kind := Kind;
Self.Indices := new openGL.Buffer.indices.Object' (to_Buffer (buffer_Indices'Access,
usage => Buffer.static_Draw));
Usage => Buffer.static_Draw));
Self.line_Width := line_Width;
end define;
@@ -88,6 +89,7 @@ is
end destroy;
--------------
-- Attributes
--

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

@@ -2,6 +2,7 @@ private
with
openGL.Buffer.indices;
package openGL.Primitive.indexed
--
-- Provides a class for indexed openGL primitives.
@@ -37,6 +38,7 @@ is
procedure destroy (Self : in out Item);
--------------
-- Attributes
--
@@ -45,6 +47,7 @@ is
procedure Indices_are (Self : in out Item; Now : in long_Indices);
--------------
-- Operations
--

5
3-mid/opengl/source/lean/geometry/opengl-primitive-long_indexed.adb
View File

@@ -6,6 +6,7 @@ with
ada.unchecked_Deallocation;
package body openGL.Primitive.long_indexed
is
---------
@@ -25,7 +26,7 @@ is
Self.facet_Kind := Kind;
Self.Indices := new Buffer.long_indices.Object' (to_Buffer (buffer_Indices'Access,
usage => Buffer.static_Draw));
Usage => Buffer.static_Draw));
end define;
@@ -52,6 +53,7 @@ is
end destroy;
--------------
-- Attributes
--
@@ -70,6 +72,7 @@ is
end Indices_are;
--------------
-- Operations
--

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

@@ -2,6 +2,7 @@ private
with
openGL.Buffer.long_indices;
package openGL.Primitive.long_indexed
--
-- Provides a class for long indexed openGL primitives.
@@ -27,6 +28,7 @@ is
procedure destroy (Self : in out Item);
--------------
-- Attributes
--
@@ -34,6 +36,7 @@ is
procedure Indices_are (Self : in out Item; Now : in long_Indices);
--------------
-- Operations
--
@@ -50,4 +53,5 @@ private
Indices : Buffer.long_indices.view;
end record;
end openGL.Primitive.long_indexed;

2
3-mid/opengl/source/lean/geometry/opengl-primitive-non_indexed.adb
View File

@@ -3,6 +3,7 @@ with
openGL.Tasks,
GL.Binding;
package body openGL.Primitive.non_indexed
is
---------
@@ -29,6 +30,7 @@ is
end new_Primitive;
overriding
procedure destroy (Self : in out Item) is null;

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

@@ -10,6 +10,7 @@ is
type Views is array (Index_t range <>) of View;
---------
-- Forge
--
@@ -23,6 +24,7 @@ is
function new_Primitive (Kind : in facet_Kind;
vertex_Count : in Natural) return Primitive.non_indexed.view;
--------------
-- Operations
--
@@ -39,4 +41,5 @@ private
vertex_Count : Natural := 0;
end record;
end openGL.Primitive.non_indexed;

17
3-mid/opengl/source/lean/geometry/opengl-primitive-short_indexed.adb
View File

@@ -6,6 +6,7 @@ with
ada.unchecked_Deallocation;
package body openGL.Primitive.short_indexed
is
---------
@@ -25,7 +26,7 @@ is
Self.facet_Kind := Kind;
Self.Indices := new Buffer.short_indices.Object' (to_Buffer (buffer_Indices'Access,
usage => Buffer.static_Draw));
Usage => Buffer.static_Draw));
end define;
@@ -43,7 +44,7 @@ is
Self.facet_Kind := Kind;
Self.Indices := new Buffer.short_indices.Object' (to_Buffer (buffer_Indices'Access,
usage => Buffer.static_Draw));
Usage => Buffer.static_Draw));
end define;
@@ -61,7 +62,7 @@ is
Self.facet_Kind := Kind;
Self.Indices := new Buffer.short_indices.Object' (to_Buffer (buffer_Indices'Access,
usage => Buffer.static_Draw));
Usage => Buffer.static_Draw));
end define;
@@ -110,6 +111,7 @@ is
end destroy;
--------------
-- Attributes
--
@@ -118,13 +120,14 @@ is
is
use Buffer.short_indices;
buffer_Indices : aliased short_Indices := [Now'Range => <>];
begin
for Each in buffer_Indices'Range
loop
buffer_Indices (Each) := Now (Each) - 1; -- Adjust indices to zero-based-indexing for GL.
end loop;
Self.Indices.set (to => buffer_Indices);
Self.Indices.set (To => buffer_Indices);
end Indices_are;
@@ -133,13 +136,14 @@ is
is
use Buffer.short_indices;
buffer_Indices : aliased short_Indices := [Now'Range => <>];
begin
for Each in buffer_Indices'Range
loop
buffer_Indices (Each) := short_Index_t (Now (Each) - 1); -- Adjust indices to zero-based-indexing for GL.
end loop;
Self.Indices.set (to => buffer_Indices);
Self.Indices.set (To => buffer_Indices);
end Indices_are;
@@ -148,13 +152,14 @@ is
is
use Buffer.short_indices;
buffer_Indices : aliased short_Indices := [Now'Range => <>];
begin
for Each in buffer_Indices'Range
loop
buffer_Indices (Each) := short_Index_t (Now (Each) - 1); -- Adjust indices to zero-based-indexing for GL.
end loop;
Self.Indices.set (to => buffer_Indices);
Self.Indices.set (To => buffer_Indices);
end Indices_are;

5
3-mid/opengl/source/lean/geometry/opengl-primitive-short_indexed.ads
View File

@@ -2,6 +2,7 @@ private
with
openGL.Buffer.short_indices;
package openGL.Primitive.short_indexed
--
-- Provides a class for short indexed openGL primitives.
@@ -14,6 +15,7 @@ is
type Views is array (Index_t range <>) of View;
---------
-- Forge
--
@@ -37,6 +39,7 @@ is
procedure destroy (Self : in out Item);
--------------
-- Attributes
--
@@ -46,6 +49,7 @@ is
procedure Indices_are (Self : in out Item; Now : in long_Indices);
--------------
-- Operations
--
@@ -62,4 +66,5 @@ private
Indices : Buffer.short_indices.view;
end record;
end openGL.Primitive.short_indexed;

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

@@ -1,8 +1,10 @@
with
openGL.Tasks,
openGL.Errors,
GL.Binding,
ada.unchecked_Deallocation;
package body openGL.Primitive
is
---------
@@ -16,6 +18,7 @@ is
end define;
procedure free (Self : in out View)
is
procedure deallocate is new ada.Unchecked_Deallocation (Primitive.item'Class,
@@ -88,6 +91,7 @@ is
if Self.line_Width /= unused_line_Width
then
glLineWidth (glFloat (Self.line_Width));
Errors.log;
end if;
end render;

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

@@ -5,6 +5,7 @@ private
with
ada.unchecked_Conversion;
package openGL.Primitive
--
-- Provides a base class for openGL primitives.
@@ -28,7 +29,7 @@ is
-- Forge
--
procedure define (Self : in out Item; Kind : in facet_Kind);
procedure define (Self : in out Item; Kind : in facet_Kind);
procedure destroy (Self : in out Item) is abstract;
procedure free (Self : in out View);
@@ -67,7 +68,7 @@ private
Texture : openGL.Texture.Object := openGL.Texture.null_Object;
is_Transparent : Boolean;
Bounds : openGL.Bounds;
line_Width : Real := unused_line_Width;
line_Width : Real := unused_line_Width;
end record;