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 the_ball_4_Model : constant Model.sphere.lit_colored_textured.view
:= Model.sphere.lit_colored_textured.new_Sphere (Radius => 1.0, := Model.sphere.lit_colored_textured.new_Sphere (Radius => 1.0,
Color => (Green, Opaque),
texture_Details => texture_Set.to_Set ([1 => the_Texture]), texture_Details => texture_Set.to_Set ([1 => the_Texture]),
Image => 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; GL.Pointers;
package body openGL.Buffer.general package body openGL.Buffer.general
is is
-------------------------- --------------------------
@@ -53,6 +54,7 @@ is
From'Size / 8, From'Size / 8,
+From (From'First)'Address, +From (From'First)'Address,
to_GL_Enum (Usage)); to_GL_Enum (Usage));
Errors.log;
end return; end return;
end to_Buffer; end to_Buffer;
@@ -78,6 +80,7 @@ is
Offset => GLintptr ((Position - 1) * Vertex_Size_in_bits / 8), Offset => GLintptr ((Position - 1) * Vertex_Size_in_bits / 8),
Size => new_Vertices'Size / 8, Size => new_Vertices'Size / 8,
Data => +new_Vertices (new_Vertices'First)'Address); Data => +new_Vertices (new_Vertices'First)'Address);
Errors.log;
else else
Self.destroy; Self.destroy;
@@ -89,9 +92,8 @@ is
To'Size / 8, To'Size / 8,
+To (To'First)'Address, +To (To'First)'Address,
to_GL_Enum (Self.Usage)); to_GL_Enum (Self.Usage));
end if;
Errors.log; Errors.log;
end if;
end set; 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 is private;
type Element_Array is array (Index range <>) of Element; type Element_Array is array (Index range <>) of Element;
package openGL.Buffer.general package openGL.Buffer.general
-- --
-- A generic for producing various types of openGL vertex buffer objects. -- 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 with
openGL.Buffer.general; openGL.Buffer.general;
package openGL.Buffer.indices is new openGL.Buffer.general (base_Object => Buffer.element_array_Object, package openGL.Buffer.indices is new openGL.Buffer.general (base_Object => Buffer.element_array_Object,
Index => long_Index_t, Index => long_Index_t,
Element => Index_t, Element => Index_t,

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

@@ -1,6 +1,7 @@
with with
openGL.Buffer.general; openGL.Buffer.general;
package openGL.Buffer.long_indices is new openGL.Buffer.general (base_Object => Buffer.element_array_Object, package openGL.Buffer.long_indices is new openGL.Buffer.general (base_Object => Buffer.element_array_Object,
Index => long_Index_t, Index => long_Index_t,
Element => 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 with
openGL.Buffer.general; openGL.Buffer.general;
package openGL.Buffer.normals is new openGL.Buffer.general (base_Object => Buffer.array_Object, package openGL.Buffer.normals is new openGL.Buffer.general (base_Object => Buffer.array_Object,
Index => Index_t, Index => Index_t,
Element => Normal, Element => Normal,

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

@@ -1,6 +1,7 @@
with with
openGL.Buffer.general; openGL.Buffer.general;
package openGL.Buffer.short_indices is new openGL.Buffer.general (base_Object => Buffer.element_array_Object, package openGL.Buffer.short_indices is new openGL.Buffer.general (base_Object => Buffer.element_array_Object,
Index => long_Index_t, Index => long_Index_t,
Element => short_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 with
openGL.Buffer.general; openGL.Buffer.general;
package openGL.Buffer.texture_coords is new openGL.Buffer.general (base_Object => Buffer.array_Object, package openGL.Buffer.texture_coords is new openGL.Buffer.general (base_Object => Buffer.array_Object,
Index => Index_t, Index => Index_t,
Element => Coordinate_2D, Element => Coordinate_2D,

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

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

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

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

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

@@ -3,6 +3,7 @@ with
GL.lean, GL.lean,
ada.unchecked_Conversion; ada.unchecked_Conversion;
package openGL.Buffer package openGL.Buffer
-- --
-- Models a buffer object. -- Models a buffer object.
@@ -11,7 +12,7 @@ is
-------------- --------------
--- Core Types --- 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 a_Kind is (array_Buffer, element_array_Buffer);
type Usage is (stream_Draw, static_Draw, dynamic_Draw); type Usage is (stream_Draw, static_Draw, dynamic_Draw);
@@ -121,4 +122,5 @@ private
-- --
procedure verify_Name (Self : in out Object'Class); procedure verify_Name (Self : in out Object'Class);
end openGL.Buffer; end openGL.Buffer;

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

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

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

@@ -35,9 +35,7 @@ is
private private
type Item is new Geometry.item with type Item is new Geometry.item with null record;
record
null;
end record;
end openGL.Geometry.colored; 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, Interfaces.C.Strings,
System.storage_Elements; System.storage_Elements;
package body openGL.Geometry.colored_textured package body openGL.Geometry.colored_textured
is is
use GL.lean, use GL.lean,
@@ -188,23 +189,4 @@ is
end Indices_are; 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; 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; package textured_Geometry is new texturing.Mixin;
type Item is new textured_Geometry.item with null record;
type Item is new textured_Geometry.item with
record
null;
end record;
end openGL.Geometry.colored_textured; 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; type Item is new Geometry.item with null record;
end openGL.Geometry.lit_colored; 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.Shader,
openGL.Attribute, openGL.Attribute,
openGL.Buffer.general, openGL.Buffer.general,
openGL.Texture,
openGL.Tasks, openGL.Tasks,
openGL.Errors, openGL.Errors,
@@ -209,6 +208,7 @@ is
end define_Program; end define_Program;
-------------- --------------
-- Attributes -- Attributes
-- --

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

@@ -1,9 +1,10 @@
with with
openGL.Program.lit.colored_skinned; openGL.Program.lit.colored_skinned;
package openGL.Geometry.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 is
type Item is new openGL.Geometry.item with private; type Item is new openGL.Geometry.item with private;
@@ -28,8 +29,10 @@ is
bone_Ids : Vector_4; bone_Ids : Vector_4;
bone_Weights : Vector_4; bone_Weights : Vector_4;
end record; end record;
pragma Convention (C, Vertex); pragma Convention (C, Vertex);
type Vertex_array is array (long_Index_t range <>) of aliased Vertex; type Vertex_array is array (long_Index_t range <>) of aliased Vertex;
@@ -55,4 +58,5 @@ private
overriding overriding
procedure enable_Textures (Self : in out Item); procedure enable_Textures (Self : in out Item);
end openGL.Geometry.lit_colored_skinned; 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; 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 function new_Geometry (texture_is_Alpha : in Boolean) return access Geometry.lit_colored_textured.item'Class
is is
use type openGL.Program.lit.view; use type openGL.Program.lit.view;
@@ -195,6 +196,7 @@ is
textured_Geometry.create_Uniforms (for_Program => the_Program.Program.all'Access); textured_Geometry.create_Uniforms (for_Program => the_Program.Program.all'Access);
end define; end define;
Self : constant Geometry_view := new Geometry.lit_colored_textured.item; Self : constant Geometry_view := new Geometry.lit_colored_textured.item;
begin begin
@@ -225,6 +227,7 @@ is
end new_Geometry; end new_Geometry;
---------- ----------
-- Vertex -- Vertex
-- --
@@ -241,6 +244,7 @@ is
end is_Transparent; end is_Transparent;
-------------- --------------
-- Attributes -- Attributes
-- --
@@ -257,7 +261,7 @@ is
begin begin
if Self.Vertices = null if Self.Vertices = null
then 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)); usage => Buffer.static_Draw));
else else
set (openGL_Buffer_of_geometry_Vertices.Object (Self.Vertices.all), 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; 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 Item is new textured_Geometry.item with private;
type View is access all Item'Class; type View is access all Item'Class;
@@ -46,10 +45,7 @@ is
private private
type Item is new textured_Geometry.item with type Item is new textured_Geometry.item with null record;
record
null;
end record;
end openGL.Geometry.lit_colored_textured; 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; end is_Transparent;
--------- ---------
-- Forge -- Forge
-- --
@@ -282,36 +283,4 @@ is
end Vertices_are; 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; 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); pragma Convention (C, Vertex);
type Vertex_array is array (long_Index_t range <>) of aliased 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; package textured_Geometry is new texturing.Mixin;
type Item is new textured_Geometry.item with null record;
type Item is new textured_Geometry.item with
record
null;
end record;
end openGL.Geometry.lit_colored_textured_skinned; end openGL.Geometry.lit_colored_textured_skinned;

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

@@ -160,7 +160,6 @@ is
---------- ----------
-- Vertex -- Vertex
-- --
@@ -183,7 +182,6 @@ is
-------------- --------------
-- Attributes -- 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; package textured_Geometry is new texturing.Mixin;
type Item is new textured_Geometry.item with null record;
type Item is new textured_Geometry.item with
record
null;
end record;
end openGL.Geometry.lit_textured; 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. -- Define the shaders and program.
-- --
vertex_Shader .define (Shader.Vertex, "assets/opengl/shader/lit_textured_skinned.vert"); 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"), fragment_Shader.define (Shader.Fragment, (asset_Names' (1 => to_Asset ("assets/opengl/shader/version.header"),
2 => to_Asset ("assets/opengl/shader/lighting-frag.snippet"), 2 => to_Asset ("assets/opengl/shader/lighting-frag.snippet"),
3 => to_Asset ("assets/opengl/shader/texturing-frag.snippet"), 3 => to_Asset ("assets/opengl/shader/texturing-frag.snippet"),
@@ -254,36 +253,4 @@ is
end Vertices_are; 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; 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; package textured_Geometry is new texturing.Mixin;
type Item is new textured_Geometry.item with null record;
type Item is new textured_Geometry.item with
record
null;
end record;
end openGL.Geometry.lit_textured_skinned; 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.Shader,
openGL.Program, openGL.Program,
openGL.Attribute, openGL.Attribute,
openGL.Errors,
openGL.Tasks, openGL.Tasks,
GL.lean, GL.lean,
GL.Pointers, GL.Pointers,
System,
Interfaces.C.Strings, Interfaces.C.Strings,
System.storage_Elements; System.storage_Elements;
@@ -97,10 +97,12 @@ is
glBindAttribLocation (program => the_Program.gl_Program, glBindAttribLocation (program => the_Program.gl_Program,
index => the_Program.Attribute (named => Name_1).gl_Location, index => the_Program.Attribute (named => Name_1).gl_Location,
name => +Attribute_1_Name_ptr); name => +Attribute_1_Name_ptr);
Errors.log;
glBindAttribLocation (program => the_Program.gl_Program, glBindAttribLocation (program => the_Program.gl_Program,
index => the_Program.Attribute (named => Name_2).gl_Location, index => the_Program.Attribute (named => Name_2).gl_Location,
name => +Attribute_2_Name_ptr); name => +Attribute_2_Name_ptr);
Errors.log;
textured_Geometry.create_Uniforms (for_Program => the_Program.all'Access); textured_Geometry.create_Uniforms (for_Program => the_Program.all'Access);
end; end;
@@ -112,7 +114,6 @@ is
-------------- --------------
-- Attributes -- Attributes
-- --
@@ -130,13 +131,12 @@ is
Element => Vertex, Element => Vertex,
Element_Array => Vertex_array); Element_Array => Vertex_array);
procedure Vertices_are (Self : in out Item; Now : in Vertex_array) procedure Vertices_are (Self : in out Item; Now : in Vertex_array)
is is
use openGL_Buffer_of_geometry_Vertices.Forge; use openGL_Buffer_of_geometry_Vertices.Forge;
begin begin
Self.Vertices := new openGL_Buffer_of_geometry_Vertices.Object' (to_Buffer (Now, Self.Vertices := new openGL_Buffer_of_geometry_Vertices.Object' (to_Buffer (Now,
usage => Buffer.static_Draw)); Usage => Buffer.static_Draw));
-- Set the bounds. -- Set the bounds.
-- --
declare 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; package textured_Geometry is new texturing.Mixin;
type Item is new textured_Geometry.item with null record;
type Item is new textured_Geometry.item with
record
null;
end record;
end openGL.Geometry.textured; end openGL.Geometry.textured;

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

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

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

@@ -40,15 +40,9 @@ is
--- Operations --- 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; procedure enable (for_Model : in openGL.Model.view;
Uniforms : in texturing.Uniforms); Uniforms : in texturing.Uniforms);
procedure create (Uniforms : out texturing.Uniforms; procedure create (Uniforms : out texturing.Uniforms;
for_Program : in openGL.Program.view); for_Program : in openGL.Program.view);
@@ -100,13 +94,9 @@ is
private private
type Item is new Geometry.item with type Item is new Geometry.item with null record;
record
null; --texture_Set : openGL.texture_Set.item;
end record;
end Mixin; end Mixin;
end openGL.Geometry.texturing; end openGL.Geometry.texturing;

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

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

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

@@ -135,11 +135,15 @@ private
generic generic
type any_Index_t is range <>; type any_Index_t is range <>;
with function get_Site (Index : in any_Index_t) return Vector_3; with function get_Site (Index : in any_Index_t) return Vector_3;
function get_Bounds (Count : in Natural) return openGL.Bounds; function get_Bounds (Count : in Natural) return openGL.Bounds;
generic generic
type any_Index_t is range <>; type any_Index_t is range <>;
with function get_Color (Index : in any_Index_t) return rgba_Color; with function get_Color (Index : in any_Index_t) return rgba_Color;
function get_Transparency (Count : in Natural) return Boolean; function get_Transparency (Count : in Natural) return Boolean;
end openGL.Geometry; end openGL.Geometry;

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

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

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

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

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

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

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

@@ -2,6 +2,7 @@ private
with with
openGL.Buffer.long_indices; openGL.Buffer.long_indices;
package openGL.Primitive.long_indexed package openGL.Primitive.long_indexed
-- --
-- Provides a class for long indexed openGL primitives. -- Provides a class for long indexed openGL primitives.
@@ -27,6 +28,7 @@ is
procedure destroy (Self : in out Item); procedure destroy (Self : in out Item);
-------------- --------------
-- Attributes -- Attributes
-- --
@@ -34,6 +36,7 @@ is
procedure Indices_are (Self : in out Item; Now : in long_Indices); procedure Indices_are (Self : in out Item; Now : in long_Indices);
-------------- --------------
-- Operations -- Operations
-- --
@@ -50,4 +53,5 @@ private
Indices : Buffer.long_indices.view; Indices : Buffer.long_indices.view;
end record; end record;
end openGL.Primitive.long_indexed; 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, openGL.Tasks,
GL.Binding; GL.Binding;
package body openGL.Primitive.non_indexed package body openGL.Primitive.non_indexed
is is
--------- ---------
@@ -29,6 +30,7 @@ is
end new_Primitive; end new_Primitive;
overriding overriding
procedure destroy (Self : in out Item) is null; 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; type Views is array (Index_t range <>) of View;
--------- ---------
-- Forge -- Forge
-- --
@@ -23,6 +24,7 @@ is
function new_Primitive (Kind : in facet_Kind; function new_Primitive (Kind : in facet_Kind;
vertex_Count : in Natural) return Primitive.non_indexed.view; vertex_Count : in Natural) return Primitive.non_indexed.view;
-------------- --------------
-- Operations -- Operations
-- --
@@ -39,4 +41,5 @@ private
vertex_Count : Natural := 0; vertex_Count : Natural := 0;
end record; end record;
end openGL.Primitive.non_indexed; 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; ada.unchecked_Deallocation;
package body openGL.Primitive.short_indexed package body openGL.Primitive.short_indexed
is is
--------- ---------
@@ -25,7 +26,7 @@ is
Self.facet_Kind := Kind; Self.facet_Kind := Kind;
Self.Indices := new Buffer.short_indices.Object' (to_Buffer (buffer_Indices'Access, Self.Indices := new Buffer.short_indices.Object' (to_Buffer (buffer_Indices'Access,
usage => Buffer.static_Draw)); Usage => Buffer.static_Draw));
end define; end define;
@@ -43,7 +44,7 @@ is
Self.facet_Kind := Kind; Self.facet_Kind := Kind;
Self.Indices := new Buffer.short_indices.Object' (to_Buffer (buffer_Indices'Access, Self.Indices := new Buffer.short_indices.Object' (to_Buffer (buffer_Indices'Access,
usage => Buffer.static_Draw)); Usage => Buffer.static_Draw));
end define; end define;
@@ -61,7 +62,7 @@ is
Self.facet_Kind := Kind; Self.facet_Kind := Kind;
Self.Indices := new Buffer.short_indices.Object' (to_Buffer (buffer_Indices'Access, Self.Indices := new Buffer.short_indices.Object' (to_Buffer (buffer_Indices'Access,
usage => Buffer.static_Draw)); Usage => Buffer.static_Draw));
end define; end define;
@@ -110,6 +111,7 @@ is
end destroy; end destroy;
-------------- --------------
-- Attributes -- Attributes
-- --
@@ -118,13 +120,14 @@ is
is is
use Buffer.short_indices; use Buffer.short_indices;
buffer_Indices : aliased short_Indices := [Now'Range => <>]; buffer_Indices : aliased short_Indices := [Now'Range => <>];
begin begin
for Each in buffer_Indices'Range for Each in buffer_Indices'Range
loop loop
buffer_Indices (Each) := Now (Each) - 1; -- Adjust indices to zero-based-indexing for GL. buffer_Indices (Each) := Now (Each) - 1; -- Adjust indices to zero-based-indexing for GL.
end loop; end loop;
Self.Indices.set (to => buffer_Indices); Self.Indices.set (To => buffer_Indices);
end Indices_are; end Indices_are;
@@ -133,13 +136,14 @@ is
is is
use Buffer.short_indices; use Buffer.short_indices;
buffer_Indices : aliased short_Indices := [Now'Range => <>]; buffer_Indices : aliased short_Indices := [Now'Range => <>];
begin begin
for Each in buffer_Indices'Range for Each in buffer_Indices'Range
loop loop
buffer_Indices (Each) := short_Index_t (Now (Each) - 1); -- Adjust indices to zero-based-indexing for GL. buffer_Indices (Each) := short_Index_t (Now (Each) - 1); -- Adjust indices to zero-based-indexing for GL.
end loop; end loop;
Self.Indices.set (to => buffer_Indices); Self.Indices.set (To => buffer_Indices);
end Indices_are; end Indices_are;
@@ -148,13 +152,14 @@ is
is is
use Buffer.short_indices; use Buffer.short_indices;
buffer_Indices : aliased short_Indices := [Now'Range => <>]; buffer_Indices : aliased short_Indices := [Now'Range => <>];
begin begin
for Each in buffer_Indices'Range for Each in buffer_Indices'Range
loop loop
buffer_Indices (Each) := short_Index_t (Now (Each) - 1); -- Adjust indices to zero-based-indexing for GL. buffer_Indices (Each) := short_Index_t (Now (Each) - 1); -- Adjust indices to zero-based-indexing for GL.
end loop; end loop;
Self.Indices.set (to => buffer_Indices); Self.Indices.set (To => buffer_Indices);
end Indices_are; end Indices_are;

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

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

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

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

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

@@ -5,6 +5,7 @@ private
with with
ada.unchecked_Conversion; ada.unchecked_Conversion;
package openGL.Primitive package openGL.Primitive
-- --
-- Provides a base class for openGL primitives. -- Provides a base class for openGL primitives.

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

@@ -10,7 +10,8 @@ package openGL.Model.capsule.textured
is is
package textured_Model is new texturing.Mixin (openGL.Model.capsule.item); 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 for i in 1 .. Self.texture_Details.Count
loop loop
put_Line ("KKK" & Self.texture_Details'Image);
Id := texture_Id (i); Id := texture_Id (i);
-- the_Geometry.Fade_is (which => Id, -- 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 package body openGL.Model.texturing
is is
@@ -135,8 +139,16 @@ is
procedure texture_Details_is (Self : in out textured_Item; Now : in openGL.texture_Set.item) procedure texture_Details_is (Self : in out textured_Item; Now : in openGL.texture_Set.item)
is is
procedure free is new ada.unchecked_Deallocation (Animation, Animation_view);
begin begin
free (Self.texture_Set.Animation);
Self.texture_Set := Now; 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; end texture_Details_is;

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

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

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

@@ -6,6 +6,7 @@ with
openGL.Surface, openGL.Surface,
openGL.Renderer.lean; openGL.Renderer.lean;
package openGL.Camera package openGL.Camera
-- --
-- Simulates a camera. -- Simulates a camera.
@@ -30,12 +31,12 @@ is
fairly_Far : constant := 1_000_000.0; fairly_Far : constant := 1_000_000.0;
default_field_of_view_Angle : constant Degrees := 60.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; 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; function Spin (Self : in Item'Class) return math.Matrix_3x3;
procedure Position_is (Self : in out Item'Class; Site : in math.Vector_3; 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); 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. 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 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. 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 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 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 view_Transform (Self : in Item'Class) return math.Matrix_4x4;
function projection_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, procedure Viewport_is (Self : in out Item'Class; Width,
Height : in Positive); 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. -- Returns the 'window space' site transformed to the equivalent 'world space' site.
@@ -69,16 +70,16 @@ is
procedure disable_cull (Self : in out Item); procedure disable_cull (Self : in out Item);
function vanish_Point_Size_min (Self : in Item'Class) return Real; 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. -- Visuals whose projected size falls below this minimum will be culled.
function Impostor_Size_min (Self : in Item) return Real; 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. -- 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; 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; 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.Tasks,
openGL.Errors; openGL.Errors;
package body openGL.Frame_Buffer package body openGL.Frame_Buffer
is is
@@ -27,17 +28,26 @@ is
Self.Texture := openGL.Texture.Forge.to_Texture (Dimensions' (Width, Height)); Self.Texture := openGL.Texture.Forge.to_Texture (Dimensions' (Width, Height));
glGenFramebuffers (1, Self.Name'Access); glGenFramebuffers (1, Self.Name'Access);
Errors.log;
-- Attach each texture to the first color buffer of an frame buffer object and clear it. -- Attach each texture to the first color buffer of an frame buffer object and clear it.
-- --
glBindFramebuffer (GL_FRAMEBUFFER, Self.Name); glBindFramebuffer (GL_FRAMEBUFFER, Self.Name);
Errors.log;
glFramebufferTexture2D (GL_FRAMEBUFFER, glFramebufferTexture2D (GL_FRAMEBUFFER,
GL_COLOR_ATTACHMENT0, GL_COLOR_ATTACHMENT0,
GL_TEXTURE_2D, GL_TEXTURE_2D,
Self.Texture.Name, Self.Texture.Name,
0); 0);
Errors.log;
glClear (GL_COLOR_BUFFER_BIT); glClear (GL_COLOR_BUFFER_BIT);
Errors.log;
glBindFramebuffer (GL_FRAMEBUFFER, 0); glBindFramebuffer (GL_FRAMEBUFFER, 0);
Errors.log;
return Self; return Self;
end to_frame_Buffer; end to_frame_Buffer;
@@ -53,8 +63,10 @@ is
Self : Item; Self : Item;
begin begin
Tasks.check; Tasks.check;
Self.Texture := openGL.Texture.null_Object; Self.Texture := openGL.Texture.null_Object;
glGenFramebuffers (1, Self.Name'Access); glGenFramebuffers (1, Self.Name'Access);
Errors.log;
return Self; return Self;
end to_frame_Buffer; end to_frame_Buffer;
@@ -68,7 +80,10 @@ is
use GL.lean; use GL.lean;
begin begin
Tasks.check; Tasks.check;
glDeleteFramebuffers (1, Self.Name'Access); glDeleteFramebuffers (1, Self.Name'Access);
Errors.log;
Self.Texture.destroy; Self.Texture.destroy;
end destruct; end destruct;
@@ -99,7 +114,6 @@ is
GL.lean; GL.lean;
begin begin
Tasks.check; Tasks.check;
openGL.Errors.log;
Self.Texture := Now; 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 is
use GL, use GL,
GL.lean; GL.lean;
@@ -147,6 +161,7 @@ is
check_is_OK : constant Boolean := Tasks.check with Unreferenced; check_is_OK : constant Boolean := Tasks.check with Unreferenced;
begin begin
glBindFramebuffer (GL_FRAMEBUFFER, Self.Name); glBindFramebuffer (GL_FRAMEBUFFER, Self.Name);
Errors.log;
if not Self.is_Complete if not Self.is_Complete
then then
@@ -163,6 +178,7 @@ is
check_is_OK : constant Boolean := Tasks.check with Unreferenced; check_is_OK : constant Boolean := Tasks.check with Unreferenced;
begin begin
glBindFramebuffer (GL_FRAMEBUFFER, 0); glBindFramebuffer (GL_FRAMEBUFFER, 0);
Errors.log;
end disable; end disable;

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

@@ -1,6 +1,7 @@
with with
openGL.Texture; openGL.Texture;
package openGL.Frame_Buffer package openGL.Frame_Buffer
is is
@@ -26,6 +27,7 @@ is
-------------- --------------
--- Attributes --- Attributes
-- --
subtype Buffer_Name is GL.GLuint; -- An openGL frame buffer 'Name'. subtype Buffer_Name is GL.GLuint; -- An openGL frame buffer 'Name'.
function Name (Self : in Item) return Buffer_Name; function Name (Self : in Item) return Buffer_Name;
@@ -33,7 +35,7 @@ is
function Texture (Self : in Item) return openGL.Texture.Object; function Texture (Self : in Item) return openGL.Texture.Object;
procedure Texture_is (Self : in out Item; now : in 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 with
openGL.Visual; openGL.Visual;
package openGL.Terrain package openGL.Terrain
-- --
-- Provides a constructor for heightmap terrain. -- Provides a constructor for heightmap terrain.

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

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

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

@@ -3,6 +3,7 @@ with
ada.Strings.unbounded.Hash, ada.Strings.unbounded.Hash,
ada.Containers.hashed_Maps; ada.Containers.hashed_Maps;
package openGL.Texture package openGL.Texture
-- --
-- Provides openGL textures. -- Provides openGL textures.
@@ -73,8 +74,6 @@ is
-- --
-- For rapid allocation/deallocation of texture objects. -- For rapid allocation/deallocation of texture objects.
-- TODO: Move this into a child package ?
type Pool is private; type Pool is private;
type Pool_view is access all Pool; 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) procedure animate (Self : in out Item)
is is
use ada.Calendar; 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; function to_Set (texture_Assets : in asset_Names;
texture_Tilings : in Tilings := [others => (S => 1.0, texture_Tilings : in Tilings := [others => (S => 1.0,
T => 1.0)]; T => 1.0)];
Animation : in Animation_view := null) return Item Animation : in Animation_view := null) return Item
is is
Result : Item (Count => texture_Assets'Length); 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 --- Streams
-- --

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

@@ -17,17 +17,9 @@ is
max_Textures : constant := 16; -- 32; max_Textures : constant := 16; -- 32;
type detail_Count is range 0 .. max_Textures; type detail_Count is range 0 .. max_Textures;
-- type Item (Count : detail_Count := 1) is private;
--
-- null_Set : constant Item;
--------------- ---------------
--- Texture Ids --- Texture Ids
-- --
@@ -60,13 +52,6 @@ is
type fade_Levels is array (texture_Id range <>) of fade_Level; 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 --- Animation
-- --
@@ -96,42 +81,19 @@ is
type Animation_view is access all Animation; type Animation_view is access all Animation;
-- procedure animate (the_Animation : in out Animation;
-- texture_Applies : in out texture_Apply_array);
type Detail is type Detail is
record record
Object : texture.Object; Object : texture.Object;
Texture : asset_Name; Texture : asset_Name;
Fade : fade_Level; Fade : fade_Level;
texture_Tiling : Tiling; 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; end record;
type Detail_array is array (detail_Count range <>) of Detail; 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 type Item (Count : detail_Count := 1) is
record record
Details : Detail_array (1 .. Count); Details : Detail_array (1 .. Count);
@@ -141,19 +103,10 @@ is
null_Set : constant Item; null_Set : constant Item;
--------- ---------
--- Forge --- 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; function to_Set (texture_Assets : in asset_Names;
texture_Tilings : in Tilings := [others => (S => 1.0, texture_Tilings : in Tilings := [others => (S => 1.0,
T => 1.0)]; T => 1.0)];
@@ -161,17 +114,11 @@ is
-------------- --------------
--- Attributes -- Operations
-- --
procedure animate (Self : in out Item); 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 private
@@ -191,7 +138,6 @@ private
for Animation_view'read use read; for Animation_view'read use read;
-- no_Details : constant Details := (others => <>);
null_Set : constant Item := (Count => 0, null_Set : constant Item := (Count => 0,
others => <>); others => <>);

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

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

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

@@ -13,7 +13,6 @@ is
is is
begin begin
return new Visual.item' (Model => Model, return new Visual.item' (Model => Model,
model_Transform => Identity_4x4,
camera_Transform => Identity_4x4, camera_Transform => Identity_4x4,
Transform => Identity_4x4, Transform => Identity_4x4,
mvp_Transform => Identity_4x4, mvp_Transform => Identity_4x4,
@@ -139,21 +138,6 @@ is
end mvp_Transform_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 function camera_Transform (Self : in Item) return Matrix_4x4
is is
begin begin
@@ -174,7 +158,6 @@ is
use linear_Algebra_3d; use linear_Algebra_3d;
begin begin
set_Rotation (Self.Transform, Now); set_Rotation (Self.Transform, Now);
-- set_Rotation (Self.model_Transform, Now);
end Spin_is; end Spin_is;
@@ -183,7 +166,6 @@ is
use linear_Algebra_3d; use linear_Algebra_3d;
begin begin
return get_Rotation (Self.Transform); return get_Rotation (Self.Transform);
-- return get_Rotation (Self.model_Transform);
end Spin_of; end Spin_of;
@@ -193,7 +175,6 @@ is
use linear_Algebra_3d; use linear_Algebra_3d;
begin begin
set_Translation (Self.Transform, Now); set_Translation (Self.Transform, Now);
-- set_Translation (Self.model_Transform, Now);
end Site_is; end Site_is;
@@ -202,7 +183,6 @@ is
use linear_Algebra_3d; use linear_Algebra_3d;
begin begin
return get_Translation (Self.Transform); return get_Translation (Self.Transform);
-- return get_Translation (Self.model_Transform);
end Site_of; end Site_of;

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

@@ -2,6 +2,7 @@ with
openGL.Program, openGL.Program,
openGL.Model; openGL.Model;
package openGL.Visual package openGL.Visual
is is
type Item is tagged private; type Item is tagged private;
@@ -49,8 +50,8 @@ is
procedure mvp_Transform_is (Self : in out Item; Now : in Matrix_4x4); procedure mvp_Transform_is (Self : in out Item; Now : in Matrix_4x4);
function mvp_Transform (Self : in Item) return Matrix_4x4; function mvp_Transform (Self : in Item) return Matrix_4x4;
procedure model_Transform_is (Self : in out Item; Now : in Matrix_4x4); -- procedure model_Transform_is (Self : in out Item; Now : in Matrix_4x4);
function model_Transform (Self : in Item) return Matrix_4x4; -- function model_Transform (Self : in Item) return Matrix_4x4;
procedure camera_Transform_is (Self : in out Item; Now : in Matrix_4x4); procedure camera_Transform_is (Self : in out Item; Now : in Matrix_4x4);
function camera_Transform (Self : in Item) return Matrix_4x4; function camera_Transform (Self : in Item) return Matrix_4x4;
@@ -76,7 +77,6 @@ private
Model : openGL.Model.view; Model : openGL.Model.view;
Scale : Vector_3 := [1.0, 1.0, 1.0]; Scale : Vector_3 := [1.0, 1.0, 1.0];
model_Transform : Matrix_4x4;
camera_Transform : Matrix_4x4; camera_Transform : Matrix_4x4;
Transform : Matrix_4x4; Transform : Matrix_4x4;
mvp_Transform : Matrix_4x4; mvp_Transform : Matrix_4x4;

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

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

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

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

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

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