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

Add initial prototype.

Browse Source
This commit is contained in:
Rod Kay
2022-07-31 17:34:54 +10:00
commit 54a53b2ac0
1421 changed files with 358874 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

115
3-mid/opengl/source/lean/shader/opengl-attribute.adb Normal file
View File

@@ -0,0 +1,115 @@
with
openGL.Tasks,
GL.lean,
System,
ada.unchecked_Conversion;
package body openGL.Attribute
is
use GL.lean;
---------
-- Forge
--
procedure define (Self : in out Item)
is
begin
null;
end define;
procedure destroy (Self : in out Item)
is
begin
null;
end destroy;
package body Forge
is
function to_Attribute (Name : in String;
gl_Location : in gl.GLuint;
Size : in gl.GLint;
data_Kind : in Attribute.data_Kind;
Stride : in Natural;
Offset : in storage_Offset;
Normalized : in Boolean) return Item
is
begin
return (Name => new String'(Name),
Location => gl_Location,
Size => Size,
data_Kind => data_Kind,
vertex_Stride => gl.GLint (Stride),
Offset => Offset,
Normalized => Boolean'Pos (Normalized));
end to_Attribute;
function new_Attribute (Name : in String;
gl_Location : in gl.GLuint;
Size : in gl.GLint;
data_Kind : in Attribute.data_Kind;
Stride : in Natural;
Offset : in Storage_Offset;
Normalized : in Boolean) return View
is
begin
return new Item' (to_Attribute (Name,
gl_Location,
Size,
data_Kind,
Stride,
Offset,
Normalized));
end new_Attribute;
end Forge;
--------------
-- Attributes
--
function Name (Self : in Item'Class) return String
is
begin
return Self.Name.all;
end Name;
function gl_Location (Self : in Item'Class) return gl.GLuint
is
begin
return Self.Location;
end gl_Location;
--------------
-- Operations
--
procedure enable (Self : in Item)
is
use GL,
system.Storage_Elements;
type GLvoid_access is access all GLvoid;
function to_GL is new ada.unchecked_Conversion (attribute.data_Kind, gl.GLenum); -- TODO: Address different sizes warning.
function to_GL is new ada.unchecked_Conversion (storage_Offset, GLvoid_access);
begin
Tasks.check;
glEnableVertexAttribArray (Index => Self.gl_Location);
glVertexAttribPointer (Index => Self.gl_Location,
Size => Self.Size,
the_Type => to_GL (Self.data_Kind),
Normalized => Self.Normalized,
Stride => Self.vertex_Stride,
Ptr => to_GL (Self.Offset));
end enable;
end openGL.Attribute;

88
3-mid/opengl/source/lean/shader/opengl-attribute.ads Normal file
View File

@@ -0,0 +1,88 @@
with
GL,
system.storage_Elements;
package openGL.Attribute
--
-- Models an openGL shader attribute.
--
is
type Item is tagged private;
type View is access all Item'Class;
type Views is array (Positive range <>) of View;
type data_Kind is (GL_BYTE, GL_UNSIGNED_BYTE,
GL_SHORT, GL_UNSIGNED_SHORT,
GL_INT, GL_UNSIGNED_INT,
GL_FLOAT, GL_FIXED);
---------
--- Forge
--
procedure define (Self : in out Item);
procedure destroy (Self : in out Item);
package Forge
is
use system.storage_Elements;
function to_Attribute (Name : in String;
gl_Location : in gl.GLuint;
Size : in gl.GLint;
data_Kind : in Attribute.data_Kind;
Stride : in Natural;
Offset : in storage_Offset;
Normalized : in Boolean) return Item;
function new_Attribute (Name : in String;
gl_Location : in gl.GLuint;
Size : in gl.GLint;
data_Kind : in Attribute.data_Kind;
Stride : in Natural;
Offset : in storage_Offset;
Normalized : in Boolean) return View;
end Forge;
--------------
--- Attributes
--
function Name (Self : in Item'Class) return String;
function gl_Location (Self : in Item'Class) return gl.GLuint;
--------------
--- Operations
--
procedure enable (Self : in Item);
private
type String_view is access String;
type Item is tagged
record
Name : String_view;
Location : gl.GLuint;
Size : gl.GLint;
data_Kind : Attribute.data_Kind;
vertex_Stride : gl.GLint;
Offset : system.storage_Elements.storage_Offset;
Normalized : gl.GLboolean;
end record;
for data_Kind use (GL_BYTE => 16#1400#,
GL_UNSIGNED_BYTE => 16#1401#,
GL_SHORT => 16#1402#,
GL_UNSIGNED_SHORT => 16#1403#,
GL_INT => 16#1404#,
GL_UNSIGNED_INT => 16#1405#,
GL_FLOAT => 16#1406#,
GL_FIXED => 16#140c#);
end openGL.Attribute;

238
3-mid/opengl/source/lean/shader/opengl-program-lit-colored_skinned.adb Normal file
View File

@@ -0,0 +1,238 @@
with
ada.Strings.fixed;
package body openGL.Program.lit.colored_skinned
is
-- Old code kept for reference til new code is tested and stable ...
--
-- overriding
-- procedure define (Self : in out Item)
-- is
-- use openGL.Palette,
-- GL.lean,
-- GL.Pointers,
-- Interfaces,
-- system.Storage_Elements;
--
-- check_is_OK : constant Boolean := openGL.Tasks.Check; pragma Unreferenced (check_is_OK);
--
-- sample_Vertex : Geometry.lit_textured_skinned.Vertex;
--
-- Attribute_1_Name : aliased C.char_array := "Site";
-- Attribute_1_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_1_Name'Unchecked_Access);
--
-- Attribute_2_Name : aliased C.char_array := "Normal";
-- Attribute_2_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_2_Name'Unchecked_Access);
--
-- Attribute_3_Name : aliased C.char_array := "Color";
-- Attribute_3_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_3_Name'Unchecked_Access);
--
-- Attribute_4_Name : aliased C.char_array := "Coords";
-- Attribute_4_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_4_Name'Unchecked_Access);
--
-- Attribute_5_Name : aliased C.char_array := "bone_Ids";
-- Attribute_5_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_5_Name'Unchecked_Access);
--
-- Attribute_6_Name : aliased C.char_array := "bone_Weights";
-- Attribute_6_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_6_Name'Unchecked_Access);
--
-- Attribute_1 : openGL.Attribute.view;
-- Attribute_2 : openGL.Attribute.view;
-- Attribute_3 : openGL.Attribute.view;
-- Attribute_4 : openGL.Attribute.view;
-- Attribute_5 : openGL.Attribute.view;
-- Attribute_6 : openGL.Attribute.view;
--
-- white_Image : constant openGL.Image := (1 .. 2 => (1 .. 2 => White));
--
-- begin
-- white_Texture := openGL.Texture.to_Texture (white_Image);
--
-- the_vertex_Shader .define (openGL.Shader.Vertex, "assets/opengl/shader/lit_textured_skinned.vert");
-- the_fragment_Shader.define (openGL.Shader.Fragment, "assets/opengl/shader/lit_textured_skinned.frag");
--
-- Self.define (the_vertex_Shader 'Access,
-- the_fragment_Shader'Access);
--
-- Self.enable;
--
-- Attribute_1 := openGL.Attribute.Forge.new_Attribute
-- (name => "Site",
-- gl_location => Self.attribute_Location ("Site"),
-- size => 3,
-- data_kind => openGL.Attribute.GL_FLOAT,
-- stride => Geometry.lit_textured_skinned.Vertex'Size / 8,
-- offset => 0,
-- normalized => False);
--
-- Attribute_2 := openGL.Attribute.Forge.new_Attribute
-- (name => "Normal",
-- gl_location => Self.attribute_Location ("Normal"),
-- size => 3,
-- data_kind => openGL.Attribute.GL_FLOAT,
-- stride => Geometry.lit_textured_skinned.Vertex'Size / 8,
-- offset => sample_Vertex.Normal (1)'Address
-- - sample_Vertex.Site (1)'Address,
-- normalized => False);
--
-- Attribute_3 := openGL.Attribute.Forge.new_Attribute
-- (name => "Color",
-- gl_location => Self.attribute_Location ("Color"),
-- size => 4,
-- data_kind => openGL.Attribute.GL_UNSIGNED_BYTE,
-- stride => Geometry.lit_textured_skinned.Vertex'Size / 8,
-- offset => sample_Vertex.Color.Primary.Red'Address
-- - sample_Vertex.Site (1) 'Address,
-- normalized => True);
--
-- Attribute_4 := openGL.Attribute.Forge.new_Attribute
-- (name => "Coords",
-- gl_location => Self.attribute_Location ("Coords"),
-- size => 2,
-- data_kind => openGL.Attribute.GL_FLOAT,
-- stride => Geometry.lit_textured_skinned.Vertex'Size / 8,
-- offset => sample_Vertex.Coords.S'Address
-- - sample_Vertex.Site (1)'Address,
-- normalized => False);
--
-- Attribute_5 := openGL.Attribute.Forge.new_Attribute
-- (name => "bone_Ids",
-- gl_location => Self.attribute_Location ("bone_Ids"),
-- size => 4,
-- data_kind => openGL.Attribute.GL_FLOAT,
-- stride => Geometry.lit_textured_skinned.Vertex'Size / 8,
-- offset => sample_Vertex.bone_Ids (1)'Address
-- - sample_Vertex.Site (1)'Address,
-- normalized => False);
--
-- Attribute_6 := openGL.Attribute.Forge.new_Attribute
-- (name => "bone_Weights",
-- gl_location => Self.attribute_Location ("bone_Weights"),
-- size => 4,
-- data_kind => openGL.Attribute.GL_FLOAT,
-- stride => Geometry.lit_textured_skinned.Vertex'Size / 8,
-- offset => sample_Vertex.bone_Weights (1)'Address
-- - sample_Vertex.Site (1)'Address,
-- normalized => False);
--
-- Self.add (Attribute_1);
-- Self.add (Attribute_2);
-- Self.add (Attribute_3);
-- Self.add (Attribute_4);
-- Self.add (Attribute_5);
-- Self.add (Attribute_6);
--
-- glBindAttribLocation (program => Self.gl_Program,
-- index => Self.Attribute (named => "Site").gl_Location,
-- name => +Attribute_1_Name_ptr);
--
-- glBindAttribLocation (program => Self.gl_Program,
-- index => Self.Attribute (named => "Normal").gl_Location,
-- name => +Attribute_2_Name_ptr);
--
-- glBindAttribLocation (program => Self.gl_Program,
-- index => Self.Attribute (named => "Color").gl_Location,
-- name => +Attribute_3_Name_ptr);
--
-- glBindAttribLocation (program => Self.gl_Program,
-- index => Self.Attribute (named => "Coords").gl_Location,
-- name => +Attribute_4_Name_ptr);
--
-- glBindAttribLocation (program => Self.gl_Program,
-- index => Self.Attribute (named => "bone_Ids").gl_Location,
-- name => +Attribute_5_Name_ptr);
--
-- glBindAttribLocation (program => Self.gl_Program,
-- index => Self.Attribute (named => "bone_Weights").gl_Location,
-- name => +Attribute_6_Name_ptr);
-- end define;
overriding
procedure define (Self : in out Item; use_vertex_Shader : in Shader.view;
use_fragment_Shader : in Shader.view)
is
use ada.Strings,
ada.Strings.fixed;
begin
openGL.Program.lit.item (Self).define (use_vertex_Shader,
use_fragment_Shader); -- Define base class.
for i in Self.bone_transform_Uniforms'Range
loop
Self.bone_transform_Uniforms (i).define (Self'Access,
"bone_Matrices[" & Trim (Integer'Image (i - 1), Left) & "]");
end loop;
end define;
overriding
procedure set_Uniforms (Self : in Item)
is
-- the_inverse_modelview_matrix_Uniform : constant Variable.uniform.mat3 := Self.uniform_Variable ("inv_modelview_Matrix");
-- the_shine_Uniform : constant Variable.uniform.float := Self.uniform_Variable ("Shine");
begin
openGL.Program.lit.item (Self).set_Uniforms;
-- the_shine_Uniform .Value_is (Self.Shine);
-- the_inverse_modelview_matrix_Uniform.Value_is (Self.inverse_modelview_Matrix);
-- Lights
--
-- for i in Self.directional_Light'Range
-- loop
-- declare
-- Light : openGL.Light.directional.item renames Self.directional_Light (i);
--
-- function light_Name return String
-- is
-- use ada.Strings,
-- ada.Strings.fixed;
-- begin
-- return "Lights[" & Trim (Integer'Image (i - 1), Left) & "]";
-- end light_Name;
--
-- use openGL.Conversions;
--
-- -- the_light_direction_Uniform : constant Variable.uniform.vec3 := Self.uniform_Variable (light_Name & ".direction");
-- -- the_light_halfplane_Uniform : constant Variable.uniform.vec3 := Self.uniform_Variable (light_Name & ".halfplane");
--
-- -- the_light_ambient_color_Uniform : constant Variable.uniform.vec4 := Self.uniform_Variable (light_Name & ".ambient_color");
-- -- the_light_diffuse_color_Uniform : constant Variable.uniform.vec4 := Self.uniform_Variable (light_Name & ".diffuse_color");
-- -- the_light_specular_color_Uniform : constant Variable.uniform.vec4 := Self.uniform_Variable (light_Name & ".specular_color");
-- begin
-- -- the_light_direction_Uniform.Value_is (Light.Direction);
-- -- the_light_halfplane_Uniform.Value_is (Light.halfplane_Vector);
--
-- -- the_light_ambient_color_Uniform .Value_is (to_Vector_4 (Light.ambient_Color));
-- -- the_light_diffuse_color_Uniform .Value_is (to_Vector_4 (Light.diffuse_Color));
-- -- the_light_specular_color_Uniform.Value_is (to_Vector_4 (Light.specular_Color));
-- null;
-- end;
-- end loop;
-- Texture
--
declare
sampler_Uniform : constant Variable.uniform.int := Self.uniform_Variable ("sTexture");
begin
sampler_Uniform.Value_is (0);
end;
end set_Uniforms;
procedure bone_Transform_is (Self : in Item; Which : in Integer;
Now : in Matrix_4x4)
is
begin
Self.bone_transform_Uniforms (Which).Value_is (Now);
end bone_Transform_is;
end openGL.Program.lit.colored_skinned;

30
3-mid/opengl/source/lean/shader/opengl-program-lit-colored_skinned.ads Normal file
View File

@@ -0,0 +1,30 @@
package openGL.Program.lit.colored_skinned
--
-- Provides a program for lit, colored, textured and skinned vertices.
--
is
type Item is new openGL.Program.lit.item with private;
type View is access all Item'Class;
overriding
procedure define (Self : in out Item; use_vertex_Shader : in Shader.view;
use_fragment_Shader : in Shader.view);
overriding
procedure set_Uniforms (Self : in Item);
procedure bone_Transform_is (Self : in Item; Which : in Integer;
Now : in Matrix_4x4);
private
type bone_transform_Uniforms is array (1 .. 120) of Variable.uniform.mat4;
type Item is new openGL.Program.lit.item with
record
bone_transform_Uniforms : lit.colored_skinned.bone_transform_Uniforms;
end record;
end openGL.Program.lit.colored_skinned;

52
3-mid/opengl/source/lean/shader/opengl-program-lit-colored_textured_skinned.adb Normal file
View File

@@ -0,0 +1,52 @@
with
ada.Strings.fixed;
package body openGL.Program.lit.colored_textured_skinned
is
overriding
procedure define (Self : in out Item; use_vertex_Shader : in Shader.view;
use_fragment_Shader : in Shader.view)
is
use ada.Strings,
ada.Strings.fixed;
begin
openGL.Program.lit.item (Self).define (use_vertex_Shader,
use_fragment_Shader); -- Define base class.
for i in Self.bone_transform_Uniforms'Range
loop
Self.bone_transform_Uniforms (i).define (Self'Access,
"bone_Matrices[" & Trim (Integer'Image (i - 1), Left) & "]");
end loop;
end define;
overriding
procedure set_Uniforms (Self : in Item)
is
begin
openGL.Program.lit.item (Self).set_Uniforms;
-- Texture
--
declare
sampler_Uniform : constant Variable.uniform.int := Self.uniform_Variable ("Texture");
begin
sampler_Uniform.Value_is (0);
end;
end set_Uniforms;
procedure bone_Transform_is (Self : in Item; Which : in Integer;
Now : in Matrix_4x4)
is
begin
Self.bone_transform_Uniforms (Which).Value_is (Now);
end bone_Transform_is;
end openGL.Program.lit.colored_textured_skinned;

30
3-mid/opengl/source/lean/shader/opengl-program-lit-colored_textured_skinned.ads Normal file
View File

@@ -0,0 +1,30 @@
package openGL.Program.lit.colored_textured_skinned
--
-- Provides a program for lit, colored, textured and skinned vertices.
--
is
type Item is new openGL.Program.lit.item with private;
type View is access all Item'Class;
overriding
procedure define (Self : in out Item; use_vertex_Shader : in Shader.view;
use_fragment_Shader : in Shader.view);
overriding
procedure set_Uniforms (Self : in Item);
procedure bone_Transform_is (Self : in Item; Which : in Integer;
Now : in Matrix_4x4);
private
type bone_transform_Uniforms is array (1 .. 120) of Variable.uniform.mat4;
type Item is new openGL.Program.lit.item with
record
bone_transform_Uniforms : lit.colored_textured_skinned.bone_transform_Uniforms;
end record;
end openGL.Program.lit.colored_textured_skinned;

51
3-mid/opengl/source/lean/shader/opengl-program-lit-textured_skinned.adb Normal file
View File

@@ -0,0 +1,51 @@
with
ada.Strings.fixed;
package body openGL.Program.lit.textured_skinned
is
overriding
procedure define (Self : in out Item; use_vertex_Shader : in Shader.view;
use_fragment_Shader : in Shader.view)
is
use ada.Strings,
ada.Strings.fixed;
begin
openGL.Program.lit.item (Self).define (use_vertex_Shader,
use_fragment_Shader); -- Define base class.
for i in Self.bone_transform_Uniforms'Range
loop
Self.bone_transform_Uniforms (i).define (Self'Access,
"bone_Matrices[" & Trim (Integer'Image (i - 1), Left) & "]");
end loop;
end define;
overriding
procedure set_Uniforms (Self : in Item)
is
begin
openGL.Program.lit.item (Self).set_Uniforms;
-- Texture
--
declare
sampler_Uniform : constant Variable.uniform.int := Self.uniform_Variable ("sTexture");
begin
sampler_Uniform.Value_is (0);
end;
end set_Uniforms;
procedure bone_Transform_is (Self : in Item; Which : in Integer;
Now : in Matrix_4x4)
is
begin
Self.bone_transform_Uniforms (Which).Value_is (Now);
end bone_Transform_is;
end openGL.Program.lit.textured_skinned;

30
3-mid/opengl/source/lean/shader/opengl-program-lit-textured_skinned.ads Normal file
View File

@@ -0,0 +1,30 @@
package openGL.Program.lit.textured_skinned
--
-- Provides a program for lit, colored, textured and skinned vertices.
--
is
type Item is new openGL.Program.lit.item with private;
type View is access all Item'Class;
overriding
procedure define (Self : in out Item; use_vertex_Shader : in Shader.view;
use_fragment_Shader : in Shader.view);
overriding
procedure set_Uniforms (Self : in Item);
procedure bone_Transform_is (Self : in Item; Which : in Integer;
Now : in Matrix_4x4);
private
type bone_transform_Uniforms is array (1 .. 120) of Variable.uniform.mat4;
type Item is new openGL.Program.lit.item with
record
bone_transform_Uniforms : lit.textured_skinned.bone_transform_Uniforms;
end record;
end openGL.Program.lit.textured_skinned;

108
3-mid/opengl/source/lean/shader/opengl-program-lit.adb Normal file
View File

@@ -0,0 +1,108 @@
with
openGL.Conversions,
ada.Strings.fixed;
package body openGL.Program.lit
is
overriding
procedure Lights_are (Self : in out Item; Now : in Light.items)
is
begin
Self.light_Count := Now'Length;
Self.Lights (1 .. Now'Length) := Now;
end Lights_are;
overriding
procedure camera_Site_is (Self : in out Item; Now : in Vector_3)
is
begin
Self.camera_Site := Now;
end camera_Site_is;
overriding
procedure model_Matrix_is (Self : in out Item; Now : in Matrix_4x4)
is
begin
Self.model_Transform := Now;
end model_Matrix_is;
overriding
procedure set_Uniforms (Self : in Item)
is
use openGL.Conversions,
linear_Algebra_3d;
the_model_transform_Uniform : constant Variable.uniform.mat4 := Self.uniform_Variable ("model_Transform");
the_inverse_model_rotation_Uniform : constant Variable.uniform.mat3 := Self.uniform_Variable ("inverse_model_Rotation");
the_camera_site_Uniform : constant Variable.uniform.vec3 := Self.uniform_Variable ("camera_Site");
the_light_count_Uniform : constant Variable.uniform.int := Self.uniform_Variable ("light_Count");
the_specular_color_Uniform : constant Variable.uniform.vec3 := Self.uniform_Variable ("specular_Color");
begin
openGL.Program.item (Self).set_Uniforms;
the_camera_site_Uniform.Value_is (Self.camera_Site);
the_model_transform_Uniform .Value_is (Self.model_Transform);
the_inverse_model_rotation_Uniform.Value_is (Inverse (get_Rotation (Self.model_Transform)));
-- Lights.
--
the_light_count_Uniform .Value_is (Self.light_Count);
the_specular_color_Uniform.Value_is (to_Vector_3 (Self.specular_Color));
for i in 1 .. Self.light_Count
loop
declare
use Light;
Light : openGL.Light.item renames Self.Lights (i);
function light_Name return String
is
use ada.Strings,
ada.Strings.fixed;
begin
return "Lights[" & Trim (Integer'Image (i - 1), Left) & "]";
end light_Name;
site_Uniform : constant Variable.uniform.vec4 := Self.uniform_Variable (light_Name & ".Site");
color_Uniform : constant Variable.uniform.vec3 := Self.uniform_Variable (light_Name & ".Color");
attenuation_Uniform : constant Variable.uniform.float := Self.uniform_Variable (light_Name & ".Attenuation");
ambient_coefficient_Uniform : constant Variable.uniform.float := Self.uniform_Variable (light_Name & ".ambient_Coefficient");
cone_angle_Uniform : constant Variable.uniform.float := Self.uniform_Variable (light_Name & ".cone_Angle");
cone_direction_Uniform : constant Variable.uniform.vec3 := Self.uniform_Variable (light_Name & ".cone_Direction");
begin
case Light.Kind
is
when Diffuse => site_Uniform.Value_is (Vector_4 (Light.Site & 1.0));
when Direct => site_Uniform.Value_is (Vector_4 (Light.Site & 0.0)); -- '0.0' tells shader that this light is 'direct'.
end case;
color_Uniform .Value_is (to_Vector_3 (Light.Color));
attenuation_Uniform .Value_is ( Light.Attenuation);
ambient_coefficient_Uniform.Value_is ( Light.ambient_Coefficient);
cone_angle_Uniform .Value_is (Real (Light.cone_Angle));
cone_direction_Uniform .Value_is ( Light.cone_Direction);
end;
end loop;
end set_Uniforms;
procedure specular_Color_is (Self : in out Item; Now : in Color)
is
begin
Self.specular_Color := Now;
end specular_Color_is;
end openGL.Program.lit;

48
3-mid/opengl/source/lean/shader/opengl-program-lit.ads Normal file
View File

@@ -0,0 +1,48 @@
with
openGL.Palette,
openGL.Light;
package openGL.Program.lit
--
-- Models an openGL program which uses lighting.
--
is
type Item is new openGL.Program.item with private;
type View is access all Item'Class;
------------
-- Uniforms
--
overriding
procedure camera_Site_is (Self : in out Item; Now : in Vector_3);
overriding
procedure model_Matrix_is (Self : in out Item; Now : in Matrix_4x4);
overriding
procedure Lights_are (Self : in out Item; Now : in Light.items);
overriding
procedure set_Uniforms (Self : in Item);
procedure specular_Color_is (Self : in out Item; Now : in Color);
private
type Item is new openGL.Program.item with
record
Lights : Light.items (1 .. 50);
light_Count : Natural := 0;
specular_Color : Color := Palette.Grey; -- The materials specular color.
camera_Site : Vector_3;
model_Transform : Matrix_4x4 := Identity_4x4;
end record;
end openGL.Program.lit;

345
3-mid/opengl/source/lean/shader/opengl-program.adb Normal file
View File

@@ -0,0 +1,345 @@
with
openGL.Tasks,
GL.Pointers,
GL.lean,
ada.Characters.latin_1,
interfaces.C.Strings;
package body openGL.Program
is
use gl.lean,
Interfaces;
compiling_in_debug_Mode : constant Boolean := True;
type Shader_view is access all Shader.item'Class;
--------------
-- Parameters
--
procedure Program_is (Self : in out Parameters; Now : in openGL.Program.view)
is
begin
Self.Program := Now;
end Program_is;
function Program (Self : in Parameters) return openGL.Program.view
is
begin
return Self.Program;
end Program;
---------
--- Forge
--
procedure define (Self : in out Item; use_vertex_Shader : in Shader.view;
use_fragment_Shader : in Shader.view)
is
begin
Tasks.check;
Self.gl_Program := glCreateProgram;
glAttachShader (Self.gl_Program, use_vertex_Shader.gl_Shader);
glAttachShader (Self.gl_Program, use_fragment_Shader.gl_Shader);
Self. vertex_Shader := use_vertex_Shader;
Self.fragment_Shader := use_fragment_Shader;
glLinkProgram (Self.gl_Program);
declare
use type C.int;
Status : aliased gl.glInt;
begin
glGetProgramiv (Self.gl_Program,
GL_LINK_STATUS,
Status'unchecked_Access);
if Status = 0
then
declare
link_Log : constant String := Self.ProgramInfoLog;
begin
Self.destroy;
raise Error with "Program link error ~ " & link_Log;
end;
end if;
end;
if compiling_in_debug_Mode
then
glValidateProgram (Self.gl_Program);
end if;
end define;
procedure define (Self : in out Item; use_vertex_Shader_File : in String;
use_fragment_Shader_File : in String)
is
use openGL.Shader;
the_vertex_Shader : constant Shader_view := new openGL.Shader.item;
the_fragment_Shader : constant Shader_view := new openGL.Shader.item;
begin
the_vertex_Shader .define (openGL.Shader.vertex, use_vertex_Shader_File);
the_fragment_Shader.define (openGL.Shader.fragment, use_fragment_Shader_File);
Self.define ( the_vertex_Shader.all'Access,
the_fragment_Shader.all'Access);
end define;
procedure destroy (Self : in out Item)
is
begin
Tasks.check;
glDeleteProgram (Self.gl_Program);
end destroy;
--------------
-- Attributes
--
function Attribute (Self : access Item'Class; Named : in String) return openGL.Attribute.view
is
begin
for Each in 1 .. Self.attribute_Count
loop
if Self.Attributes (Each).Name = Named
then
return Self.Attributes (Each);
end if;
end loop;
raise Error with "'" & Named & "' is not a valid program attribute.";
end Attribute;
function attribute_Location (Self : access Item'Class; Named : in String) return gl.GLuint
is
use gl.Pointers;
use type gl.GLint;
attribute_Name : C.strings.chars_ptr := C.Strings.new_String (Named & ada.characters.Latin_1.NUL);
begin
Tasks.check;
declare
gl_Location : constant gl.GLint := glGetAttribLocation (Self.gl_Program,
to_GLchar_access (attribute_Name));
begin
if gl_Location = -1
then
raise Error with "Requested attribute '" & Named & "' has no gl location in program.";
end if;
C.Strings.free (attribute_Name);
return gl.GLuint (gl_Location);
end;
end attribute_Location;
function is_defined (Self : in Item'Class) return Boolean
is
use type a_gl_Program;
begin
return Self.gl_Program /= 0;
end is_defined;
function ProgramInfoLog (Self : in Item) return String
is
use C, GL;
info_log_Length : aliased glInt := 0;
chars_Written : aliased glSizei := 0;
begin
Tasks.check;
glGetProgramiv (Self.gl_Program,
GL_INFO_LOG_LENGTH,
info_log_Length'unchecked_Access);
if info_log_Length = 0 then
return "";
end if;
declare
use GL.Pointers;
info_Log : aliased C.char_array := C.char_array' [1 .. C.size_t (info_log_Length) => <>];
info_Log_ptr : constant C.strings.chars_ptr := C.strings.to_chars_ptr (info_Log'unchecked_Access);
begin
glGetProgramInfoLog (Self.gl_Program,
glSizei (info_log_Length),
chars_Written'unchecked_Access,
to_GLchar_access (info_Log_ptr));
return C.to_Ada (info_Log);
end;
end ProgramInfoLog;
function uniform_Variable (Self : access Item'Class; Named : in String) return Variable.uniform.bool
is
the_Variable : Variable.uniform.bool;
begin
the_Variable.define (Self, Named);
return the_Variable;
end uniform_Variable;
function uniform_Variable (Self : access Item'Class; Named : in String) return Variable.uniform.int
is
the_Variable : Variable.uniform.int;
begin
the_Variable.define (Self, Named);
return the_Variable;
end uniform_Variable;
function uniform_Variable (Self : access Item'Class; Named : in String) return Variable.uniform.float
is
the_Variable : Variable.uniform.float;
begin
the_Variable.define (Self, Named);
return the_Variable;
end uniform_Variable;
function uniform_Variable (Self : access Item'Class; Named : in String) return Variable.uniform.vec3
is
the_Variable : Variable.uniform.vec3;
begin
the_Variable.define (Self, Named);
return the_Variable;
end uniform_Variable;
function uniform_Variable (Self : access Item'Class; Named : in String) return Variable.uniform.vec4
is
the_Variable : Variable.uniform.vec4;
begin
the_Variable.define (Self, Named);
return the_Variable;
end uniform_Variable;
function uniform_Variable (Self : access Item'Class; Named : in String) return Variable.uniform.mat3
is
the_Variable : Variable.uniform.mat3;
begin
the_Variable.define (Self, Named);
return the_Variable;
end uniform_Variable;
function uniform_Variable (Self : access Item'Class; Named : in String) return Variable.uniform.mat4
is
the_Variable : Variable.uniform.mat4;
begin
the_Variable.define (Self, Named);
return the_Variable;
end uniform_Variable;
--------------
-- Operations
--
procedure add (Self : in out Item; Attribute : in openGL.Attribute.view)
is
begin
Self.attribute_Count := Self.attribute_Count + 1;
Self.Attributes (Self.attribute_Count) := Attribute;
end add;
procedure enable (Self : in out Item)
is
use type gl.GLuint;
begin
Tasks.check;
if Self.gl_Program = 0
then
Item'Class (Self).define; -- TODO: This appears to do nothing.
end if;
glUseProgram (self.gl_Program);
end enable;
procedure enable_Attributes (Self : in Item)
is
begin
for Each in 1 .. Self.attribute_Count
loop
Self.Attributes (Each).enable;
end loop;
end enable_Attributes;
procedure mvp_Transform_is (Self : in out Item; Now : in Matrix_4x4)
is
begin
Self.mvp_Transform := Now;
end mvp_Transform_is;
procedure Scale_is (Self : in out Item; Now : in Vector_3)
is
begin
Self.Scale := Now;
end Scale_is;
procedure set_Uniforms (Self : in Item)
is
the_mvp_Uniform : constant Variable.uniform.mat4 := Self.uniform_Variable ("mvp_Transform");
the_scale_Uniform : constant Variable.uniform.vec3 := Self.uniform_Variable ("Scale");
begin
the_mvp_Uniform .Value_is (Self.mvp_Transform);
the_scale_Uniform.Value_is (Self.Scale);
end set_Uniforms;
-- Privvy
--
function gl_Program (Self : in Item) return a_gl_Program
is
begin
return Self.gl_Program;
end gl_Program;
end openGL.Program;

131
3-mid/opengl/source/lean/shader/opengl-program.ads Normal file
View File

@@ -0,0 +1,131 @@
with
openGL.Shader,
openGL.Variable.uniform,
openGL.Attribute,
openGL.Light;
private
with
GL;
package openGL.Program
--
-- Models an openGL program.
--
is
type Item is tagged limited private;
type View is access all Item'Class;
---------
--- Forge
--
procedure define (Self : in out Item) is null;
procedure define (Self : in out Item; use_vertex_Shader : in Shader.view;
use_fragment_Shader : in Shader.view);
procedure define (Self : in out Item; use_vertex_Shader_File : in String;
use_fragment_Shader_File : in String);
procedure destroy (Self : in out Item);
----------------------
-- Program Parameters
--
-- These are used by individual visuals which require program Uniforms to vary from visual to visual.
-- The Parmaters type is extended to contain the required varying data and 'enable' is overridden to
-- apply the varying data to the programs Uniforms. 'enable' is called as part of the rendering process
-- just prior to the visuals geometry being rendered.
--
-- (See 'gel.Human' for an example of usage.)
type Parameters is limited new openGL.Parameters with private;
type Parameters_view is access all Parameters'Class;
procedure Program_is (Self : in out Parameters; Now : in Program.view);
function Program (Self : in Parameters) return Program.view;
procedure enable (Self : in out Parameters) is null;
--------------
-- Attributes
--
function is_defined (Self : in Item'Class) return Boolean;
function uniform_Variable (Self : access Item'Class; Named : in String) return Variable.uniform.bool;
function uniform_Variable (Self : access Item'Class; Named : in String) return Variable.uniform.int;
function uniform_Variable (Self : access Item'Class; Named : in String) return Variable.uniform.float;
function uniform_Variable (Self : access Item'Class; Named : in String) return Variable.uniform.vec3;
function uniform_Variable (Self : access Item'Class; Named : in String) return Variable.uniform.vec4;
function uniform_Variable (Self : access Item'Class; Named : in String) return Variable.uniform.mat3;
function uniform_Variable (Self : access Item'Class; Named : in String) return Variable.uniform.mat4;
function Attribute (Self : access Item'Class; Named : in String) return Attribute.view;
function attribute_Location (Self : access Item'Class; Named : in String) return gl.GLuint;
function ProgramInfoLog (Self : in Item) return String; -- TODO: Better name.
--------------
-- Operations
--
procedure add (Self : in out Item; Attribute : in openGL.Attribute.view);
procedure enable (Self : in out Item);
procedure enable_Attributes (Self : in Item);
------------
-- Uniforms
--
procedure mvp_Transform_is (Self : in out Item; Now : in Matrix_4x4);
procedure camera_Site_is (Self : in out Item; Now : in Vector_3) is null;
procedure model_Matrix_is (Self : in out Item; Now : in Matrix_4x4) is null;
procedure Lights_are (Self : in out Item; Now : in Light.items) is null;
procedure Scale_is (Self : in out Item; Now : in Vector_3);
procedure set_Uniforms (Self : in Item);
----------
-- Privvy TODO: move this to privvy child package.
--
subtype a_gl_Program is gl.GLuint;
function gl_Program (Self : in Item) return a_gl_Program;
private
type Item is tagged limited
record
gl_Program : gl.GLuint := 0;
vertex_Shader : Shader.view;
fragment_Shader : Shader.view;
Attributes : openGL.Attribute.views (1 .. 8);
attribute_Count : Natural := 0;
mvp_Transform : Matrix_4x4;
Scale : Vector_3 := [1.0, 1.0, 1.0];
end record;
-------------
-- Parameters
--
type Parameters is limited new openGL.Parameters with
record
Program : openGL.Program.view;
end record;
end openGL.Program;

182
3-mid/opengl/source/lean/shader/opengl-shader.adb Normal file
View File

@@ -0,0 +1,182 @@
with
openGL.Tasks,
openGL.Errors,
GL.lean,
GL.Pointers,
ada.Characters.latin_1,
ada.Strings.unbounded,
ada.Text_IO,
ada.IO_Exceptions,
interfaces.C.Strings;
package body openGL.Shader
is
use GL.lean,
Interfaces;
-----------
-- Utility
--
function read_text_File (Filename : in String) return C.char_array;
---------
-- Forge
--
procedure define (Self : in out Item; Kind : in shader.Kind;
source_Filename : in String)
is
use GL.Pointers,
C.Strings;
the_Source : aliased C.char_array := read_text_File (source_Filename);
the_Source_ptr : aliased
constant chars_ptr := to_chars_ptr (the_Source'unchecked_Access);
the_Source_Array : aliased chars_ptr_array := [1 => the_Source_ptr];
begin
Tasks.check;
Self.Kind := Kind;
if Kind = Vertex
then Self.gl_Shader := glCreateShader (GL_VERTEX_SHADER);
else Self.gl_Shader := glCreateShader (GL_FRAGMENT_SHADER);
end if;
Errors.log;
glShaderSource (Self.gl_Shader,
1,
to_GLchar_Pointer_access (the_Source_array'Access),
null);
Errors.log;
glCompileShader (Self.gl_Shader);
Errors.log;
declare
use type C.int;
Status : aliased gl.glInt;
begin
glGetShaderiv (self.gl_Shader,
GL_COMPILE_STATUS,
Status'unchecked_Access);
if Status = 0
then
declare
compile_Log : constant String := Self.shader_info_Log;
begin
Self.destroy;
raise Error with "'" & source_Filename & "' compilation failed ~ " & compile_Log;
end;
end if;
end;
end define;
procedure destroy (Self : in out Item)
is
begin
Tasks.check;
glDeleteShader (self.gl_Shader);
end destroy;
--------------
-- Attributes
--
function shader_info_Log (Self : in Item) return String
is
use C, GL;
info_log_Length : aliased glInt := 0;
chars_Written : aliased glSizei := 0;
begin
Tasks.check;
glGetShaderiv (Self.gl_Shader,
GL_INFO_LOG_LENGTH,
info_log_Length'unchecked_Access);
if info_log_Length = 0
then
return "";
end if;
declare
use gl.Pointers;
info_Log : aliased C.char_array := C.char_array' [1 .. C.size_t (info_log_Length) => <>];
info_Log_ptr : constant C.Strings.chars_Ptr := C.Strings.to_chars_ptr (info_Log'unchecked_Access);
begin
glGetShaderInfoLog (self.gl_Shader,
glSizei (info_log_Length),
chars_Written'unchecked_Access,
to_GLchar_access (info_Log_ptr));
return C.to_Ada (info_Log);
end;
end shader_info_Log;
----------
-- Privvy
--
function gl_Shader (Self : in Item) return a_gl_Shader
is
begin
return Self.gl_Shader;
end gl_Shader;
-----------
-- Utility
--
NL : constant String := "" & ada.characters.latin_1.LF;
function read_text_File (Filename : in String) return C.char_array
is
use ada.Text_IO,
ada.Strings.unbounded;
the_File : ada.Text_IO.File_type;
Pad : unbounded_String;
begin
open (the_File, in_File, Filename);
while not end_of_File (the_File)
loop
append (Pad, get_Line (the_File) & NL);
end loop;
close (the_File);
declare
use type Interfaces.C.size_t;
the_Data : C.char_array (1 .. C.size_t (Length (Pad)) + 1);
begin
for i in 1 .. the_Data'Last - 1
loop
the_Data (i) := C.char (Element (Pad, Integer (i)));
end loop;
the_Data (the_Data'Last) := C.char'Val (0);
return the_Data;
end;
exception
when ada.IO_Exceptions.name_Error =>
raise Error with "Unable to locate shader asset named '" & Filename & "'.";
end read_text_File;
end openGL.Shader;

50
3-mid/opengl/source/lean/shader/opengl-shader.ads Normal file
View File

@@ -0,0 +1,50 @@
with
GL;
package openGL.Shader
--
-- Models an openGL shader.
--
is
type Item is tagged limited private;
type Items is array (Positive range <>) of aliased Item;
type View is access all Item'class;
type Views is array (Positive range <>) of View;
type Kind is (Vertex, Fragment);
---------
-- Forge
--
procedure define (Self : in out Item; Kind : in Shader.Kind;
source_Filename : in String);
procedure destroy (Self : in out Item);
--------------
-- Attributes
--
function shader_info_Log (Self : in Item) return String;
----------
-- Privvy
--
subtype a_gl_Shader is gl.GLuint;
function gl_Shader (Self : in Item) return a_gl_Shader;
private
type Item is tagged limited
record
Kind : shader.Kind;
gl_Shader : a_gl_Shader;
end record;
end openGL.Shader;

147
3-mid/opengl/source/lean/shader/opengl-variable-uniform.adb Normal file
View File

@@ -0,0 +1,147 @@
with
openGL.Program,
openGL.Tasks,
openGL.Errors,
GL.lean,
GL.Pointers,
interfaces.C.Strings;
package body openGL.Variable.uniform
is
use GL.lean,
Interfaces;
---------
-- Forge
--
procedure define (Self : in out Item; Program : access openGL.Program.item'Class;
Name : in String)
is
use GL.Pointers, C;
the_Name : C.Strings.chars_ptr := C.Strings.new_String (Name);
begin
Tasks.check;
Self.gl_Variable := glGetUniformLocation (Program.gl_Program,
to_GLchar_access (the_Name));
Errors.log;
C.Strings.free (the_Name);
if Self.gl_Variable = -1
then
raise openGL.Error with "Unable to get location for uniform named '" & Name & "'";
end if;
end define;
overriding
procedure destroy (Self : in out Item)
is
begin
null;
end destroy;
-----------
-- Actuals
--
-- bool
--
procedure Value_is (Self : in bool; Now : in Boolean)
is
begin
Tasks.check;
glUniform1i (Self.gl_Variable,
Boolean'Pos (Now));
Errors.log;
end Value_is;
-- int
--
procedure Value_is (Self : in int; Now : in Integer)
is
begin
Tasks.check;
glUniform1i (Self.gl_Variable,
gl.GLint (Now));
Errors.log;
end Value_is;
-- float
--
procedure Value_is (Self : in float; Now : in Real)
is
begin
Tasks.check;
glUniform1fv (Self.gl_Variable,
1,
Now'Address);
Errors.log;
end Value_is;
-- vec3
--
procedure Value_is (Self : in vec3; Now : in Vector_3)
is
begin
Tasks.check;
glUniform3fv (Self.gl_Variable,
1,
Now (1)'Address);
Errors.log;
end Value_is;
-- vec4
--
procedure Value_is (Self : in vec4; Now : in Vector_4)
is
begin
Tasks.check;
glUniform4fv (Self.gl_Variable,
1,
Now (1)'Address);
Errors.log;
end Value_is;
-- mat3
--
procedure Value_is (Self : in mat3; Now : in Matrix_3x3)
is
begin
Tasks.check;
glUniformMatrix3fv (Self.gl_Variable,
1,
gl.GL_FALSE,
Now (1, 1)'Address);
Errors.log;
end Value_is;
-- mat4
--
procedure Value_is (Self : in mat4; Now : in Matrix_4x4)
is
begin
Tasks.check;
glUniformMatrix4fv (Self.gl_Variable,
1,
gl.GL_FALSE,
Now (1, 1)'Address);
Errors.log;
end Value_is;
end openGL.Variable.uniform;

60
3-mid/opengl/source/lean/shader/opengl-variable-uniform.ads Normal file
View File

@@ -0,0 +1,60 @@
limited
with
openGL.Program;
package openGL.Variable.uniform
--
-- Models a uniform variable for shaders.
--
is
type Item is abstract new Variable.item with private;
---------
-- Forge
--
procedure define (Self : in out Item; Program : access openGL.Program.item'class;
Name : in String);
overriding
procedure destroy (Self : in out Item);
-----------
-- Actuals
--
type bool is new Variable.uniform.item with private;
type int is new Variable.uniform.item with private;
type float is new Variable.uniform.item with private;
type vec3 is new Variable.uniform.item with private;
type vec4 is new Variable.uniform.item with private;
type mat3 is new Variable.uniform.item with private;
type mat4 is new Variable.uniform.item with private;
procedure Value_is (Self : in bool; Now : in Boolean);
procedure Value_is (Self : in int; Now : in Integer);
procedure Value_is (Self : in float; Now : in Real);
procedure Value_is (Self : in vec3; Now : in Vector_3);
procedure Value_is (Self : in vec4; Now : in Vector_4);
procedure Value_is (Self : in mat3; Now : in Matrix_3x3);
procedure Value_is (Self : in mat4; Now : in Matrix_4x4);
private
type Item is abstract new openGL.Variable.item with null record;
type bool is new Variable.uniform.item with null record;
type int is new Variable.uniform.item with null record;
type float is new Variable.uniform.item with null record;
type vec3 is new Variable.uniform.item with null record;
type vec4 is new Variable.uniform.item with null record;
type mat3 is new Variable.uniform.item with null record;
type mat4 is new Variable.uniform.item with null record;
end openGL.Variable.uniform;

22
3-mid/opengl/source/lean/shader/opengl-variable.adb Normal file
View File

@@ -0,0 +1,22 @@
package body openGL.Variable
is
---------
-- Forge
--
procedure define (Self : in out Item) -- TODO: Rid these ?
is
begin
null;
end define;
procedure destroy (Self : in out Item)
is
begin
null;
end destroy;
end openGL.Variable;

28
3-mid/opengl/source/lean/shader/opengl-variable.ads Normal file
View File

@@ -0,0 +1,28 @@
with
GL;
package openGL.Variable
--
-- Models a shader variable.
--
is
type Item is abstract tagged private;
---------
-- Forge
--
procedure define (Self : in out Item);
procedure destroy (Self : in out Item);
private
type Item is abstract tagged
record
gl_Variable : gl.GLint;
end record;
end openGL.Variable;