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/demo/opengl-demo.adb
View File

@@ -157,6 +157,7 @@ is
the_ball_4_Model : constant Model.sphere.lit_colored_textured.view
:= Model.sphere.lit_colored_textured.new_Sphere (Radius => 1.0,
Color => (Green, Opaque),
texture_Details => texture_Set.to_Set ([1 => the_Texture]),
Image => the_Texture);

6
3-mid/opengl/source/lean/buffer/opengl-buffer-general.adb
View File

@@ -4,6 +4,7 @@ with
GL.Pointers;
package body openGL.Buffer.general
is
--------------------------
@@ -53,6 +54,7 @@ is
From'Size / 8,
+From (From'First)'Address,
to_GL_Enum (Usage));
Errors.log;
end return;
end to_Buffer;
@@ -78,6 +80,7 @@ is
Offset => GLintptr ((Position - 1) * Vertex_Size_in_bits / 8),
Size => new_Vertices'Size / 8,
Data => +new_Vertices (new_Vertices'First)'Address);
Errors.log;
else
Self.destroy;
@@ -89,9 +92,8 @@ is
To'Size / 8,
+To (To'First)'Address,
to_GL_Enum (Self.Usage));
Errors.log;
end if;
Errors.log;
end set;

1
3-mid/opengl/source/lean/buffer/opengl-buffer-general.ads
View File

@@ -5,6 +5,7 @@ generic
type Element is private;
type Element_Array is array (Index range <>) of Element;
package openGL.Buffer.general
--
-- A generic for producing various types of openGL vertex buffer objects.

1
3-mid/opengl/source/lean/buffer/opengl-buffer-indices.ads
View File

@@ -1,6 +1,7 @@
with
openGL.Buffer.general;
package openGL.Buffer.indices is new openGL.Buffer.general (base_Object => Buffer.element_array_Object,
Index => long_Index_t,
Element => Index_t,

1
3-mid/opengl/source/lean/buffer/opengl-buffer-long_indices.ads
View File

@@ -1,6 +1,7 @@
with
openGL.Buffer.general;
package openGL.Buffer.long_indices is new openGL.Buffer.general (base_Object => Buffer.element_array_Object,
Index => long_Index_t,
Element => long_Index_t,

1
3-mid/opengl/source/lean/buffer/opengl-buffer-normals.ads
View File

@@ -1,6 +1,7 @@
with
openGL.Buffer.general;
package openGL.Buffer.normals is new openGL.Buffer.general (base_Object => Buffer.array_Object,
Index => Index_t,
Element => Normal,

1
3-mid/opengl/source/lean/buffer/opengl-buffer-short_indices.ads
View File

@@ -1,6 +1,7 @@
with
openGL.Buffer.general;
package openGL.Buffer.short_indices is new openGL.Buffer.general (base_Object => Buffer.element_array_Object,
Index => long_Index_t,
Element => short_Index_t,

1
3-mid/opengl/source/lean/buffer/opengl-buffer-texture_coords.ads
View File

@@ -1,6 +1,7 @@
with
openGL.Buffer.general;
package openGL.Buffer.texture_coords is new openGL.Buffer.general (base_Object => Buffer.array_Object,
Index => Index_t,
Element => Coordinate_2D,

1
3-mid/opengl/source/lean/buffer/opengl-buffer-vertex.ads
View File

@@ -1,6 +1,7 @@
with
openGL.Buffer.general;
package openGL.Buffer.vertex is new openGL.Buffer.general (base_Object => Buffer.array_Object,
Index => Index_t,
Element => Site,

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

@@ -3,6 +3,7 @@ with
openGL.Tasks,
ada.unchecked_Deallocation;
package body openGL.Buffer
is
use type a_Name;
@@ -17,7 +18,7 @@ is
Name : aliased a_Name;
begin
Tasks.check;
glGenBuffers (1, Name'unchecked_Access);
glGenBuffers (1, Name'unchecked_Access); Errors.log;
return Name;
end new_vbo_Name;
@@ -28,8 +29,9 @@ is
Name : aliased a_Name := vbo_Name;
begin
Tasks.check;
glDeleteBuffers (1, Name'unchecked_Access);
glDeleteBuffers (1, Name'unchecked_Access); Errors.log;
end free;
pragma Unreferenced (free);

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

@@ -3,6 +3,7 @@ with
GL.lean,
ada.unchecked_Conversion;
package openGL.Buffer
--
-- Models a buffer object.
@@ -11,7 +12,7 @@ is
--------------
--- Core Types
--
subtype a_Name is GL.GLuint; -- An openGL vertex buffer 'Name', which is a natural integer.
subtype a_Name is GL.GLuint; -- An openGL vertex buffer 'Name'.
type a_Kind is (array_Buffer, element_array_Buffer);
type Usage is (stream_Draw, static_Draw, dynamic_Draw);
@@ -121,4 +122,5 @@ private
--
procedure verify_Name (Self : in out Object'Class);
end openGL.Buffer;

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;

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

@@ -10,7 +10,8 @@ package openGL.Model.capsule.textured
is
package textured_Model is new texturing.Mixin (openGL.Model.capsule.item);
type Item is new textured_Model.textured_item with private; type View is access all Item'Class;
type Item is new textured_Model.textured_item with private;
type View is access all Item'Class;
---------

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

@@ -86,9 +86,6 @@ is
for i in 1 .. Self.texture_Details.Count
loop
put_Line ("KKK" & Self.texture_Details'Image);
Id := texture_Id (i);
-- the_Geometry.Fade_is (which => Id,

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

@@ -1,3 +1,7 @@
with
ada.unchecked_Deallocation;
package body openGL.Model.texturing
is
@@ -135,8 +139,16 @@ is
procedure texture_Details_is (Self : in out textured_Item; Now : in openGL.texture_Set.item)
is
procedure free is new ada.unchecked_Deallocation (Animation, Animation_view);
begin
free (Self.texture_Set.Animation);
Self.texture_Set := Now;
if Now.Animation /= null
then
Self.texture_Set.Animation := new texture_Set.Animation' (Now.Animation.all);
end if;
end texture_Details_is;

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

@@ -2,6 +2,7 @@ with
ada.Text_IO,
ada.Exceptions;
package body openGL.Camera
is
use math.Algebra.linear,
@@ -36,7 +37,7 @@ is
-- Attributes
--
function to_World_Site (Self : in Item; Window_Site : in math.Vector_3) return math.Vector_3
function to_World_Site (Self : in Item; window_Site : in math.Vector_3) return math.Vector_3
is
perspective_Transform : constant math.Matrix_4x4 := to_Perspective (FoVy => Self.FoVy,
Aspect => Self.Aspect,
@@ -56,11 +57,11 @@ is
procedure Site_is (Self : in out Item; now : in math.Vector_3)
procedure Site_is (Self : in out Item; Now : in math.Vector_3)
is
begin
Self.world_Transform := to_transform_Matrix ((Self.Spin,
now));
Now));
Self.update_View_Transform;
end Site_is;
@@ -87,7 +88,7 @@ is
procedure Spin_is (Self : in out Item'Class; now : in math.Matrix_3x3)
is
begin
set_Rotation (Self.world_Transform, to => now);
set_Rotation (Self.world_Transform, To => Now);
Self.update_View_Transform;
end Spin_is;
@@ -129,10 +130,10 @@ is
end Aspect;
procedure Aspect_is (Self : in out Item'Class; now : in math.Real)
procedure Aspect_is (Self : in out Item'Class; Now : in math.Real)
is
begin
Self.Aspect := now;
Self.Aspect := Now;
end Aspect_is;
@@ -144,7 +145,7 @@ is
end near_Plane_Distance;
procedure near_Plane_Distance_is (Self : in out Item'Class; now : in math.Real)
procedure near_Plane_Distance_is (Self : in out Item'Class; Now : in math.Real)
is
begin
Self.near_Plane_Distance := now;
@@ -159,10 +160,10 @@ is
end far_Plane_Distance;
procedure far_Plane_Distance_is (Self : in out Item'Class; now : in math.Real)
procedure far_Plane_Distance_is (Self : in out Item'Class; Now : in math.Real)
is
begin
Self.far_Plane_Distance := now;
Self.far_Plane_Distance := Now;
end far_Plane_Distance_is;
@@ -224,7 +225,7 @@ is
end Viewport;
procedure Renderer_is (Self : in out Item; now : in Renderer.lean.view)
procedure Renderer_is (Self : in out Item; Now : in Renderer.lean.view)
is
begin
Self.Renderer := now;
@@ -253,7 +254,7 @@ is
end vanish_Point_Size_min;
procedure vanish_Point_Size_min_is (Self : in out Item'Class; now : in Real)
procedure vanish_Point_Size_min_is (Self : in out Item'Class; Now : in Real)
is
begin
Self.Culler.vanish_Point_Size_min_is (now);
@@ -271,17 +272,17 @@ is
end Impostor_Size_min;
procedure Impostor_Size_min_is (Self : in out Item; now : in Real)
procedure Impostor_Size_min_is (Self : in out Item; Now : in Real)
is
begin
Self.Impostorer.Impostor_Size_min_is (now);
Self.Impostorer.Impostor_Size_min_is (Now);
end Impostor_Size_min_is;
procedure allow_Impostors (Self : in out Item; now : in Boolean := True)
procedure allow_Impostors (Self : in out Item; Now : in Boolean := True)
is
begin
Self.Impostors_allowed := now;
Self.Impostors_allowed := Now;
end allow_Impostors;
@@ -363,11 +364,11 @@ is
--
procedure render (Self : in out Item; Visuals : in Visual.views;
to : in Surface.view := null)
To : in Surface.view := null)
is
pragma Unreferenced (To); -- TODO: Finish using surfaces.
begin
Self.cull_Engine.cull (Visuals, do_cull => Self.is_Culling);
Self.cull_Engine.cull (Visuals, do_Cull => Self.is_Culling);
end render;

23
3-mid/opengl/source/lean/opengl-camera.ads
View File

@@ -6,6 +6,7 @@ with
openGL.Surface,
openGL.Renderer.lean;
package openGL.Camera
--
-- Simulates a camera.
@@ -30,12 +31,12 @@ is
fairly_Far : constant := 1_000_000.0;
default_field_of_view_Angle : constant Degrees := 60.0;
procedure Renderer_is (Self : in out Item; now : in Renderer.lean.view);
procedure Renderer_is (Self : in out Item; Now : in Renderer.lean.view);
procedure Site_is (Self : in out Item; now : in math.Vector_3);
procedure Site_is (Self : in out Item; Now : in math.Vector_3);
function Site (Self : in Item) return math.Vector_3;
procedure Spin_is (Self : in out Item'Class; now : in math.Matrix_3x3);
procedure Spin_is (Self : in out Item'Class; Now : in math.Matrix_3x3);
function Spin (Self : in Item'Class) return math.Matrix_3x3;
procedure Position_is (Self : in out Item'Class; Site : in math.Vector_3;
@@ -46,13 +47,13 @@ is
procedure FoVy_is (Self : in out Item'Class; Now : in math.Degrees);
function Aspect (Self : in Item'Class) return math.Real; -- X/Y Aspect ratio.
procedure Aspect_is (Self : in out Item'Class; now : in math.Real);
procedure Aspect_is (Self : in out Item'Class; Now : in math.Real);
function near_Plane_Distance (Self : in Item'Class) return math.Real; -- Distance to the near clipping plane.
function far_Plane_Distance (Self : in Item'Class) return math.Real; -- Distance to the far clipping plane.
procedure near_Plane_Distance_is (Self : in out Item'Class; now : in math.Real);
procedure far_Plane_Distance_is (Self : in out Item'Class; now : in math.Real);
procedure near_Plane_Distance_is (Self : in out Item'Class; Now : in math.Real);
procedure far_Plane_Distance_is (Self : in out Item'Class; Now : in math.Real);
function view_Transform (Self : in Item'Class) return math.Matrix_4x4;
function projection_Transform (Self : in Item'Class) return math.Matrix_4x4;
@@ -61,7 +62,7 @@ is
procedure Viewport_is (Self : in out Item'Class; Width,
Height : in Positive);
function to_World_Site (Self : in Item; Window_Site : in math.Vector_3) return math.Vector_3;
function to_World_Site (Self : in Item; window_Site : in math.Vector_3) return math.Vector_3;
--
-- Returns the 'window space' site transformed to the equivalent 'world space' site.
@@ -69,16 +70,16 @@ is
procedure disable_cull (Self : in out Item);
function vanish_Point_Size_min (Self : in Item'Class) return Real;
procedure vanish_Point_Size_min_is (Self : in out Item'Class; now : in Real);
procedure vanish_Point_Size_min_is (Self : in out Item'Class; Now : in Real);
--
-- Visuals whose projected size falls below this minimum will be culled.
function Impostor_Size_min (Self : in Item) return Real;
procedure Impostor_Size_min_is (Self : in out Item; now : in Real);
procedure Impostor_Size_min_is (Self : in out Item; Now : in Real);
--
-- Visuals whose projected size falls below this minimum will be substituted with impostors.
procedure allow_Impostors (Self : in out Item; now : in Boolean := True);
procedure allow_Impostors (Self : in out Item; Now : in Boolean := True);
--------------
@@ -86,7 +87,7 @@ is
--
procedure render (Self : in out Item; Visuals : in Visual.views;
to : in Surface.view := null);
To : in Surface.view := null);
function current_Planes (Self : in Item) return Frustum.plane_Array;
--

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

@@ -5,6 +5,7 @@ with
openGL.Tasks,
openGL.Errors;
package body openGL.Frame_Buffer
is
@@ -27,17 +28,26 @@ is
Self.Texture := openGL.Texture.Forge.to_Texture (Dimensions' (Width, Height));
glGenFramebuffers (1, Self.Name'Access);
Errors.log;
-- Attach each texture to the first color buffer of an frame buffer object and clear it.
--
glBindFramebuffer (GL_FRAMEBUFFER, Self.Name);
Errors.log;
glFramebufferTexture2D (GL_FRAMEBUFFER,
GL_COLOR_ATTACHMENT0,
GL_TEXTURE_2D,
Self.Texture.Name,
0);
Errors.log;
glClear (GL_COLOR_BUFFER_BIT);
Errors.log;
glBindFramebuffer (GL_FRAMEBUFFER, 0);
Errors.log;
return Self;
end to_frame_Buffer;
@@ -53,8 +63,10 @@ is
Self : Item;
begin
Tasks.check;
Self.Texture := openGL.Texture.null_Object;
glGenFramebuffers (1, Self.Name'Access);
Errors.log;
return Self;
end to_frame_Buffer;
@@ -68,7 +80,10 @@ is
use GL.lean;
begin
Tasks.check;
glDeleteFramebuffers (1, Self.Name'Access);
Errors.log;
Self.Texture.destroy;
end destruct;
@@ -99,7 +114,6 @@ is
GL.lean;
begin
Tasks.check;
openGL.Errors.log;
Self.Texture := Now;
@@ -121,7 +135,7 @@ is
function is_complete (Self : in Item) return Boolean
function is_Complete (Self : in Item) return Boolean
is
use GL,
GL.lean;
@@ -147,6 +161,7 @@ is
check_is_OK : constant Boolean := Tasks.check with Unreferenced;
begin
glBindFramebuffer (GL_FRAMEBUFFER, Self.Name);
Errors.log;
if not Self.is_Complete
then
@@ -163,6 +178,7 @@ is
check_is_OK : constant Boolean := Tasks.check with Unreferenced;
begin
glBindFramebuffer (GL_FRAMEBUFFER, 0);
Errors.log;
end disable;

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

@@ -1,6 +1,7 @@
with
openGL.Texture;
package openGL.Frame_Buffer
is
@@ -26,6 +27,7 @@ is
--------------
--- Attributes
--
subtype Buffer_Name is GL.GLuint; -- An openGL frame buffer 'Name'.
function Name (Self : in Item) return Buffer_Name;
@@ -33,7 +35,7 @@ is
function Texture (Self : in Item) return openGL.Texture.Object;
procedure Texture_is (Self : in out Item; now : in openGL.Texture.Object);
function is_complete (Self : in Item) return Boolean;
function is_Complete (Self : in Item) return Boolean;
--------------

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

@@ -1,6 +1,7 @@
with
openGL.Visual;
package openGL.Terrain
--
-- Provides a constructor for heightmap terrain.

65
3-mid/opengl/source/lean/opengl-texture.adb
View File

@@ -28,6 +28,8 @@ is
begin
Tasks.check;
glGenTextures (1, the_Name'Access);
Errors.log;
return the_Name;
end new_texture_Name;
@@ -39,7 +41,8 @@ is
begin
Tasks.check;
glDeleteTextures (1, the_Name'Access);
end free;
Errors.log;
end free;
---------
@@ -52,6 +55,7 @@ is
function to_Texture (Name : in texture_Name) return Object
is
Self : Texture.Object;
begin
Self.Name := Name;
-- TODO: Fill in remaining fields by querying GL.
@@ -72,16 +76,18 @@ is
Self.Name := new_texture_Name;
Self.enable;
glPixelStorei (GL_UNPACK_ALIGNMENT, 1);
glPixelStorei (GL_UNPACK_ALIGNMENT, 1); Errors.log;
glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_CLAMP_TO_EDGE);
glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP_TO_EDGE);
glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_CLAMP_TO_EDGE); Errors.log;
glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP_TO_EDGE); Errors.log;
-- glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_REPEAT);
-- glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_REPEAT);
glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR);
glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR);
glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR); Errors.log;
glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR); Errors.log;
return Self;
end to_Texture;
@@ -197,13 +203,11 @@ is
0,
GL_RGB,
GL_UNSIGNED_BYTE,
+the_Image (1, 1).Red'Address);
Errors.log;
+the_Image (1, 1).Red'Address); Errors.log;
if use_Mipmaps
then
glGenerateMipmap (GL_TEXTURE_2D);
Errors.log;
glGenerateMipmap (GL_TEXTURE_2D); Errors.log;
end if;
end set_Image;
@@ -242,13 +246,11 @@ is
0,
GL_RGBA,
GL_UNSIGNED_BYTE,
+the_Image (1, 1).Primary.Red'Address);
Errors.log;
+the_Image (1, 1).Primary.Red'Address); Errors.log;
if use_Mipmaps
then
glGenerateMipmap (GL_TEXTURE_2D);
Errors.log;
glGenerateMipmap (GL_TEXTURE_2D); Errors.log;
end if;
end set_Image;
@@ -273,8 +275,7 @@ is
gl.Binding.glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_REPEAT); Errors.log;
gl.Binding.glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_REPEAT); Errors.log;
glBindTexture (GL.GL_TEXTURE_2D, Self.Name);
Errors.log;
glBindTexture (GL.GL_TEXTURE_2D, Self.Name); Errors.log;
end enable;
@@ -320,6 +321,7 @@ is
function fetch (From : access name_Map_of_texture'Class; texture_Name : in asset_Name) return Object
is
Name : constant unbounded_String := to_unbounded_String (to_String (texture_Name));
begin
if From.Contains (Name)
then
@@ -391,30 +393,36 @@ is
GLsizei (Size.Height),
0,
GL_RGBA, GL_UNSIGNED_BYTE,
null); -- NB: Actual image is not initialised.
null); Errors.log; -- NB: Actual image is not initialised.
else -- No existing, unused texture found, so create a new one.
else -- No existing, unused texture found, so create a new one.
the_Texture.Pool := From.all'unchecked_Access;
the_Texture.Name := new_texture_Name;
the_Texture.enable;
glPixelStorei (GL_UNPACK_ALIGNMENT, 1);
glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_WRAP_S,
GL_CLAMP_TO_EDGE);
glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_WRAP_T,
GL_CLAMP_TO_EDGE);
glPixelStorei (GL_UNPACK_ALIGNMENT, 1); Errors.log;
glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER,
GL_LINEAR);
glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER,
glTexParameteri (GL_TEXTURE_2D,
GL_TEXTURE_WRAP_S,
GL_CLAMP_TO_EDGE); Errors.log;
glTexParameteri (GL_TEXTURE_2D,
GL_TEXTURE_WRAP_T,
GL_CLAMP_TO_EDGE); Errors.log;
glTexParameteri (GL_TEXTURE_2D,
GL_TEXTURE_MAG_FILTER,
GL_LINEAR);
glTexParameteri (GL_TEXTURE_2D,
GL_TEXTURE_MIN_FILTER,
GL_LINEAR); Errors.log;
gltexImage2D (gl_TEXTURE_2D, 0, gl_RGBA,
GLsizei (Size.Width),
GLsizei (Size.Height),
0,
GL_RGBA, GL_UNSIGNED_BYTE,
null); -- NB: Actual image is not initialised.
null); Errors.log; -- NB: Actual image is not initialised.
end if;
the_Texture.Dimensions := Size;
@@ -428,7 +436,8 @@ is
is
use type texture_Name;
begin
if the_Texture.Name = 0 then
if the_Texture.Name = 0
then
return;
end if;

3
3-mid/opengl/source/lean/opengl-texture.ads
View File

@@ -3,6 +3,7 @@ with
ada.Strings.unbounded.Hash,
ada.Containers.hashed_Maps;
package openGL.Texture
--
-- Provides openGL textures.
@@ -73,8 +74,6 @@ is
--
-- For rapid allocation/deallocation of texture objects.
-- TODO: Move this into a child package ?
type Pool is private;
type Pool_view is access all Pool;

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

@@ -19,33 +19,6 @@ is
-- procedure animate (the_Animation : in out Animation;
-- texture_Applies : in out texture_Apply_array)
-- is
-- use ada.Calendar;
--
-- 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);
-- old_Frame : Frame renames the_Animation.Frames (the_Animation.Current);
-- new_Frame : Frame renames the_Animation.Frames (next_frame_Id);
-- begin
-- texture_Applies (old_Frame.texture_Id) := False;
-- texture_Applies (new_Frame.texture_Id) := True;
--
-- the_Animation.Current := next_frame_Id;
-- the_Animation.next_frame_Time := Now + the_Animation.frame_Duration;
-- end;
-- end if;
-- end animate;
procedure animate (Self : in out Item)
is
use ada.Calendar;
@@ -72,33 +45,13 @@ is
-----------
--- Details
---------
--- Forge
--
-- function to_Details (texture_Assets : in asset_Names;
-- Animation : in Animation_view := null) return Details
-- is
-- Result : Details;
-- begin
-- Result.texture_Count := texture_Assets'Length;
--
-- for i in 1 .. texture_Assets'Length
-- loop
-- Result.Textures (i) := texture_Assets (i);
-- end loop;
--
-- Result.Animation := Animation;
--
-- return Result;
-- end to_Details;
function to_Set (texture_Assets : in asset_Names;
texture_Tilings : in Tilings := [others => (S => 1.0,
T => 1.0)];
Animation : in Animation_view := null) return Item
is
Result : Item (Count => texture_Assets'Length);
@@ -126,42 +79,6 @@ is
--------------
--- Attributes
--
-- function get_Details (Self : in Item) return Detail_array
-- is
-- begin
-- return Self.Details;
-- end get_Details;
--
--
--
-- procedure Details_are (Self : in out Item; Now : in Detail_array)
-- is
-- begin
-- Self.Details := Now;
-- end Details_are;
--
--
--
-- function get_Animation (Self : in Item) return Animation_view
-- is
-- begin
-- return Self.Animation;
-- end get_Animation;
--
--
--
-- procedure Animation_is (Self : in out Item; Now : in Animation_view)
-- is
-- begin
-- Self.Animation := Now;
-- end Animation_is;
-----------
--- Streams
--

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

@@ -17,17 +17,9 @@ is
max_Textures : constant := 16; -- 32;
type detail_Count is range 0 .. max_Textures;
-- type Item (Count : detail_Count := 1) is private;
--
-- null_Set : constant Item;
---------------
--- Texture Ids
--
@@ -60,13 +52,6 @@ is
type fade_Levels is array (texture_Id range <>) of fade_Level;
---------
--- Apply
--
-- type texture_Apply_array is array (texture_Set.texture_Id) of Boolean;
-------------
--- Animation
--
@@ -96,42 +81,19 @@ is
type Animation_view is access all Animation;
-- procedure animate (the_Animation : in out Animation;
-- texture_Applies : in out texture_Apply_array);
type Detail is
record
Object : texture.Object;
Texture : asset_Name;
Fade : fade_Level;
texture_Tiling : Tiling;
texture_Apply : Boolean; -- If the textures is to be applied to the visual.
texture_Apply : Boolean; -- If the texture is to be applied to the visual.
end record;
type Detail_array is array (detail_Count range <>) of Detail;
-----------
--- Details
--
-- type Details is
-- record
-- texture_Count : Natural := 0;
-- Fades : fade_Levels (texture_Id) := [others => 0.0];
-- Textures : asset_Names (1 .. Positive (texture_Id'Last)) := [others => null_Asset];
-- Objects : texture.Objects (1 .. Positive (texture_Id'Last)) := [others => texture.null_Object];
-- texture_Tilings : Tilings := [others => (S => 1.0,
-- T => 1.0)];
-- texture_Applies : texture_Apply_array := [1 => True, others => False]; -- The textures to be applied to the visual.
-- Animation : Animation_view;
-- end record;
type Item (Count : detail_Count := 1) is
record
Details : Detail_array (1 .. Count);
@@ -141,19 +103,10 @@ is
null_Set : constant Item;
---------
--- Forge
--
-- function to_Details (texture_Assets : in asset_Names;
-- Animation : in Animation_view := null) return Details;
--
-- no_Details : constant Details;
function to_Set (texture_Assets : in asset_Names;
texture_Tilings : in Tilings := [others => (S => 1.0,
T => 1.0)];
@@ -161,17 +114,11 @@ is
--------------
--- Attributes
-- Operations
--
procedure animate (Self : in out Item);
-- function get_Details (Self : in Item) return Detail_array;
-- procedure Details_are (Self : in out Item; Now : in Detail_array);
--
-- function get_Animation (Self : in Item) return Animation_view;
-- procedure Animation_is (Self : in out Item; Now : in Animation_view);
private
@@ -191,7 +138,6 @@ private
for Animation_view'read use read;
-- no_Details : constant Details := (others => <>);
null_Set : constant Item := (Count => 0,
others => <>);

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

@@ -1,6 +1,8 @@
with
GL.Binding,
openGL.Tasks;
openGL.Tasks,
openGL.Errors;
package body openGL.Viewport
is
@@ -14,7 +16,7 @@ is
begin
Tasks.check;
glGetIntegerv (gl_VIEWPORT,
Extent (1)'unchecked_Access);
Extent (1)'unchecked_Access); Errors.log;
return (Integer (Extent (3)),
Integer (Extent (4)));
@@ -29,7 +31,7 @@ is
Tasks.check;
glViewport (0, 0,
GLint (Now.Width),
GLint (Now.Height));
GLint (Now.Height)); Errors.log;
end Extent_is;

22
3-mid/opengl/source/lean/opengl-visual.adb
View File

@@ -13,7 +13,6 @@ is
is
begin
return new Visual.item' (Model => Model,
model_Transform => Identity_4x4,
camera_Transform => Identity_4x4,
Transform => Identity_4x4,
mvp_Transform => Identity_4x4,
@@ -66,7 +65,7 @@ is
function is_Terrain (Self : in Item) return Boolean
function is_Terrain (Self : in Item) return Boolean
is
begin
return Self.is_Terrain;
@@ -139,21 +138,6 @@ is
end mvp_Transform_is;
function model_Transform (Self : in Item) return Matrix_4x4
is
begin
return Self.model_Transform;
end model_Transform;
procedure model_Transform_is (Self : in out Item; Now : in Matrix_4x4)
is
begin
Self.model_Transform := Now;
end model_Transform_is;
function camera_Transform (Self : in Item) return Matrix_4x4
is
begin
@@ -174,7 +158,6 @@ is
use linear_Algebra_3d;
begin
set_Rotation (Self.Transform, Now);
-- set_Rotation (Self.model_Transform, Now);
end Spin_is;
@@ -183,7 +166,6 @@ is
use linear_Algebra_3d;
begin
return get_Rotation (Self.Transform);
-- return get_Rotation (Self.model_Transform);
end Spin_of;
@@ -193,7 +175,6 @@ is
use linear_Algebra_3d;
begin
set_Translation (Self.Transform, Now);
-- set_Translation (Self.model_Transform, Now);
end Site_is;
@@ -202,7 +183,6 @@ is
use linear_Algebra_3d;
begin
return get_Translation (Self.Transform);
-- return get_Translation (Self.model_Transform);
end Site_of;

48
3-mid/opengl/source/lean/opengl-visual.ads
View File

@@ -2,6 +2,7 @@ with
openGL.Program,
openGL.Model;
package openGL.Visual
is
type Item is tagged private;
@@ -31,38 +32,38 @@ is
-- Attributes
--
procedure Model_is (Self : in out Item; Now : in Model.view);
function Model (Self : in Item) return Model.view;
procedure Model_is (Self : in out Item; Now : in Model.view);
function Model (Self : in Item) return Model.view;
procedure Scale_is (Self : in out Item; Now : in Vector_3);
function Scale (Self : in Item) return Vector_3;
procedure Scale_is (Self : in out Item; Now : in Vector_3);
function Scale (Self : in Item) return Vector_3;
procedure is_Terrain (Self : in out Item; Now : in Boolean := True);
function is_Terrain (Self : in Item) return Boolean;
procedure is_Terrain (Self : in out Item; Now : in Boolean := True);
function is_Terrain (Self : in Item) return Boolean;
procedure face_Count_is (Self : in out Item; Now : in Natural);
function face_Count (Self : in Item) return Natural;
procedure face_Count_is (Self : in out Item; Now : in Natural);
function face_Count (Self : in Item) return Natural;
procedure apparent_Size_is (Self : in out Item; Now : in Real);
function apparent_Size (Self : in Item) return Real;
procedure apparent_Size_is (Self : in out Item; Now : in Real);
function apparent_Size (Self : in Item) return Real;
procedure mvp_Transform_is (Self : in out Item; Now : in Matrix_4x4);
function mvp_Transform (Self : in Item) return Matrix_4x4;
procedure mvp_Transform_is (Self : in out Item; Now : in Matrix_4x4);
function mvp_Transform (Self : in Item) return Matrix_4x4;
procedure model_Transform_is (Self : in out Item; Now : in Matrix_4x4);
function model_Transform (Self : in Item) return Matrix_4x4;
-- procedure model_Transform_is (Self : in out Item; Now : in Matrix_4x4);
-- function model_Transform (Self : in Item) return Matrix_4x4;
procedure camera_Transform_is (Self : in out Item; Now : in Matrix_4x4);
function camera_Transform (Self : in Item) return Matrix_4x4;
procedure Transform_is (Self : in out Item; Now : in Matrix_4x4);
function Transform (Self : in Item) return Matrix_4x4;
procedure Transform_is (Self : in out Item; Now : in Matrix_4x4);
function Transform (Self : in Item) return Matrix_4x4;
procedure Site_is (Self : in out Item; Now : in Vector_3);
function Site_of (Self : in Item) return Vector_3;
procedure Site_is (Self : in out Item; Now : in Vector_3);
function Site_of (Self : in Item) return Vector_3;
procedure Spin_is (Self : in out Item; Now : in Matrix_3x3);
function Spin_of (Self : in Item) return Matrix_3x3;
procedure Spin_is (Self : in out Item; Now : in Matrix_3x3);
function Spin_of (Self : in Item) return Matrix_3x3;
procedure program_Parameters_are (Self : in out Item; Now : in program.Parameters_view);
function program_Parameters (Self : in Item) return program.Parameters_view;
@@ -76,17 +77,16 @@ private
Model : openGL.Model.view;
Scale : Vector_3 := [1.0, 1.0, 1.0];
model_Transform : Matrix_4x4;
camera_Transform : Matrix_4x4;
Transform : Matrix_4x4;
mvp_Transform : Matrix_4x4;
program_Parameters : program.Parameters_view;
is_Terrain : Boolean := False;
face_Count : Positive := 1;
is_Terrain : Boolean := False;
face_Count : Positive := 1;
apparent_Size : Real; -- A measure of how large the visual is in screen size.
apparent_Size : Real; -- A measure of how large the visual is in screen size.
end record;
end openGL.Visual;

17
3-mid/opengl/source/lean/renderer/opengl-renderer-lean.adb
View File

@@ -697,9 +697,9 @@ is
Heap_less_than'unrestricted_Access);
end if;
glDisable (GL_BLEND);
glEnable (GL_DEPTH_TEST);
glDepthMask (gl_TRUE); -- Make depth buffer read/write.
glDisable (GL_BLEND); Errors.log;
glEnable (GL_DEPTH_TEST); Errors.log;
glDepthMask (gl_TRUE); Errors.log; -- Make depth buffer read/write.
for Each in 1 .. opaque_Count
loop
@@ -710,6 +710,7 @@ is
current_Program := the_Couple.Geometry.Program;
end if;
current_Program.enable; -- TODO: Only need to do this when program changes ?
current_Program.mvp_Transform_is (the_Couple.Visual.mvp_Transform);
current_Program.model_Matrix_is (the_Couple.Visual.Transform);
@@ -759,13 +760,13 @@ is
Heap_less_than'unrestricted_Access);
end if;
glDepthMask (gl_False); -- Make depth buffer read-only, for correct transparency.
glDepthMask (gl_False); Errors.log; -- Make depth buffer read-only, for correct transparency.
glEnable (GL_BLEND);
gl.lean.glBlendEquation (gl.lean.GL_FUNC_ADD);
glEnable (GL_BLEND); Errors.log;
gl.lean.glBlendEquation (gl.lean.GL_FUNC_ADD); Errors.log;
glBlendFunc (GL_SRC_ALPHA,
GL_ONE_MINUS_SRC_ALPHA);
GL_ONE_MINUS_SRC_ALPHA); Errors.log;
for Each in 1 .. lucid_Count
loop
@@ -786,7 +787,7 @@ is
the_Couple.Geometry.render;
end loop;
glDepthMask (gl_True);
glDepthMask (gl_True); Errors.log;
end;
Errors.log;

2
3-mid/opengl/source/opengl-errors-debugging.adb
View File

@@ -3,5 +3,5 @@ separate (openGL.Errors)
function Debugging return Boolean
is
begin
return True;
return False;
end Debugging;

49
4-high/gel/applet/demo/sprite/mixed_shapes/launch_mixed_shapes.adb
View File

@@ -8,6 +8,7 @@ with
physics.Model,
openGL.Model.box.colored,
openGL.Model.sphere.lit_textured,
openGL.Model.sphere.lit_colored_textured,
openGL.Model.capsule.lit_colored_textured,
openGL.Model.capsule.textured,
@@ -89,17 +90,17 @@ is
hs : constant := 1.0;
gl_Heights : constant openGL.IO.height_Map_view := openGL.IO.to_height_Map (image_Filename => terrain_Heights,
Scale => 2.0);
Scale => 10.0);
the_heightfield_Model : constant openGL.Model.terrain.view
:= openGL.Model.terrain.new_Terrain (heights_Asset => terrain_Heights,
Row => 1,
Col => 1,
Heights => openGL.Model.terrain.height_Map_view (gl_Heights),
color_Map => terrain_Texture,
texture_Details => texture_Set.to_Set ([1 => terrain_Texture]),
Tiling => (s => (0.0, 1.0),
t => (0.0, 1.0)));
:= openGL.Model.terrain.new_Terrain (heights_Asset => terrain_Heights,
Row => 1,
Col => 1,
Heights => openGL.Model.terrain.height_Map_view (gl_Heights),
color_Map => terrain_Texture,
texture_Details => texture_Set.to_Set ([1 => terrain_Texture]),
Tiling => (s => (0.0, 1.0),
t => (0.0, 1.0)));
the_heightfield_physics_Model : constant physics.Model.view
:= physics.Model.forge.new_physics_Model (shape_Info => (Kind => physics.Model.heightfield,
@@ -127,6 +128,8 @@ begin
Light : openGL.Light.item := the_Applet.Renderer.new_Light;
begin
Light.Site_is ([0.0, 1000.0, 0.0]);
Light.ambient_Coefficient_is (0.1);
-- Light.Kind_is (openGL.Light.Diffuse);
the_Applet.Renderer.set (Light);
end;
@@ -167,10 +170,18 @@ begin
sphere_Radius => 1.0),
Mass => 1.0);
the_ball_Model : constant openGL.Model.sphere.lit_colored_textured.view
:= openGL.Model.sphere.lit_colored_textured.new_Sphere (Radius => 1.0,
Image => openGL.to_Asset ("assets/gel/golf_green-16x16.tga"),
texture_Details => texture_Set.to_Set ([1 => openGL.to_Asset ("assets/gel/Face1.bmp")]));
-- the_ball_Model : constant openGL.Model.sphere.lit_colored_textured.view
-- := openGL.Model.sphere.lit_colored_textured.new_Sphere (Radius => 1.0,
-- -- Image => openGL.to_Asset ("assets/gel/golf_green-16x16.tga"),
-- Image => openGL.to_Asset ("assets/gel/texture/earth_map.bmp"),
-- -- texture_Details => texture_Set.to_Set ([1 => openGL.to_Asset ("assets/gel/Face1.bmp")]));
-- texture_Details => texture_Set.to_Set ([1 => openGL.to_Asset ("assets/gel/texture/earth_map.bmp")]));
the_ball_Model : constant openGL.Model.sphere.lit_textured.view
:= openGL.Model.sphere.lit_textured.new_Sphere (Radius => 1.0,
-- Image => openGL.to_Asset ("assets/gel/golf_green-16x16.tga"),
Image => openGL.to_Asset ("assets/gel/texture/earth_map.bmp"),
-- texture_Details => texture_Set.to_Set ([1 => openGL.to_Asset ("assets/gel/Face1.bmp")]));
texture_Details => texture_Set.to_Set ([1 => openGL.to_Asset ("assets/gel/texture/earth_map.bmp")]));
the_Ball : constant gel.Sprite.view
:= gel.Sprite.forge.new_Sprite (Name => "demo.Ball",
World => the_Applet.gui_World.all'Access,
@@ -260,12 +271,12 @@ begin
s : constant := 0.5;
the_hull_Model : constant openGL.Model.box.colored.view
:= openGL.Model.box.colored.new_Box (Size => [s*2.0, s*2.0, s*2.0],
Faces => [Front => (Colors => [others => (Shade_of (Grey, 1.0), Opaque)]),
Rear => (Colors => [others => (Shade_of (Grey, 0.5), Opaque)]),
Upper => (Colors => [others => (Shade_of (Grey, 0.4), Opaque)]),
Lower => (Colors => [others => (Shade_of (Grey, 0.3), Opaque)]),
Left => (Colors => [others => (Shade_of (Grey, 0.2), Opaque)]),
Right => (Colors => [others => (Shade_of (Grey, 0.1), Opaque)])]);
Faces => [Front => (Colors => [others => (Shade_of (Green, 1.0), Opaque)]),
Rear => (Colors => [others => (Shade_of (Green, 0.5), Opaque)]),
Upper => (Colors => [others => (Shade_of (Green, 0.4), Opaque)]),
Lower => (Colors => [others => (Shade_of (Green, 0.3), Opaque)]),
Left => (Colors => [others => (Shade_of (Green, 0.2), Opaque)]),
Right => (Colors => [others => (Shade_of (Green, 0.1), Opaque)])]);
the_hull_physics_Model : constant physics.Model.view
:= physics.Model.forge.new_physics_Model (shape_Info => (Kind => physics.Model.hull,
Points => new physics.Vector_3_array' ([-s, -s, s],