Add initial prototype.
This commit is contained in:
Rod Kay
152
3-mid/opengl/source/lean/geometry/opengl-geometry-colored.adb
Normal file
152
3-mid/opengl/source/lean/geometry/opengl-geometry-colored.adb
Normal file
@@ -0,0 +1,152 @@
|
||||
with
|
||||
openGL.Shader,
|
||||
openGL.Program,
|
||||
openGL.Buffer.general,
|
||||
openGL.Tasks,
|
||||
openGL.Attribute,
|
||||
openGL.Errors,
|
||||
|
||||
GL.lean,
|
||||
GL.Pointers,
|
||||
|
||||
Interfaces.C.Strings,
|
||||
System.storage_Elements;
|
||||
|
||||
package body openGL.Geometry.colored
|
||||
is
|
||||
use GL.lean, GL.Pointers;
|
||||
use Interfaces;
|
||||
|
||||
-----------
|
||||
-- Globals
|
||||
--
|
||||
|
||||
vertex_Shader : aliased Shader.item;
|
||||
fragment_Shader : aliased Shader.item;
|
||||
the_Program : openGL.Program.view;
|
||||
|
||||
Name_1 : constant String := "Site";
|
||||
Name_2 : constant String := "Color";
|
||||
|
||||
Attribute_1_Name : aliased C.char_array := C.to_C (Name_1);
|
||||
Attribute_2_Name : aliased C.char_array := C.to_C (Name_2);
|
||||
|
||||
Attribute_1_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_1_Name'Access);
|
||||
Attribute_2_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_2_Name'Access);
|
||||
|
||||
|
||||
---------
|
||||
-- Forge
|
||||
--
|
||||
|
||||
function new_Geometry return Geometry.colored.view
|
||||
is
|
||||
use System.storage_Elements;
|
||||
use type openGL.Program.view;
|
||||
|
||||
Self : constant Geometry.colored.view := new Geometry.colored.item;
|
||||
begin
|
||||
Tasks.check;
|
||||
|
||||
if the_Program = null
|
||||
then -- Define the shaders and program.
|
||||
declare
|
||||
use openGL.Attribute.Forge;
|
||||
|
||||
sample_Vertex : Vertex;
|
||||
Attribute_1 : Attribute.view;
|
||||
Attribute_2 : Attribute.view;
|
||||
begin
|
||||
vertex_Shader .define (Shader.Vertex, "assets/opengl/shader/colored.vert");
|
||||
fragment_Shader.define (Shader.Fragment, "assets/opengl/shader/colored.frag");
|
||||
|
||||
the_Program := new openGL.Program.item;
|
||||
the_Program.define (vertex_Shader 'Access,
|
||||
fragment_Shader'Access);
|
||||
|
||||
Attribute_1 := new_Attribute (Name => Name_1,
|
||||
gl_Location => the_Program.attribute_Location (Name_1),
|
||||
Size => 3,
|
||||
data_Kind => Attribute.GL_FLOAT,
|
||||
Stride => colored.Vertex'Size / 8,
|
||||
Offset => 0,
|
||||
Normalized => False);
|
||||
|
||||
Attribute_2 := new_Attribute (Name => Name_2,
|
||||
gl_Location => the_Program.attribute_Location (Name_2),
|
||||
Size => 4,
|
||||
data_Kind => Attribute.GL_UNSIGNED_BYTE,
|
||||
Stride => colored.Vertex'Size / 8,
|
||||
Offset => sample_Vertex.Color.primary.Red'Address
|
||||
- sample_Vertex.Site (1) 'Address,
|
||||
Normalized => True);
|
||||
the_Program.add (Attribute_1);
|
||||
the_Program.add (Attribute_2);
|
||||
|
||||
glBindAttribLocation (Program => the_Program.gl_Program,
|
||||
Index => the_Program.Attribute (named => Name_1).gl_Location,
|
||||
Name => +Attribute_1_Name_ptr);
|
||||
Errors.log;
|
||||
|
||||
glBindAttribLocation (Program => the_Program.gl_Program,
|
||||
Index => the_Program.Attribute (named => Name_2).gl_Location,
|
||||
Name => +Attribute_2_Name_ptr);
|
||||
Errors.log;
|
||||
end;
|
||||
end if;
|
||||
|
||||
Self.Program_is (the_Program);
|
||||
|
||||
return Self;
|
||||
end new_Geometry;
|
||||
|
||||
|
||||
------------
|
||||
-- Vertices
|
||||
--
|
||||
|
||||
function is_Transparent (Self : in Vertex_array) return Boolean
|
||||
is
|
||||
function get_Color (Index : in Index_t) return rgba_Color
|
||||
is (Self (Index).Color);
|
||||
|
||||
function my_Transparency is new get_Transparency (any_Index_t => Index_t,
|
||||
get_Color => get_Color);
|
||||
begin
|
||||
return my_Transparency (Count => Self'Length);
|
||||
end is_Transparent;
|
||||
|
||||
|
||||
--------------
|
||||
-- Attributes
|
||||
--
|
||||
|
||||
package openGL_Buffer_of_geometry_Vertices is new Buffer.general (base_Object => Buffer.array_Object,
|
||||
Index => Index_t,
|
||||
Element => Vertex,
|
||||
Element_Array => Vertex_array);
|
||||
|
||||
procedure Vertices_are (Self : in out Item; Now : in Vertex_array)
|
||||
is
|
||||
use openGL.Buffer,
|
||||
openGL_Buffer_of_geometry_Vertices.Forge;
|
||||
begin
|
||||
free (Self.Vertices);
|
||||
Self.Vertices := new openGL_Buffer_of_geometry_Vertices.Object' (to_Buffer (Now,
|
||||
usage => Buffer.static_Draw));
|
||||
Self.is_Transparent := is_Transparent (Now);
|
||||
|
||||
-- Set the bounds.
|
||||
--
|
||||
declare
|
||||
function get_Site (Index : in Index_t) return Vector_3
|
||||
is (Now (Index).Site);
|
||||
|
||||
function bounding_Box is new get_Bounds (Index_t, get_Site);
|
||||
begin
|
||||
Self.Bounds_are (bounding_Box (Count => Now'Length));
|
||||
end;
|
||||
end Vertices_are;
|
||||
|
||||
|
||||
end openGL.Geometry.colored;
|
||||
@@ -0,0 +1,43 @@
|
||||
package openGL.Geometry.colored
|
||||
--
|
||||
-- Supports per-vertex site and color.
|
||||
--
|
||||
is
|
||||
type Item is new Geometry.item with private;
|
||||
type View is access Item'Class;
|
||||
|
||||
|
||||
|
||||
function new_Geometry return Geometry.colored.view;
|
||||
|
||||
|
||||
------------
|
||||
-- Vertices
|
||||
--
|
||||
|
||||
type Vertex is
|
||||
record
|
||||
Site : Vector_3;
|
||||
Color : rgba_Color;
|
||||
end record;
|
||||
|
||||
type Vertex_array is array (Index_t range <>) of aliased Vertex;
|
||||
type Vertex_array_view is access Vertex_array;
|
||||
|
||||
|
||||
--------------
|
||||
-- Attributes
|
||||
--
|
||||
|
||||
procedure Vertices_are (Self : in out Item; Now : in Vertex_array);
|
||||
|
||||
|
||||
|
||||
private
|
||||
|
||||
type Item is new Geometry.item with
|
||||
record
|
||||
null;
|
||||
end record;
|
||||
|
||||
end openGL.Geometry.colored;
|
||||
@@ -0,0 +1,213 @@
|
||||
with
|
||||
openGL.Shader,
|
||||
openGL.Buffer.general,
|
||||
openGL.Program,
|
||||
openGL.Attribute,
|
||||
openGL.Texture,
|
||||
openGL.Palette,
|
||||
openGL.Tasks,
|
||||
openGL.Errors,
|
||||
|
||||
GL.Binding,
|
||||
GL.lean,
|
||||
GL.Pointers,
|
||||
|
||||
System,
|
||||
Interfaces.C.Strings,
|
||||
System.storage_Elements;
|
||||
|
||||
package body openGL.Geometry.colored_textured
|
||||
is
|
||||
use GL.lean,
|
||||
GL.Pointers,
|
||||
Interfaces;
|
||||
|
||||
-----------
|
||||
-- Globals
|
||||
--
|
||||
|
||||
vertex_Shader : aliased Shader.item;
|
||||
fragment_Shader : aliased Shader.item;
|
||||
the_Program : openGL.Program.view;
|
||||
white_Texture : openGL.Texture.Object;
|
||||
|
||||
Name_1 : constant String := "Site";
|
||||
Name_2 : constant String := "Color";
|
||||
Name_3 : constant String := "Coords";
|
||||
|
||||
Attribute_1_Name : aliased C.char_array := C.to_C (Name_1);
|
||||
Attribute_2_Name : aliased C.char_array := C.to_C (Name_2);
|
||||
Attribute_3_Name : aliased C.char_array := C.to_C (Name_3);
|
||||
|
||||
Attribute_1_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_1_Name'Access);
|
||||
Attribute_2_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_2_Name'Access);
|
||||
Attribute_3_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_3_Name'Access);
|
||||
|
||||
|
||||
---------
|
||||
-- Forge
|
||||
--
|
||||
|
||||
type Geometry_view is access all Geometry.colored_textured.item'Class;
|
||||
|
||||
function new_Geometry return access Geometry.colored_textured.item'Class
|
||||
is
|
||||
use System,
|
||||
System.storage_Elements;
|
||||
use type openGL.Program.view;
|
||||
|
||||
Self : constant Geometry_view := new Geometry.colored_textured.item;
|
||||
|
||||
begin
|
||||
Tasks.check;
|
||||
|
||||
if the_Program = null
|
||||
then -- Define the shaders and program.
|
||||
declare
|
||||
use Palette,
|
||||
Attribute.Forge;
|
||||
|
||||
Sample : Vertex;
|
||||
|
||||
Attribute_1 : Attribute.view;
|
||||
Attribute_2 : Attribute.view;
|
||||
Attribute_3 : Attribute.view;
|
||||
|
||||
white_Image : constant Image := [1 .. 2 => [1 .. 2 => +White]];
|
||||
begin
|
||||
white_Texture := openGL.Texture.Forge.to_Texture (white_Image);
|
||||
|
||||
vertex_Shader .define (Shader.Vertex, "assets/opengl/shader/colored_textured.vert");
|
||||
fragment_Shader.define (Shader.Fragment, "assets/opengl/shader/colored_textured.frag");
|
||||
|
||||
the_Program := new openGL.Program.item;
|
||||
the_Program.define (vertex_Shader 'Access,
|
||||
fragment_Shader'Access);
|
||||
the_Program.enable;
|
||||
|
||||
Attribute_1 := new_Attribute (Name => Name_1,
|
||||
gl_Location => the_Program.attribute_Location (Name_1),
|
||||
Size => 3,
|
||||
data_Kind => Attribute.GL_FLOAT,
|
||||
Stride => colored_textured.Vertex'Size / 8,
|
||||
Offset => 0,
|
||||
Normalized => False);
|
||||
|
||||
Attribute_2 := new_Attribute (Name => Name_2,
|
||||
gl_Location => the_Program.attribute_Location (Name_2),
|
||||
Size => 4,
|
||||
data_Kind => Attribute.GL_UNSIGNED_BYTE,
|
||||
Stride => colored_textured.Vertex'Size / 8,
|
||||
Offset => Sample.Color.Primary.Red'Address
|
||||
- Sample.Site (1) 'Address,
|
||||
Normalized => True);
|
||||
|
||||
Attribute_3 := new_Attribute (Name => Name_3,
|
||||
gl_Location => the_Program.attribute_Location (Name_3),
|
||||
Size => 2,
|
||||
data_Kind => attribute.GL_FLOAT,
|
||||
Stride => Colored_textured.Vertex'Size / 8,
|
||||
Offset => Sample.Coords.S'Address
|
||||
- Sample.Site (1)'Address,
|
||||
Normalized => False);
|
||||
the_Program.add (Attribute_1);
|
||||
the_Program.add (Attribute_2);
|
||||
the_Program.add (Attribute_3);
|
||||
|
||||
glBindAttribLocation (program => the_Program.gl_Program,
|
||||
index => the_Program.Attribute (named => Name_1).gl_Location,
|
||||
name => +Attribute_1_Name_ptr);
|
||||
Errors.log;
|
||||
|
||||
glBindAttribLocation (program => the_Program.gl_Program,
|
||||
index => the_Program.Attribute (named => Name_2).gl_Location,
|
||||
name => +Attribute_2_Name_ptr);
|
||||
Errors.log;
|
||||
|
||||
glBindAttribLocation (program => the_Program.gl_Program,
|
||||
index => the_Program.Attribute (named => Name_3).gl_Location,
|
||||
name => +Attribute_3_Name_ptr);
|
||||
Errors.log;
|
||||
end;
|
||||
end if;
|
||||
|
||||
Self.Program_is (the_Program.all'Access);
|
||||
return Self;
|
||||
end new_Geometry;
|
||||
|
||||
|
||||
----------
|
||||
-- Vertex
|
||||
--
|
||||
|
||||
function is_Transparent (Self : in Vertex_array) return Boolean
|
||||
is
|
||||
function get_Color (Index : in long_Index_t) return rgba_Color
|
||||
is (Self (Index).Color);
|
||||
|
||||
function my_Transparency is new get_Transparency (any_Index_t => long_Index_t,
|
||||
get_Color => get_Color);
|
||||
begin
|
||||
return my_Transparency (Count => Self'Length);
|
||||
end is_Transparent;
|
||||
|
||||
|
||||
--------------
|
||||
-- Attributes
|
||||
--
|
||||
|
||||
package openGL_Buffer_of_geometry_Vertices is new Buffer.general (base_Object => Buffer.array_Object,
|
||||
Index => long_Index_t,
|
||||
Element => Vertex,
|
||||
Element_Array => Vertex_array);
|
||||
|
||||
procedure Vertices_are (Self : in out Item; Now : in Vertex_array)
|
||||
is
|
||||
use openGL_Buffer_of_geometry_Vertices.Forge;
|
||||
begin
|
||||
Self.Vertices := new openGL_Buffer_of_geometry_Vertices.Object' (to_Buffer (Now,
|
||||
usage => Buffer.static_Draw));
|
||||
Self.is_Transparent := is_Transparent (Now);
|
||||
|
||||
-- Set the bounds.
|
||||
--
|
||||
declare
|
||||
function get_Site (Index : in long_Index_t) return Vector_3
|
||||
is (Now (Index).Site);
|
||||
|
||||
function bounding_Box is new get_Bounds (long_Index_t, get_Site);
|
||||
begin
|
||||
Self.Bounds_are (bounding_Box (count => Now'Length));
|
||||
end;
|
||||
end Vertices_are;
|
||||
|
||||
|
||||
overriding
|
||||
procedure Indices_are (Self : in out Item; Now : in Indices;
|
||||
for_Facia : in Positive)
|
||||
is
|
||||
begin
|
||||
raise Error with "TODO";
|
||||
end Indices_are;
|
||||
|
||||
|
||||
overriding
|
||||
procedure enable_Texture (Self : in 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_Texture;
|
||||
|
||||
|
||||
end openGL.Geometry.colored_textured;
|
||||
@@ -0,0 +1,47 @@
|
||||
package openGL.Geometry.colored_textured
|
||||
--
|
||||
-- Supports per-vertex site, color and texture.
|
||||
--
|
||||
is
|
||||
type Item is new openGL.Geometry.item with private;
|
||||
|
||||
function new_Geometry return access Geometry.colored_textured.item'Class;
|
||||
|
||||
|
||||
----------
|
||||
-- Vertex
|
||||
--
|
||||
|
||||
type Vertex is
|
||||
record
|
||||
Site : Vector_3;
|
||||
Color : rgba_Color;
|
||||
Coords : Coordinate_2D;
|
||||
end record;
|
||||
|
||||
type Vertex_array is array (long_Index_t range <>) of aliased Vertex;
|
||||
type Vertex_array_view is access Vertex_array;
|
||||
|
||||
|
||||
--------------
|
||||
-- Attributes
|
||||
--
|
||||
|
||||
procedure Vertices_are (Self : in out Item; Now : in Vertex_array);
|
||||
|
||||
overriding
|
||||
procedure Indices_are (Self : in out Item; Now : in Indices;
|
||||
for_Facia : in Positive);
|
||||
|
||||
|
||||
private
|
||||
|
||||
type Item is new Geometry.item with
|
||||
record
|
||||
null;
|
||||
end record;
|
||||
|
||||
overriding
|
||||
procedure enable_Texture (Self : in Item);
|
||||
|
||||
end openGL.Geometry.colored_textured;
|
||||
@@ -0,0 +1,211 @@
|
||||
with
|
||||
openGL.Program.lit,
|
||||
openGL.Buffer.general,
|
||||
openGL.Shader,
|
||||
openGL.Attribute,
|
||||
openGL.Tasks,
|
||||
openGL.Errors,
|
||||
|
||||
GL.lean,
|
||||
GL.Pointers,
|
||||
|
||||
Interfaces.C.Strings,
|
||||
System.storage_Elements;
|
||||
|
||||
|
||||
package body openGL.Geometry.lit_colored
|
||||
is
|
||||
use GL.lean,
|
||||
GL.Pointers,
|
||||
Interfaces,
|
||||
System;
|
||||
|
||||
------------------
|
||||
-- Shader Program
|
||||
--
|
||||
|
||||
type Program is
|
||||
record
|
||||
vertex_Shader : aliased Shader.item;
|
||||
fragment_Shader : aliased Shader.item;
|
||||
Program : openGL.Program.lit.view;
|
||||
end record;
|
||||
|
||||
|
||||
-----------
|
||||
--- Globals
|
||||
--
|
||||
|
||||
the_Program : aliased Program;
|
||||
|
||||
|
||||
Name_1 : constant String := "Site";
|
||||
Name_2 : constant String := "Normal";
|
||||
Name_3 : constant String := "Color";
|
||||
Name_4 : constant String := "Shine";
|
||||
|
||||
Attribute_1_Name : aliased C.char_array := C.to_C (Name_1);
|
||||
Attribute_2_Name : aliased C.char_array := C.to_C (Name_2);
|
||||
Attribute_3_Name : aliased C.char_array := C.to_C (Name_3);
|
||||
Attribute_4_Name : aliased C.char_array := C.to_C (Name_4);
|
||||
|
||||
Attribute_1_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_1_Name'Access);
|
||||
Attribute_2_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_2_Name'Access);
|
||||
Attribute_3_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_3_Name'Access);
|
||||
Attribute_4_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_4_Name'Access);
|
||||
|
||||
|
||||
---------
|
||||
-- Forge
|
||||
--
|
||||
|
||||
function new_Geometry return View
|
||||
is
|
||||
use System.storage_Elements;
|
||||
use type openGL.Program.lit.view;
|
||||
|
||||
procedure define (the_Program : access Program)
|
||||
is
|
||||
use Attribute.Forge;
|
||||
|
||||
Sample : Vertex;
|
||||
|
||||
Attribute_1,
|
||||
Attribute_2,
|
||||
Attribute_3,
|
||||
Attribute_4 : Attribute.view;
|
||||
begin
|
||||
the_Program.Program := new openGL.Program.lit.item;
|
||||
|
||||
the_Program. vertex_Shader.define (Shader.Vertex, "assets/opengl/shader/lit_colored.vert");
|
||||
the_Program.fragment_Shader.define (Shader.Fragment, "assets/opengl/shader/lit_colored.frag");
|
||||
|
||||
the_Program.Program.define (the_Program. vertex_Shader'Access,
|
||||
the_Program.fragment_Shader'Access);
|
||||
|
||||
Attribute_1 := new_Attribute (Name => Name_1,
|
||||
gl_Location => the_Program.Program.attribute_Location (Name_1),
|
||||
Size => 3,
|
||||
data_Kind => attribute.GL_FLOAT,
|
||||
Stride => lit_colored.Vertex'Size / 8,
|
||||
Offset => 0,
|
||||
Normalized => False);
|
||||
|
||||
Attribute_2 := new_Attribute (Name => Name_2,
|
||||
gl_Location => the_Program.Program.attribute_Location (Name_2),
|
||||
Size => 3,
|
||||
data_Kind => attribute.GL_FLOAT,
|
||||
Stride => lit_colored.Vertex'Size / 8,
|
||||
Offset => Sample.Normal (1)'Address
|
||||
- Sample.Site (1)'Address,
|
||||
Normalized => False);
|
||||
|
||||
Attribute_3 := new_Attribute (Name => Name_3,
|
||||
gl_Location => the_Program.Program.attribute_Location (Name_3),
|
||||
Size => 4,
|
||||
data_Kind => attribute.GL_UNSIGNED_BYTE,
|
||||
Stride => lit_colored.Vertex'Size / 8,
|
||||
Offset => Sample.Color.Primary.Red'Address
|
||||
- Sample.Site (1) 'Address,
|
||||
Normalized => True);
|
||||
|
||||
Attribute_4 := new_Attribute (Name => Name_4,
|
||||
gl_Location => the_Program.Program.attribute_Location (Name_4),
|
||||
Size => 1,
|
||||
data_Kind => attribute.GL_FLOAT,
|
||||
Stride => lit_colored.Vertex'Size / 8,
|
||||
Offset => Sample.Shine 'Address
|
||||
- Sample.Site (1) 'Address,
|
||||
Normalized => True);
|
||||
|
||||
the_Program.Program.add (Attribute_1);
|
||||
the_Program.Program.add (Attribute_2);
|
||||
the_Program.Program.add (Attribute_3);
|
||||
the_Program.Program.add (Attribute_4);
|
||||
|
||||
glBindAttribLocation (program => the_Program.Program.gl_Program,
|
||||
index => the_Program.Program.Attribute (named => Name_1).gl_Location,
|
||||
name => +Attribute_1_Name_ptr);
|
||||
Errors.log;
|
||||
|
||||
glBindAttribLocation (program => the_Program.Program.gl_Program,
|
||||
index => the_Program.Program.Attribute (named => Name_2).gl_Location,
|
||||
name => +Attribute_2_Name_ptr);
|
||||
Errors.log;
|
||||
|
||||
glBindAttribLocation (program => the_Program.Program.gl_Program,
|
||||
index => the_Program.Program.Attribute (named => Name_3).gl_Location,
|
||||
name => +Attribute_3_Name_ptr);
|
||||
Errors.log;
|
||||
|
||||
glBindAttribLocation (program => the_Program.Program.gl_Program,
|
||||
index => the_Program.Program.Attribute (named => Name_4).gl_Location,
|
||||
name => +Attribute_4_Name_ptr);
|
||||
Errors.log;
|
||||
end define;
|
||||
|
||||
Self : constant View := new Geometry.lit_colored.item;
|
||||
|
||||
begin
|
||||
Tasks.check;
|
||||
|
||||
if the_Program.Program = null -- Define the shaders and program, if required.
|
||||
then
|
||||
define (the_Program'Access);
|
||||
end if;
|
||||
|
||||
Self.Program_is (openGL.Program.view (the_Program.Program));
|
||||
return Self;
|
||||
end new_Geometry;
|
||||
|
||||
|
||||
----------
|
||||
-- Vertex
|
||||
--
|
||||
|
||||
function is_Transparent (Self : in Vertex_array) return Boolean
|
||||
is
|
||||
function get_Color (Index : in Index_t) return rgba_Color
|
||||
is (Self (Index).Color);
|
||||
|
||||
function my_Transparency is new get_Transparency (any_Index_t => Index_t,
|
||||
get_Color => get_Color);
|
||||
begin
|
||||
return my_Transparency (Count => Self'Length);
|
||||
end is_Transparent;
|
||||
|
||||
|
||||
--------------
|
||||
-- Attributes
|
||||
--
|
||||
|
||||
package openGL_Buffer_of_geometry_Vertices is new Buffer.general (base_Object => Buffer.array_Object,
|
||||
Index => Index_t,
|
||||
Element => Vertex,
|
||||
Element_Array => Vertex_array);
|
||||
|
||||
procedure Vertices_are (Self : in out Item; Now : in Vertex_array)
|
||||
is
|
||||
use openGL_Buffer_of_geometry_Vertices.Forge;
|
||||
begin
|
||||
Buffer.free (Self.Vertices);
|
||||
|
||||
Self.is_Transparent := False;
|
||||
self.Vertices := new openGL_Buffer_of_geometry_Vertices.Object' (to_Buffer (Now,
|
||||
usage => Buffer.static_Draw));
|
||||
Self.is_Transparent := is_Transparent (Now);
|
||||
|
||||
-- Set the bounds.
|
||||
--
|
||||
declare
|
||||
function get_Site (Index : in Index_t) return Vector_3
|
||||
is (Now (Index).Site);
|
||||
|
||||
function bounding_Box is new get_Bounds (Index_t, get_Site);
|
||||
begin
|
||||
Self.Bounds_are (bounding_Box (count => Now'Length));
|
||||
end;
|
||||
end Vertices_are;
|
||||
|
||||
|
||||
end openGL.Geometry.lit_colored;
|
||||
@@ -0,0 +1,40 @@
|
||||
package openGL.Geometry.lit_colored
|
||||
--
|
||||
-- Supports per-vertex color and lighting.
|
||||
--
|
||||
is
|
||||
type Item is new openGL.Geometry.item with private;
|
||||
type View is access all Item'Class;
|
||||
|
||||
|
||||
function new_Geometry return View;
|
||||
|
||||
|
||||
----------
|
||||
-- Vertex
|
||||
--
|
||||
|
||||
type Vertex is
|
||||
record
|
||||
Site : Vector_3;
|
||||
Normal : Vector_3;
|
||||
Color : rgba_Color;
|
||||
Shine : Real;
|
||||
end record;
|
||||
|
||||
type Vertex_array is array (Index_t range <>) of aliased Vertex;
|
||||
|
||||
|
||||
--------------
|
||||
-- Attributes
|
||||
--
|
||||
|
||||
procedure Vertices_are (Self : in out Item; Now : in Vertex_array);
|
||||
|
||||
|
||||
|
||||
private
|
||||
|
||||
type Item is new Geometry.item with null record;
|
||||
|
||||
end openGL.Geometry.lit_colored;
|
||||
@@ -0,0 +1,268 @@
|
||||
with
|
||||
openGL.Shader,
|
||||
openGL.Attribute,
|
||||
openGL.Buffer.general,
|
||||
openGL.Texture,
|
||||
openGL.Tasks,
|
||||
openGL.Errors,
|
||||
|
||||
GL.lean,
|
||||
GL.Pointers,
|
||||
|
||||
Interfaces.C.Strings,
|
||||
System.storage_Elements;
|
||||
|
||||
|
||||
package body openGL.Geometry.lit_colored_skinned
|
||||
is
|
||||
-- Globals
|
||||
--
|
||||
vertex_Shader : aliased Shader.item;
|
||||
fragment_Shader : aliased Shader.item;
|
||||
|
||||
the_Program : aliased openGL.Program.lit.colored_skinned.item;
|
||||
is_Defined : Boolean := False;
|
||||
|
||||
Name_1 : constant String := "Site";
|
||||
Name_2 : constant String := "Normal";
|
||||
Name_3 : constant String := "Color";
|
||||
Name_4 : constant String := "Shine";
|
||||
Name_5 : constant String := "bone_Ids";
|
||||
Name_6 : constant String := "bone_Weights";
|
||||
|
||||
use Interfaces;
|
||||
|
||||
Attribute_1_Name : aliased C.char_array := C.to_C (Name_1);
|
||||
Attribute_2_Name : aliased C.char_array := C.to_C (Name_2);
|
||||
Attribute_3_Name : aliased C.char_array := C.to_C (Name_3);
|
||||
Attribute_4_Name : aliased C.char_array := C.to_C (Name_4);
|
||||
Attribute_5_Name : aliased C.char_array := C.to_C (Name_5);
|
||||
Attribute_6_Name : aliased C.char_array := C.to_C (Name_6);
|
||||
|
||||
Attribute_1_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_1_Name'Access);
|
||||
Attribute_2_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_2_Name'Access);
|
||||
Attribute_3_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_3_Name'Access);
|
||||
Attribute_4_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_4_Name'Access);
|
||||
Attribute_5_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_5_Name'Access);
|
||||
Attribute_6_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_6_Name'Access);
|
||||
|
||||
|
||||
----------
|
||||
-- Vertex
|
||||
--
|
||||
|
||||
function is_Transparent (Self : in Vertex_array) return Boolean -- TODO: Replace this with the generic (check that all similar functions use the generic).
|
||||
is
|
||||
use type color_Value;
|
||||
begin
|
||||
for Each in Self'Range
|
||||
loop
|
||||
if Self (Each).Color.Alpha /= opaque_Value
|
||||
then
|
||||
return True;
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
return False;
|
||||
end is_Transparent;
|
||||
|
||||
|
||||
---------
|
||||
-- Forge
|
||||
--
|
||||
|
||||
function new_Geometry return Geometry.lit_colored_skinned.view
|
||||
is
|
||||
Self : constant Geometry.lit_colored_skinned.view := new Geometry.lit_colored_skinned.item;
|
||||
begin
|
||||
Self.Program_is (the_Program'Access);
|
||||
return Self;
|
||||
end new_Geometry;
|
||||
|
||||
|
||||
|
||||
procedure define_Program
|
||||
is
|
||||
use Attribute.Forge,
|
||||
GL.lean,
|
||||
GL.Pointers,
|
||||
System.storage_Elements;
|
||||
|
||||
Sample : Vertex;
|
||||
|
||||
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;
|
||||
|
||||
begin
|
||||
Tasks.check;
|
||||
|
||||
if is_Defined
|
||||
then
|
||||
raise Error with "The lit_colored_textured_skinned program has already been defined.";
|
||||
end if;
|
||||
|
||||
is_Defined := True;
|
||||
|
||||
-- Define the shaders and program.
|
||||
--
|
||||
vertex_Shader .define (Shader.Vertex, "assets/opengl/shader/lit_colored_skinned.vert");
|
||||
fragment_Shader.define (Shader.Fragment, "assets/opengl/shader/lit_colored_skinned.frag");
|
||||
|
||||
the_Program.define ( vertex_Shader'Access,
|
||||
fragment_Shader'Access);
|
||||
the_Program.enable;
|
||||
|
||||
Attribute_1 := new_Attribute (Name => Name_1,
|
||||
gl_Location => the_Program.attribute_Location (Name_1),
|
||||
Size => 3,
|
||||
data_Kind => Attribute.GL_FLOAT,
|
||||
Stride => lit_colored_skinned.Vertex'Size / 8,
|
||||
Offset => 0,
|
||||
Normalized => False);
|
||||
|
||||
Attribute_2 := new_Attribute (Name => Name_2,
|
||||
gl_Location => the_Program.attribute_Location (Name_2),
|
||||
Size => 3,
|
||||
data_Kind => Attribute.GL_FLOAT,
|
||||
Stride => lit_colored_skinned.Vertex'Size / 8,
|
||||
Offset => Sample.Normal (1)'Address
|
||||
- Sample.Site (1)'Address,
|
||||
Normalized => False);
|
||||
|
||||
Attribute_3 := new_Attribute (Name => Name_3,
|
||||
gl_Location => the_Program.attribute_Location (Name_3),
|
||||
Size => 4,
|
||||
data_Kind => Attribute.GL_UNSIGNED_BYTE,
|
||||
Stride => lit_colored_skinned.Vertex'Size / 8,
|
||||
Offset => Sample.Color.Primary.Red'Address
|
||||
- Sample.Site (1) 'Address,
|
||||
Normalized => True);
|
||||
|
||||
Attribute_4 := new_Attribute (Name => Name_4,
|
||||
gl_Location => the_Program.attribute_Location (Name_4),
|
||||
Size => 4,
|
||||
data_Kind => Attribute.GL_FLOAT,
|
||||
Stride => lit_colored_skinned.Vertex'Size / 8,
|
||||
Offset => Sample.bone_Ids (1)'Address
|
||||
- Sample.Site (1)'Address,
|
||||
Normalized => False);
|
||||
|
||||
Attribute_5 := new_Attribute (Name => Name_5,
|
||||
gl_Location => the_Program.attribute_Location (Name_5),
|
||||
Size => 4,
|
||||
data_Kind => Attribute.GL_FLOAT,
|
||||
Stride => lit_colored_skinned.Vertex'Size / 8,
|
||||
Offset => Sample.bone_Ids (1)'Address
|
||||
- Sample.Site (1)'Address,
|
||||
Normalized => False);
|
||||
|
||||
Attribute_6 := new_Attribute (Name => Name_6,
|
||||
gl_Location => the_Program.attribute_Location (Name_6),
|
||||
Size => 4,
|
||||
data_Kind => Attribute.GL_FLOAT,
|
||||
Stride => lit_colored_skinned.Vertex'Size / 8,
|
||||
Offset => Sample.bone_Weights (1)'Address
|
||||
- Sample.Site (1)'Address,
|
||||
Normalized => False);
|
||||
the_Program.add (Attribute_1);
|
||||
the_Program.add (Attribute_2);
|
||||
the_Program.add (Attribute_3);
|
||||
the_Program.add (Attribute_4);
|
||||
the_Program.add (Attribute_5);
|
||||
the_Program.add (Attribute_6);
|
||||
|
||||
glBindAttribLocation (program => the_Program.gl_Program,
|
||||
index => the_Program.Attribute (named => Name_1).gl_Location,
|
||||
name => +Attribute_1_Name_ptr);
|
||||
Errors.log;
|
||||
|
||||
glBindAttribLocation (program => the_Program.gl_Program,
|
||||
index => the_Program.Attribute (named => Name_2).gl_Location,
|
||||
name => +Attribute_2_Name_ptr);
|
||||
Errors.log;
|
||||
|
||||
glBindAttribLocation (program => the_Program.gl_Program,
|
||||
index => the_Program.Attribute (named => Name_3).gl_Location,
|
||||
name => +Attribute_3_Name_ptr);
|
||||
Errors.log;
|
||||
|
||||
glBindAttribLocation (program => the_Program.gl_Program,
|
||||
index => the_Program.Attribute (named => Name_4).gl_Location,
|
||||
name => +Attribute_4_Name_ptr);
|
||||
Errors.log;
|
||||
|
||||
glBindAttribLocation (program => the_Program.gl_Program,
|
||||
index => the_Program.Attribute (named => Name_5).gl_Location,
|
||||
name => +Attribute_5_Name_ptr);
|
||||
Errors.log;
|
||||
|
||||
glBindAttribLocation (program => the_Program.gl_Program,
|
||||
index => the_Program.Attribute (named => Name_6).gl_Location,
|
||||
name => +Attribute_6_Name_ptr);
|
||||
Errors.log;
|
||||
|
||||
end define_Program;
|
||||
|
||||
|
||||
--------------
|
||||
-- Attributes
|
||||
--
|
||||
|
||||
function Program return openGL.Program.lit.colored_skinned.view
|
||||
is
|
||||
begin
|
||||
return the_Program'Access;
|
||||
end Program;
|
||||
|
||||
|
||||
|
||||
overriding
|
||||
procedure Indices_are (Self : in out Item; Now : in Indices;
|
||||
for_Facia : in Positive)
|
||||
is
|
||||
begin
|
||||
raise Error with "openGL.Geometry.lit_coloured_textured_skinned - 'Indices_are' ~ TODO";
|
||||
end Indices_are;
|
||||
|
||||
|
||||
|
||||
package openGL_Buffer_of_geometry_Vertices is new Buffer.general (base_Object => Buffer.array_Object,
|
||||
Index => long_Index_t,
|
||||
Element => Vertex,
|
||||
Element_Array => Vertex_array);
|
||||
|
||||
procedure Vertices_are (Self : in out Item; Now : in Vertex_array)
|
||||
is
|
||||
use openGL_Buffer_of_geometry_Vertices.Forge;
|
||||
begin
|
||||
Self.Vertices := new openGL_Buffer_of_geometry_Vertices.object' (to_Buffer (Now,
|
||||
usage => Buffer.static_Draw));
|
||||
Self.is_Transparent := Self.is_Transparent
|
||||
or is_Transparent (Now);
|
||||
-- Set the bounds.
|
||||
--
|
||||
declare
|
||||
function get_Site (Index : in long_Index_t) return Vector_3
|
||||
is (Now (Index).Site);
|
||||
|
||||
function bounding_Box is new get_Bounds (long_Index_t, get_Site);
|
||||
begin
|
||||
Self.Bounds_are (bounding_Box (Count => Now'Length));
|
||||
end;
|
||||
end Vertices_are;
|
||||
|
||||
|
||||
|
||||
overriding
|
||||
procedure enable_Texture (Self : in Item)
|
||||
is
|
||||
begin
|
||||
null;
|
||||
end enable_Texture;
|
||||
|
||||
|
||||
end openGL.Geometry.lit_colored_skinned;
|
||||
@@ -0,0 +1,57 @@
|
||||
with
|
||||
openGL.Program.lit.colored_skinned;
|
||||
|
||||
package openGL.Geometry.lit_colored_skinned
|
||||
--
|
||||
-- Supports per-vertex site color, texture, lighting and skinning.
|
||||
--
|
||||
is
|
||||
type Item is new openGL.Geometry.item with private;
|
||||
type View is access all Item'Class;
|
||||
|
||||
function new_Geometry return View;
|
||||
|
||||
procedure define_Program;
|
||||
|
||||
|
||||
----------
|
||||
-- Vertex
|
||||
--
|
||||
|
||||
type Vertex is
|
||||
record
|
||||
Site : Vector_3;
|
||||
Normal : Vector_3;
|
||||
Color : rgba_Color;
|
||||
Shine : Real;
|
||||
|
||||
bone_Ids : Vector_4;
|
||||
bone_Weights : Vector_4;
|
||||
end record;
|
||||
pragma Convention (C, Vertex);
|
||||
|
||||
type Vertex_array is array (long_Index_t range <>) of aliased Vertex;
|
||||
|
||||
|
||||
--------------
|
||||
-- Attributes
|
||||
--
|
||||
|
||||
procedure Vertices_are (Self : in out Item; Now : in Vertex_array);
|
||||
|
||||
overriding
|
||||
procedure Indices_are (Self : in out Item; Now : in Indices;
|
||||
for_Facia : in Positive);
|
||||
|
||||
function Program return openGL.Program.lit.colored_skinned.view;
|
||||
|
||||
|
||||
|
||||
private
|
||||
|
||||
type Item is new Geometry.item with null record;
|
||||
|
||||
overriding
|
||||
procedure enable_Texture (Self : in Item);
|
||||
|
||||
end openGL.Geometry.lit_colored_skinned;
|
||||
@@ -0,0 +1,295 @@
|
||||
with
|
||||
openGL.Program.lit,
|
||||
openGL.Palette,
|
||||
openGL.Shader,
|
||||
openGL.Buffer.general,
|
||||
openGL.Attribute,
|
||||
openGL.Texture,
|
||||
openGL.Tasks,
|
||||
openGL.Errors,
|
||||
|
||||
GL.Binding,
|
||||
GL.lean,
|
||||
GL.Pointers,
|
||||
|
||||
Interfaces.C.Strings,
|
||||
System.storage_Elements;
|
||||
|
||||
package body openGL.Geometry.lit_colored_textured
|
||||
is
|
||||
use GL.lean,
|
||||
GL.Pointers,
|
||||
Interfaces,
|
||||
System;
|
||||
|
||||
------------------
|
||||
-- Shader Program
|
||||
--
|
||||
|
||||
type program_Id is (rgba_Texture, alpha_Texture);
|
||||
|
||||
type Program is
|
||||
record
|
||||
vertex_Shader : aliased Shader.item;
|
||||
fragment_Shader : aliased Shader.item;
|
||||
Program : openGL.Program.lit.view;
|
||||
end record;
|
||||
|
||||
type Programs is array (program_Id) of aliased Program;
|
||||
|
||||
|
||||
-----------
|
||||
--- Globals
|
||||
--
|
||||
|
||||
the_Programs : Programs;
|
||||
|
||||
Name_1 : constant String := "Site";
|
||||
Name_2 : constant String := "Normal";
|
||||
Name_3 : constant String := "Color";
|
||||
Name_4 : constant String := "Coords";
|
||||
Name_5 : constant String := "Shine";
|
||||
|
||||
Attribute_1_Name : aliased C.char_array := C.to_C (Name_1);
|
||||
Attribute_2_Name : aliased C.char_array := C.to_C (Name_2);
|
||||
Attribute_3_Name : aliased C.char_array := C.to_C (Name_3);
|
||||
Attribute_4_Name : aliased C.char_array := C.to_C (Name_4);
|
||||
Attribute_5_Name : aliased C.char_array := C.to_C (Name_5);
|
||||
|
||||
Attribute_1_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_1_Name'Access);
|
||||
Attribute_2_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_2_Name'Access);
|
||||
Attribute_3_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_3_Name'Access);
|
||||
Attribute_4_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_4_Name'Access);
|
||||
Attribute_5_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_5_Name'Access);
|
||||
|
||||
white_Texture : openGL.Texture.Object;
|
||||
|
||||
|
||||
---------
|
||||
-- Forge
|
||||
--
|
||||
|
||||
type Geometry_view is access all Geometry.lit_colored_textured.item'Class;
|
||||
|
||||
function new_Geometry (texture_is_Alpha : in Boolean) return access Geometry.lit_colored_textured.item'Class
|
||||
is
|
||||
use type openGL.Program.lit.view;
|
||||
|
||||
|
||||
procedure define (the_Program : access Program;
|
||||
use_fragment_Shader : in String)
|
||||
is
|
||||
use openGL.Palette,
|
||||
Attribute.Forge,
|
||||
system.Storage_Elements;
|
||||
|
||||
Sample : Vertex;
|
||||
|
||||
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;
|
||||
|
||||
white_Image : constant openGL.Image := [1 .. 2 => [1 .. 2 => +White]];
|
||||
|
||||
begin
|
||||
white_Texture := openGL.Texture.Forge.to_Texture (white_Image);
|
||||
the_Program.Program := new openGL.Program.lit.item;
|
||||
|
||||
the_Program. vertex_Shader.define (Shader.Vertex, "assets/opengl/shader/lit_colored_textured.vert");
|
||||
the_Program.fragment_Shader.define (Shader.Fragment, use_fragment_Shader);
|
||||
|
||||
the_Program.Program.define (the_Program. vertex_Shader'Access,
|
||||
the_Program.fragment_Shader'Access);
|
||||
the_Program.Program.enable;
|
||||
|
||||
Attribute_1 := new_Attribute (Name => Name_1,
|
||||
gl_Location => the_Program.Program.attribute_Location (Name_1),
|
||||
Size => 3,
|
||||
data_Kind => attribute.GL_FLOAT,
|
||||
Stride => lit_colored_textured.Vertex'Size / 8,
|
||||
Offset => 0,
|
||||
Normalized => False);
|
||||
|
||||
Attribute_2 := new_Attribute (Name => Name_2,
|
||||
gl_Location => the_Program.Program.attribute_Location (Name_2),
|
||||
Size => 3,
|
||||
data_Kind => attribute.GL_FLOAT,
|
||||
Stride => lit_colored_textured.Vertex'Size / 8,
|
||||
Offset => Sample.Normal (1)'Address
|
||||
- Sample.Site (1)'Address,
|
||||
Normalized => False);
|
||||
|
||||
Attribute_3 := new_Attribute (Name => Name_3,
|
||||
gl_Location => the_Program.Program.attribute_Location (Name_3),
|
||||
Size => 4,
|
||||
data_Kind => attribute.GL_UNSIGNED_BYTE,
|
||||
Stride => lit_colored_textured.Vertex'Size / 8,
|
||||
Offset => Sample.Color.Primary.Red'Address
|
||||
- Sample.Site (1) 'Address,
|
||||
Normalized => True);
|
||||
|
||||
Attribute_4 := new_Attribute (Name => Name_4,
|
||||
gl_Location => the_Program.Program.attribute_Location (Name_4),
|
||||
Size => 2,
|
||||
data_Kind => attribute.GL_FLOAT,
|
||||
Stride => lit_colored_textured.Vertex'Size / 8,
|
||||
Offset => Sample.Coords.S'Address
|
||||
- Sample.Site (1)'Address,
|
||||
Normalized => False);
|
||||
|
||||
Attribute_5 := new_Attribute (Name => Name_5,
|
||||
gl_Location => the_Program.Program.attribute_Location (Name_5),
|
||||
Size => 1,
|
||||
data_Kind => attribute.GL_FLOAT,
|
||||
Stride => lit_colored_textured.Vertex'Size / 8,
|
||||
Offset => Sample.Shine 'Address
|
||||
- Sample.Site (1)'Address,
|
||||
Normalized => False);
|
||||
|
||||
the_Program.Program.add (Attribute_1);
|
||||
the_Program.Program.add (Attribute_2);
|
||||
the_Program.Program.add (Attribute_3);
|
||||
the_Program.Program.add (Attribute_4);
|
||||
the_Program.Program.add (Attribute_5);
|
||||
|
||||
glBindAttribLocation (Program => the_Program.Program.gl_Program,
|
||||
Index => the_Program.Program.Attribute (named => Name_1).gl_Location,
|
||||
Name => +Attribute_1_Name_ptr);
|
||||
Errors.log;
|
||||
|
||||
glBindAttribLocation (Program => the_Program.Program.gl_Program,
|
||||
Index => the_Program.Program.Attribute (named => Name_2).gl_Location,
|
||||
Name => +Attribute_2_Name_ptr);
|
||||
Errors.log;
|
||||
|
||||
glBindAttribLocation (Program => the_Program.Program.gl_Program,
|
||||
Index => the_Program.Program.Attribute (named => Name_3).gl_Location,
|
||||
Name => +Attribute_3_Name_ptr);
|
||||
Errors.log;
|
||||
|
||||
glBindAttribLocation (Program => the_Program.Program.gl_Program,
|
||||
Index => the_Program.Program.Attribute (named => Name_4).gl_Location,
|
||||
Name => +Attribute_4_Name_ptr);
|
||||
Errors.log;
|
||||
|
||||
glBindAttribLocation (Program => the_Program.Program.gl_Program,
|
||||
Index => the_Program.Program.Attribute (named => Name_5).gl_Location,
|
||||
Name => +Attribute_5_Name_ptr);
|
||||
Errors.log;
|
||||
end define;
|
||||
|
||||
Self : constant Geometry_view := new Geometry.lit_colored_textured.item;
|
||||
|
||||
begin
|
||||
Tasks.check;
|
||||
|
||||
if texture_is_Alpha -- Define the shaders and program, if required.
|
||||
then
|
||||
if the_Programs (alpha_Texture).Program = null
|
||||
then
|
||||
define (the_Programs (alpha_Texture)'Access,
|
||||
use_fragment_Shader => "assets/opengl/shader/lit_colored_text.frag");
|
||||
end if;
|
||||
else
|
||||
if the_Programs (rgba_Texture).Program = null
|
||||
then
|
||||
define (the_Programs (rgba_Texture)'Access,
|
||||
use_fragment_Shader => "assets/opengl/shader/lit_colored_textured.frag");
|
||||
end if;
|
||||
end if;
|
||||
|
||||
if texture_is_Alpha
|
||||
then Self.is_Transparent := True;
|
||||
Self.Program_is (the_Programs (alpha_Texture).Program.all'Access);
|
||||
else Self.Program_is (the_Programs ( rgba_Texture).Program.all'Access);
|
||||
end if;
|
||||
|
||||
return Self;
|
||||
end new_Geometry;
|
||||
|
||||
|
||||
----------
|
||||
-- Vertex
|
||||
--
|
||||
|
||||
function is_Transparent (Self : in Vertex_array) return Boolean
|
||||
is
|
||||
function get_Color (Index : in Index_t) return rgba_Color
|
||||
is (Self (Index).Color);
|
||||
|
||||
function my_Transparency is new get_Transparency (any_Index_t => Index_t,
|
||||
get_Color => get_Color);
|
||||
begin
|
||||
return my_Transparency (Count => Self'Length);
|
||||
end is_Transparent;
|
||||
|
||||
|
||||
--------------
|
||||
-- Attributes
|
||||
--
|
||||
|
||||
package openGL_Buffer_of_geometry_Vertices is new Buffer.general (base_Object => Buffer.array_Object,
|
||||
Index => Index_t,
|
||||
Element => Vertex,
|
||||
Element_Array => Vertex_array);
|
||||
|
||||
procedure Vertices_are (Self : in out Item; Now : in Vertex_array)
|
||||
is
|
||||
use openGL_Buffer_of_geometry_Vertices;
|
||||
use type Buffer.view;
|
||||
begin
|
||||
if Self.Vertices = null
|
||||
then
|
||||
self.Vertices := new openGL_Buffer_of_geometry_Vertices.Object' (Forge.to_Buffer (Now,
|
||||
usage => Buffer.static_Draw));
|
||||
else
|
||||
set (openGL_Buffer_of_geometry_Vertices.Object (Self.Vertices.all),
|
||||
to => Now);
|
||||
end if;
|
||||
|
||||
Self.is_Transparent := is_Transparent (Now);
|
||||
|
||||
-- Set the bounds.
|
||||
--
|
||||
declare
|
||||
function get_Site (Index : in Index_t) return Vector_3
|
||||
is (Now (Index).Site);
|
||||
|
||||
function bounding_Box is new get_Bounds (Index_t, get_Site);
|
||||
begin
|
||||
Self.Bounds_are (bounding_Box (Count => Now'Length));
|
||||
end;
|
||||
end Vertices_are;
|
||||
|
||||
|
||||
overriding
|
||||
procedure Indices_are (Self : in out Item; Now : in Indices;
|
||||
for_Facia : in Positive)
|
||||
is
|
||||
begin
|
||||
raise Error with "TODO";
|
||||
end Indices_are;
|
||||
|
||||
|
||||
overriding
|
||||
procedure enable_Texture (Self : in 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_Texture;
|
||||
|
||||
|
||||
end openGL.Geometry.lit_colored_textured;
|
||||
@@ -0,0 +1,47 @@
|
||||
package openGL.Geometry.lit_colored_textured
|
||||
--
|
||||
-- Supports per-vertex site color, texture and lighting.
|
||||
--
|
||||
is
|
||||
type Item is new openGL.Geometry.item with private;
|
||||
type View is access all Item'Class;
|
||||
|
||||
function new_Geometry (texture_is_Alpha : in Boolean) return access Geometry.lit_colored_textured.item'Class;
|
||||
|
||||
|
||||
----------
|
||||
-- Vertex
|
||||
--
|
||||
|
||||
type Vertex is
|
||||
record
|
||||
Site : Vector_3;
|
||||
Normal : Vector_3;
|
||||
Color : rgba_Color;
|
||||
Coords : Coordinate_2D;
|
||||
Shine : Real;
|
||||
end record;
|
||||
|
||||
type Vertex_array is array (Index_t range <>) of aliased Vertex;
|
||||
|
||||
|
||||
--------------
|
||||
-- Attributes
|
||||
--
|
||||
|
||||
procedure Vertices_are (Self : in out Item; Now : in Vertex_array);
|
||||
|
||||
overriding
|
||||
procedure Indices_are (Self : in out Item; Now : in Indices;
|
||||
for_Facia : in Positive);
|
||||
|
||||
|
||||
|
||||
private
|
||||
|
||||
type Item is new Geometry.item with null record;
|
||||
|
||||
overriding
|
||||
procedure enable_Texture (Self : in Item);
|
||||
|
||||
end openGL.Geometry.lit_colored_textured;
|
||||
@@ -0,0 +1,321 @@
|
||||
with
|
||||
openGL.Shader,
|
||||
openGL.Attribute,
|
||||
openGL.Buffer.general,
|
||||
openGL.Texture,
|
||||
openGL.Palette,
|
||||
openGL.Tasks,
|
||||
openGL.Errors,
|
||||
|
||||
GL.Binding,
|
||||
GL.lean,
|
||||
GL.Pointers,
|
||||
|
||||
Interfaces.C.Strings,
|
||||
System.storage_Elements;
|
||||
|
||||
|
||||
package body openGL.Geometry.lit_colored_textured_skinned
|
||||
is
|
||||
-- Globals
|
||||
--
|
||||
vertex_Shader : aliased Shader.item;
|
||||
fragment_Shader : aliased Shader.item;
|
||||
|
||||
the_Program : aliased openGL.Program.lit.colored_textured_skinned.item;
|
||||
is_Defined : Boolean := False;
|
||||
|
||||
Name_1 : constant String := "Site";
|
||||
Name_2 : constant String := "Normal";
|
||||
Name_3 : constant String := "Color";
|
||||
Name_4 : constant String := "Coords";
|
||||
Name_5 : constant String := "Shine";
|
||||
Name_6 : constant String := "bone_Ids";
|
||||
Name_7 : constant String := "bone_Weights";
|
||||
|
||||
use Interfaces;
|
||||
|
||||
Attribute_1_Name : aliased C.char_array := C.to_C (Name_1);
|
||||
Attribute_2_Name : aliased C.char_array := C.to_C (Name_2);
|
||||
Attribute_3_Name : aliased C.char_array := C.to_C (Name_3);
|
||||
Attribute_4_Name : aliased C.char_array := C.to_C (Name_4);
|
||||
Attribute_5_Name : aliased C.char_array := C.to_C (Name_5);
|
||||
Attribute_6_Name : aliased C.char_array := C.to_C (Name_6);
|
||||
Attribute_7_Name : aliased C.char_array := C.to_C (Name_7);
|
||||
|
||||
Attribute_1_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_1_Name'Access);
|
||||
Attribute_2_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_2_Name'Access);
|
||||
Attribute_3_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_3_Name'Access);
|
||||
Attribute_4_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_4_Name'Access);
|
||||
Attribute_5_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_5_Name'Access);
|
||||
Attribute_6_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_6_Name'Access);
|
||||
Attribute_7_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_7_Name'Access);
|
||||
|
||||
white_Texture : openGL.Texture.Object;
|
||||
|
||||
|
||||
----------
|
||||
-- Vertex
|
||||
--
|
||||
|
||||
function is_Transparent (Self : in Vertex_array) return Boolean -- TODO: Replace this with the generic (check that all similar functions use the generic).
|
||||
is
|
||||
use type color_Value;
|
||||
begin
|
||||
for Each in Self'Range
|
||||
loop
|
||||
if Self (Each).Color.Alpha /= opaque_Value
|
||||
then
|
||||
return True;
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
return False;
|
||||
end is_Transparent;
|
||||
|
||||
|
||||
---------
|
||||
-- Forge
|
||||
--
|
||||
|
||||
type Geometry_view is access all Geometry.lit_colored_textured_skinned.item'Class;
|
||||
|
||||
|
||||
function new_Geometry return access Geometry.lit_colored_textured_skinned.item'Class
|
||||
is
|
||||
Self : constant Geometry_view := new Geometry.lit_colored_textured_skinned.item;
|
||||
begin
|
||||
Self.Program_is (the_Program'Access);
|
||||
return Self;
|
||||
end new_Geometry;
|
||||
|
||||
|
||||
|
||||
procedure define_Program
|
||||
is
|
||||
use Palette,
|
||||
Attribute.Forge,
|
||||
GL.lean,
|
||||
GL.Pointers,
|
||||
System.storage_Elements;
|
||||
|
||||
Sample : Vertex;
|
||||
|
||||
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;
|
||||
Attribute_7 : openGL.Attribute.view;
|
||||
|
||||
white_Image : constant openGL.Image := [1 .. 2 => [1 .. 2 => +White]];
|
||||
|
||||
begin
|
||||
Tasks.check;
|
||||
|
||||
if is_Defined
|
||||
then
|
||||
raise Error with "The lit_colored_textured_skinned program has already been defined.";
|
||||
end if;
|
||||
|
||||
is_Defined := True;
|
||||
|
||||
-- Define the shaders and program.
|
||||
--
|
||||
white_Texture := openGL.Texture.Forge.to_Texture (white_Image);
|
||||
|
||||
vertex_Shader .define (Shader.Vertex, "assets/opengl/shader/lit_colored_textured_skinned.vert");
|
||||
fragment_Shader.define (Shader.Fragment, "assets/opengl/shader/lit_colored_textured_skinned.frag");
|
||||
|
||||
the_Program.define ( vertex_Shader'Access,
|
||||
fragment_Shader'Access);
|
||||
the_Program.enable;
|
||||
|
||||
Attribute_1 := new_Attribute (Name => Name_1,
|
||||
gl_Location => the_Program.attribute_Location (Name_1),
|
||||
Size => 3,
|
||||
data_Kind => Attribute.GL_FLOAT,
|
||||
Stride => lit_colored_textured_skinned.Vertex'Size / 8,
|
||||
Offset => 0,
|
||||
Normalized => False);
|
||||
|
||||
Attribute_2 := new_Attribute (Name => Name_2,
|
||||
gl_Location => the_Program.attribute_Location (Name_2),
|
||||
Size => 3,
|
||||
data_Kind => Attribute.GL_FLOAT,
|
||||
Stride => lit_colored_textured_skinned.Vertex'Size / 8,
|
||||
Offset => Sample.Normal (1)'Address
|
||||
- Sample.Site (1)'Address,
|
||||
Normalized => False);
|
||||
|
||||
Attribute_3 := new_Attribute (Name => Name_3,
|
||||
gl_Location => the_Program.attribute_Location (Name_3),
|
||||
Size => 4,
|
||||
data_Kind => Attribute.GL_UNSIGNED_BYTE,
|
||||
Stride => lit_colored_textured_skinned.Vertex'Size / 8,
|
||||
Offset => Sample.Color.Primary.Red'Address
|
||||
- Sample.Site (1) 'Address,
|
||||
Normalized => True);
|
||||
|
||||
Attribute_4 := new_Attribute (Name => Name_4,
|
||||
gl_Location => the_Program.attribute_Location (Name_4),
|
||||
Size => 2,
|
||||
data_Kind => Attribute.GL_FLOAT,
|
||||
Stride => lit_colored_textured_skinned.Vertex'Size / 8,
|
||||
Offset => Sample.Coords.S'Address
|
||||
- Sample.Site (1)'Address,
|
||||
Normalized => False);
|
||||
|
||||
Attribute_5 := new_Attribute (Name => Name_5,
|
||||
gl_Location => the_Program.attribute_Location (Name_5),
|
||||
Size => 4,
|
||||
data_Kind => Attribute.GL_FLOAT,
|
||||
Stride => lit_colored_textured_skinned.Vertex'Size / 8,
|
||||
Offset => Sample.bone_Ids (1)'Address
|
||||
- Sample.Site (1)'Address,
|
||||
Normalized => False);
|
||||
|
||||
Attribute_6 := new_Attribute (Name => Name_6,
|
||||
gl_Location => the_Program.attribute_Location (Name_6),
|
||||
Size => 4,
|
||||
data_Kind => Attribute.GL_FLOAT,
|
||||
Stride => lit_colored_textured_skinned.Vertex'Size / 8,
|
||||
Offset => Sample.bone_Ids (1)'Address
|
||||
- Sample.Site (1)'Address,
|
||||
Normalized => False);
|
||||
|
||||
Attribute_7 := new_Attribute (Name => Name_7,
|
||||
gl_Location => the_Program.attribute_Location (Name_7),
|
||||
Size => 4,
|
||||
data_Kind => Attribute.GL_FLOAT,
|
||||
Stride => lit_colored_textured_skinned.Vertex'Size / 8,
|
||||
Offset => Sample.bone_Weights (1)'Address
|
||||
- Sample.Site (1)'Address,
|
||||
Normalized => False);
|
||||
the_Program.add (Attribute_1);
|
||||
the_Program.add (Attribute_2);
|
||||
the_Program.add (Attribute_3);
|
||||
the_Program.add (Attribute_4);
|
||||
the_Program.add (Attribute_5);
|
||||
the_Program.add (Attribute_6);
|
||||
the_Program.add (Attribute_7);
|
||||
|
||||
glBindAttribLocation (program => the_Program.gl_Program,
|
||||
index => the_Program.Attribute (named => Name_1).gl_Location,
|
||||
name => +Attribute_1_Name_ptr);
|
||||
Errors.log;
|
||||
|
||||
glBindAttribLocation (program => the_Program.gl_Program,
|
||||
index => the_Program.Attribute (named => Name_2).gl_Location,
|
||||
name => +Attribute_2_Name_ptr);
|
||||
Errors.log;
|
||||
|
||||
glBindAttribLocation (program => the_Program.gl_Program,
|
||||
index => the_Program.Attribute (named => Name_3).gl_Location,
|
||||
name => +Attribute_3_Name_ptr);
|
||||
Errors.log;
|
||||
|
||||
glBindAttribLocation (program => the_Program.gl_Program,
|
||||
index => the_Program.Attribute (named => Name_4).gl_Location,
|
||||
name => +Attribute_4_Name_ptr);
|
||||
Errors.log;
|
||||
|
||||
glBindAttribLocation (program => the_Program.gl_Program,
|
||||
index => the_Program.Attribute (named => Name_5).gl_Location,
|
||||
name => +Attribute_5_Name_ptr);
|
||||
Errors.log;
|
||||
|
||||
glBindAttribLocation (program => the_Program.gl_Program,
|
||||
index => the_Program.Attribute (named => Name_6).gl_Location,
|
||||
name => +Attribute_6_Name_ptr);
|
||||
Errors.log;
|
||||
|
||||
glBindAttribLocation (program => the_Program.gl_Program,
|
||||
index => the_Program.Attribute (named => Name_7).gl_Location,
|
||||
name => +Attribute_7_Name_ptr);
|
||||
Errors.log;
|
||||
end define_Program;
|
||||
|
||||
|
||||
--------------
|
||||
-- Attributes
|
||||
--
|
||||
|
||||
function Program return openGL.Program.lit.colored_textured_skinned.view
|
||||
is
|
||||
begin
|
||||
return the_Program'Access;
|
||||
end Program;
|
||||
|
||||
|
||||
|
||||
overriding
|
||||
procedure Indices_are (Self : in out Item; Now : in Indices;
|
||||
for_Facia : in Positive)
|
||||
is
|
||||
begin
|
||||
raise Error with "openGL.Geometry.lit_coloured_textured_skinned - 'Indices_are' ~ TODO";
|
||||
end Indices_are;
|
||||
|
||||
|
||||
|
||||
package openGL_Buffer_of_geometry_Vertices is new Buffer.general (base_Object => Buffer.array_Object,
|
||||
Index => long_Index_t,
|
||||
Element => Vertex,
|
||||
Element_Array => Vertex_array);
|
||||
|
||||
procedure Vertices_are (Self : in out Item; Now : in Vertex_array)
|
||||
is
|
||||
use openGL_Buffer_of_geometry_Vertices.Forge;
|
||||
begin
|
||||
Self.Vertices := new openGL_Buffer_of_geometry_Vertices.object' (to_Buffer (Now,
|
||||
usage => Buffer.static_Draw));
|
||||
Self.is_Transparent := Self.is_Transparent
|
||||
or is_Transparent (Now);
|
||||
-- Set the bounds.
|
||||
--
|
||||
declare
|
||||
function get_Site (Index : in long_Index_t) return Vector_3
|
||||
is (Now (Index).Site);
|
||||
|
||||
function bounding_Box is new get_Bounds (long_Index_t, get_Site);
|
||||
begin
|
||||
Self.Bounds_are (bounding_Box (Count => Now'Length));
|
||||
end;
|
||||
end Vertices_are;
|
||||
|
||||
|
||||
|
||||
overriding
|
||||
procedure enable_Texture (Self : in 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_Texture;
|
||||
|
||||
|
||||
end openGL.Geometry.lit_colored_textured_skinned;
|
||||
@@ -0,0 +1,58 @@
|
||||
with
|
||||
openGL.Program.lit.colored_textured_skinned;
|
||||
|
||||
|
||||
package openGL.Geometry.lit_colored_textured_skinned
|
||||
--
|
||||
-- Supports per-vertex site color, texture, lighting and skinning.
|
||||
--
|
||||
is
|
||||
type Item is new openGL.Geometry.item with private;
|
||||
|
||||
function new_Geometry return access Geometry.lit_colored_textured_skinned.item'Class;
|
||||
|
||||
procedure define_Program;
|
||||
|
||||
|
||||
----------
|
||||
-- Vertex
|
||||
--
|
||||
|
||||
type Vertex is
|
||||
record
|
||||
Site : Vector_3;
|
||||
Normal : Vector_3;
|
||||
Color : rgba_Color;
|
||||
Coords : Coordinate_2D;
|
||||
Shine : Real;
|
||||
|
||||
bone_Ids : Vector_4;
|
||||
bone_Weights : Vector_4;
|
||||
end record;
|
||||
pragma Convention (C, Vertex);
|
||||
|
||||
type Vertex_array is array (long_Index_t range <>) of aliased Vertex;
|
||||
|
||||
|
||||
--------------
|
||||
-- Attributes
|
||||
--
|
||||
|
||||
procedure Vertices_are (Self : in out Item; Now : in Vertex_array);
|
||||
|
||||
overriding
|
||||
procedure Indices_are (Self : in out Item; Now : in Indices;
|
||||
for_Facia : in Positive);
|
||||
|
||||
function Program return openGL.Program.lit.colored_textured_skinned.view;
|
||||
|
||||
|
||||
|
||||
private
|
||||
|
||||
type Item is new Geometry.item with null record;
|
||||
|
||||
overriding
|
||||
procedure enable_Texture (Self : in Item);
|
||||
|
||||
end openGL.Geometry.lit_colored_textured_skinned;
|
||||
@@ -0,0 +1,270 @@
|
||||
with
|
||||
openGL.Buffer.general,
|
||||
openGL.Shader,
|
||||
openGL.Program.lit,
|
||||
openGL.Attribute,
|
||||
openGL.Texture,
|
||||
openGL.Palette,
|
||||
openGL.Tasks,
|
||||
openGL.Errors,
|
||||
|
||||
GL.Binding,
|
||||
GL.lean,
|
||||
GL.Pointers,
|
||||
|
||||
Interfaces.C.Strings,
|
||||
System.storage_Elements;
|
||||
|
||||
|
||||
package body openGL.Geometry.lit_textured
|
||||
is
|
||||
use GL.lean,
|
||||
GL.Pointers,
|
||||
Interfaces;
|
||||
|
||||
-----------
|
||||
-- Globals
|
||||
--
|
||||
|
||||
vertex_Shader : aliased Shader.item;
|
||||
fragment_Shader : aliased Shader.item;
|
||||
|
||||
the_Program : openGL.Program.lit.view;
|
||||
white_Texture : openGL.Texture.Object;
|
||||
|
||||
Name_1 : constant String := "Site";
|
||||
Name_2 : constant String := "Normal";
|
||||
Name_3 : constant String := "Coords";
|
||||
Name_4 : constant String := "Shine";
|
||||
|
||||
Attribute_1_Name : aliased C.char_array := C.to_C (Name_1);
|
||||
Attribute_2_Name : aliased C.char_array := C.to_C (Name_2);
|
||||
Attribute_3_Name : aliased C.char_array := C.to_C (Name_3);
|
||||
Attribute_4_Name : aliased C.char_array := C.to_C (Name_4);
|
||||
|
||||
Attribute_1_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_1_Name'Access);
|
||||
Attribute_2_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_2_Name'Access);
|
||||
Attribute_3_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_3_Name'Access);
|
||||
Attribute_4_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_4_Name'Access);
|
||||
|
||||
|
||||
---------
|
||||
-- Forge
|
||||
--
|
||||
|
||||
function new_Geometry return View
|
||||
is
|
||||
use System,
|
||||
System.storage_Elements;
|
||||
use type openGL.Program.lit.view;
|
||||
|
||||
Self : constant View := new Geometry.lit_textured.item;
|
||||
|
||||
begin
|
||||
Tasks.check;
|
||||
|
||||
if the_Program = null
|
||||
then -- Define the shaders and program.
|
||||
declare
|
||||
use Palette,
|
||||
Attribute.Forge;
|
||||
|
||||
Sample : Vertex;
|
||||
|
||||
Attribute_1 : Attribute.view;
|
||||
Attribute_2 : Attribute.view;
|
||||
Attribute_3 : Attribute.view;
|
||||
Attribute_4 : Attribute.view;
|
||||
|
||||
white_Image : constant Image := [1 .. 2 => [1 .. 2 => +White]];
|
||||
|
||||
begin
|
||||
white_Texture := openGL.Texture.Forge.to_Texture (white_Image);
|
||||
|
||||
vertex_Shader .define (Shader.Vertex, "assets/opengl/shader/lit_textured.vert");
|
||||
fragment_Shader.define (Shader.Fragment, "assets/opengl/shader/lit_textured.frag");
|
||||
|
||||
the_Program := new openGL.Program.lit.item;
|
||||
the_Program.define ( vertex_Shader'Access,
|
||||
fragment_Shader'Access);
|
||||
the_Program.enable;
|
||||
|
||||
Attribute_1 := new_Attribute (Name => Name_1,
|
||||
gl_Location => the_Program.attribute_Location (Name_1),
|
||||
Size => 3,
|
||||
data_Kind => attribute.GL_FLOAT,
|
||||
Stride => lit_textured.Vertex'Size / 8,
|
||||
Offset => 0,
|
||||
Normalized => False);
|
||||
|
||||
Attribute_2 := new_Attribute (Name => Name_2,
|
||||
gl_Location => the_Program.attribute_Location (Name_2),
|
||||
Size => 3,
|
||||
data_Kind => attribute.GL_FLOAT,
|
||||
Stride => lit_textured.Vertex'Size / 8,
|
||||
Offset => Sample.Normal (1)'Address
|
||||
- Sample.Site (1)'Address,
|
||||
Normalized => False);
|
||||
|
||||
Attribute_3 := new_Attribute (Name => Name_3,
|
||||
gl_Location => the_Program.attribute_Location (Name_3),
|
||||
Size => 2,
|
||||
data_Kind => attribute.GL_FLOAT,
|
||||
Stride => lit_textured.Vertex'Size / 8,
|
||||
Offset => Sample.Coords.S'Address
|
||||
- Sample.Site (1)'Address,
|
||||
Normalized => False);
|
||||
|
||||
Attribute_4 := new_Attribute (Name => Name_4,
|
||||
gl_Location => the_Program.attribute_Location (Name_4),
|
||||
Size => 1,
|
||||
data_Kind => attribute.GL_FLOAT,
|
||||
Stride => lit_textured.Vertex'Size / 8,
|
||||
Offset => Sample.Shine 'Address
|
||||
- Sample.Site (1)'Address,
|
||||
Normalized => False);
|
||||
|
||||
the_Program.add (Attribute_1);
|
||||
the_Program.add (Attribute_2);
|
||||
the_Program.add (Attribute_3);
|
||||
the_Program.add (Attribute_4);
|
||||
|
||||
glBindAttribLocation (program => the_Program.gl_Program,
|
||||
index => the_Program.Attribute (named => Name_1).gl_Location,
|
||||
name => +Attribute_1_Name_ptr);
|
||||
Errors.log;
|
||||
|
||||
glBindAttribLocation (program => the_Program.gl_Program,
|
||||
index => the_Program.Attribute (named => Name_2).gl_Location,
|
||||
name => +Attribute_2_Name_ptr);
|
||||
Errors.log;
|
||||
|
||||
glBindAttribLocation (program => the_Program.gl_Program,
|
||||
index => the_Program.Attribute (named => Name_3).gl_Location,
|
||||
name => +Attribute_3_Name_ptr);
|
||||
Errors.log;
|
||||
|
||||
glBindAttribLocation (program => the_Program.gl_Program,
|
||||
index => the_Program.Attribute (named => Name_4).gl_Location,
|
||||
name => +Attribute_4_Name_ptr);
|
||||
Errors.log;
|
||||
end;
|
||||
end if;
|
||||
|
||||
Self.Program_is (the_Program.all'Access);
|
||||
return Self;
|
||||
end new_Geometry;
|
||||
|
||||
|
||||
----------
|
||||
-- Vertex
|
||||
--
|
||||
|
||||
function is_Transparent (Self : in Vertex_array) return Boolean -- TODO: Do these properly.
|
||||
is
|
||||
pragma Unreferenced (Self);
|
||||
begin
|
||||
return False;
|
||||
end is_Transparent;
|
||||
|
||||
|
||||
|
||||
function is_Transparent (Self : in Vertex_large_array) return Boolean
|
||||
is
|
||||
pragma Unreferenced (Self);
|
||||
begin
|
||||
return False;
|
||||
end is_Transparent;
|
||||
|
||||
|
||||
--------------
|
||||
-- Attributes
|
||||
--
|
||||
|
||||
package openGL_Buffer_of_geometry_Vertices is new Buffer.general (base_Object => Buffer.array_Object,
|
||||
Index => Index_t,
|
||||
Element => Vertex,
|
||||
Element_Array => Vertex_array);
|
||||
|
||||
package openGL_large_Buffer_of_geometry_Vertices is new Buffer.general (base_Object => Buffer.array_Object,
|
||||
Index => long_Index_t,
|
||||
Element => Vertex,
|
||||
Element_Array => Vertex_large_array);
|
||||
|
||||
|
||||
procedure Vertices_are (Self : in out Item; Now : in Vertex_array)
|
||||
is
|
||||
use openGL_Buffer_of_geometry_Vertices.Forge;
|
||||
begin
|
||||
Self.Vertices := new openGL_Buffer_of_geometry_Vertices.Object' (to_Buffer (Now,
|
||||
usage => Buffer.static_Draw));
|
||||
Self.is_Transparent := is_Transparent (Now);
|
||||
|
||||
-- Set the bounds.
|
||||
--
|
||||
declare
|
||||
function get_Site (Index : in Index_t) return Vector_3
|
||||
is (Now (Index).Site);
|
||||
|
||||
function bounding_Box is new get_Bounds (Index_t, get_Site);
|
||||
begin
|
||||
Self.Bounds_are (bounding_Box (Count => Now'Length));
|
||||
end;
|
||||
end Vertices_are;
|
||||
|
||||
|
||||
|
||||
procedure Vertices_are (Self : in out Item; Now : in Vertex_large_array)
|
||||
is
|
||||
use openGL_large_Buffer_of_geometry_Vertices.Forge;
|
||||
begin
|
||||
Self.Vertices := new openGL_large_Buffer_of_geometry_Vertices.Object' (to_Buffer (Now,
|
||||
usage => Buffer.static_Draw));
|
||||
Self.is_Transparent := is_Transparent (Now);
|
||||
|
||||
-- Set the bounds.
|
||||
--
|
||||
declare
|
||||
function get_Site (Index : in long_Index_t) return Vector_3
|
||||
is (Now (Index).Site);
|
||||
|
||||
function bounding_Box is new get_Bounds (long_Index_t, get_Site);
|
||||
begin
|
||||
Self.Bounds_are (bounding_Box (Count => Now'Length));
|
||||
end;
|
||||
end Vertices_are;
|
||||
|
||||
|
||||
|
||||
overriding
|
||||
procedure Indices_are (Self : in out Item; Now : in Indices;
|
||||
for_Facia : in Positive)
|
||||
is
|
||||
begin
|
||||
raise Error with "TODO";
|
||||
end Indices_are;
|
||||
|
||||
|
||||
overriding
|
||||
procedure enable_Texture (Self : in Item)
|
||||
is
|
||||
use GL,
|
||||
GL.Binding,
|
||||
openGL.Texture;
|
||||
|
||||
check_is_OK : constant Boolean := openGL.Tasks.Check; pragma Unreferenced (check_is_OK);
|
||||
|
||||
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_Texture;
|
||||
|
||||
|
||||
end openGL.Geometry.lit_textured;
|
||||
@@ -0,0 +1,48 @@
|
||||
package openGL.Geometry.lit_textured
|
||||
--
|
||||
-- Supports per-vertex site texture and lighting.
|
||||
--
|
||||
is
|
||||
type Item is new openGL.Geometry.item with private;
|
||||
type View is access all Item'Class;
|
||||
|
||||
|
||||
function new_Geometry return View;
|
||||
|
||||
|
||||
----------
|
||||
-- Vertex
|
||||
--
|
||||
|
||||
type Vertex is
|
||||
record
|
||||
Site : Vector_3;
|
||||
Normal : Vector_3;
|
||||
Coords : Coordinate_2D;
|
||||
Shine : Real;
|
||||
end record;
|
||||
|
||||
type Vertex_array is array ( Index_t range <>) of aliased Vertex;
|
||||
type Vertex_large_array is array (long_Index_t range <>) of aliased Vertex;
|
||||
|
||||
|
||||
--------------
|
||||
-- Attributes
|
||||
--
|
||||
|
||||
procedure Vertices_are (Self : in out Item; Now : in Vertex_array);
|
||||
procedure Vertices_are (Self : in out Item; Now : in Vertex_large_array);
|
||||
|
||||
overriding
|
||||
procedure Indices_are (Self : in out Item; Now : in Indices;
|
||||
for_Facia : in Positive);
|
||||
|
||||
|
||||
private
|
||||
|
||||
type Item is new Geometry.item with null record;
|
||||
|
||||
overriding
|
||||
procedure enable_Texture (Self : in Item);
|
||||
|
||||
end openGL.Geometry.lit_textured;
|
||||
@@ -0,0 +1,295 @@
|
||||
with
|
||||
openGL.Shader,
|
||||
openGL.Attribute,
|
||||
openGL.Buffer.general,
|
||||
openGL.Texture,
|
||||
openGL.Palette,
|
||||
openGL.Tasks,
|
||||
openGL.Errors,
|
||||
|
||||
GL.Binding,
|
||||
GL.lean,
|
||||
GL.Pointers,
|
||||
|
||||
Interfaces.C.Strings,
|
||||
System.storage_Elements;
|
||||
|
||||
|
||||
package body openGL.Geometry.lit_textured_skinned
|
||||
is
|
||||
-----------
|
||||
-- Globals
|
||||
--
|
||||
vertex_Shader : aliased Shader.item;
|
||||
fragment_Shader : aliased Shader.item;
|
||||
|
||||
the_Program : aliased openGL.Program.lit.textured_skinned.item;
|
||||
is_Defined : Boolean := False;
|
||||
|
||||
Name_1 : constant String := "Site";
|
||||
Name_2 : constant String := "Normal";
|
||||
Name_3 : constant String := "Coords";
|
||||
Name_4 : constant String := "Shine";
|
||||
Name_5 : constant String := "bone_Ids";
|
||||
Name_6 : constant String := "bone_Weights";
|
||||
|
||||
use Interfaces;
|
||||
|
||||
Attribute_1_Name : aliased C.char_array := C.to_C (Name_1);
|
||||
Attribute_2_Name : aliased C.char_array := C.to_C (Name_2);
|
||||
Attribute_3_Name : aliased C.char_array := C.to_C (Name_3);
|
||||
Attribute_4_Name : aliased C.char_array := C.to_C (Name_4);
|
||||
Attribute_5_Name : aliased C.char_array := C.to_C (Name_5);
|
||||
Attribute_6_Name : aliased C.char_array := C.to_C (Name_6);
|
||||
|
||||
Attribute_1_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_1_Name'Access);
|
||||
Attribute_2_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_2_Name'Access);
|
||||
Attribute_3_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_3_Name'Access);
|
||||
Attribute_4_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_4_Name'Access);
|
||||
Attribute_5_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_5_Name'Access);
|
||||
Attribute_6_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_6_Name'Access);
|
||||
|
||||
white_Texture : openGL.Texture.Object;
|
||||
|
||||
|
||||
----------
|
||||
-- Vertex
|
||||
--
|
||||
|
||||
function is_Transparent (Self : in Vertex_array) return Boolean -- TODO: Replace this with the generic (check that all similar functions use the generic).
|
||||
is
|
||||
pragma Unreferenced (Self);
|
||||
begin
|
||||
return False;
|
||||
end is_Transparent;
|
||||
|
||||
|
||||
---------
|
||||
-- Forge
|
||||
--
|
||||
|
||||
type Geometry_view is access all Geometry.lit_textured_skinned.item'Class;
|
||||
|
||||
|
||||
function new_Geometry return access Geometry.lit_textured_skinned.item'Class
|
||||
is
|
||||
Self : constant Geometry_view := new Geometry.lit_textured_skinned.item;
|
||||
begin
|
||||
Self.Program_is (the_Program'Access);
|
||||
return Self;
|
||||
end new_Geometry;
|
||||
|
||||
|
||||
|
||||
procedure define_Program
|
||||
is
|
||||
use Palette,
|
||||
Attribute.Forge,
|
||||
GL.lean,
|
||||
GL.Pointers,
|
||||
System.storage_Elements;
|
||||
|
||||
Sample : Vertex;
|
||||
|
||||
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
|
||||
Tasks.check;
|
||||
|
||||
if is_Defined
|
||||
then
|
||||
raise Error with "The 'lit_textured_skinned' program has already been defined.";
|
||||
end if;
|
||||
|
||||
is_Defined := True;
|
||||
|
||||
-- Define the shaders and program.
|
||||
--
|
||||
white_Texture := openGL.Texture.Forge.to_Texture (white_Image);
|
||||
|
||||
vertex_Shader .define (Shader.Vertex, "assets/opengl/shader/lit_textured_skinned.vert");
|
||||
fragment_Shader.define (Shader.Fragment, "assets/opengl/shader/lit_textured_skinned.frag");
|
||||
|
||||
the_Program.define ( vertex_Shader'Access,
|
||||
fragment_Shader'Access);
|
||||
the_Program.enable;
|
||||
|
||||
Attribute_1 := new_Attribute (Name => Name_1,
|
||||
gl_Location => the_Program.attribute_Location (Name_1),
|
||||
Size => 3,
|
||||
data_Kind => Attribute.GL_FLOAT,
|
||||
Stride => lit_textured_skinned.Vertex'Size / 8,
|
||||
Offset => 0,
|
||||
Normalized => False);
|
||||
|
||||
Attribute_2 := new_Attribute (Name => Name_2,
|
||||
gl_Location => the_Program.attribute_Location (Name_2),
|
||||
Size => 3,
|
||||
data_Kind => Attribute.GL_FLOAT,
|
||||
Stride => lit_textured_skinned.Vertex'Size / 8,
|
||||
Offset => Sample.Normal (1)'Address
|
||||
- Sample.Site (1)'Address,
|
||||
Normalized => False);
|
||||
|
||||
Attribute_3 := new_Attribute (Name => Name_3,
|
||||
gl_Location => the_Program.attribute_Location (Name_3),
|
||||
Size => 2,
|
||||
data_Kind => Attribute.GL_FLOAT,
|
||||
Stride => lit_textured_skinned.Vertex'Size / 8,
|
||||
Offset => Sample.Coords.S'Address
|
||||
- Sample.Site (1)'Address,
|
||||
Normalized => False);
|
||||
|
||||
Attribute_4 := new_Attribute (Name => Name_4,
|
||||
gl_Location => the_Program.attribute_Location (Name_4),
|
||||
Size => 1,
|
||||
data_Kind => attribute.GL_FLOAT,
|
||||
Stride => lit_textured_skinned.Vertex'Size / 8,
|
||||
Offset => Sample.Shine 'Address
|
||||
- Sample.Site (1)'Address,
|
||||
Normalized => False);
|
||||
|
||||
Attribute_5 := new_Attribute (Name => Name_5,
|
||||
gl_Location => the_Program.attribute_Location (Name_5),
|
||||
Size => 4,
|
||||
data_Kind => Attribute.GL_FLOAT,
|
||||
Stride => lit_textured_skinned.Vertex'Size / 8,
|
||||
Offset => Sample.bone_Ids (1)'Address
|
||||
- Sample.Site (1)'Address,
|
||||
Normalized => False);
|
||||
|
||||
Attribute_6 := new_Attribute (Name => Name_6,
|
||||
gl_Location => the_Program.attribute_Location (Name_6),
|
||||
Size => 4,
|
||||
data_Kind => Attribute.GL_FLOAT,
|
||||
Stride => lit_textured_skinned.Vertex'Size / 8,
|
||||
Offset => Sample.bone_Weights (1)'Address
|
||||
- Sample.Site (1)'Address,
|
||||
Normalized => False);
|
||||
the_Program.add (Attribute_1);
|
||||
the_Program.add (Attribute_2);
|
||||
the_Program.add (Attribute_3);
|
||||
the_Program.add (Attribute_4);
|
||||
the_Program.add (Attribute_5);
|
||||
the_Program.add (Attribute_6);
|
||||
|
||||
glBindAttribLocation (program => the_Program.gl_Program,
|
||||
index => the_Program.Attribute (named => Name_1).gl_Location,
|
||||
name => +Attribute_1_Name_ptr);
|
||||
Errors.log;
|
||||
|
||||
glBindAttribLocation (program => the_Program.gl_Program,
|
||||
index => the_Program.Attribute (named => Name_2).gl_Location,
|
||||
name => +Attribute_2_Name_ptr);
|
||||
Errors.log;
|
||||
|
||||
glBindAttribLocation (program => the_Program.gl_Program,
|
||||
index => the_Program.Attribute (named => Name_3).gl_Location,
|
||||
name => +Attribute_3_Name_ptr);
|
||||
Errors.log;
|
||||
|
||||
glBindAttribLocation (program => the_Program.gl_Program,
|
||||
index => the_Program.Attribute (named => Name_4).gl_Location,
|
||||
name => +Attribute_4_Name_ptr);
|
||||
Errors.log;
|
||||
|
||||
glBindAttribLocation (program => the_Program.gl_Program,
|
||||
index => the_Program.Attribute (named => Name_5).gl_Location,
|
||||
name => +Attribute_5_Name_ptr);
|
||||
Errors.log;
|
||||
|
||||
glBindAttribLocation (program => the_Program.gl_Program,
|
||||
index => the_Program.Attribute (named => Name_6).gl_Location,
|
||||
name => +Attribute_6_Name_ptr);
|
||||
Errors.log;
|
||||
end define_Program;
|
||||
|
||||
|
||||
--------------
|
||||
-- Attributes
|
||||
--
|
||||
|
||||
function Program return openGL.Program.lit.textured_skinned.view
|
||||
is
|
||||
begin
|
||||
return the_Program'Access;
|
||||
end Program;
|
||||
|
||||
|
||||
|
||||
overriding
|
||||
procedure Indices_are (Self : in out Item; Now : in Indices;
|
||||
for_Facia : in Positive)
|
||||
is
|
||||
begin
|
||||
raise Error with "openGL.Geometry.lit_textured_skinned - 'Indices_are' ~ TODO";
|
||||
end Indices_are;
|
||||
|
||||
|
||||
|
||||
package openGL_Buffer_of_geometry_Vertices is new Buffer.general (base_Object => Buffer.array_Object,
|
||||
Index => long_Index_t,
|
||||
Element => Vertex,
|
||||
Element_Array => Vertex_array);
|
||||
|
||||
procedure Vertices_are (Self : in out Item; Now : in Vertex_array)
|
||||
is
|
||||
use openGL_Buffer_of_geometry_Vertices.Forge;
|
||||
begin
|
||||
Self.Vertices := new openGL_Buffer_of_geometry_Vertices.object' (to_Buffer (Now,
|
||||
usage => Buffer.static_Draw));
|
||||
Self.is_Transparent := Self.is_Transparent
|
||||
or is_Transparent (Now);
|
||||
-- Set the bounds.
|
||||
--
|
||||
declare
|
||||
function get_Site (Index : in long_Index_t) return Vector_3
|
||||
is (Now (Index).Site);
|
||||
|
||||
function bounding_Box is new get_Bounds (long_Index_t, get_Site);
|
||||
begin
|
||||
Self.Bounds_are (bounding_Box (Count => Now'Length));
|
||||
end;
|
||||
end Vertices_are;
|
||||
|
||||
|
||||
|
||||
overriding
|
||||
procedure enable_Texture (Self : in 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_Texture;
|
||||
|
||||
|
||||
end openGL.Geometry.lit_textured_skinned;
|
||||
@@ -0,0 +1,57 @@
|
||||
with
|
||||
openGL.Program.lit.textured_skinned;
|
||||
|
||||
|
||||
package openGL.Geometry.lit_textured_skinned
|
||||
--
|
||||
-- Supports per-vertex site, texture, lighting and skinning.
|
||||
--
|
||||
is
|
||||
type Item is new openGL.Geometry.item with private;
|
||||
|
||||
function new_Geometry return access Geometry.lit_textured_skinned.item'Class;
|
||||
|
||||
procedure define_Program;
|
||||
|
||||
|
||||
----------
|
||||
-- Vertex
|
||||
--
|
||||
|
||||
type Vertex is
|
||||
record
|
||||
Site : Vector_3;
|
||||
Normal : Vector_3;
|
||||
Coords : Coordinate_2D;
|
||||
Shine : Real;
|
||||
|
||||
bone_Ids : Vector_4;
|
||||
bone_Weights : Vector_4;
|
||||
end record;
|
||||
pragma Convention (C, Vertex);
|
||||
|
||||
type Vertex_array is array (long_Index_t range <>) of aliased Vertex;
|
||||
|
||||
|
||||
--------------
|
||||
-- Attributes
|
||||
--
|
||||
|
||||
procedure Vertices_are (Self : in out Item; Now : in Vertex_array);
|
||||
|
||||
overriding
|
||||
procedure Indices_are (Self : in out Item; Now : in Indices;
|
||||
for_Facia : in Positive);
|
||||
|
||||
function Program return openGL.Program.lit.textured_skinned.view;
|
||||
|
||||
|
||||
|
||||
private
|
||||
|
||||
type Item is new Geometry.item with null record;
|
||||
|
||||
overriding
|
||||
procedure enable_Texture (Self : in Item);
|
||||
|
||||
end openGL.Geometry.lit_textured_skinned;
|
||||
185
3-mid/opengl/source/lean/geometry/opengl-geometry-textured.adb
Normal file
185
3-mid/opengl/source/lean/geometry/opengl-geometry-textured.adb
Normal file
@@ -0,0 +1,185 @@
|
||||
with
|
||||
openGL.Buffer.general,
|
||||
openGL.Shader,
|
||||
openGL.Program,
|
||||
openGL.Palette,
|
||||
openGL.Attribute,
|
||||
openGL.Texture,
|
||||
openGL.Tasks,
|
||||
openGL.Errors,
|
||||
|
||||
GL.Binding,
|
||||
GL.lean,
|
||||
GL.Pointers,
|
||||
|
||||
System,
|
||||
Interfaces.C.Strings,
|
||||
System.storage_Elements;
|
||||
|
||||
|
||||
package body openGL.Geometry.textured
|
||||
is
|
||||
use GL.lean,
|
||||
GL.Pointers,
|
||||
|
||||
Interfaces,
|
||||
System;
|
||||
|
||||
-----------
|
||||
-- Globals
|
||||
--
|
||||
|
||||
vertex_Shader : aliased Shader.item;
|
||||
fragment_Shader : aliased Shader.item;
|
||||
|
||||
the_Program : openGL.Program.view;
|
||||
white_Texture : openGL.Texture.Object;
|
||||
|
||||
Name_1 : constant String := "Site";
|
||||
Name_2 : constant String := "Coords";
|
||||
|
||||
Attribute_1_Name : aliased C.char_array := C.to_C (Name_1);
|
||||
Attribute_2_Name : aliased C.char_array := C.to_C (Name_2);
|
||||
|
||||
Attribute_1_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_1_Name'Access);
|
||||
Attribute_2_Name_ptr : aliased constant C.strings.chars_ptr := C.strings.to_chars_ptr (Attribute_2_Name'Access);
|
||||
|
||||
|
||||
---------
|
||||
-- Forge
|
||||
--
|
||||
|
||||
function new_Geometry return View
|
||||
is
|
||||
use type openGL.Program.view;
|
||||
|
||||
Self : constant View := new Geometry.textured.item;
|
||||
|
||||
begin
|
||||
Tasks.check;
|
||||
|
||||
if the_Program = null
|
||||
then -- Define the shaders and program.
|
||||
declare
|
||||
use Palette,
|
||||
Attribute.Forge,
|
||||
system.Storage_Elements;
|
||||
|
||||
Sample : Vertex;
|
||||
|
||||
Attribute_1 : Attribute.view;
|
||||
Attribute_2 : Attribute.view;
|
||||
|
||||
white_Image : constant openGL.Image := [1 .. 2 => [1 .. 2 => +White]];
|
||||
|
||||
begin
|
||||
white_Texture := openGL.Texture.Forge.to_Texture (white_Image);
|
||||
|
||||
vertex_Shader .define (openGL.Shader.vertex, "assets/opengl/shader/textured.vert");
|
||||
fragment_Shader.define (openGL.Shader.fragment, "assets/opengl/shader/textured.frag");
|
||||
|
||||
the_Program := new openGL.Program.item;
|
||||
|
||||
the_Program.define ( vertex_Shader'Access,
|
||||
fragment_Shader'Access);
|
||||
the_Program.enable;
|
||||
|
||||
Attribute_1 := new_Attribute (Name => Name_1,
|
||||
gl_Location => the_Program.attribute_Location (Name_1),
|
||||
Size => 3,
|
||||
data_Kind => Attribute.GL_FLOAT,
|
||||
Stride => textured.Vertex'Size / 8,
|
||||
Offset => 0,
|
||||
Normalized => False);
|
||||
|
||||
Attribute_2 := new_Attribute (Name => Name_2,
|
||||
gl_Location => the_Program.attribute_Location (Name_2),
|
||||
Size => 2,
|
||||
data_Kind => attribute.GL_FLOAT,
|
||||
Stride => textured.Vertex'Size / 8,
|
||||
Offset => Sample.Coords.S'Address
|
||||
- Sample.Site (1)'Address,
|
||||
Normalized => False);
|
||||
the_Program.add (Attribute_1);
|
||||
the_Program.add (Attribute_2);
|
||||
|
||||
glBindAttribLocation (program => the_Program.gl_Program,
|
||||
index => the_Program.Attribute (named => Name_1).gl_Location,
|
||||
name => +Attribute_1_Name_ptr);
|
||||
|
||||
glBindAttribLocation (program => the_Program.gl_Program,
|
||||
index => the_Program.Attribute (named => Name_2).gl_Location,
|
||||
name => +Attribute_2_Name_ptr);
|
||||
end;
|
||||
end if;
|
||||
|
||||
Self.Program_is (the_Program.all'Access);
|
||||
return Self;
|
||||
end new_Geometry;
|
||||
|
||||
|
||||
--------------
|
||||
-- Attributes
|
||||
--
|
||||
|
||||
overriding
|
||||
function is_Transparent (Self : in Item) return Boolean
|
||||
is
|
||||
begin
|
||||
return Self.is_Transparent;
|
||||
end is_Transparent;
|
||||
|
||||
|
||||
package openGL_Buffer_of_geometry_Vertices is new Buffer.general (base_Object => Buffer.array_Object,
|
||||
Index => Index_t,
|
||||
Element => Vertex,
|
||||
Element_Array => Vertex_array);
|
||||
|
||||
procedure Vertices_are (Self : in out Item; Now : in Vertex_array)
|
||||
is
|
||||
use openGL_Buffer_of_geometry_Vertices.Forge;
|
||||
begin
|
||||
Self.Vertices := new openGL_Buffer_of_geometry_Vertices.Object' (to_Buffer (Now,
|
||||
usage => Buffer.static_Draw));
|
||||
-- Set the bounds.
|
||||
--
|
||||
declare
|
||||
function get_Site (Index : in Index_t) return Vector_3
|
||||
is (Now (Index).Site);
|
||||
|
||||
function bounding_Box is new get_Bounds (Index_t, get_Site);
|
||||
begin
|
||||
Self.Bounds_are (bounding_Box (Count => Now'Length));
|
||||
end;
|
||||
end Vertices_are;
|
||||
|
||||
|
||||
overriding
|
||||
procedure Indices_are (Self : in out Item; Now : in Indices;
|
||||
for_Facia : in Positive)
|
||||
is
|
||||
begin
|
||||
raise Error with "opengl gemoetry textured - 'Indices_are' ~ TODO";
|
||||
end Indices_are;
|
||||
|
||||
|
||||
overriding
|
||||
procedure enable_Texture (Self : in 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 white_Texture.enable;
|
||||
else Self.Texture .enable;
|
||||
end if;
|
||||
end enable_Texture;
|
||||
|
||||
|
||||
end openGL.Geometry.textured;
|
||||
@@ -0,0 +1,45 @@
|
||||
package openGL.Geometry.textured
|
||||
--
|
||||
-- Supports per-vertex site and texture.
|
||||
--
|
||||
is
|
||||
type Item is new openGL.Geometry.item with private;
|
||||
type View is access all Item'Class;
|
||||
|
||||
function new_Geometry return View;
|
||||
|
||||
|
||||
----------
|
||||
-- Vertex
|
||||
--
|
||||
type Vertex is
|
||||
record
|
||||
Site : Vector_3;
|
||||
Coords : Coordinate_2D;
|
||||
end record;
|
||||
|
||||
type Vertex_array is array (Index_t range <>) of aliased Vertex;
|
||||
|
||||
|
||||
--------------
|
||||
-- Attributes
|
||||
--
|
||||
|
||||
overriding
|
||||
function is_Transparent (Self : in Item) return Boolean;
|
||||
|
||||
procedure Vertices_are (Self : in out Item; Now : in Vertex_array);
|
||||
|
||||
overriding
|
||||
procedure Indices_are (Self : in out Item; Now : in Indices;
|
||||
for_Facia : in Positive);
|
||||
|
||||
|
||||
private
|
||||
|
||||
type Item is new Geometry.item with null record;
|
||||
|
||||
overriding
|
||||
procedure enable_Texture (Self : in Item);
|
||||
|
||||
end openGL.Geometry.textured;
|
||||
510
3-mid/opengl/source/lean/geometry/opengl-geometry.adb
Normal file
510
3-mid/opengl/source/lean/geometry/opengl-geometry.adb
Normal file
@@ -0,0 +1,510 @@
|
||||
with
|
||||
openGL.Primitive.indexed,
|
||||
openGL.Primitive.long_indexed,
|
||||
|
||||
ada.unchecked_Deallocation,
|
||||
ada.unchecked_Conversion;
|
||||
|
||||
package body openGL.Geometry
|
||||
is
|
||||
---------
|
||||
-- Forge
|
||||
--
|
||||
|
||||
procedure destroy (Self : in out Item)
|
||||
is
|
||||
use openGL.Buffer;
|
||||
begin
|
||||
free (Self.Vertices);
|
||||
Self.free_Primitives;
|
||||
end destroy;
|
||||
|
||||
|
||||
procedure free (Self : in out View)
|
||||
is
|
||||
procedure deallocate is new ada.unchecked_Deallocation (Item'Class, View);
|
||||
begin
|
||||
if Self = null then
|
||||
return;
|
||||
end if;
|
||||
|
||||
Self.destroy;
|
||||
deallocate (Self);
|
||||
end free;
|
||||
|
||||
|
||||
procedure free_Primitives (Self : in out Item)
|
||||
is
|
||||
begin
|
||||
for Each in 1 .. Self.primitive_Count
|
||||
loop
|
||||
Primitive.free (Self.Primitives (Each));
|
||||
end loop;
|
||||
|
||||
Self.primitive_Count := 0;
|
||||
end free_Primitives;
|
||||
|
||||
|
||||
--------------
|
||||
-- Attributes
|
||||
--
|
||||
|
||||
function Label (Self : in Item'Class) return String
|
||||
is
|
||||
begin
|
||||
return to_String (Self.Label);
|
||||
end Label;
|
||||
|
||||
|
||||
procedure Label_is (Self : in out Item'Class; Now : in String)
|
||||
is
|
||||
begin
|
||||
overwrite (Self.Label, 1, Now);
|
||||
end Label_is;
|
||||
|
||||
|
||||
|
||||
procedure Indices_are (Self : in out Item; Now : in Indices;
|
||||
for_Facia : in Positive)
|
||||
is
|
||||
the_Primitive : constant Primitive.indexed.view
|
||||
:= Primitive.indexed.view (Self.Primitives (Index_t (for_Facia)));
|
||||
begin
|
||||
the_Primitive.Indices_are (Now);
|
||||
end Indices_are;
|
||||
|
||||
|
||||
procedure Indices_are (Self : in out Item; Now : in long_Indices;
|
||||
for_Facia : in Positive)
|
||||
is
|
||||
the_Primitive : constant Primitive.long_indexed.view
|
||||
:= Primitive.long_indexed.view (Self.Primitives (Index_t (for_Facia)));
|
||||
begin
|
||||
the_Primitive.Indices_are (Now);
|
||||
end Indices_are;
|
||||
|
||||
|
||||
|
||||
function Primitives (Self : in Item'Class) return Primitive.views
|
||||
is
|
||||
begin
|
||||
return Self.Primitives (1 .. Self.primitive_Count);
|
||||
end Primitives;
|
||||
|
||||
|
||||
|
||||
function Texture (Self : in Item'Class) return openGL.Texture.Object
|
||||
is
|
||||
begin
|
||||
return Self.Texture;
|
||||
end Texture;
|
||||
|
||||
|
||||
procedure Texture_is (Self : in out Item'Class; Now : in openGL.Texture.Object)
|
||||
is
|
||||
begin
|
||||
Self.Texture := Now;
|
||||
Self.is_Transparent := Self.is_Transparent
|
||||
or Now .is_Transparent;
|
||||
end Texture_is;
|
||||
|
||||
|
||||
|
||||
procedure Program_is (Self : in out Item; Now : in openGL.Program.view)
|
||||
is
|
||||
begin
|
||||
Self.Program := Now;
|
||||
end Program_is;
|
||||
|
||||
|
||||
function Program (Self : in Item) return openGL.Program.view
|
||||
is
|
||||
begin
|
||||
return Self.Program;
|
||||
end Program;
|
||||
|
||||
|
||||
|
||||
function Bounds (self : in Item'Class) return openGL.Bounds
|
||||
is
|
||||
begin
|
||||
return Self.Bounds;
|
||||
end Bounds;
|
||||
|
||||
|
||||
procedure Bounds_are (Self : in out Item'Class; Now : in openGL.Bounds)
|
||||
is
|
||||
begin
|
||||
Self.Bounds := Now;
|
||||
end Bounds_are;
|
||||
|
||||
|
||||
|
||||
function is_Transparent (Self : in Item) return Boolean
|
||||
is
|
||||
begin
|
||||
return Self.is_Transparent
|
||||
or Self.Texture.is_Transparent;
|
||||
end is_Transparent;
|
||||
|
||||
|
||||
procedure is_Transparent (Self : in out Item; Now : in Boolean := True)
|
||||
is
|
||||
begin
|
||||
Self.is_Transparent := Now;
|
||||
end is_Transparent;
|
||||
|
||||
|
||||
--------------
|
||||
-- Operations
|
||||
--
|
||||
|
||||
procedure add (Self : in out Item'Class; the_Primitive : in Primitive.view)
|
||||
is
|
||||
begin
|
||||
Self.primitive_Count := Self.primitive_Count + 1;
|
||||
Self.Primitives (self.primitive_Count) := the_Primitive;
|
||||
end add;
|
||||
|
||||
|
||||
|
||||
procedure render (Self : in out Item'Class)
|
||||
is
|
||||
begin
|
||||
if Self.primitive_Count = 0
|
||||
then
|
||||
raise Error with "Unable to render geometry with no primitives.";
|
||||
end if;
|
||||
|
||||
Self .enable_Texture;
|
||||
Self.Program .set_Uniforms;
|
||||
Self.Vertices.enable;
|
||||
Self.Program .enable_Attributes;
|
||||
|
||||
for Each in 1 .. self.primitive_Count -- Render each primitive.
|
||||
loop
|
||||
Self.Primitives (Each).render;
|
||||
end loop;
|
||||
end render;
|
||||
|
||||
|
||||
-----------
|
||||
-- Normals
|
||||
--
|
||||
|
||||
generic
|
||||
type any_Index_t is range <>;
|
||||
type any_Indices is array (long_Index_t range <>) of any_Index_t;
|
||||
|
||||
function any_vertex_Id_in (face_Kind : in primitive.facet_Kind;
|
||||
Indices : in any_Indices;
|
||||
for_Facet : in long_Index_t;
|
||||
for_Point : in long_Index_t) return any_Index_t;
|
||||
|
||||
function any_vertex_Id_in (face_Kind : in Primitive.facet_Kind;
|
||||
Indices : in any_Indices;
|
||||
for_Facet : in long_Index_t;
|
||||
for_Point : in long_Index_t) return any_Index_t
|
||||
is
|
||||
use openGL.Primitive;
|
||||
begin
|
||||
case face_Kind
|
||||
is
|
||||
when Triangles =>
|
||||
return Indices (3 * (for_Facet - 1) + for_Point);
|
||||
|
||||
when triangle_Strip =>
|
||||
return Indices (for_Facet - 1 + for_Point);
|
||||
|
||||
when triangle_Fan =>
|
||||
if for_Point = 1
|
||||
then return 1;
|
||||
else return Indices (for_Facet - 1 + for_Point);
|
||||
end if;
|
||||
|
||||
when others =>
|
||||
raise Error with "openGL primitive " & face_Kind'Image & " not yet supported.";
|
||||
end case;
|
||||
end any_vertex_Id_in;
|
||||
|
||||
|
||||
|
||||
generic
|
||||
type any_Index_t is range <>;
|
||||
type any_Indices is array (long_Index_t range <>) of any_Index_t;
|
||||
|
||||
function any_facet_Count_in (face_Kind : in primitive.facet_Kind;
|
||||
Indices : in any_Indices) return long_Index_t;
|
||||
--
|
||||
-- Returns the maximum possible facet count, which includes redundant facets.
|
||||
|
||||
|
||||
function any_facet_Count_in (face_Kind : in primitive.facet_Kind;
|
||||
Indices : in any_Indices) return long_Index_t
|
||||
is
|
||||
use Primitive;
|
||||
begin
|
||||
case face_Kind
|
||||
is
|
||||
when Triangles =>
|
||||
return Indices'Length / 3;
|
||||
|
||||
when triangle_Strip
|
||||
| triangle_Fan =>
|
||||
return Indices'Length - 2;
|
||||
|
||||
when others =>
|
||||
raise Error with "openGL primitive " & face_Kind'Image & " not yet supported.";
|
||||
end case;
|
||||
end any_facet_Count_in;
|
||||
|
||||
|
||||
function facet_Count_in is new any_facet_Count_in (any_Index_t => Index_t,
|
||||
any_Indices => Indices);
|
||||
pragma Unreferenced (facet_Count_in);
|
||||
|
||||
|
||||
----------
|
||||
-- Facets
|
||||
--
|
||||
type Facet is array ( Index_t range 1 .. 3) of Index_t; -- An 'indexed' triangle.
|
||||
type Facets is array (long_Index_t range <> ) of Facet;
|
||||
|
||||
type Facets_view is access all Facets;
|
||||
procedure free is new ada.unchecked_Deallocation (Facets, Facets_view);
|
||||
|
||||
|
||||
generic
|
||||
type any_Index_t is range <>;
|
||||
type any_Indices is array (long_Index_t range <>) of any_Index_t;
|
||||
|
||||
function any_Facets_of (face_Kind : in primitive.facet_Kind;
|
||||
Indices : in any_Indices) return access Facets;
|
||||
--
|
||||
-- 'Facets_of' returns all non-redundant facets.
|
||||
|
||||
|
||||
function any_Facets_of (face_Kind : in primitive.facet_Kind;
|
||||
Indices : in any_Indices) return access Facets
|
||||
is
|
||||
use openGL.Primitive;
|
||||
|
||||
function facet_Count_in is new any_facet_Count_in (any_Index_t => any_Index_t,
|
||||
any_Indices => any_Indices);
|
||||
|
||||
function vertex_Id_in is new any_vertex_Id_in (any_Index_t => any_Index_t,
|
||||
any_Indices => any_Indices);
|
||||
|
||||
the_Facets : Facets_view := new Facets (1 .. facet_Count_in (face_Kind, Indices));
|
||||
Count : long_Index_t := 0;
|
||||
|
||||
begin
|
||||
for Each in the_Facets'Range
|
||||
loop
|
||||
declare
|
||||
P1 : constant Index_t := Index_t (vertex_Id_in (face_Kind, Indices, Each, 1));
|
||||
P2 : constant Index_t := Index_t (vertex_Id_in (face_Kind, Indices, Each, 2));
|
||||
P3 : constant Index_t := Index_t (vertex_Id_in (face_Kind, Indices, Each, 3));
|
||||
begin
|
||||
if not ( P1 = P2
|
||||
or P1 = P3
|
||||
or P2 = P3)
|
||||
then
|
||||
Count := Count + 1;
|
||||
|
||||
case face_Kind
|
||||
is
|
||||
when Triangles
|
||||
| triangle_Fan =>
|
||||
the_Facets (Count) := [P1, P2, P3];
|
||||
|
||||
when triangle_Strip =>
|
||||
if Each mod 2 = 0
|
||||
then -- Is an even facet.
|
||||
the_Facets (Count) := [P1, P3, P2];
|
||||
else
|
||||
the_Facets (Count) := [P1, P2, P3];
|
||||
end if;
|
||||
|
||||
when others =>
|
||||
raise Error with "openGL primitive " & face_Kind'Image & " not yet supported.";
|
||||
end case;
|
||||
|
||||
end if;
|
||||
end;
|
||||
end loop;
|
||||
|
||||
declare
|
||||
Result : constant Facets_view := new Facets' (the_Facets (1 .. Count));
|
||||
begin
|
||||
free (the_Facets);
|
||||
return Result;
|
||||
end;
|
||||
end any_Facets_of;
|
||||
|
||||
|
||||
function Facets_of is new any_Facets_of (Index_t,
|
||||
Indices);
|
||||
pragma Unreferenced (Facets_of);
|
||||
|
||||
|
||||
-----------
|
||||
-- Normals
|
||||
--
|
||||
type Normals_view is access Normals;
|
||||
|
||||
|
||||
generic
|
||||
type any_Index_t is range <>;
|
||||
type any_Indices is array (long_Index_t range <>) of any_Index_t;
|
||||
|
||||
function any_Normals_of (face_Kind : in primitive.facet_Kind;
|
||||
Indices : in any_Indices;
|
||||
Sites : in openGL.Sites) return access Normals;
|
||||
|
||||
|
||||
function any_Normals_of (face_Kind : in primitive.facet_Kind;
|
||||
Indices : in any_Indices;
|
||||
Sites : in openGL.Sites) return access Normals
|
||||
is
|
||||
function Facets_of is new any_Facets_of (any_Index_t,
|
||||
any_Indices);
|
||||
|
||||
the_Normals : constant Normals_view := new Normals (Sites'Range);
|
||||
the_Facets : Facets_view := Facets_of (face_Kind,
|
||||
Indices).all'unchecked_Access;
|
||||
|
||||
type facet_Normals is array (long_Index_t range 1 .. the_Facets'Length) of Normal;
|
||||
type facet_Normals_view is access all facet_Normals;
|
||||
|
||||
procedure free is new ada.unchecked_Deallocation (facet_Normals, facet_Normals_view); -- TODO: Should not be needed since freeing will occur when 'facet_Normals_view' goes out of scope ?
|
||||
|
||||
the_facet_Normals : facet_Normals_view := new facet_Normals;
|
||||
N : Vector_3;
|
||||
length_N : Real;
|
||||
|
||||
begin
|
||||
-- Calculate normal at each facet.
|
||||
--
|
||||
for Each in the_Facets'Range
|
||||
loop
|
||||
N := (Sites (the_Facets (Each)(2)) - Sites (the_Facets (Each)(1)))
|
||||
* (Sites (the_Facets (Each)(3)) - Sites (the_Facets (Each)(1)));
|
||||
|
||||
length_N := abs (N);
|
||||
|
||||
if almost_Zero (length_N)
|
||||
then the_facet_Normals (Each) := N; -- 0 vector !
|
||||
else the_facet_Normals (Each) := (1.0 / length_N) * N;
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
-- Calculate normal at each vertex.
|
||||
--
|
||||
declare
|
||||
Id : Index_t;
|
||||
Length : Real;
|
||||
begin
|
||||
for Each in the_Normals'Range
|
||||
loop
|
||||
the_Normals (Each) := Origin_3D;
|
||||
end loop;
|
||||
|
||||
for f in the_Facets'Range
|
||||
loop
|
||||
for p in Index_t' (1) .. 3
|
||||
loop
|
||||
Id := the_Facets (f) (p);
|
||||
the_Normals (Id) := the_Normals (Id) + the_facet_Normals (f);
|
||||
end loop;
|
||||
end loop;
|
||||
|
||||
for p in the_Normals'Range
|
||||
loop
|
||||
Length := abs (the_Normals (p));
|
||||
|
||||
if almost_Zero (Length)
|
||||
then the_Normals (p) := [0.0, -1.0, 0.0];
|
||||
else the_Normals (p) := (1.0 / Length) * the_Normals (p);
|
||||
end if;
|
||||
end loop;
|
||||
end;
|
||||
|
||||
free (the_Facets);
|
||||
free (the_facet_Normals);
|
||||
|
||||
return the_Normals.all'Unchecked_Access;
|
||||
end any_Normals_of;
|
||||
|
||||
|
||||
|
||||
function Normals_of (face_Kind : in primitive.facet_Kind;
|
||||
Indices : in openGL.Indices;
|
||||
Sites : in openGL.Sites) return access Normals
|
||||
is
|
||||
function my_Normals_of is new any_Normals_of (any_Index_t => Index_t,
|
||||
any_Indices => openGL.Indices);
|
||||
begin
|
||||
return my_Normals_of (face_Kind,
|
||||
Indices,
|
||||
Sites).all'unchecked_Access;
|
||||
end Normals_of;
|
||||
|
||||
|
||||
|
||||
function Normals_of (face_Kind : in primitive.facet_Kind;
|
||||
Indices : in openGL.long_Indices;
|
||||
Sites : in openGL.Sites) return access Normals
|
||||
is
|
||||
function my_Normals_of is new any_Normals_of (any_Index_t => long_Index_t,
|
||||
any_Indices => openGL.long_Indices);
|
||||
begin
|
||||
return my_Normals_of (face_Kind,
|
||||
Indices,
|
||||
Sites).all'unchecked_Access;
|
||||
end Normals_of;
|
||||
|
||||
|
||||
---------
|
||||
-- Bounds
|
||||
--
|
||||
|
||||
function get_Bounds (Count : in Natural) return openGL.Bounds
|
||||
is
|
||||
use Geometry_3D;
|
||||
the_Bounds : openGL.Bounds := null_Bounds;
|
||||
begin
|
||||
for i in 1 .. any_Index_t (Count)
|
||||
loop
|
||||
the_Bounds.Box := the_Bounds.Box
|
||||
or get_Site (i);
|
||||
|
||||
the_Bounds.Ball := Real'Max (the_Bounds.Ball,
|
||||
abs (get_Site (i)));
|
||||
end loop;
|
||||
|
||||
return the_Bounds;
|
||||
end get_Bounds;
|
||||
|
||||
|
||||
---------------
|
||||
-- Transparency
|
||||
--
|
||||
|
||||
function get_Transparency (Count : in Natural) return Boolean
|
||||
is
|
||||
use type color_Value;
|
||||
begin
|
||||
for i in 1 .. any_Index_t (Count)
|
||||
loop
|
||||
if get_Color (i).Alpha /= opaque_Value
|
||||
then
|
||||
return True;
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
return False;
|
||||
end get_Transparency;
|
||||
|
||||
|
||||
end openGL.Geometry;
|
||||
113
3-mid/opengl/source/lean/geometry/opengl-geometry.ads
Normal file
113
3-mid/opengl/source/lean/geometry/opengl-geometry.ads
Normal file
@@ -0,0 +1,113 @@
|
||||
with
|
||||
openGL.Primitive,
|
||||
openGL.Buffer,
|
||||
openGL.Program,
|
||||
openGL.Texture;
|
||||
|
||||
private
|
||||
with
|
||||
ada.Strings.unbounded;
|
||||
|
||||
package openGL.Geometry
|
||||
--
|
||||
-- Provides a base class for openGL geometry.
|
||||
-- A Geometry is composed of up to 5 primitives.
|
||||
-- Each primitive has its own set of GL indices and a facet kind.
|
||||
-- All primitives share a common set of vertices.
|
||||
-- Subclasses may be created to provide for the various possible variants of an openGL vertex.
|
||||
--
|
||||
is
|
||||
type Item is abstract tagged limited private;
|
||||
subtype Class is Item'Class;
|
||||
|
||||
type View is access all Item'class;
|
||||
type Views is array (Index_t range <>) of View;
|
||||
|
||||
|
||||
---------
|
||||
--- Forge
|
||||
--
|
||||
|
||||
procedure destroy (Self : in out Item);
|
||||
procedure free (Self : in out View);
|
||||
|
||||
|
||||
--------------
|
||||
-- Attributes
|
||||
--
|
||||
|
||||
procedure Label_is (Self : in out Item'Class; Now : in String);
|
||||
function Label (Self : in Item'Class) return String;
|
||||
|
||||
procedure Texture_is (Self : in out Item'Class; Now : in Texture.Object);
|
||||
function Texture (Self : in Item'Class) return Texture.Object;
|
||||
|
||||
procedure Bounds_are (Self : in out Item'Class; Now : in Bounds);
|
||||
function Bounds (self : in Item'Class) return Bounds; -- Returns the bounds in object space.
|
||||
|
||||
procedure is_Transparent (Self : in out Item; Now : in Boolean := True);
|
||||
function is_Transparent (Self : in Item) return Boolean;
|
||||
|
||||
procedure Program_is (Self : in out Item; Now : in Program.view);
|
||||
function Program (Self : in Item) return Program.view;
|
||||
|
||||
procedure add (Self : in out Item'Class; the_Primitive : in Primitive.view);
|
||||
function Primitives (Self : in Item'Class) return Primitive.views;
|
||||
procedure free_Primitives (Self : in out Item);
|
||||
|
||||
procedure Indices_are (Self : in out Item; Now : in Indices;
|
||||
for_Facia : in Positive);
|
||||
procedure Indices_are (Self : in out Item; Now : in long_Indices;
|
||||
for_Facia : in Positive);
|
||||
|
||||
--------------
|
||||
-- Operations
|
||||
--
|
||||
|
||||
procedure render (Self : in out Item'Class);
|
||||
procedure enable_Texture (Self : in Item) is null;
|
||||
|
||||
|
||||
-----------
|
||||
-- Normals
|
||||
--
|
||||
|
||||
function Normals_of (face_Kind : in primitive.facet_Kind;
|
||||
Indices : in openGL.Indices;
|
||||
Sites : in openGL.Sites) return access Normals;
|
||||
|
||||
function Normals_of (face_Kind : in primitive.facet_Kind;
|
||||
Indices : in openGL.long_Indices;
|
||||
Sites : in openGL.Sites) return access Normals;
|
||||
|
||||
|
||||
private
|
||||
use ada.Strings.unbounded;
|
||||
|
||||
type Item is abstract tagged limited
|
||||
record
|
||||
Label : unbounded_String;
|
||||
Texture : openGL.Texture.Object := openGL.Texture.null_Object;
|
||||
|
||||
Program : openGL.Program.view;
|
||||
Vertices : Buffer.view;
|
||||
|
||||
Primitives : Primitive.views (1 .. 5);
|
||||
primitive_Count : Index_t := 0;
|
||||
|
||||
is_Transparent : Boolean := False; -- Geometry contains lucid colors.
|
||||
Bounds : openGL.Bounds;
|
||||
end record;
|
||||
|
||||
|
||||
generic
|
||||
type any_Index_t is range <>;
|
||||
with function get_Site (Index : in any_Index_t) return Vector_3;
|
||||
function get_Bounds (Count : in Natural) return openGL.Bounds;
|
||||
|
||||
generic
|
||||
type any_Index_t is range <>;
|
||||
with function get_Color (Index : in any_Index_t) return rgba_Color;
|
||||
function get_Transparency (Count : in Natural) return Boolean;
|
||||
|
||||
end openGL.Geometry;
|
||||
148
3-mid/opengl/source/lean/geometry/opengl-primitive-indexed.adb
Normal file
148
3-mid/opengl/source/lean/geometry/opengl-primitive-indexed.adb
Normal file
@@ -0,0 +1,148 @@
|
||||
with
|
||||
openGL.Errors,
|
||||
openGL.Buffer,
|
||||
openGL.Tasks,
|
||||
|
||||
GL.Binding,
|
||||
GL.lean;
|
||||
|
||||
package body openGL.Primitive.indexed
|
||||
is
|
||||
---------
|
||||
--- Forge
|
||||
--
|
||||
|
||||
procedure define (Self : in out Item; Kind : in facet_Kind;
|
||||
Indices : in openGL.Indices;
|
||||
line_Width : in Real)
|
||||
is
|
||||
use openGL.Buffer.indices.Forge;
|
||||
buffer_Indices : aliased openGL.Indices := [Indices'Range => <>];
|
||||
|
||||
begin
|
||||
for Each in buffer_Indices'Range
|
||||
loop
|
||||
buffer_Indices (Each) := Indices (Each) - 1; -- Adjust indices to zero-based indexing for GL.
|
||||
end loop;
|
||||
|
||||
Self.facet_Kind := Kind;
|
||||
Self.Indices := new Buffer.indices.Object' (to_Buffer (buffer_Indices'Access,
|
||||
usage => Buffer.static_Draw));
|
||||
Self.line_Width := line_Width;
|
||||
end define;
|
||||
|
||||
|
||||
|
||||
procedure define (Self : in out Item; Kind : in facet_Kind;
|
||||
Indices : in long_Indices;
|
||||
line_Width : in Real)
|
||||
is
|
||||
use openGL.Buffer.indices.Forge;
|
||||
buffer_Indices : aliased openGL.Indices := [Indices'Range => <>];
|
||||
|
||||
begin
|
||||
for Each in buffer_Indices'Range
|
||||
loop
|
||||
buffer_Indices (Each) := Index_t (Indices (Each) - 1); -- Adjust indices to zero-based indexing for GL.
|
||||
end loop;
|
||||
|
||||
Self.facet_Kind := Kind;
|
||||
Self.Indices := new openGL.Buffer.indices.Object' (to_Buffer (buffer_Indices'Access,
|
||||
usage => Buffer.static_Draw));
|
||||
Self.line_Width := line_Width;
|
||||
end define;
|
||||
|
||||
|
||||
|
||||
function new_Primitive (Kind : in facet_Kind;
|
||||
Indices : in openGL.Indices;
|
||||
line_Width : in Real := unused_line_Width) return Primitive.indexed.view
|
||||
is
|
||||
Self : constant View := new Item;
|
||||
begin
|
||||
define (Self.all, Kind, Indices, line_Width);
|
||||
return Self;
|
||||
end new_Primitive;
|
||||
|
||||
|
||||
|
||||
function new_Primitive (Kind : in facet_Kind;
|
||||
Indices : in long_Indices;
|
||||
line_Width : in Real := unused_line_Width) return Primitive.indexed.view
|
||||
is
|
||||
Self : constant View := new Item;
|
||||
begin
|
||||
define (Self.all, Kind, Indices, line_Width);
|
||||
return Self;
|
||||
end new_Primitive;
|
||||
|
||||
|
||||
|
||||
overriding
|
||||
procedure destroy (Self : in out Item)
|
||||
is
|
||||
the_Indices : Buffer.view := Buffer.view (Self.Indices);
|
||||
begin
|
||||
Buffer.free (the_Indices);
|
||||
Self.Indices := null;
|
||||
end destroy;
|
||||
|
||||
|
||||
--------------
|
||||
-- Attributes
|
||||
--
|
||||
|
||||
procedure Indices_are (Self : in out Item; Now : in Indices)
|
||||
is
|
||||
use Buffer.indices;
|
||||
buffer_Indices : aliased Indices := [Now'Range => <>];
|
||||
begin
|
||||
for Each in buffer_Indices'Range
|
||||
loop
|
||||
buffer_Indices (Each) := Now (Each) - 1; -- Adjust indices to zero-based-indexing for GL.
|
||||
end loop;
|
||||
|
||||
Self.Indices.set (to => buffer_Indices);
|
||||
end Indices_are;
|
||||
|
||||
|
||||
|
||||
procedure Indices_are (Self : in out Item; Now : in long_Indices)
|
||||
is
|
||||
use Buffer.indices;
|
||||
buffer_Indices : aliased Indices := [Now'Range => <>];
|
||||
begin
|
||||
for Each in buffer_Indices'Range
|
||||
loop
|
||||
buffer_Indices (Each) := Index_t (Now (Each) - 1); -- Adjust indices to zero-based-indexing for GL.
|
||||
end loop;
|
||||
|
||||
Self.Indices.set (to => buffer_Indices);
|
||||
end Indices_are;
|
||||
|
||||
|
||||
--------------
|
||||
-- Operations
|
||||
--
|
||||
|
||||
overriding
|
||||
procedure render (Self : in out Item)
|
||||
is
|
||||
use GL,
|
||||
GL.Binding,
|
||||
GL.lean;
|
||||
begin
|
||||
Tasks.check;
|
||||
|
||||
Primitive.item (Self).render; -- Do base class render.
|
||||
Self.Indices.enable;
|
||||
|
||||
glDrawElements (Thin (Self.facet_Kind),
|
||||
gl.GLint (Self.Indices.Length),
|
||||
GL_UNSIGNED_SHORT,
|
||||
null);
|
||||
Errors.log;
|
||||
end render;
|
||||
|
||||
|
||||
end openGL.Primitive.indexed;
|
||||
@@ -0,0 +1,64 @@
|
||||
private
|
||||
with
|
||||
openGL.Buffer.indices;
|
||||
|
||||
package openGL.Primitive.indexed
|
||||
--
|
||||
-- Provides a class for indexed openGL primitives.
|
||||
--
|
||||
is
|
||||
type Item is limited new Primitive.item with private;
|
||||
subtype Class is Item'Class;
|
||||
|
||||
type View is access all Item'class;
|
||||
type Views is array (Index_t range <>) of View;
|
||||
|
||||
|
||||
---------
|
||||
-- Forge
|
||||
--
|
||||
|
||||
function new_Primitive (Kind : in facet_Kind;
|
||||
Indices : in openGL.Indices;
|
||||
line_Width : in Real := unused_line_Width) return Primitive.indexed.view;
|
||||
|
||||
function new_Primitive (Kind : in facet_Kind;
|
||||
Indices : in openGL.long_Indices;
|
||||
line_Width : in Real := unused_line_Width) return Primitive.indexed.view;
|
||||
|
||||
procedure define (Self : in out Item; Kind : in facet_Kind;
|
||||
Indices : in openGL.Indices;
|
||||
line_Width : in Real);
|
||||
|
||||
procedure define (Self : in out Item; Kind : in facet_Kind;
|
||||
Indices : in openGL.long_Indices;
|
||||
line_Width : in Real);
|
||||
overriding
|
||||
procedure destroy (Self : in out Item);
|
||||
|
||||
|
||||
--------------
|
||||
-- Attributes
|
||||
--
|
||||
|
||||
procedure Indices_are (Self : in out Item; Now : in Indices);
|
||||
procedure Indices_are (Self : in out Item; Now : in long_Indices);
|
||||
|
||||
|
||||
--------------
|
||||
-- Operations
|
||||
--
|
||||
|
||||
overriding
|
||||
procedure render (Self : in out Item);
|
||||
|
||||
|
||||
|
||||
private
|
||||
|
||||
type Item is limited new Primitive.item with
|
||||
record
|
||||
Indices : Buffer.indices.view;
|
||||
end record;
|
||||
|
||||
end openGL.Primitive.indexed;
|
||||
@@ -0,0 +1,95 @@
|
||||
with
|
||||
openGL.Errors,
|
||||
openGL.Buffer,
|
||||
openGL.Tasks,
|
||||
GL.Binding,
|
||||
|
||||
ada.unchecked_Deallocation;
|
||||
|
||||
package body openGL.Primitive.long_indexed
|
||||
is
|
||||
---------
|
||||
--- Forge
|
||||
--
|
||||
|
||||
procedure define (Self : in out Item; Kind : in facet_Kind;
|
||||
Indices : in long_Indices)
|
||||
is
|
||||
use Buffer.long_indices.Forge;
|
||||
buffer_Indices : aliased long_Indices := [Indices'Range => <>];
|
||||
begin
|
||||
for Each in buffer_Indices'Range
|
||||
loop
|
||||
buffer_Indices (Each) := Indices (Each) - 1; -- Adjust indices to zero-based-indexing for GL.
|
||||
end loop;
|
||||
|
||||
Self.facet_Kind := Kind;
|
||||
Self.Indices := new Buffer.long_indices.Object' (to_Buffer (buffer_Indices'Access,
|
||||
usage => Buffer.static_Draw));
|
||||
end define;
|
||||
|
||||
|
||||
|
||||
function new_Primitive (Kind : in facet_Kind;
|
||||
Indices : in long_Indices) return Primitive.long_indexed.view
|
||||
is
|
||||
Self : constant View := new Item;
|
||||
begin
|
||||
define (Self.all, Kind, Indices);
|
||||
return Self;
|
||||
end new_Primitive;
|
||||
|
||||
|
||||
|
||||
overriding
|
||||
procedure destroy (Self : in out Item)
|
||||
is
|
||||
procedure free is new ada.unchecked_Deallocation (Buffer.long_indices.Object'Class,
|
||||
Buffer.long_indices.view);
|
||||
begin
|
||||
Buffer.destroy (Self.Indices.all);
|
||||
free (Self.Indices);
|
||||
end destroy;
|
||||
|
||||
|
||||
--------------
|
||||
-- Attributes
|
||||
--
|
||||
|
||||
procedure Indices_are (Self : in out Item; Now : in long_Indices)
|
||||
is
|
||||
use Buffer.long_indices;
|
||||
buffer_Indices : aliased long_Indices := [Now'Range => <>];
|
||||
begin
|
||||
for Each in buffer_Indices'Range
|
||||
loop
|
||||
buffer_Indices (Each) := Now (Each) - 1; -- Adjust indices to zero-based-indexing for GL.
|
||||
end loop;
|
||||
|
||||
Self.Indices.set (to => buffer_Indices);
|
||||
end Indices_are;
|
||||
|
||||
|
||||
--------------
|
||||
-- Operations
|
||||
--
|
||||
|
||||
overriding
|
||||
procedure render (Self : in out Item)
|
||||
is
|
||||
use GL,
|
||||
GL.Binding;
|
||||
begin
|
||||
Tasks.check;
|
||||
openGL.Primitive.item (Self).render; -- Do base class render.
|
||||
|
||||
Self.Indices.enable;
|
||||
glDrawElements (Thin (Self.facet_Kind),
|
||||
gl.GLint (Self.Indices.Length),
|
||||
GL_UNSIGNED_INT,
|
||||
null);
|
||||
Errors.log;
|
||||
end render;
|
||||
|
||||
|
||||
end openGL.Primitive.long_indexed;
|
||||
@@ -0,0 +1,53 @@
|
||||
private
|
||||
with
|
||||
openGL.Buffer.long_indices;
|
||||
|
||||
package openGL.Primitive.long_indexed
|
||||
--
|
||||
-- Provides a class for long indexed openGL primitives.
|
||||
--
|
||||
is
|
||||
type Item is limited new Primitive.item with private;
|
||||
subtype Class is Item'Class;
|
||||
|
||||
type View is access all Item'class;
|
||||
type Views is array (Index_t range <>) of View;
|
||||
|
||||
|
||||
---------
|
||||
-- Forge
|
||||
--
|
||||
|
||||
function new_Primitive (Kind : in facet_Kind;
|
||||
Indices : in long_Indices) return Primitive.long_indexed.view;
|
||||
|
||||
procedure define (Self : in out Item; Kind : in facet_Kind;
|
||||
Indices : in long_Indices);
|
||||
overriding
|
||||
procedure destroy (Self : in out Item);
|
||||
|
||||
|
||||
--------------
|
||||
-- Attributes
|
||||
--
|
||||
|
||||
procedure Indices_are (Self : in out Item; Now : in long_Indices);
|
||||
|
||||
|
||||
--------------
|
||||
-- Operations
|
||||
--
|
||||
|
||||
overriding
|
||||
procedure render (Self : in out Item);
|
||||
|
||||
|
||||
|
||||
private
|
||||
|
||||
type Item is limited new Primitive.item with
|
||||
record
|
||||
Indices : Buffer.long_indices.view;
|
||||
end record;
|
||||
|
||||
end openGL.Primitive.long_indexed;
|
||||
@@ -0,0 +1,54 @@
|
||||
with
|
||||
openGL.Errors,
|
||||
openGL.Tasks,
|
||||
GL.Binding;
|
||||
|
||||
package body openGL.Primitive.non_indexed
|
||||
is
|
||||
---------
|
||||
-- Forge
|
||||
--
|
||||
|
||||
overriding
|
||||
procedure define (Self : in out Item; Kind : in facet_Kind)
|
||||
is
|
||||
begin
|
||||
Self.facet_Kind := Kind;
|
||||
end define;
|
||||
|
||||
|
||||
function new_Primitive (Kind : in facet_Kind;
|
||||
vertex_Count : in Natural) return Primitive.non_indexed.view
|
||||
is
|
||||
Self : constant View := new Item;
|
||||
begin
|
||||
define (Self.all, Kind);
|
||||
Self.vertex_Count := vertex_Count;
|
||||
|
||||
return Self;
|
||||
end new_Primitive;
|
||||
|
||||
|
||||
overriding
|
||||
procedure destroy (Self : in out Item) is null;
|
||||
|
||||
|
||||
--------------
|
||||
-- Operations
|
||||
--
|
||||
|
||||
overriding
|
||||
procedure render (Self : in out Item)
|
||||
is
|
||||
use GL,
|
||||
GL.Binding;
|
||||
begin
|
||||
Tasks.check;
|
||||
glDrawArrays (Thin (Self.facet_Kind),
|
||||
0,
|
||||
gl.GLint (Self.vertex_Count));
|
||||
Errors.log;
|
||||
end render;
|
||||
|
||||
|
||||
end openGL.Primitive.non_indexed;
|
||||
@@ -0,0 +1,42 @@
|
||||
package openGL.Primitive.non_indexed
|
||||
--
|
||||
-- Provides a class for non-indexed openGL primitives.
|
||||
--
|
||||
is
|
||||
type Item is limited new Primitive.item with private;
|
||||
subtype Class is Item'Class;
|
||||
|
||||
type View is access all Item'Class;
|
||||
type Views is array (Index_t range <>) of View;
|
||||
|
||||
|
||||
---------
|
||||
-- Forge
|
||||
--
|
||||
|
||||
overriding
|
||||
procedure define (Self : in out Item; Kind : in facet_Kind);
|
||||
|
||||
overriding
|
||||
procedure destroy (Self : in out Item);
|
||||
|
||||
function new_Primitive (Kind : in facet_Kind;
|
||||
vertex_Count : in Natural) return Primitive.non_indexed.view;
|
||||
|
||||
--------------
|
||||
-- Operations
|
||||
--
|
||||
|
||||
overriding
|
||||
procedure render (Self : in out Item);
|
||||
|
||||
|
||||
|
||||
private
|
||||
|
||||
type Item is limited new Primitive.item with
|
||||
record
|
||||
vertex_Count : Natural := 0;
|
||||
end record;
|
||||
|
||||
end openGL.Primitive.non_indexed;
|
||||
@@ -0,0 +1,185 @@
|
||||
with
|
||||
openGL.Errors,
|
||||
openGL.Buffer,
|
||||
openGL.Tasks,
|
||||
GL.Binding,
|
||||
|
||||
ada.unchecked_Deallocation;
|
||||
|
||||
package body openGL.Primitive.short_indexed
|
||||
is
|
||||
---------
|
||||
--- Forge
|
||||
--
|
||||
|
||||
procedure define (Self : in out Item; Kind : in facet_Kind;
|
||||
Indices : in short_Indices)
|
||||
is
|
||||
use Buffer.short_indices.Forge;
|
||||
buffer_Indices : aliased short_Indices := [Indices'Range => <>];
|
||||
begin
|
||||
for Each in buffer_Indices'Range
|
||||
loop
|
||||
buffer_Indices (Each) := Indices (Each) - 1; -- Adjust indices to zero-based indexing for GL.
|
||||
end loop;
|
||||
|
||||
Self.facet_Kind := Kind;
|
||||
Self.Indices := new Buffer.short_indices.Object' (to_Buffer (buffer_Indices'Access,
|
||||
usage => Buffer.static_Draw));
|
||||
end define;
|
||||
|
||||
|
||||
|
||||
procedure define (Self : in out Item; Kind : in facet_Kind;
|
||||
Indices : in openGL.Indices)
|
||||
is
|
||||
use Buffer.short_indices.Forge;
|
||||
buffer_Indices : aliased short_Indices := [Indices'Range => <>];
|
||||
begin
|
||||
for Each in buffer_Indices'Range
|
||||
loop
|
||||
buffer_Indices (Each) := short_Index_t (Indices (Each) - 1); -- Adjust indices to zero-based indexing for GL.
|
||||
end loop;
|
||||
|
||||
Self.facet_Kind := Kind;
|
||||
Self.Indices := new Buffer.short_indices.Object' (to_Buffer (buffer_Indices'Access,
|
||||
usage => Buffer.static_Draw));
|
||||
end define;
|
||||
|
||||
|
||||
|
||||
procedure define (Self : in out Item; Kind : in facet_Kind;
|
||||
Indices : in long_Indices)
|
||||
is
|
||||
use Buffer.short_indices.Forge;
|
||||
buffer_Indices : aliased short_indices := [Indices'Range => <>];
|
||||
begin
|
||||
for Each in buffer_Indices'Range
|
||||
loop
|
||||
buffer_Indices (Each) := short_Index_t (Indices (Each) - 1); -- Adjust indices to zero-based indexing for GL.
|
||||
end loop;
|
||||
|
||||
Self.facet_Kind := Kind;
|
||||
Self.Indices := new Buffer.short_indices.Object' (to_Buffer (buffer_Indices'Access,
|
||||
usage => Buffer.static_Draw));
|
||||
end define;
|
||||
|
||||
|
||||
|
||||
function new_Primitive (Kind : in facet_Kind;
|
||||
Indices : in short_Indices) return Primitive.short_indexed.view
|
||||
is
|
||||
Self : constant View := new Item;
|
||||
begin
|
||||
define (Self.all, Kind, Indices);
|
||||
return Self;
|
||||
end new_Primitive;
|
||||
|
||||
|
||||
|
||||
function new_Primitive (Kind : in facet_Kind;
|
||||
Indices : in openGL.Indices) return Primitive.short_indexed.view
|
||||
is
|
||||
Self : constant View := new Item;
|
||||
begin
|
||||
define (Self.all, Kind, Indices);
|
||||
return Self;
|
||||
end new_Primitive;
|
||||
|
||||
|
||||
|
||||
function new_Primitive (Kind : in facet_Kind;
|
||||
Indices : in openGL.long_Indices) return Primitive.short_indexed.view
|
||||
is
|
||||
Self : constant View := new Item;
|
||||
begin
|
||||
define (Self.all, Kind, Indices);
|
||||
return Self;
|
||||
end new_Primitive;
|
||||
|
||||
|
||||
|
||||
overriding
|
||||
procedure destroy (Self : in out Item)
|
||||
is
|
||||
procedure free is new ada.unchecked_Deallocation (Buffer.short_Indices.Object'Class,
|
||||
Buffer.short_Indices.view);
|
||||
begin
|
||||
Buffer.destroy (Self.Indices.all);
|
||||
free (Self.Indices);
|
||||
end destroy;
|
||||
|
||||
|
||||
--------------
|
||||
-- Attributes
|
||||
--
|
||||
|
||||
procedure Indices_are (Self : in out Item; Now : in short_Indices)
|
||||
is
|
||||
use Buffer.short_indices;
|
||||
buffer_Indices : aliased short_Indices := [Now'Range => <>];
|
||||
begin
|
||||
for Each in buffer_Indices'Range
|
||||
loop
|
||||
buffer_Indices (Each) := Now (Each) - 1; -- Adjust indices to zero-based-indexing for GL.
|
||||
end loop;
|
||||
|
||||
Self.Indices.set (to => buffer_Indices);
|
||||
end Indices_are;
|
||||
|
||||
|
||||
|
||||
procedure Indices_are (Self : in out Item; Now : in Indices)
|
||||
is
|
||||
use Buffer.short_indices;
|
||||
buffer_Indices : aliased short_Indices := [Now'Range => <>];
|
||||
begin
|
||||
for Each in buffer_Indices'Range
|
||||
loop
|
||||
buffer_Indices (Each) := short_Index_t (Now (Each) - 1); -- Adjust indices to zero-based-indexing for GL.
|
||||
end loop;
|
||||
|
||||
Self.Indices.set (to => buffer_Indices);
|
||||
end Indices_are;
|
||||
|
||||
|
||||
|
||||
procedure Indices_are (Self : in out Item; Now : in long_Indices)
|
||||
is
|
||||
use Buffer.short_indices;
|
||||
buffer_Indices : aliased short_Indices := [Now'Range => <>];
|
||||
begin
|
||||
for Each in buffer_Indices'Range
|
||||
loop
|
||||
buffer_Indices (Each) := short_Index_t (Now (Each) - 1); -- Adjust indices to zero-based-indexing for GL.
|
||||
end loop;
|
||||
|
||||
Self.Indices.set (to => buffer_Indices);
|
||||
end Indices_are;
|
||||
|
||||
|
||||
|
||||
--------------
|
||||
-- Operations
|
||||
--
|
||||
|
||||
overriding
|
||||
procedure render (Self : in out Item)
|
||||
is
|
||||
use GL,
|
||||
GL.Binding;
|
||||
begin
|
||||
Tasks.check;
|
||||
|
||||
openGL.Primitive.item (Self).render; -- Do base class render.
|
||||
Self.Indices.enable;
|
||||
|
||||
glDrawElements (Thin (Self.facet_Kind),
|
||||
gl.GLint (Self.Indices.Length),
|
||||
GL_UNSIGNED_BYTE,
|
||||
null);
|
||||
Errors.log;
|
||||
end render;
|
||||
|
||||
|
||||
end openGL.Primitive.short_indexed;
|
||||
@@ -0,0 +1,65 @@
|
||||
private
|
||||
with
|
||||
openGL.Buffer.short_indices;
|
||||
|
||||
package openGL.Primitive.short_indexed
|
||||
--
|
||||
-- Provides a class for short indexed openGL primitives.
|
||||
--
|
||||
is
|
||||
type Item is limited new Primitive.item with private;
|
||||
subtype Class is Item'Class;
|
||||
|
||||
type View is access all Item'Class;
|
||||
type Views is array (Index_t range <>) of View;
|
||||
|
||||
|
||||
---------
|
||||
-- Forge
|
||||
--
|
||||
|
||||
function new_Primitive (Kind : in facet_Kind;
|
||||
Indices : in openGL.short_Indices) return Primitive.short_indexed.view;
|
||||
|
||||
function new_Primitive (Kind : in facet_Kind;
|
||||
Indices : in openGL.Indices) return Primitive.short_indexed.view;
|
||||
|
||||
function new_Primitive (Kind : in facet_Kind;
|
||||
Indices : in openGL.long_Indices) return Primitive.short_indexed.view;
|
||||
|
||||
procedure define (Self : in out Item; Kind : in facet_Kind;
|
||||
Indices : in openGL.short_Indices);
|
||||
procedure define (Self : in out Item; Kind : in facet_Kind;
|
||||
Indices : in openGL.Indices);
|
||||
procedure define (Self : in out Item; Kind : in facet_Kind;
|
||||
Indices : in openGL.long_Indices);
|
||||
overriding
|
||||
procedure destroy (Self : in out Item);
|
||||
|
||||
|
||||
--------------
|
||||
-- Attributes
|
||||
--
|
||||
|
||||
procedure Indices_are (Self : in out Item; Now : in short_Indices);
|
||||
procedure Indices_are (Self : in out Item; Now : in Indices);
|
||||
procedure Indices_are (Self : in out Item; Now : in long_Indices);
|
||||
|
||||
|
||||
--------------
|
||||
-- Operations
|
||||
--
|
||||
|
||||
overriding
|
||||
procedure render (Self : in out Item);
|
||||
|
||||
|
||||
|
||||
private
|
||||
|
||||
type Item is limited new Primitive.item with
|
||||
record
|
||||
Indices : Buffer.short_indices.view;
|
||||
end record;
|
||||
|
||||
end openGL.Primitive.short_indexed;
|
||||
95
3-mid/opengl/source/lean/geometry/opengl-primitive.adb
Normal file
95
3-mid/opengl/source/lean/geometry/opengl-primitive.adb
Normal file
@@ -0,0 +1,95 @@
|
||||
with
|
||||
openGL.Tasks,
|
||||
GL.Binding,
|
||||
ada.unchecked_Deallocation;
|
||||
|
||||
package body openGL.Primitive
|
||||
is
|
||||
---------
|
||||
-- Forge
|
||||
--
|
||||
|
||||
procedure define (Self : in out Item; Kind : in facet_Kind)
|
||||
is
|
||||
begin
|
||||
Self.facet_Kind := Kind;
|
||||
end define;
|
||||
|
||||
|
||||
procedure free (Self : in out View)
|
||||
is
|
||||
procedure deallocate is new ada.Unchecked_Deallocation (Primitive.item'Class,
|
||||
Primitive.view);
|
||||
begin
|
||||
Self.destroy;
|
||||
deallocate (Self);
|
||||
end free;
|
||||
|
||||
|
||||
--------------
|
||||
-- Attributes
|
||||
--
|
||||
|
||||
function Texture (Self : in Item) return openGL.Texture.Object
|
||||
is
|
||||
begin
|
||||
return Self.Texture;
|
||||
end Texture;
|
||||
|
||||
|
||||
procedure Texture_is (Self : in out Item; Now : in openGL.Texture.Object)
|
||||
is
|
||||
begin
|
||||
Self.Texture := Now;
|
||||
end Texture_is;
|
||||
|
||||
|
||||
|
||||
function Bounds (self : in Item) return openGL.Bounds
|
||||
is
|
||||
begin
|
||||
return Self.Bounds;
|
||||
end Bounds;
|
||||
|
||||
|
||||
procedure Bounds_are (Self : in out Item; Now : in openGL.Bounds)
|
||||
is
|
||||
begin
|
||||
Self.Bounds := Now;
|
||||
end Bounds_are;
|
||||
|
||||
|
||||
|
||||
function is_Transparent (self : in Item) return Boolean
|
||||
is
|
||||
begin
|
||||
return Self.is_Transparent;
|
||||
end is_Transparent;
|
||||
|
||||
|
||||
procedure is_Transparent (Self : in out Item; Now : in Boolean := True)
|
||||
is
|
||||
begin
|
||||
Self.is_Transparent := Now;
|
||||
end is_Transparent;
|
||||
|
||||
|
||||
--------------
|
||||
--- Operations
|
||||
--
|
||||
|
||||
procedure render (Self : in out Item)
|
||||
is
|
||||
use GL,
|
||||
GL.Binding;
|
||||
begin
|
||||
Tasks.check;
|
||||
|
||||
if Self.line_Width /= unused_line_Width
|
||||
then
|
||||
glLineWidth (glFloat (Self.line_Width));
|
||||
end if;
|
||||
end render;
|
||||
|
||||
|
||||
end openGL.Primitive;
|
||||
96
3-mid/opengl/source/lean/geometry/opengl-primitive.ads
Normal file
96
3-mid/opengl/source/lean/geometry/opengl-primitive.ads
Normal file
@@ -0,0 +1,96 @@
|
||||
with
|
||||
openGL.Texture;
|
||||
|
||||
private
|
||||
with
|
||||
ada.unchecked_Conversion;
|
||||
|
||||
package openGL.Primitive
|
||||
--
|
||||
-- Provides a base class for openGL primitives.
|
||||
--
|
||||
is
|
||||
type Item is abstract tagged limited private;
|
||||
subtype Class is Item'Class;
|
||||
|
||||
type View is access all Item'class;
|
||||
type Views is array (Index_t range <>) of View;
|
||||
|
||||
|
||||
----------
|
||||
-- Facets
|
||||
--
|
||||
type facet_Kind is (Points,
|
||||
Lines, line_Loop, line_Strip,
|
||||
Triangles, triangle_Strip, triangle_Fan);
|
||||
|
||||
---------
|
||||
-- Forge
|
||||
--
|
||||
|
||||
procedure define (Self : in out Item; Kind : in facet_Kind);
|
||||
procedure destroy (Self : in out Item) is abstract;
|
||||
procedure free (Self : in out View);
|
||||
|
||||
|
||||
--------------
|
||||
-- Attributes
|
||||
--
|
||||
|
||||
function Texture (Self : in Item) return openGL.Texture.Object;
|
||||
procedure Texture_is (Self : in out Item; Now : in openGL.Texture.Object);
|
||||
|
||||
procedure Bounds_are (Self : in out Item; Now : in openGL.Bounds);
|
||||
function Bounds (self : in Item) return openGL.Bounds;
|
||||
--
|
||||
-- Returns the bounds in object space.
|
||||
|
||||
procedure is_Transparent (Self : in out Item; Now : in Boolean := True);
|
||||
function is_Transparent (Self : in Item) return Boolean;
|
||||
|
||||
|
||||
---------------
|
||||
--- Operations
|
||||
--
|
||||
|
||||
procedure render (Self : in out Item);
|
||||
|
||||
unused_line_Width : constant := -1.0;
|
||||
|
||||
|
||||
|
||||
private
|
||||
|
||||
type Item is abstract tagged limited
|
||||
record
|
||||
facet_Kind : primitive.facet_Kind;
|
||||
Texture : openGL.Texture.Object := openGL.Texture.null_Object;
|
||||
is_Transparent : Boolean;
|
||||
Bounds : openGL.Bounds;
|
||||
line_Width : Real := unused_line_Width;
|
||||
end record;
|
||||
|
||||
|
||||
----------
|
||||
-- Facets
|
||||
--
|
||||
|
||||
function Thin (Self : in facet_Kind) return gl.GLenum;
|
||||
|
||||
for facet_Kind use (Points => gl.GL_POINTS,
|
||||
Lines => gl.GL_LINES,
|
||||
line_Loop => gl.GL_LINE_LOOP,
|
||||
line_Strip => gl.GL_LINE_STRIP,
|
||||
Triangles => gl.GL_TRIANGLES,
|
||||
triangle_Strip => gl.GL_TRIANGLE_STRIP,
|
||||
triangle_Fan => gl.GL_TRIANGLE_FAN);
|
||||
|
||||
for facet_Kind'Size use gl.GLenum'Size;
|
||||
|
||||
function Convert is new ada.Unchecked_Conversion (facet_Kind, gl.GLenum);
|
||||
|
||||
function Thin (Self : in facet_Kind) return gl.GLenum
|
||||
renames Convert;
|
||||
|
||||
|
||||
end openGL.Primitive;
|
||||
Reference in New Issue
Block a user