Add initial prototype.
This commit is contained in:
Rod Kay
361
3-mid/opengl/source/demo/opengl-demo.adb
Normal file
361
3-mid/opengl/source/demo/opengl-demo.adb
Normal file
@@ -0,0 +1,361 @@
|
||||
with
|
||||
openGL.Palette,
|
||||
openGL.Font,
|
||||
openGL.IO,
|
||||
openGL.Model.arrow .colored,
|
||||
openGL.Model.billboard.textured,
|
||||
openGL.Model.box .colored,
|
||||
openGL.Model.box .textured,
|
||||
openGL.Model.box .lit_textured,
|
||||
openGL.Model.capsule .lit_textured,
|
||||
openGL.Model.grid,
|
||||
openGL.Model.hexagon .lit_colored,
|
||||
openGL.Model.hexagon_Column.lit_colored_faceted,
|
||||
openGL.Model.hexagon_Column.lit_colored_rounded,
|
||||
openGL.Model.line .colored,
|
||||
openGL.Model.any,
|
||||
openGL.Model.polygon .lit_colored,
|
||||
openGL.Model.segment_line,
|
||||
openGL.Model.sphere .colored,
|
||||
openGL.Model.sphere .lit_colored,
|
||||
openGL.Model.sphere .lit_textured,
|
||||
openGL.Model.Text .lit_colored,
|
||||
openGL.Model.terrain,
|
||||
|
||||
SDL.Video.Windows.Makers,
|
||||
ada.Text_IO;
|
||||
|
||||
|
||||
package body openGL.Demo
|
||||
is
|
||||
-- package std_SDL renames standard.SDL;
|
||||
|
||||
|
||||
procedure my_context_Setter
|
||||
is
|
||||
begin
|
||||
sdl.Video.gl.set_Current (GL_Context, To => Window);
|
||||
end my_context_Setter;
|
||||
|
||||
|
||||
procedure my_Swapper
|
||||
is
|
||||
use sdl.Video.GL;
|
||||
begin
|
||||
swap (Window);
|
||||
end my_Swapper;
|
||||
|
||||
|
||||
procedure define (Name : in String;
|
||||
Width : in Positive := 1366;
|
||||
Height : in Positive := 768)
|
||||
is
|
||||
use Palette,
|
||||
linear_Algebra_3d,
|
||||
SDL;
|
||||
use type sdl.Video.Windows.Window_Flags;
|
||||
|
||||
null_Context : SDL.Video.GL.Contexts;
|
||||
|
||||
begin
|
||||
if not sdl.initialise
|
||||
then
|
||||
raise Error with "Unable to initialise SDL.";
|
||||
end if;
|
||||
|
||||
Video.Windows.Makers.create (Win => Window,
|
||||
Title => Name,
|
||||
X => 100,
|
||||
Y => 100,
|
||||
Width => C.int (Width),
|
||||
Height => C.int (Height),
|
||||
Flags => Video.Windows.openGL
|
||||
or Video.Windows.Resizable);
|
||||
|
||||
Video.GL.create (GL_Context, From => Window);
|
||||
|
||||
Renderer.define;
|
||||
Renderer.Background_is (Grey);
|
||||
Renderer.Swapper_is (my_Swapper'unrestricted_Access);
|
||||
|
||||
sdl.Video.gl.set_Current (null_Context, To => Window);
|
||||
Renderer.Context_Setter_is (my_context_Setter'unrestricted_Access);
|
||||
Renderer.start_Engine;
|
||||
|
||||
Camera.define;
|
||||
Camera.Renderer_is (Renderer'unchecked_Access);
|
||||
Camera.Position_is ([0.0, 0.0, 5.0],
|
||||
y_Rotation_from (to_Radians (0.0)));
|
||||
|
||||
Camera.Viewport_is (width => Width,
|
||||
height => Height);
|
||||
end define;
|
||||
|
||||
|
||||
|
||||
procedure destroy
|
||||
is
|
||||
begin
|
||||
Camera .destroy;
|
||||
Renderer.stop_Engine;
|
||||
ada.Text_IO.new_Line;
|
||||
end destroy;
|
||||
|
||||
|
||||
function Models return openGL.Model.views
|
||||
is
|
||||
use Model,
|
||||
Palette;
|
||||
|
||||
the_Texture : constant asset_Name := to_Asset ("assets/opengl/texture/Face1.bmp");
|
||||
the_font_Id : constant Font.font_Id := (to_Asset ("assets/opengl/font/LiberationMono-Regular.ttf"),
|
||||
Size => 12);
|
||||
|
||||
the_arrow_Model : constant Model.arrow.colored.view
|
||||
:= Model.arrow.colored.new_Arrow (End_2 => [0.0, 1.0, 0.0]);
|
||||
|
||||
the_ball_1_Model : constant Model.sphere.colored.view
|
||||
:= Model.sphere.colored.new_Sphere (Radius => 0.5, Color => (Red, Opaque));
|
||||
|
||||
the_ball_2_Model : constant Model.sphere.lit_colored.view
|
||||
:= Model.sphere.lit_colored.new_Sphere (Radius => 1.0, Color => (Green, Opaque));
|
||||
|
||||
the_ball_3_Model : constant Model.sphere.lit_textured.view
|
||||
:= Model.sphere.lit_textured.new_Sphere (Radius => 1.0, Image => the_Texture);
|
||||
|
||||
the_billboard_Model : constant Model.billboard.textured.view
|
||||
:= Model.billboard.textured.forge.new_Billboard (Size => (1.0, 1.0),
|
||||
Plane => Billboard.xy,
|
||||
Texture => the_Texture);
|
||||
|
||||
the_colored_billboard_Model : constant Model.billboard.textured.view
|
||||
:= Model.billboard.textured.forge.new_Billboard (Size => (1.0, 1.0),
|
||||
Plane => Billboard.xy,
|
||||
Texture => the_Texture);
|
||||
use Model.box;
|
||||
|
||||
the_box_1_Model : constant Model.box.colored.view
|
||||
:= Model.box.colored.new_Box
|
||||
(Size => [1.0, 2.0, 3.0],
|
||||
Faces => [Front => (Colors => [others => (Blue, Opaque)]),
|
||||
Rear => (Colors => [others => (Blue, Opaque)]),
|
||||
Upper => (Colors => [others => (Green, Opaque)]),
|
||||
Lower => (Colors => [others => (Green, Opaque)]),
|
||||
Left => (Colors => [others => (Dark_Red, Opaque)]),
|
||||
Right => (Colors => [others => (Red, Opaque)])]);
|
||||
|
||||
the_box_2_Model : constant Model.box.lit_textured.view
|
||||
:= Model.box.lit_textured.new_Box
|
||||
(Size => [1.0, 2.0, 1.0],
|
||||
Faces => [others => (texture_Name => the_Texture)]);
|
||||
|
||||
the_box_3_Model : constant Model.box.textured.view
|
||||
:= Model.box.textured.new_Box
|
||||
(Size => [1.0, 2.0, 3.0],
|
||||
Faces => [others => (texture_Name => the_Texture)]);
|
||||
|
||||
the_capsule_Model : constant Model.capsule.lit_textured.view
|
||||
:= Model.capsule.lit_textured.new_Capsule (Radius => 0.5,
|
||||
Height => 2.0,
|
||||
Image => the_Texture);
|
||||
the_grid_Model : constant Model.grid.view
|
||||
:= Model.grid.new_grid_Model (Color => Red,
|
||||
Width => 3,
|
||||
Height => 3);
|
||||
|
||||
the_hexagon_Model : constant Model.hexagon.lit_colored.view
|
||||
:= Model.hexagon.lit_colored.new_Hexagon (Radius => 0.25,
|
||||
Face => (center_Color => (Green, Opaque),
|
||||
Colors => [others => (Red, Opaque)]));
|
||||
|
||||
the_faceted_hexagon_column_Model : constant Model.hexagon_Column.lit_colored_faceted.view
|
||||
:= Model.hexagon_Column.lit_colored_faceted.new_hexagon_Column
|
||||
(Radius => 0.25,
|
||||
Height => 1.0,
|
||||
Upper => (center_Color => (Green, Opaque), Colors => [others => (Red, Opaque)]),
|
||||
Lower => (center_Color => (Green, Opaque), Colors => [others => (Red, Opaque)]),
|
||||
Shaft => (Color => (Green, Opaque)));
|
||||
|
||||
the_rounded_hexagon_column_Model : constant Model.hexagon_Column.lit_colored_rounded.view
|
||||
:= Model.hexagon_Column.lit_colored_rounded.new_hexagon_Column
|
||||
(Radius => 0.25,
|
||||
Height => 1.0,
|
||||
Upper => (center_Color => (Green, Opaque), Colors => [others => (Red, Opaque)]),
|
||||
Lower => (center_Color => (Green, Opaque), Colors => [others => (Red, Opaque)]),
|
||||
Shaft => (Color => (White, Opaque)));
|
||||
|
||||
the_line_Model : constant Model.line.colored.view
|
||||
:= Model.line.colored.new_line_Model (Color => Red,
|
||||
End_1 => [0.0, 0.0, 0.0],
|
||||
End_2 => [5.0, 5.0, 0.0]);
|
||||
|
||||
the_collada_Model : constant Model.any.view
|
||||
:= Model.any.new_Model (--Scale => (1.0, 1.0, 1.0),
|
||||
Model => to_Asset ("assets/opengl/model/human.dae"),
|
||||
Texture => the_Texture,
|
||||
Texture_is_lucid => False);
|
||||
|
||||
the_wavefront_Model : constant Model.any.view
|
||||
:= Model.any.new_Model (--Scale => (1.0, 1.0, 1.0),
|
||||
Model => to_Asset ("assets/opengl/model/human.obj"),
|
||||
Texture => the_Texture,
|
||||
Texture_is_lucid => False);
|
||||
|
||||
the_polygon_Model : constant Model.polygon.lit_colored.view
|
||||
:= Model.polygon.lit_colored.new_Polygon (Vertices => [Origin_2D, [1.0, 0.0], [1.0, 1.0], [-1.0, 0.5]],
|
||||
Color => (Red, Opaque));
|
||||
|
||||
the_text_Model : constant Model.Text.lit_colored.view
|
||||
:= Model.Text.lit_colored.new_Text (Text => "Once upon a midnight dreary ...",
|
||||
Font => the_font_Id,
|
||||
Color => (Green, Opaque),
|
||||
Centered => True);
|
||||
|
||||
the_segment_line_Model : constant Model.segment_line.view
|
||||
:= Model.segment_line.new_segment_line_Model (Color => Green);
|
||||
|
||||
-- Terrain
|
||||
--
|
||||
heights_File : constant asset_Name := to_Asset ("assets/opengl/terrain/kidwelly-terrain.png");
|
||||
texture_File : constant asset_Name := to_Asset ("assets/opengl/terrain/kidwelly-terrain-texture.png");
|
||||
|
||||
the_Region : constant IO.height_Map_view := IO.to_height_Map (heights_File, 10.0);
|
||||
Tiling : constant texture_Transform_2d := (S => (0.0, 1.0),
|
||||
T => (0.0, 1.0));
|
||||
the_ground_Model : constant Model.terrain.view
|
||||
:= Model.Terrain.new_Terrain (heights_Asset => heights_File,
|
||||
Row => 1,
|
||||
Col => 1,
|
||||
Heights => the_Region.all'Access,
|
||||
Color_Map => texture_File,
|
||||
Tiling => Tiling);
|
||||
begin
|
||||
Demo.Renderer.add_Font (the_font_Id);
|
||||
|
||||
the_segment_line_Model.add_1st_Segment (start_Site => [0.0, 0.0, 0.0],
|
||||
end_Site => [1.0, 1.0, 0.0]);
|
||||
the_segment_line_Model.add_Segment (end_Site => [0.0, 1.0, 0.0]);
|
||||
the_segment_line_Model.add_Segment (end_Site => [2.0, 2.0, 0.0]);
|
||||
the_segment_line_Model.add_Segment (end_Site => [0.0, 2.0, 0.0]);
|
||||
|
||||
return [ the_ground_Model.all'Access,
|
||||
the_polygon_Model.all'Access,
|
||||
the_text_Model.all'Access,
|
||||
the_arrow_Model.all'Access,
|
||||
the_ball_1_Model.all'Access,
|
||||
the_ball_2_Model.all'Access,
|
||||
the_ball_3_Model.all'Access,
|
||||
|
||||
the_billboard_Model.all'Access,
|
||||
the_colored_billboard_Model.all'Access,
|
||||
the_box_1_Model.all'Access,
|
||||
the_box_2_Model.all'Access,
|
||||
the_box_3_Model.all'Access,
|
||||
|
||||
the_capsule_Model.all'Access,
|
||||
the_grid_Model.all'Access,
|
||||
|
||||
the_hexagon_Model.all'Access,
|
||||
the_faceted_hexagon_column_Model.all'Access,
|
||||
the_rounded_hexagon_column_Model.all'Access,
|
||||
|
||||
the_line_Model.all'Access,
|
||||
the_collada_Model.all'Access,
|
||||
the_wavefront_Model.all'Access,
|
||||
|
||||
the_segment_line_Model.all'Access];
|
||||
end Models;
|
||||
|
||||
|
||||
procedure layout (the_Visuals : in Visual.views)
|
||||
is
|
||||
initial_X : constant openGL.Real := -6.0;
|
||||
initial_Y : constant openGL.Real := 6.0;
|
||||
|
||||
X : openGL.Real := initial_X;
|
||||
Y : openGL.Real := initial_Y;
|
||||
Pad : constant openGL.Real := 3.0;
|
||||
i : Positive := 1;
|
||||
|
||||
procedure set_next_Visual_Site
|
||||
is
|
||||
begin
|
||||
the_Visuals (i).Site_is ([X, Y, 0.0]);
|
||||
|
||||
i := i + 1;
|
||||
X := X + Pad;
|
||||
end set_next_Visual_Site;
|
||||
|
||||
procedure new_Line
|
||||
is
|
||||
begin
|
||||
X := initial_X;
|
||||
Y := Y - Pad;
|
||||
end new_Line;
|
||||
|
||||
begin
|
||||
set_next_Visual_Site;
|
||||
set_next_Visual_Site;
|
||||
set_next_Visual_Site;
|
||||
set_next_Visual_Site;
|
||||
|
||||
new_Line;
|
||||
set_next_Visual_Site;
|
||||
set_next_Visual_Site;
|
||||
set_next_Visual_Site;
|
||||
set_next_Visual_Site;
|
||||
set_next_Visual_Site;
|
||||
|
||||
new_Line;
|
||||
set_next_Visual_Site;
|
||||
set_next_Visual_Site;
|
||||
|
||||
new_Line;
|
||||
set_next_Visual_Site;
|
||||
set_next_Visual_Site;
|
||||
set_next_Visual_Site;
|
||||
|
||||
new_Line;
|
||||
set_next_Visual_Site;
|
||||
set_next_Visual_Site;
|
||||
set_next_Visual_Site;
|
||||
|
||||
new_Line;
|
||||
set_next_Visual_Site;
|
||||
set_next_Visual_Site;
|
||||
set_next_Visual_Site;
|
||||
|
||||
new_Line;
|
||||
set_next_Visual_Site;
|
||||
end layout;
|
||||
|
||||
|
||||
procedure print_Usage (append_Message : in String := "")
|
||||
is
|
||||
use ada.Text_IO;
|
||||
begin
|
||||
put_Line ("Camera controls: 'w' => Move forward");
|
||||
put_Line (" 'z' => Move backward");
|
||||
put_Line (" 'a' => Move left");
|
||||
put_Line (" 's' => Move right");
|
||||
put_Line (" 'e' => Move up");
|
||||
put_Line (" 'd' => Move down");
|
||||
put_Line (" 'W' => Rotate clockwise about Z-axis");
|
||||
put_Line (" 'Z' => Rotate counter-clockwise about Z-axis");
|
||||
put_Line (" 'A' => Orbit clockwise about Y-Axis");
|
||||
put_Line (" 'S' => Orbit counter clockwise about Y-axis");
|
||||
put_Line (" 'E' => Rotate clockwise about X-axis");
|
||||
put_Line (" 'D' => Rotate counter clockwise about X-axis");
|
||||
put_Line (" 'q' => Quit");
|
||||
|
||||
new_Line;
|
||||
|
||||
if append_Message /= ""
|
||||
then
|
||||
put_Line (append_Message);
|
||||
new_Line;
|
||||
end if;
|
||||
end print_Usage;
|
||||
|
||||
|
||||
end openGL.Demo;
|
||||
43
3-mid/opengl/source/demo/opengl-demo.ads
Normal file
43
3-mid/opengl/source/demo/opengl-demo.ads
Normal file
@@ -0,0 +1,43 @@
|
||||
with
|
||||
openGL.Model,
|
||||
openGL.Visual,
|
||||
openGL.Renderer.lean,
|
||||
openGL.Camera,
|
||||
openGL.Dolly,
|
||||
openGL.frame_Counter,
|
||||
|
||||
sdl.Video.Windows,
|
||||
sdl.Video.GL;
|
||||
|
||||
|
||||
package openGL.Demo
|
||||
--
|
||||
-- Provides a convenient method of setting up a simple openGL demo.
|
||||
--
|
||||
is
|
||||
Window : standard.sdl.Video.Windows.Window;
|
||||
GL_Context : standard.sdl.Video.GL.Contexts;
|
||||
|
||||
Renderer : aliased openGL.Renderer.lean.item;
|
||||
Camera : aliased openGL.Camera.item;
|
||||
Dolly : openGL.Dolly.item (camera => Camera'unchecked_Access);
|
||||
FPS_Counter : openGL.frame_Counter.item;
|
||||
Done : Boolean := False;
|
||||
|
||||
function Models return openGL.Model.views;
|
||||
--
|
||||
-- Creates a set of models with one model of each kind.
|
||||
|
||||
procedure layout (the_Visuals : in openGL.Visual.views);
|
||||
--
|
||||
-- Layout the visuals in a grid fashion for viewing all at once.
|
||||
|
||||
procedure print_Usage (append_Message : in String := "");
|
||||
|
||||
|
||||
procedure define (Name : in String;
|
||||
Width : in Positive := 1366;
|
||||
Height : in Positive := 768);
|
||||
procedure destroy;
|
||||
|
||||
end openGL.Demo;
|
||||
13
3-mid/opengl/source/desk/opengl-raster.adb
Normal file
13
3-mid/opengl/source/desk/opengl-raster.adb
Normal file
@@ -0,0 +1,13 @@
|
||||
package body openGL.Raster
|
||||
is
|
||||
|
||||
procedure set_Window_Position (X, Y : in Real;
|
||||
Z : in Real := 0.0;
|
||||
W : in Real := 1.0)
|
||||
is
|
||||
pragma Unreferenced (Z, W);
|
||||
begin
|
||||
raise Program_Error with "TODO: unimplemented";
|
||||
end set_Window_Position;
|
||||
|
||||
end openGL.Raster;
|
||||
11
3-mid/opengl/source/desk/opengl-raster.ads
Normal file
11
3-mid/opengl/source/desk/opengl-raster.ads
Normal file
@@ -0,0 +1,11 @@
|
||||
package openGL.Raster
|
||||
--
|
||||
-- Provides raster operations.
|
||||
--
|
||||
is
|
||||
|
||||
procedure set_Window_Position (X, Y : in Real;
|
||||
Z : in Real := 0.0; -- Default of '0.0' places text in front of all other renders.
|
||||
W : in Real := 1.0);
|
||||
|
||||
end openGL.Raster;
|
||||
107
3-mid/opengl/source/lean/buffer/opengl-buffer-general.adb
Normal file
107
3-mid/opengl/source/lean/buffer/opengl-buffer-general.adb
Normal file
@@ -0,0 +1,107 @@
|
||||
with
|
||||
openGL.Errors,
|
||||
openGL.Tasks,
|
||||
|
||||
GL.Pointers;
|
||||
|
||||
package body openGL.Buffer.general
|
||||
is
|
||||
--------------------------
|
||||
-- 'vertex buffer' Object
|
||||
--
|
||||
|
||||
package body Forge
|
||||
is
|
||||
function to_Buffer (From : access constant Element_Array;
|
||||
Usage : in Buffer.Usage) return Object
|
||||
is
|
||||
use GL.Pointers;
|
||||
begin
|
||||
Tasks.check;
|
||||
|
||||
return new_Buffer : Object
|
||||
do
|
||||
new_Buffer.Usage := Usage;
|
||||
new_Buffer.Length := From'Length;
|
||||
new_Buffer.verify_Name;
|
||||
new_Buffer.enable;
|
||||
|
||||
glBufferData (to_GL_Enum (new_Buffer.Kind),
|
||||
From.all'Size / 8,
|
||||
+From (From'First)'Address,
|
||||
to_GL_Enum (Usage));
|
||||
Errors.log;
|
||||
end return;
|
||||
end to_Buffer;
|
||||
|
||||
|
||||
function to_Buffer (From : in Element_Array;
|
||||
Usage : in Buffer.Usage) return Object
|
||||
is
|
||||
use GL.Pointers;
|
||||
begin
|
||||
Tasks.check;
|
||||
|
||||
return new_Buffer : Object
|
||||
do
|
||||
new_Buffer.Usage := Usage;
|
||||
new_Buffer.Length := From'Length;
|
||||
new_Buffer.verify_Name;
|
||||
new_Buffer.enable;
|
||||
|
||||
glBufferData (to_GL_Enum (new_Buffer.Kind),
|
||||
From'Size / 8,
|
||||
+From (From'First)'Address,
|
||||
to_GL_Enum (Usage));
|
||||
end return;
|
||||
end to_Buffer;
|
||||
|
||||
end Forge;
|
||||
|
||||
|
||||
|
||||
procedure set (Self : in out Object; Position : in Positive := 1;
|
||||
To : in Element_Array)
|
||||
is
|
||||
use GL.Pointers;
|
||||
|
||||
new_Vertices : aliased Element_Array := To;
|
||||
Vertex_Size_in_bits : constant Natural := To (To'First)'Size;
|
||||
|
||||
begin
|
||||
Tasks.check;
|
||||
|
||||
if Self.Length = To'Length
|
||||
then
|
||||
Self.enable;
|
||||
glBufferSubData (Target => to_GL_Enum (Self.Kind),
|
||||
Offset => GLintptr ((Position - 1) * Vertex_Size_in_bits / 8),
|
||||
Size => new_Vertices'Size / 8,
|
||||
Data => +new_Vertices (new_Vertices'First)'Address);
|
||||
else
|
||||
Self.destroy;
|
||||
|
||||
Self.verify_Name;
|
||||
Self.Length := To'Length;
|
||||
Self.enable;
|
||||
|
||||
glBufferData (to_GL_Enum (Self.Kind),
|
||||
To'Size / 8,
|
||||
+To (To'First)'Address,
|
||||
to_GL_Enum (Self.Usage));
|
||||
end if;
|
||||
|
||||
Errors.log;
|
||||
end set;
|
||||
|
||||
|
||||
|
||||
procedure set (Self : in out Object; Position : in Positive := 1;
|
||||
To : access constant Element_Array)
|
||||
is
|
||||
begin
|
||||
Self.set (Position, To.all);
|
||||
end set;
|
||||
|
||||
|
||||
end openGL.Buffer.general;
|
||||
53
3-mid/opengl/source/lean/buffer/opengl-buffer-general.ads
Normal file
53
3-mid/opengl/source/lean/buffer/opengl-buffer-general.ads
Normal file
@@ -0,0 +1,53 @@
|
||||
generic
|
||||
type base_Object is new openGL.Buffer.Object with private;
|
||||
|
||||
type Index is range <>;
|
||||
type Element is private;
|
||||
type Element_Array is array (Index range <>) of Element;
|
||||
|
||||
package openGL.Buffer.general
|
||||
--
|
||||
-- A generic for producing various types of openGL vertex buffer objects.
|
||||
--
|
||||
is
|
||||
type Object is new base_Object with private;
|
||||
type View is access all Object'Class;
|
||||
|
||||
|
||||
---------
|
||||
-- Forge
|
||||
--
|
||||
|
||||
package Forge
|
||||
is
|
||||
function to_Buffer (From : access constant Element_Array;
|
||||
Usage : in Buffer.Usage) return Object;
|
||||
|
||||
function to_Buffer (From : in Element_Array;
|
||||
Usage : in Buffer.Usage) return Object;
|
||||
end Forge;
|
||||
|
||||
|
||||
--------------
|
||||
-- Operations
|
||||
--
|
||||
|
||||
procedure set (Self : in out Object; Position : in Positive := 1;
|
||||
To : in Element_Array);
|
||||
|
||||
procedure set (Self : in out Object; Position : in Positive := 1;
|
||||
To : access constant Element_Array);
|
||||
|
||||
|
||||
|
||||
private
|
||||
|
||||
type Object is new base_Object with
|
||||
record
|
||||
Usage : Buffer.Usage;
|
||||
end record;
|
||||
|
||||
default_Terminator : Element; -- No 'Interfaces.C.Pointers' subprogram is called which uses the default terminator, so
|
||||
-- a default 'Element' should suffice.
|
||||
|
||||
end openGL.Buffer.general;
|
||||
@@ -0,0 +1,7 @@
|
||||
with
|
||||
openGL.Buffer.general;
|
||||
|
||||
package openGL.Buffer.indices is new openGL.Buffer.general (base_Object => Buffer.element_array_Object,
|
||||
Index => long_Index_t,
|
||||
Element => Index_t,
|
||||
Element_Array => Indices);
|
||||
@@ -0,0 +1,7 @@
|
||||
with
|
||||
openGL.Buffer.general;
|
||||
|
||||
package openGL.Buffer.long_indices is new openGL.Buffer.general (base_Object => Buffer.element_array_Object,
|
||||
Index => long_Index_t,
|
||||
Element => long_Index_t,
|
||||
Element_Array => long_Indices);
|
||||
@@ -0,0 +1,7 @@
|
||||
with
|
||||
openGL.Buffer.general;
|
||||
|
||||
package openGL.Buffer.normals is new openGL.Buffer.general (base_Object => Buffer.array_Object,
|
||||
Index => Index_t,
|
||||
Element => Normal,
|
||||
Element_Array => Normals);
|
||||
@@ -0,0 +1,7 @@
|
||||
with
|
||||
openGL.Buffer.general;
|
||||
|
||||
package openGL.Buffer.short_indices is new openGL.Buffer.general (base_Object => Buffer.element_array_Object,
|
||||
Index => long_Index_t,
|
||||
Element => short_Index_t,
|
||||
Element_Array => short_Indices);
|
||||
@@ -0,0 +1,7 @@
|
||||
with
|
||||
openGL.Buffer.general;
|
||||
|
||||
package openGL.Buffer.texture_coords is new openGL.Buffer.general (base_Object => Buffer.array_Object,
|
||||
Index => Index_t,
|
||||
Element => Coordinate_2D,
|
||||
Element_Array => Coordinates_2D);
|
||||
7
3-mid/opengl/source/lean/buffer/opengl-buffer-vertex.ads
Normal file
7
3-mid/opengl/source/lean/buffer/opengl-buffer-vertex.ads
Normal file
@@ -0,0 +1,7 @@
|
||||
with
|
||||
openGL.Buffer.general;
|
||||
|
||||
package openGL.Buffer.vertex is new openGL.Buffer.general (base_Object => Buffer.array_Object,
|
||||
Index => Index_t,
|
||||
Element => Site,
|
||||
Element_Array => Sites);
|
||||
134
3-mid/opengl/source/lean/buffer/opengl-buffer.adb
Normal file
134
3-mid/opengl/source/lean/buffer/opengl-buffer.adb
Normal file
@@ -0,0 +1,134 @@
|
||||
with
|
||||
openGL.Errors,
|
||||
openGL.Tasks,
|
||||
ada.unchecked_Deallocation;
|
||||
|
||||
package body openGL.Buffer
|
||||
is
|
||||
use type a_Name;
|
||||
|
||||
|
||||
---------------
|
||||
-- Buffer Name
|
||||
--
|
||||
|
||||
function new_vbo_Name return a_Name
|
||||
is
|
||||
Name : aliased a_Name;
|
||||
begin
|
||||
Tasks.check;
|
||||
glGenBuffers (1, Name'unchecked_Access);
|
||||
return Name;
|
||||
end new_vbo_Name;
|
||||
|
||||
|
||||
|
||||
procedure free (vbo_Name : in a_Name)
|
||||
is
|
||||
Name : aliased a_Name := vbo_Name;
|
||||
begin
|
||||
Tasks.check;
|
||||
glDeleteBuffers (1, Name'unchecked_Access);
|
||||
end free;
|
||||
pragma Unreferenced (free);
|
||||
|
||||
|
||||
----------
|
||||
-- Object
|
||||
--
|
||||
|
||||
procedure verify_Name (Self : in out Object'Class)
|
||||
is
|
||||
begin
|
||||
if Self.Name = 0 then
|
||||
Self.Name := new_vbo_Name;
|
||||
end if;
|
||||
end verify_Name;
|
||||
|
||||
|
||||
|
||||
function Name (Self : in Object) return Buffer.a_Name
|
||||
is
|
||||
begin
|
||||
return Self.Name;
|
||||
end Name;
|
||||
|
||||
|
||||
|
||||
procedure enable (Self : in Object'Class)
|
||||
is
|
||||
pragma assert (Self.Name > 0);
|
||||
begin
|
||||
Tasks.check;
|
||||
glBindBuffer (to_GL_Enum (Self.Kind),
|
||||
Self.Name);
|
||||
openGL.Errors.log;
|
||||
end enable;
|
||||
|
||||
|
||||
|
||||
procedure destroy (Self : in out Object'Class)
|
||||
is
|
||||
begin
|
||||
Tasks.check;
|
||||
|
||||
glBindBuffer (to_GL_Enum (Self.Kind), 0);
|
||||
openGL.Errors.log;
|
||||
|
||||
glDeleteBuffers (1, Self.Name'Access);
|
||||
openGL.Errors.log;
|
||||
|
||||
Self.Name := 0;
|
||||
end destroy;
|
||||
|
||||
|
||||
|
||||
procedure free (Self : in out View)
|
||||
is
|
||||
procedure deallocate is new ada.unchecked_Deallocation (Buffer.Object'Class,
|
||||
Buffer.view);
|
||||
begin
|
||||
if Self /= null
|
||||
then
|
||||
Self.destroy;
|
||||
deallocate (Self);
|
||||
end if;
|
||||
end free;
|
||||
|
||||
|
||||
|
||||
function Length (Self : in Object) return Positive
|
||||
is
|
||||
begin
|
||||
return Self.Length;
|
||||
end Length;
|
||||
|
||||
|
||||
-------------------------
|
||||
-- 'array' Buffer Object
|
||||
--
|
||||
|
||||
overriding
|
||||
function Kind (Self : in array_Object) return Buffer.a_Kind
|
||||
is
|
||||
pragma Unreferenced (Self);
|
||||
begin
|
||||
return array_Buffer;
|
||||
end Kind;
|
||||
|
||||
|
||||
|
||||
---------------------------------
|
||||
-- 'element array' Buffer object
|
||||
--
|
||||
|
||||
overriding
|
||||
function Kind (Self : in element_array_Object) return Buffer.a_Kind
|
||||
is
|
||||
pragma Unreferenced (Self);
|
||||
begin
|
||||
return element_array_Buffer;
|
||||
end Kind;
|
||||
|
||||
|
||||
end openGL.Buffer;
|
||||
124
3-mid/opengl/source/lean/buffer/opengl-buffer.ads
Normal file
124
3-mid/opengl/source/lean/buffer/opengl-buffer.ads
Normal file
@@ -0,0 +1,124 @@
|
||||
private
|
||||
with
|
||||
GL.lean,
|
||||
ada.unchecked_Conversion;
|
||||
|
||||
package openGL.Buffer
|
||||
--
|
||||
-- Models a buffer object.
|
||||
--
|
||||
is
|
||||
--------------
|
||||
--- Core Types
|
||||
--
|
||||
subtype a_Name is GL.GLuint; -- An openGL vertex buffer 'Name', which is a natural integer.
|
||||
type a_Kind is (array_Buffer, element_array_Buffer);
|
||||
type Usage is (stream_Draw, static_Draw, dynamic_Draw);
|
||||
|
||||
|
||||
-----------------
|
||||
-- Buffer Object
|
||||
--
|
||||
type Object is abstract tagged limited private;
|
||||
type View is access all Object'Class;
|
||||
|
||||
procedure destroy (Self : in out Object'Class);
|
||||
procedure free (Self : in out View);
|
||||
|
||||
|
||||
--------------
|
||||
-- Attributes
|
||||
--
|
||||
|
||||
function Name (Self : in Object) return Buffer.a_Name;
|
||||
function Kind (Self : in Object) return Buffer.a_Kind is abstract;
|
||||
function Length (Self : in Object) return Positive;
|
||||
|
||||
|
||||
--------------
|
||||
-- Operations
|
||||
--
|
||||
|
||||
procedure enable (Self : in Object'Class);
|
||||
|
||||
|
||||
-----------------------------------------------
|
||||
-- Derived 'array' and 'element array' Classes
|
||||
--
|
||||
|
||||
type array_Object is new Object with private;
|
||||
type element_array_Object is new Object with private;
|
||||
|
||||
--
|
||||
-- Refer to child packages, for specific buffers:
|
||||
--
|
||||
-- - gl.Buffer.vertex
|
||||
-- - gl.Buffer.texture_coords
|
||||
-- - gl.Buffer.normals
|
||||
-- - gl.Buffer.indices
|
||||
--
|
||||
-- (TODO: pixel pack/unpack buffers)
|
||||
|
||||
|
||||
----------
|
||||
-- Errors
|
||||
--
|
||||
|
||||
no_platform_Support : exception;
|
||||
--
|
||||
-- Raised by buffer 'Map' functions when OS platform does not
|
||||
-- support GL Buffer objects.
|
||||
|
||||
|
||||
|
||||
private
|
||||
use GL.lean;
|
||||
|
||||
|
||||
-- Buffer Kinds
|
||||
--
|
||||
|
||||
for a_Kind use (array_Buffer => GL_ARRAY_BUFFER,
|
||||
element_array_Buffer => GL_ELEMENT_ARRAY_BUFFER);
|
||||
|
||||
for a_Kind'Size use gl.GLenum'Size;
|
||||
|
||||
function to_GL_Enum is new ada.unchecked_Conversion (a_Kind, gl.GLenum);
|
||||
|
||||
|
||||
-- Usage
|
||||
--
|
||||
for Usage use (stream_Draw => GL_STREAM_DRAW,
|
||||
static_Draw => GL_STATIC_DRAW,
|
||||
dynamic_Draw => GL_DYNAMIC_DRAW);
|
||||
|
||||
for Usage'Size use GL.GLenum'Size;
|
||||
|
||||
function to_GL_Enum is new ada.unchecked_Conversion (Usage, gl.GLenum);
|
||||
|
||||
|
||||
----------
|
||||
-- Object
|
||||
--
|
||||
|
||||
type Object is abstract tagged limited
|
||||
record
|
||||
Name : aliased Buffer.a_Name := 0;
|
||||
Length : Positive;
|
||||
end record;
|
||||
|
||||
overriding
|
||||
function Kind (Self : in array_Object) return Buffer.a_Kind;
|
||||
|
||||
overriding
|
||||
function Kind (Self : in element_array_Object) return Buffer.a_Kind;
|
||||
|
||||
type array_Object is new Object with null record;
|
||||
type element_array_Object is new Object with null record;
|
||||
|
||||
|
||||
-- Support
|
||||
--
|
||||
procedure verify_Name (Self : in out Object'Class);
|
||||
|
||||
end openGL.Buffer;
|
||||
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;
|
||||
325
3-mid/opengl/source/lean/io/opengl-io-collada.adb
Normal file
325
3-mid/opengl/source/lean/io/opengl-io-collada.adb
Normal file
@@ -0,0 +1,325 @@
|
||||
with
|
||||
collada.Document,
|
||||
collada.Library.geometries,
|
||||
collada.Library.controllers,
|
||||
|
||||
ada.Text_IO;
|
||||
|
||||
|
||||
package body openGL.IO.collada
|
||||
is
|
||||
package std_Collada renames Standard.Collada;
|
||||
|
||||
|
||||
function to_Model (model_Path : in String) return IO.Model
|
||||
is
|
||||
use std_Collada.Library,
|
||||
std_Collada.Library.geometries,
|
||||
ada.Text_IO;
|
||||
|
||||
use type std_Collada.Library.controllers.Controller_array_view;
|
||||
|
||||
|
||||
which_Geometry : constant := 1; -- Select which gemometry, just for testing.
|
||||
|
||||
the_Document : constant std_Collada.Document.item := std_Collada.Document.to_Document (model_Path);
|
||||
|
||||
the_Mesh : constant geometries.Mesh := the_Document.Libraries.Geometries.Contents (which_Geometry).Mesh;
|
||||
the_Primitive : constant geometries.Primitive := the_Mesh.Primitives (1);
|
||||
|
||||
collada_Positions : constant access std_Collada.Float_array := Positions_of (the_Mesh);
|
||||
collada_Normals : constant access std_Collada.Float_array := Normals_of (the_Mesh, the_Primitive);
|
||||
collada_Coords : constant access std_Collada.Float_array := Coords_of (the_Mesh, the_Primitive);
|
||||
|
||||
|
||||
function get_coord_Count return long_Index_t
|
||||
is
|
||||
begin
|
||||
if collada_Coords = null
|
||||
then
|
||||
return 0;
|
||||
else
|
||||
return collada_Coords'Length / 2;
|
||||
end if;
|
||||
end get_coord_Count;
|
||||
|
||||
|
||||
site_Count : constant long_Index_t := collada_Positions'Length / 3;
|
||||
normal_Count : constant long_Index_t := collada_Normals 'Length / 3;
|
||||
coord_Count : constant long_Index_t := get_coord_Count;
|
||||
|
||||
the_Sites : constant many_Sites_view := new many_Sites (1 .. site_Count);
|
||||
the_Normals : constant many_Normals_view := new many_Normals (1 .. normal_Count);
|
||||
the_Coords : many_Coords_view;
|
||||
the_Weights : bone_Weights_array_view;
|
||||
|
||||
the_Faces : IO.Faces_view := new IO.Faces (1 .. 50_000);
|
||||
face_Count : long_Index_t := 0;
|
||||
|
||||
begin
|
||||
if coord_Count > 0
|
||||
then
|
||||
the_Coords := new many_Coordinates_2D (1 .. coord_Count);
|
||||
end if;
|
||||
|
||||
for i in 1 .. Integer (site_Count)
|
||||
loop
|
||||
the_Sites (long_Index_t (i)) := [collada_Positions (3 * (i - 1) + 1),
|
||||
collada_Positions (3 * (i - 1) + 2),
|
||||
collada_Positions (3 * (i - 1) + 3)];
|
||||
end loop;
|
||||
|
||||
for i in 1 .. Integer (normal_Count)
|
||||
loop
|
||||
the_Normals (long_Index_t (i)) := [collada_Normals (3 * (i - 1) + 1),
|
||||
collada_Normals (3 * (i - 1) + 2),
|
||||
collada_Normals (3 * (i - 1) + 3)];
|
||||
end loop;
|
||||
|
||||
if collada_Coords /= null
|
||||
then
|
||||
for i in 1 .. Integer (coord_Count)
|
||||
loop
|
||||
the_Coords (long_Index_t (i)) := (collada_Coords (2 * (i - 1) + 1),
|
||||
collada_Coords (2 * (i - 1) + 2));
|
||||
end loop;
|
||||
end if;
|
||||
|
||||
-- Skinning
|
||||
--
|
||||
if the_Document.Libraries.Controllers.Contents /= null
|
||||
and then the_Document.Libraries.Controllers.Contents'Length > 0
|
||||
then
|
||||
declare
|
||||
use std_Collada.Library.controllers;
|
||||
|
||||
the_Controller : constant controllers.Controller := the_Document.Libraries.Controllers.Contents (which_Geometry);
|
||||
the_Skin : constant controllers.Skin := the_Controller.Skin;
|
||||
|
||||
collada_Weights : constant access std_Collada.Float_array := Weights_of (the_Skin);
|
||||
|
||||
V : std_Collada.Int_array renames the_Skin.vertex_Weights.V .all;
|
||||
v_Count : std_Collada.Int_array renames the_Skin.vertex_Weights.v_Count.all;
|
||||
v_Cursor : math.Index := 0;
|
||||
inputs_Count : constant math.Index := the_Skin.vertex_Weights.Inputs'Length;
|
||||
|
||||
begin
|
||||
the_Weights := new bone_Weights_array (1 .. long_Index_t (the_Skin.vertex_Weights.Count));
|
||||
|
||||
for each_Vertex in v_Count'Range
|
||||
loop
|
||||
declare
|
||||
the_Count : constant long_Index_t := long_Index_t (v_Count (each_Vertex));
|
||||
these_Weights : bone_Weights_view renames the_Weights (long_Index_t (each_Vertex));
|
||||
Base : Math.Index;
|
||||
begin
|
||||
these_Weights := new bone_Weights (1 .. the_Count);
|
||||
|
||||
for i in 1 .. the_Count
|
||||
loop
|
||||
v_Cursor := v_Cursor + 1;
|
||||
Base := (v_Cursor - 1) * inputs_Count + 1;
|
||||
|
||||
these_Weights (i).Bone := bone_Id ( 1
|
||||
+ V (Base + joint_Offset_of (the_Skin.vertex_weights)));
|
||||
these_Weights (i).Weight := Real (collada_Weights ( 1
|
||||
+ math.Index (V ( Base
|
||||
+ weight_Offset_of (the_Skin.vertex_Weights)))));
|
||||
end loop;
|
||||
end;
|
||||
end loop;
|
||||
end;
|
||||
end if;
|
||||
|
||||
|
||||
-- Primitives
|
||||
--
|
||||
case the_Primitive.Kind
|
||||
is
|
||||
when polyList =>
|
||||
parse_polyList :
|
||||
declare
|
||||
P : std_Collada.Int_array renames the_Primitive.P_List (1).all;
|
||||
inputs_Count : constant Natural := the_Primitive.Inputs'Length;
|
||||
|
||||
p_First : math.Index := 1;
|
||||
p_Last : math.Index;
|
||||
|
||||
vertex_Count : Natural;
|
||||
|
||||
begin
|
||||
for Each in the_Primitive.vCount'Range
|
||||
loop
|
||||
vertex_Count := the_Primitive.vCount (Each);
|
||||
p_Last := p_First
|
||||
+ math.Index (inputs_Count * vertex_Count)
|
||||
- 1;
|
||||
declare
|
||||
the_Vertices : Vertices (1 .. long_Index_t (vertex_Count));
|
||||
|
||||
P_Indices : constant std_Collada.Int_array (1 .. p_Last - p_First + 1) := P (p_First .. p_Last);
|
||||
the_Face : IO.Face;
|
||||
Base : math.Index;
|
||||
begin
|
||||
for vertex_Id in the_Vertices'Range
|
||||
loop
|
||||
Base := math.Index (vertex_Id - 1)
|
||||
* math.Index (inputs_Count)
|
||||
+ 1;
|
||||
|
||||
the_Vertices (vertex_Id).site_Id := 1
|
||||
+ long_Index_t (P_Indices ( Base
|
||||
+ vertex_Offset_of (the_Primitive)));
|
||||
the_Vertices (vertex_Id).normal_Id := 1
|
||||
+ long_Index_t (P_Indices ( Base
|
||||
+ normal_Offset_of (the_Primitive)));
|
||||
if collada_Coords /= null
|
||||
then
|
||||
the_Vertices (vertex_Id).coord_Id := 1
|
||||
+ long_Index_t ( P_Indices (Base
|
||||
+ coord_Offset_of (the_Primitive)));
|
||||
else
|
||||
the_Vertices (vertex_Id).coord_Id := null_Id;
|
||||
end if;
|
||||
|
||||
the_Vertices (vertex_Id).weights_Id := the_Vertices (vertex_Id).site_Id;
|
||||
end loop;
|
||||
|
||||
case vertex_Count
|
||||
is
|
||||
when 3 => the_Face := (Triangle, the_Vertices);
|
||||
when 4 => the_Face := (Quad, the_Vertices);
|
||||
when others => put_Line ("parse_polyList ~ unhandled vertex count:" & vertex_Count'Image);
|
||||
end case;
|
||||
|
||||
face_Count := face_Count + 1;
|
||||
the_Faces (face_Count) := the_Face;
|
||||
end;
|
||||
|
||||
p_First := p_Last + 1;
|
||||
end loop;
|
||||
end parse_polyList;
|
||||
|
||||
|
||||
when Polygons =>
|
||||
parse_Polygons:
|
||||
declare
|
||||
inputs_Count : constant Natural := the_Primitive.Inputs'Length;
|
||||
begin
|
||||
for Each in the_Primitive.P_List'Range
|
||||
loop
|
||||
declare
|
||||
P_Indices : std_Collada.Int_array renames the_Primitive.P_List (Each).all;
|
||||
|
||||
vertex_Count : constant Natural := P_Indices'Length / inputs_Count;
|
||||
the_Vertices : Vertices (1 .. long_Index_t (vertex_Count));
|
||||
|
||||
the_Face : IO.Face;
|
||||
Base : math.Index;
|
||||
begin
|
||||
for vertex_Id in the_Vertices'Range
|
||||
loop
|
||||
Base := math.Index ( (Integer (vertex_Id) - 1)
|
||||
* inputs_Count
|
||||
+ 1);
|
||||
|
||||
the_Vertices (vertex_Id).site_Id := 1
|
||||
+ long_Index_t (P_Indices ( Base
|
||||
+ vertex_Offset_of (the_Primitive)));
|
||||
the_Vertices (vertex_Id).normal_Id := 1
|
||||
+ long_Index_t (P_Indices ( Base
|
||||
+ normal_Offset_of (the_Primitive)));
|
||||
if collada_Coords /= null
|
||||
then
|
||||
the_Vertices (vertex_Id).coord_Id := 1
|
||||
+ long_Index_t (P_Indices ( Base
|
||||
+ coord_Offset_of (the_Primitive)));
|
||||
else
|
||||
the_Vertices (vertex_Id).coord_Id := null_Id;
|
||||
end if;
|
||||
|
||||
the_Vertices (vertex_Id).weights_Id := the_Vertices (vertex_Id).site_Id;
|
||||
end loop;
|
||||
|
||||
case vertex_Count
|
||||
is
|
||||
when 3 => the_Face := (Triangle, the_Vertices);
|
||||
when 4 => the_Face := (Quad, the_Vertices);
|
||||
when others => put_Line ("parse_Polygons ~ unhandled vertex count:" & vertex_Count'Image);
|
||||
end case;
|
||||
|
||||
face_Count := face_Count + 1;
|
||||
the_Faces (face_Count) := the_Face;
|
||||
end;
|
||||
|
||||
end loop;
|
||||
end parse_Polygons;
|
||||
|
||||
|
||||
when Triangles =>
|
||||
parse_Triangles:
|
||||
declare
|
||||
inputs_Count : constant Natural := the_Primitive.Inputs'Length;
|
||||
P_Indices : std_Collada.Int_array renames the_Primitive.P_List (1).all;
|
||||
Base : math.Index := 1;
|
||||
|
||||
begin
|
||||
for each_Tri in 1 .. the_Primitive.Count
|
||||
loop
|
||||
declare
|
||||
vertex_Count : constant := 3;
|
||||
the_Vertices : Vertices (1 .. vertex_Count);
|
||||
|
||||
the_Face : IO.Face;
|
||||
begin
|
||||
for vertex_Id in the_Vertices'Range
|
||||
loop
|
||||
the_Vertices (vertex_Id).site_Id := 1
|
||||
+ long_Index_t (P_Indices ( Base
|
||||
+ vertex_Offset_of (the_Primitive)));
|
||||
the_Vertices (vertex_Id).normal_Id := 1
|
||||
+ long_Index_t (P_Indices ( Base
|
||||
+ normal_Offset_of (the_Primitive)));
|
||||
if collada_Coords /= null
|
||||
then
|
||||
the_Vertices (vertex_Id).coord_Id := 1
|
||||
+ long_Index_t (P_Indices ( Base
|
||||
+ coord_Offset_of (the_Primitive)));
|
||||
else
|
||||
the_Vertices (vertex_Id).coord_Id := null_Id;
|
||||
end if;
|
||||
|
||||
the_Vertices (vertex_Id).weights_Id := the_Vertices (vertex_Id).site_Id;
|
||||
|
||||
Base := Base + inputs_Count;
|
||||
end loop;
|
||||
|
||||
the_Face := (Triangle, the_Vertices);
|
||||
face_Count := face_Count + 1;
|
||||
the_Faces (face_Count) := the_Face;
|
||||
end;
|
||||
|
||||
end loop;
|
||||
end parse_Triangles;
|
||||
|
||||
|
||||
when others =>
|
||||
put_Line ("Warning: ignoring unimplemented primitive kind: " & the_Primitive.Kind'Image);
|
||||
end case;
|
||||
|
||||
|
||||
declare
|
||||
used_Faces : constant IO.Faces_view := new IO.Faces' (the_Faces (1 .. face_Count));
|
||||
begin
|
||||
free (the_Faces);
|
||||
|
||||
return (Sites => the_Sites,
|
||||
Coords => the_Coords,
|
||||
Normals => the_Normals,
|
||||
Weights => the_Weights,
|
||||
Faces => used_Faces);
|
||||
end;
|
||||
end to_Model;
|
||||
|
||||
|
||||
end openGL.IO.collada;
|
||||
9
3-mid/opengl/source/lean/io/opengl-io-collada.ads
Normal file
9
3-mid/opengl/source/lean/io/opengl-io-collada.ads
Normal file
@@ -0,0 +1,9 @@
|
||||
package openGL.IO.collada
|
||||
--
|
||||
-- Provides a function to convert a Collada model file to an openGL IO model.
|
||||
--
|
||||
is
|
||||
|
||||
function to_Model (model_Path : in String) return IO.Model;
|
||||
|
||||
end openGL.IO.collada;
|
||||
80
3-mid/opengl/source/lean/io/opengl-io-lat_long_radius.adb
Normal file
80
3-mid/opengl/source/lean/io/opengl-io-lat_long_radius.adb
Normal file
@@ -0,0 +1,80 @@
|
||||
with
|
||||
float_Math.Geometry.d3.Modeller.Forge;
|
||||
|
||||
package body openGL.IO.lat_long_Radius
|
||||
is
|
||||
|
||||
function to_Model (math_Model : access Geometry_3d.a_Model) return IO.Model
|
||||
is
|
||||
site_Count : constant long_Index_t := long_Index_t (math_Model.site_Count);
|
||||
coord_Count : constant long_Index_t := 0; --get_coord_Count; -- TODO: Add texturing.
|
||||
normal_Count : constant long_Index_t := 0; --collada_Normals'Length / 3; -- TODO: Add lighting.
|
||||
|
||||
the_Sites : constant many_Sites_view := new many_Sites (1 .. site_Count);
|
||||
the_Normals : constant many_Normals_view := new many_Normals (1 .. normal_Count);
|
||||
the_Coords : many_Coords_view;
|
||||
|
||||
the_Faces : IO.Faces_view := new IO.Faces (1 .. 50_000);
|
||||
face_Count : long_Index_t := 0;
|
||||
|
||||
begin
|
||||
if coord_Count > 0
|
||||
then
|
||||
the_Coords := new many_Coordinates_2D (1 .. coord_Count);
|
||||
end if;
|
||||
|
||||
for i in 1 .. Integer (site_Count)
|
||||
loop
|
||||
the_Sites (long_Index_t (i)) := math_Model.Sites (i);
|
||||
end loop;
|
||||
|
||||
|
||||
-- Primitives
|
||||
--
|
||||
declare
|
||||
the_Vertices : Vertices (1 .. long_Index_t (math_Model.tri_Count * 3));
|
||||
Start : long_Index_t;
|
||||
the_Face : IO.Face;
|
||||
begin
|
||||
for i in math_Model.Triangles'Range
|
||||
loop
|
||||
Start := long_Index_t ((i - 1) * 3 + 1);
|
||||
|
||||
the_Vertices (Start ) := (site_Id => long_Index_t (math_Model.Triangles (i) (1)), others => 0);
|
||||
the_Vertices (Start + 1) := (site_Id => long_Index_t (math_Model.Triangles (i) (2)), others => 0);
|
||||
the_Vertices (Start + 2) := (site_Id => long_Index_t (math_Model.Triangles (i) (3)), others => 0);
|
||||
|
||||
the_Face := (Triangle,
|
||||
the_Vertices (Start .. Start + 2));
|
||||
|
||||
face_Count := face_Count + 1;
|
||||
the_Faces (face_Count) := the_Face;
|
||||
end loop;
|
||||
end;
|
||||
|
||||
declare
|
||||
used_Faces : constant IO.Faces_view := new IO.Faces' (the_Faces (1 .. face_Count));
|
||||
begin
|
||||
free (the_Faces);
|
||||
|
||||
return (Sites => the_Sites,
|
||||
Coords => the_Coords,
|
||||
Normals => the_Normals,
|
||||
Weights => null,
|
||||
Faces => used_Faces);
|
||||
end;
|
||||
end to_Model;
|
||||
|
||||
|
||||
|
||||
function to_Model (model_File : in String) return IO.Model
|
||||
is
|
||||
use float_Math.Geometry.d3.Modeller.Forge;
|
||||
|
||||
the_math_Model : aliased Geometry_3d.a_Model := mesh_Model_from (Model => polar_Model_from (model_File));
|
||||
begin
|
||||
return to_Model (the_math_Model'Access);
|
||||
end to_Model;
|
||||
|
||||
|
||||
end openGL.IO.lat_long_Radius;
|
||||
11
3-mid/opengl/source/lean/io/opengl-io-lat_long_radius.ads
Normal file
11
3-mid/opengl/source/lean/io/opengl-io-lat_long_radius.ads
Normal file
@@ -0,0 +1,11 @@
|
||||
package openGL.IO.lat_long_Radius
|
||||
--
|
||||
-- Provides a function to convert a model file containing longitude, latitude
|
||||
-- and radius triplets (one triplet per line) to an openGL IO model.
|
||||
--
|
||||
is
|
||||
|
||||
function to_Model (model_File : in String) return IO.Model;
|
||||
function to_Model (math_Model : access Geometry_3d.a_Model) return IO.Model;
|
||||
|
||||
end openGL.IO.lat_long_Radius;
|
||||
519
3-mid/opengl/source/lean/io/opengl-io-wavefront.adb
Normal file
519
3-mid/opengl/source/lean/io/opengl-io-wavefront.adb
Normal file
@@ -0,0 +1,519 @@
|
||||
with
|
||||
ada.Text_IO,
|
||||
ada.Integer_Text_IO,
|
||||
ada.Strings.fixed,
|
||||
ada.Strings.unbounded;
|
||||
|
||||
package body openGL.IO.wavefront
|
||||
is
|
||||
package real_Text_IO is new Ada.Text_IO.Float_IO (openGL.Real);
|
||||
|
||||
function to_Text (Self : in String) return Text
|
||||
is
|
||||
begin
|
||||
return ada.Strings.unbounded.to_unbounded_String (Self);
|
||||
end to_Text;
|
||||
|
||||
|
||||
|
||||
function to_Vector_3 (Self : in String) return Vector_3
|
||||
is
|
||||
use real_Text_IO;
|
||||
|
||||
X, Y, Z : Real;
|
||||
Last : Natural;
|
||||
begin
|
||||
get (Self, X, Last);
|
||||
get (Self (Last + 1 .. Self'Last), Y, Last);
|
||||
get (Self (Last + 1 .. Self'Last), Z, Last);
|
||||
|
||||
return [X, Y, Z];
|
||||
end to_Vector_3;
|
||||
|
||||
|
||||
|
||||
function to_Coordinate (Self : in String) return Coordinate_2D
|
||||
is
|
||||
use real_Text_IO;
|
||||
|
||||
U, V : Real;
|
||||
Last : Natural;
|
||||
begin
|
||||
get (Self, U, Last);
|
||||
get (Self (Last + 1 .. Self'Last), V, Last);
|
||||
|
||||
return (U, V);
|
||||
end to_Coordinate;
|
||||
|
||||
|
||||
|
||||
function to_Facet (Self : in String) return IO.Face
|
||||
is
|
||||
use ada.Integer_Text_IO;
|
||||
|
||||
site_Id,
|
||||
coord_Id,
|
||||
normal_Id : Integer;
|
||||
|
||||
the_Vertices : Vertices (1 .. 5_000);
|
||||
vertex_Count : long_Index_t := 0;
|
||||
Last : Natural := Self'First - 1;
|
||||
begin
|
||||
loop
|
||||
get (Self (Last + 1 .. Self'Last),
|
||||
site_Id,
|
||||
Last);
|
||||
|
||||
if Last = Self'Last
|
||||
or else Self (Last + 1) = ' '
|
||||
then -- Both texture coord and normal are absent.
|
||||
coord_Id := Integer (null_Id);
|
||||
normal_Id := Integer (null_Id);
|
||||
|
||||
elsif Self (Last + 1) = '/'
|
||||
then
|
||||
if Self (Last + 2) = '/'
|
||||
then -- Texture coord is absent.
|
||||
coord_Id := Integer (null_Id);
|
||||
get (Self (Last + 3 .. Self'Last),
|
||||
normal_Id,
|
||||
Last);
|
||||
else
|
||||
get (Self (Last + 2 .. Self'Last),
|
||||
coord_Id,
|
||||
Last);
|
||||
|
||||
if Last = Self'Last
|
||||
or else Self (Last + 1) = ' '
|
||||
then -- Lighting normal is absent.
|
||||
normal_Id := Integer (null_Id);
|
||||
|
||||
elsif Self (Last + 1) = '/'
|
||||
then
|
||||
get (Self (Last + 2 .. Self'Last),
|
||||
normal_Id,
|
||||
Last);
|
||||
else
|
||||
raise Constraint_Error with "Invalid indices: " & Self & ".";
|
||||
end if;
|
||||
end if;
|
||||
|
||||
else
|
||||
raise Constraint_Error with "Invalid indices: " & Self & ".";
|
||||
end if;
|
||||
|
||||
if site_Id < 0
|
||||
or else coord_Id < 0
|
||||
or else normal_Id < 0
|
||||
then
|
||||
raise Constraint_Error with "Negative indices not implemented: " & Self & ".";
|
||||
end if;
|
||||
|
||||
vertex_Count := vertex_Count + 1;
|
||||
the_Vertices (vertex_Count) := (long_Index_t ( site_Id),
|
||||
long_Index_t ( coord_Id),
|
||||
long_Index_t (normal_Id),
|
||||
null_Id);
|
||||
exit when Last + 1 >= Self'Last;
|
||||
end loop;
|
||||
|
||||
case vertex_Count
|
||||
is
|
||||
when 3 => return (Triangle, the_Vertices (1 .. 3));
|
||||
when 4 => return (Quad, the_Vertices (1 .. 4));
|
||||
when others => return (Polygon, new Vertices' (the_Vertices (1 .. vertex_Count)));
|
||||
end case;
|
||||
end to_Facet;
|
||||
|
||||
|
||||
|
||||
function to_Model (model_File : in String) return IO.Model
|
||||
is
|
||||
use ada.Strings.fixed,
|
||||
ada.Text_IO;
|
||||
|
||||
the_File : File_Type;
|
||||
|
||||
max_Elements : constant := 200_000;
|
||||
|
||||
the_Sites : many_Sites_view := new many_Sites (1 .. max_Elements);
|
||||
the_Coords : many_Coords_view := new many_Coordinates_2D (1 .. max_Elements);
|
||||
the_Normals : many_Normals_view := new many_Normals (1 .. max_Elements);
|
||||
the_Faces : IO.Faces_view := new IO.Faces' (1 .. max_Elements => <>);
|
||||
|
||||
site_Count : long_Index_t := 0;
|
||||
coord_Count : long_Index_t := 0;
|
||||
normal_Count : long_Index_t := 0;
|
||||
face_Count : long_Index_t := 0;
|
||||
|
||||
begin
|
||||
open (the_File, In_File, model_File);
|
||||
|
||||
while not end_of_File (the_File)
|
||||
loop
|
||||
declare
|
||||
the_Line : constant String := get_Line (the_File);
|
||||
begin
|
||||
if the_Line'Length = 0 or else the_Line (1) = '#'
|
||||
then
|
||||
null;
|
||||
|
||||
elsif Head (the_Line, 6) = "mtllib"
|
||||
then
|
||||
null; -- TODO
|
||||
|
||||
elsif Head (the_Line, 2) = "f "
|
||||
then
|
||||
face_Count := face_Count + 1;
|
||||
the_Faces (face_Count) := to_Facet (the_Line (3 .. the_Line'Last));
|
||||
|
||||
elsif Head (the_Line, 2) = "v "
|
||||
then
|
||||
site_Count := site_Count + 1;
|
||||
the_Sites (site_Count) := to_Vector_3 (the_Line (3 .. the_Line'Last));
|
||||
|
||||
elsif Head (the_Line, 3) = "vt "
|
||||
then
|
||||
coord_Count := coord_Count + 1;
|
||||
the_Coords (coord_Count) := to_Coordinate (the_Line (4 .. the_Line'Last));
|
||||
|
||||
elsif Head (the_Line, 3) = "vn "
|
||||
then
|
||||
normal_Count := normal_Count + 1;
|
||||
the_Normals (normal_Count) := to_Vector_3 (the_Line (4 .. the_Line'Last));
|
||||
|
||||
elsif Head (the_Line, 2) = "o "
|
||||
then
|
||||
null; -- Currently ignored. TODO
|
||||
|
||||
elsif Head (the_Line, 2) = "g "
|
||||
then
|
||||
null; -- Currently ignored. TODO
|
||||
|
||||
elsif Head (the_Line, 2) = "s "
|
||||
then
|
||||
null; -- Currently ignored. TODO
|
||||
|
||||
else
|
||||
null; -- Currently ignored. TODO
|
||||
end if;
|
||||
end;
|
||||
end loop;
|
||||
|
||||
close (the_File);
|
||||
|
||||
|
||||
declare
|
||||
used_Sites : constant IO. many_Sites_view := new many_Sites' (the_Sites (1 .. site_Count));
|
||||
used_Coords : constant IO. many_Coords_view := new many_Coordinates_2D' (the_Coords (1 .. coord_Count));
|
||||
used_Normals : constant IO.many_Normals_view := new many_Normals' (the_Normals (1 .. normal_Count));
|
||||
used_Faces : constant IO. Faces_view := new IO.Faces' (the_Faces (1 .. face_Count));
|
||||
begin
|
||||
free (the_Sites);
|
||||
free (the_Coords);
|
||||
free (the_Normals);
|
||||
free (the_Faces);
|
||||
|
||||
return (Sites => used_Sites,
|
||||
Coords => used_Coords,
|
||||
Normals => used_Normals,
|
||||
Weights => null,
|
||||
Faces => used_Faces);
|
||||
end;
|
||||
end to_Model;
|
||||
|
||||
|
||||
|
||||
----------
|
||||
--- Images
|
||||
--
|
||||
|
||||
function Image (Self : in IO.Face) return String
|
||||
is
|
||||
use ada.Strings.unbounded;
|
||||
|
||||
the_Vertices : Vertices renames Vertices_of (Self);
|
||||
the_Image : unbounded_String := to_unbounded_String ("f ");
|
||||
|
||||
function id_Image (Self : in long_Index_t) return String
|
||||
is
|
||||
use ada.Strings.fixed;
|
||||
begin
|
||||
return Trim (long_Index_t'Image (Self),
|
||||
ada.Strings.left);
|
||||
end id_Image;
|
||||
|
||||
begin
|
||||
for i in the_Vertices'Range
|
||||
loop
|
||||
append (the_Image,
|
||||
id_Image (the_Vertices (i).site_Id));
|
||||
|
||||
if the_Vertices (i).coord_Id = null_Id
|
||||
then
|
||||
if the_Vertices (i).normal_Id /= null_Id
|
||||
then
|
||||
append (the_Image, "/");
|
||||
end if;
|
||||
else
|
||||
append (the_Image, "/" & id_Image (the_Vertices (i).coord_Id));
|
||||
end if;
|
||||
|
||||
-- if the_Vertices (i).normal_Id /= null_Id
|
||||
-- then
|
||||
-- append (the_Image,
|
||||
-- "/" & id_Image (the_Vertices (i).normal_Id));
|
||||
-- end if;
|
||||
|
||||
append (the_Image, " ");
|
||||
end loop;
|
||||
|
||||
return to_String (the_Image);
|
||||
end Image;
|
||||
|
||||
|
||||
|
||||
function Image (Self : in wavefront.Group) return String
|
||||
is
|
||||
use ada.Strings.unbounded;
|
||||
begin
|
||||
case Self.Kind
|
||||
is
|
||||
when object_Name => return "o " & to_String (Self.object_Name);
|
||||
when group_Name => return "g " & to_String (Self. group_Name);
|
||||
when smoothing_Group => return "s" & Self.smooth_group_Id'Image;
|
||||
when merging_Group => return ""; -- TODO
|
||||
end case;
|
||||
end Image;
|
||||
|
||||
|
||||
|
||||
function Image (Self : in wavefront.Face) return String
|
||||
is
|
||||
begin
|
||||
case Self.Kind
|
||||
is
|
||||
when a_Group => return Image (Self.Group);
|
||||
when a_Facet => return Image (Self.Facet);
|
||||
end case;
|
||||
end Image;
|
||||
|
||||
|
||||
type wf_Faces_view is access all wavefront.Faces;
|
||||
|
||||
|
||||
function to_Model (model_Path : in String) return wavefront.Model
|
||||
is
|
||||
use ada.Strings.fixed,
|
||||
ada.Text_IO;
|
||||
|
||||
the_material_Library : Text;
|
||||
the_material_Name : Text;
|
||||
the_object_Name : Text;
|
||||
the_group_Name : Text;
|
||||
|
||||
the_Sites : Sites (1 .. 50_000);
|
||||
site_Count : Index_t := 0;
|
||||
|
||||
the_Coords : Coordinates_2D (1 .. 50_000);
|
||||
coord_Count : Index_t := 0;
|
||||
|
||||
the_Normals : Normals (1 .. 50_000);
|
||||
normal_Count : Index_t := 0;
|
||||
|
||||
the_Faces : wf_Faces_view := new Faces' (1 .. 100_000 => <>);
|
||||
face_Count : long_Index_t := 0;
|
||||
|
||||
the_File : File_Type;
|
||||
|
||||
begin
|
||||
Open (the_File, In_File, model_Path);
|
||||
|
||||
while not End_Of_File (the_File)
|
||||
loop
|
||||
declare
|
||||
use ada.Strings.unbounded;
|
||||
the_Line : constant String := Get_Line (the_File);
|
||||
begin
|
||||
if the_Line'Length = 0 or else the_Line (1) = '#' then
|
||||
null;
|
||||
|
||||
elsif Head (the_Line, 6) = "mtllib" then
|
||||
the_material_Library := to_unbounded_String (the_Line (8 .. the_Line'Last));
|
||||
|
||||
elsif Head (the_Line, 6) = "usemtl" then
|
||||
the_material_Name := to_unbounded_String (the_Line (8 .. the_Line'Last));
|
||||
|
||||
elsif Head (the_Line, 2) = "f " then
|
||||
face_Count := face_Count + 1;
|
||||
the_Faces (face_Count) := (a_Facet,
|
||||
to_Facet (the_Line (3 .. the_Line'Last)));
|
||||
|
||||
elsif Head (the_Line, 2) = "v " then
|
||||
site_Count := site_Count + 1;
|
||||
the_Sites (site_Count) := to_Vector_3 (the_Line (3 .. the_Line'Last));
|
||||
|
||||
elsif Head (the_Line, 3) = "vt " then
|
||||
coord_Count := coord_Count + 1;
|
||||
the_Coords (coord_Count) := to_Coordinate (the_Line (4 .. the_Line'Last));
|
||||
|
||||
elsif Head (the_Line, 3) = "vn " then
|
||||
normal_Count := normal_Count + 1;
|
||||
the_Normals (normal_Count) := to_Vector_3 (the_Line (4 .. the_Line'Last));
|
||||
|
||||
elsif Head (the_Line, 2) = "o " then
|
||||
the_object_Name := to_unbounded_String (the_Line (3 .. the_Line'Last));
|
||||
-- face_Count := face_Count + 1;
|
||||
-- the_Faces (face_Count) := (a_Group,
|
||||
-- (object_Name,
|
||||
-- object_Name => to_Text (the_Line (3 .. the_Line'Last))));
|
||||
|
||||
elsif Head (the_Line, 2) = "g " then
|
||||
the_group_Name := to_unbounded_String (the_Line (3 .. the_Line'Last));
|
||||
-- face_Count := face_Count + 1;
|
||||
-- the_Faces (face_Count) := (a_Group,
|
||||
-- (group_Name,
|
||||
-- group_Name => to_Text (the_Line (3 .. the_Line'Last))));
|
||||
|
||||
elsif Head (the_Line, 2) = "s " then
|
||||
declare
|
||||
use Ada.Integer_Text_IO;
|
||||
|
||||
the_Id : Natural;
|
||||
Last : Natural;
|
||||
begin
|
||||
if Head (the_Line, 5) = "s off" then
|
||||
the_Id := 0;
|
||||
else
|
||||
Get (the_Line (3 .. the_Line'Last), the_Id, Last);
|
||||
end if;
|
||||
|
||||
face_Count := face_Count + 1;
|
||||
the_Faces (face_Count) := (a_Group,
|
||||
(smoothing_Group,
|
||||
smooth_group_Id => the_Id));
|
||||
end;
|
||||
|
||||
else
|
||||
put_Line ("openGL.io.wavefront ~ Unhandled line in " & model_Path & ": '" & the_Line & "'");
|
||||
end if;
|
||||
end;
|
||||
end loop;
|
||||
|
||||
Close (the_File);
|
||||
|
||||
|
||||
declare
|
||||
procedure free is new Ada.Unchecked_Deallocation (Faces, wf_Faces_view);
|
||||
|
||||
used_Faces : constant wf_Faces_view := new wavefront.Faces'(the_Faces (1 .. face_Count));
|
||||
begin
|
||||
free (the_Faces);
|
||||
|
||||
return (material_Library => the_material_Library,
|
||||
material_Name => the_material_Name,
|
||||
object_Name => the_object_Name,
|
||||
group_Name => the_group_Name,
|
||||
|
||||
Sites => new openGL.Sites' (the_Sites (1 .. site_Count)),
|
||||
Coords => new Coordinates_2D' (the_Coords (1 .. coord_Count)),
|
||||
Normals => new openGL.Normals' (the_Normals (1 .. normal_Count)),
|
||||
Faces => used_Faces);
|
||||
end;
|
||||
end to_Model;
|
||||
|
||||
|
||||
|
||||
procedure write (the_Model : in wavefront.Model; to_File : in String)
|
||||
is
|
||||
use ada.Strings.unbounded,
|
||||
ada.Text_IO;
|
||||
|
||||
the_File : File_type;
|
||||
|
||||
use Real_text_IO;
|
||||
begin
|
||||
Create (the_File, Out_File, Name => to_File);
|
||||
|
||||
if the_Model.material_Library /= ""
|
||||
then
|
||||
put_Line (the_File, "mtllib " & to_String (the_Model.material_Library));
|
||||
new_Line (the_File);
|
||||
end if;
|
||||
|
||||
if the_Model.object_Name /= ""
|
||||
then
|
||||
put_Line (the_File, "o " & to_String (the_Model.object_Name));
|
||||
new_Line (the_File);
|
||||
end if;
|
||||
|
||||
-- Write sites.
|
||||
--
|
||||
for Each in the_Model.Sites'Range
|
||||
loop
|
||||
Put (the_File, "v ");
|
||||
Put (the_File, the_Model.Sites (Each) (1), Aft => 19, Exp => 0);
|
||||
Put (the_File, " ");
|
||||
Put (the_File, the_Model.Sites (Each) (2), Aft => 19, Exp => 0);
|
||||
Put (the_File, " ");
|
||||
Put (the_File, the_Model.Sites (Each) (3), Aft => 19, Exp => 0);
|
||||
|
||||
New_Line (the_File);
|
||||
end loop;
|
||||
|
||||
New_Line (the_File);
|
||||
|
||||
-- Write texture coords.
|
||||
--
|
||||
for Each in the_Model.Coords'Range
|
||||
loop
|
||||
Put (the_File, "vt ");
|
||||
Put (the_File, the_Model.Coords (Each).S, Aft => 19, Exp => 0);
|
||||
Put (the_File, " ");
|
||||
Put (the_File, the_Model.Coords (Each).T, Aft => 19, Exp => 0);
|
||||
|
||||
New_Line (the_File);
|
||||
end loop;
|
||||
|
||||
-- New_Line (the_File);
|
||||
|
||||
-- Write normals.
|
||||
--
|
||||
-- for Each in the_Model.Normals'Range
|
||||
-- loop
|
||||
-- Put (the_File, "vn ");
|
||||
-- Put (the_File, the_Model.Normals (Each) (1), Aft => 19, Exp => 0);
|
||||
-- Put (the_File, " ");
|
||||
-- Put (the_File, the_Model.Normals (Each) (2), Aft => 19, Exp => 0);
|
||||
-- Put (the_File, " ");
|
||||
-- Put (the_File, the_Model.Normals (Each) (3), Aft => 19, Exp => 0);
|
||||
--
|
||||
-- New_Line (the_File);
|
||||
-- end loop;
|
||||
|
||||
New_Line (the_File);
|
||||
|
||||
-- Write faces.
|
||||
--
|
||||
if the_Model.group_Name /= ""
|
||||
then
|
||||
put_Line (the_File, "g " & to_String (the_Model.group_Name));
|
||||
new_Line (the_File);
|
||||
end if;
|
||||
|
||||
if the_Model.material_Name /= ""
|
||||
then
|
||||
put_Line (the_File, "usemtl " & to_String (the_Model.material_Name));
|
||||
new_Line (the_File);
|
||||
end if;
|
||||
|
||||
for Each in the_Model.Faces'Range
|
||||
loop
|
||||
Put_Line (the_File, Image (the_Model.Faces (Each)));
|
||||
end loop;
|
||||
|
||||
Close (the_File);
|
||||
end write;
|
||||
|
||||
|
||||
end openGL.IO.wavefront;
|
||||
80
3-mid/opengl/source/lean/io/opengl-io-wavefront.ads
Normal file
80
3-mid/opengl/source/lean/io/opengl-io-wavefront.ads
Normal file
@@ -0,0 +1,80 @@
|
||||
package openGL.IO.wavefront
|
||||
--
|
||||
-- Provides a function to convert a Wavefront model file (*.obj) to an openGL IO model.
|
||||
--
|
||||
is
|
||||
---------
|
||||
-- Group
|
||||
--
|
||||
|
||||
type group_Kind is (object_Name, group_Name,
|
||||
smoothing_Group, merging_Group);
|
||||
|
||||
type Group (Kind : group_Kind := group_Name) is
|
||||
record
|
||||
case Kind
|
||||
is
|
||||
when object_Name => object_Name : Text;
|
||||
when group_Name => group_Name : Text;
|
||||
when smoothing_Group => smooth_group_Id : Natural;
|
||||
when merging_Group => null;
|
||||
end case;
|
||||
end record;
|
||||
|
||||
function Image (Self : in Group) return String;
|
||||
|
||||
|
||||
--------
|
||||
-- Face
|
||||
--
|
||||
|
||||
type face_Kind is (a_Group, a_Facet);
|
||||
|
||||
type Face (Kind : face_Kind := a_Facet) is
|
||||
record
|
||||
case Kind
|
||||
is
|
||||
when a_Group => Group : wavefront.Group;
|
||||
when a_Facet => Facet : openGL.IO.Face;
|
||||
end case;
|
||||
end record;
|
||||
|
||||
type Faces is array (long_Index_t range <>) of Face;
|
||||
|
||||
function Image (Self : in wavefront.Face) return String;
|
||||
function to_Model (model_File : in String) return IO.Model;
|
||||
|
||||
|
||||
type Sites_view is access openGL.Sites;
|
||||
type Coordinates_2D_view is access openGL.Coordinates_2D;
|
||||
type Normals_view is access openGL.Normals;
|
||||
|
||||
type Model is
|
||||
record
|
||||
material_Library : Text;
|
||||
material_Name : Text;
|
||||
object_Name : Text;
|
||||
group_Name : Text;
|
||||
|
||||
Sites : Sites_view;
|
||||
Coords : Coordinates_2D_view;
|
||||
Normals : Normals_view;
|
||||
Faces : access wavefront.Faces;
|
||||
end record;
|
||||
|
||||
function to_Model (model_Path : in String) return wavefront.Model;
|
||||
|
||||
procedure write (the_Model : in wavefront.Model;
|
||||
to_File : in String);
|
||||
|
||||
|
||||
-----------
|
||||
-- Utility
|
||||
--
|
||||
|
||||
function to_Vector_3 (Self : in String) return Vector_3;
|
||||
function to_Coordinate (Self : in String) return Coordinate_2D;
|
||||
function to_Text (Self : in String) return Text;
|
||||
|
||||
|
||||
end openGL.IO.wavefront;
|
||||
917
3-mid/opengl/source/lean/io/opengl-io.adb
Normal file
917
3-mid/opengl/source/lean/io/opengl-io.adb
Normal file
@@ -0,0 +1,917 @@
|
||||
with
|
||||
openGL.Images,
|
||||
openGL.Viewport,
|
||||
openGL.Tasks,
|
||||
openGL.Errors,
|
||||
|
||||
GID,
|
||||
|
||||
GL.Binding,
|
||||
GL.safe,
|
||||
GL.Pointers,
|
||||
|
||||
ada.unchecked_Conversion,
|
||||
ada.Calendar,
|
||||
ada.Characters.handling,
|
||||
|
||||
System;
|
||||
|
||||
|
||||
package body openGL.IO
|
||||
is
|
||||
use ada.Characters.handling,
|
||||
ada.Streams.Stream_IO;
|
||||
|
||||
use type Index_t;
|
||||
|
||||
|
||||
--------
|
||||
-- Face
|
||||
--
|
||||
|
||||
function Vertices_of (Self : in Face) return Vertices
|
||||
is
|
||||
begin
|
||||
case Self.Kind
|
||||
is
|
||||
when Triangle => return Self.Tri;
|
||||
when Quad => return Self.Quad;
|
||||
when Polygon => return Self.Poly.all;
|
||||
end case;
|
||||
end Vertices_of;
|
||||
|
||||
|
||||
|
||||
procedure set_Vertex_in (Self : in out Face; Which : in long_Index_t;
|
||||
To : in Vertex)
|
||||
is
|
||||
begin
|
||||
case Self.Kind
|
||||
is
|
||||
when Triangle => Self.Tri (Which) := To;
|
||||
when Quad => Self.Quad (Which) := To;
|
||||
when Polygon => Self.Poly (Which) := To;
|
||||
end case;
|
||||
end set_Vertex_in;
|
||||
|
||||
|
||||
|
||||
procedure destroy (Self : in out Face)
|
||||
is
|
||||
procedure free is new ada.unchecked_Deallocation (Vertices, Vertices_view);
|
||||
begin
|
||||
if Self.Kind = Polygon
|
||||
then
|
||||
free (Self.Poly);
|
||||
end if;
|
||||
end destroy;
|
||||
|
||||
|
||||
-------------
|
||||
-- Operations
|
||||
--
|
||||
|
||||
function current_Frame return Image
|
||||
is
|
||||
use GL,
|
||||
GL.Binding,
|
||||
GL.Pointers,
|
||||
Texture;
|
||||
|
||||
Extent : constant Extent_2d := openGL.Viewport.Extent;
|
||||
Frame : Image (1 .. Index_t (Extent.Width),
|
||||
1 .. Index_t (Extent.Height));
|
||||
begin
|
||||
glReadPixels (0, 0,
|
||||
GLsizei (Extent.Width),
|
||||
GLsizei (Extent.Height),
|
||||
to_GL (Format' (Texture.RGB)),
|
||||
GL_UNSIGNED_BYTE,
|
||||
to_GLvoid_access (Frame (1, 1).Red'Access));
|
||||
return Frame;
|
||||
end current_Frame;
|
||||
|
||||
|
||||
---------
|
||||
-- Forge
|
||||
--
|
||||
|
||||
function to_height_Map (image_Filename : in asset_Name;
|
||||
Scale : in Real := 1.0) return height_Map_view
|
||||
is
|
||||
File : Ada.Streams.Stream_IO.File_Type;
|
||||
Image : GID.Image_Descriptor;
|
||||
up_Name : constant String := To_Upper (to_String (image_Filename));
|
||||
|
||||
next_Frame : ada.Calendar.Day_Duration := 0.0;
|
||||
|
||||
begin
|
||||
open (File, in_File, to_String (image_Filename));
|
||||
|
||||
GID.load_Image_Header (Image,
|
||||
Stream (File).all,
|
||||
try_tga => image_Filename'Length >= 4
|
||||
and then up_Name (up_Name'Last - 3 .. up_Name'Last) = ".TGA");
|
||||
declare
|
||||
image_Width : constant Positive := GID.Pixel_Width (Image);
|
||||
image_Height : constant Positive := GID.Pixel_Height (Image);
|
||||
|
||||
the_Heights : constant access height_Map := new height_Map' (1 .. Index_t (image_height) =>
|
||||
(1 .. Index_t (image_width) => <>));
|
||||
procedure load_raw_Image
|
||||
is
|
||||
subtype primary_Color_range is GL.GLubyte;
|
||||
|
||||
Row, Col : Index_t;
|
||||
|
||||
|
||||
procedure set_X_Y (x, y : Natural)
|
||||
is
|
||||
begin
|
||||
Col := Index_t (X + 1);
|
||||
Row := Index_t (Y + 1);
|
||||
end Set_X_Y;
|
||||
|
||||
|
||||
procedure put_Pixel (Red, Green, Blue : primary_Color_range;
|
||||
Alpha : primary_Color_range)
|
||||
is
|
||||
pragma Warnings (Off, alpha); -- Alpha is just ignored.
|
||||
use type GL.GLubyte, Real;
|
||||
begin
|
||||
the_Heights (Row, Col) := (Real (Red) + Real (Green) + Real (Blue))
|
||||
/ (3.0 * 255.0)
|
||||
* Scale;
|
||||
|
||||
if Col = Index_t (image_Width)
|
||||
then
|
||||
Row := Row + 1;
|
||||
Col := 1;
|
||||
else
|
||||
Col := Col + 1;
|
||||
end if;
|
||||
|
||||
-- ^ GID requires us to look to next pixel on the right for next time.
|
||||
end put_Pixel;
|
||||
|
||||
|
||||
procedure Feedback (Percents : Natural) is null;
|
||||
|
||||
procedure load_Image is new GID.load_Image_contents (primary_Color_range,
|
||||
set_X_Y,
|
||||
put_Pixel,
|
||||
Feedback,
|
||||
GID.fast);
|
||||
begin
|
||||
load_Image (Image, next_Frame);
|
||||
end load_Raw_image;
|
||||
|
||||
begin
|
||||
load_raw_Image;
|
||||
close (File);
|
||||
|
||||
return the_Heights.all'unchecked_Access;
|
||||
end;
|
||||
end to_height_Map;
|
||||
|
||||
|
||||
|
||||
function fetch_Image (Stream : in ada.Streams.Stream_IO.Stream_access;
|
||||
try_TGA : in Boolean) return Image
|
||||
is
|
||||
begin
|
||||
return Images.fetch_Image (Stream, try_TGA);
|
||||
end fetch_Image;
|
||||
|
||||
|
||||
|
||||
function to_Image (image_Filename : in asset_Name) return Image
|
||||
is
|
||||
File : ada.Streams.Stream_IO.File_type;
|
||||
up_Name : constant String := to_Upper (to_String (image_Filename));
|
||||
begin
|
||||
open (File, In_File, to_String (image_Filename));
|
||||
|
||||
declare
|
||||
the_Image : constant Image
|
||||
:= fetch_Image (Stream (File),
|
||||
try_TGA => image_Filename'Length >= 4
|
||||
and then up_Name (up_Name'Last - 3 .. up_Name'Last) = ".TGA");
|
||||
begin
|
||||
close (File);
|
||||
return the_Image;
|
||||
end;
|
||||
end to_Image;
|
||||
|
||||
|
||||
|
||||
function to_lucid_Image (image_Filename : in asset_Name) return lucid_Image
|
||||
is
|
||||
Unused : aliased Boolean;
|
||||
begin
|
||||
return to_lucid_Image (image_Filename, Unused'Access);
|
||||
end to_lucid_Image;
|
||||
|
||||
|
||||
|
||||
function to_lucid_Image (image_Filename : in asset_Name;
|
||||
is_Lucid : access Boolean) return lucid_Image
|
||||
is
|
||||
File : ada.Streams.Stream_IO.File_type;
|
||||
the_Image : GID.Image_Descriptor;
|
||||
up_Name : constant String := to_Upper (to_String (image_Filename));
|
||||
|
||||
next_Frame : ada.Calendar.Day_Duration := 0.0;
|
||||
|
||||
begin
|
||||
open (File, in_File, to_String (image_Filename));
|
||||
|
||||
GID.load_Image_Header (the_Image,
|
||||
Stream (File).all,
|
||||
try_TGA => image_Filename'Length >= 4
|
||||
and then up_Name (up_Name'Last - 3 .. up_Name'Last) = ".TGA");
|
||||
declare
|
||||
image_Width : constant Positive := GID.Pixel_Width (the_Image);
|
||||
image_Height : constant Positive := GID.Pixel_Height (the_Image);
|
||||
|
||||
Frame : lucid_Image (1 .. Index_t (image_Height),
|
||||
1 .. Index_t (image_Width));
|
||||
|
||||
procedure load_raw_Image
|
||||
is
|
||||
subtype primary_Color_range is GL.GLubyte;
|
||||
|
||||
Row, Col : Index_t;
|
||||
|
||||
|
||||
procedure set_X_Y (X, Y : Natural)
|
||||
is
|
||||
begin
|
||||
Col := Index_t (X + 1);
|
||||
Row := Index_t (Y + 1);
|
||||
end set_X_Y;
|
||||
|
||||
|
||||
procedure put_Pixel (Red, Green, Blue : primary_Color_range;
|
||||
Alpha : primary_Color_range)
|
||||
is
|
||||
use type GL.GLubyte, Real;
|
||||
begin
|
||||
Frame (Row, Col) := ((Red, Green, Blue), Alpha);
|
||||
|
||||
if Col = Index_t (image_Width)
|
||||
then -- GID requires us to look to next pixel on the right for next time.
|
||||
Row := Row + 1;
|
||||
Col := 1;
|
||||
else
|
||||
Col := Col + 1;
|
||||
end if;
|
||||
|
||||
if Alpha /= opaque_Value
|
||||
then
|
||||
is_Lucid.all := True;
|
||||
end if;
|
||||
end put_Pixel;
|
||||
|
||||
|
||||
procedure Feedback (Percents : Natural) is null;
|
||||
|
||||
procedure load_Image is new GID.load_Image_contents (primary_Color_range,
|
||||
set_X_Y,
|
||||
put_Pixel,
|
||||
Feedback,
|
||||
GID.fast);
|
||||
begin
|
||||
load_Image (the_Image, next_Frame);
|
||||
end Load_raw_image;
|
||||
|
||||
begin
|
||||
is_Lucid.all := False;
|
||||
|
||||
load_raw_Image;
|
||||
close (File);
|
||||
|
||||
return Frame;
|
||||
end;
|
||||
end to_lucid_Image;
|
||||
|
||||
|
||||
|
||||
function to_Texture (image_Filename : in asset_Name) return Texture.Object
|
||||
is
|
||||
use Texture;
|
||||
|
||||
is_Lucid : aliased Boolean;
|
||||
the_lucid_Image : constant lucid_Image := to_lucid_Image (image_Filename, is_Lucid'Access);
|
||||
the_Texture : Texture.Object := Forge.to_Texture (Texture.Dimensions' (the_lucid_Image'Length (2),
|
||||
the_lucid_Image'Length (1)));
|
||||
begin
|
||||
if is_Lucid
|
||||
then
|
||||
set_Image (the_Texture, the_lucid_Image);
|
||||
else
|
||||
declare
|
||||
the_opaque_Image : constant Image := to_Image (the_lucid_Image);
|
||||
begin
|
||||
set_Image (the_Texture, the_opaque_Image);
|
||||
end;
|
||||
end if;
|
||||
|
||||
return the_Texture;
|
||||
end to_Texture;
|
||||
|
||||
|
||||
|
||||
procedure destroy (Self : in out Model)
|
||||
is
|
||||
procedure free is new ada.unchecked_Deallocation (bone_Weights, bone_Weights_view);
|
||||
procedure free is new ada.unchecked_Deallocation (bone_Weights_array, bone_Weights_array_view);
|
||||
begin
|
||||
free (Self.Sites);
|
||||
free (Self.Coords);
|
||||
free (Self.Normals);
|
||||
|
||||
if Self.Weights /= null
|
||||
then
|
||||
for Each in Self.Weights'Range
|
||||
loop
|
||||
free (Self.Weights (Each));
|
||||
end loop;
|
||||
|
||||
free (Self.Weights);
|
||||
end if;
|
||||
|
||||
for Each in Self.Faces'Range
|
||||
loop
|
||||
destroy (Self.Faces (Each));
|
||||
end loop;
|
||||
|
||||
free (Self.Faces);
|
||||
end destroy;
|
||||
|
||||
|
||||
|
||||
--------------------
|
||||
--- Raw Image Frames
|
||||
--
|
||||
|
||||
procedure write_raw_Frame (to_Stream : in Stream_access;
|
||||
Width, Height : in Natural;
|
||||
with_Alpha : in Boolean)
|
||||
is
|
||||
use GL,
|
||||
GL.Binding,
|
||||
Texture;
|
||||
|
||||
-- 4-byte padding for .bmp/.avi formats is the same as GL's default
|
||||
-- padding: see glPixelStore, GL_[UN]PACK_ALIGNMENT = 4 as initial value.
|
||||
-- http://www.openGL.org/sdk/docs/man/xhtml/glPixelStore.xml
|
||||
--
|
||||
padded_row_Size : constant Positive := (if with_Alpha then 4 * Integer (Float'Ceiling (Float (Width)))
|
||||
else 4 * Integer (Float'Ceiling (Float (Width) * 3.0 / 4.0)));
|
||||
-- (in bytes)
|
||||
|
||||
type temp_Bitmap_type is array (Natural range <>) of aliased gl.GLUbyte;
|
||||
|
||||
PicData : temp_Bitmap_type (0 .. (padded_row_size + 4) * (height + 4) - 1);
|
||||
--
|
||||
-- No dynamic allocation needed!
|
||||
-- The "+4" are there to avoid parity address problems when GL writes
|
||||
-- to the buffer.
|
||||
|
||||
type Loc_pointer is new gl.safe.GLvoid_Pointer;
|
||||
|
||||
function convert is new ada.unchecked_Conversion (System.Address, Loc_pointer);
|
||||
--
|
||||
-- This method is functionally identical as GNAT's Unrestricted_Access
|
||||
-- but has no type safety (cf GNAT Docs).
|
||||
|
||||
pragma no_strict_Aliasing (Loc_pointer); -- Recommended by GNAT 2005+.
|
||||
|
||||
pPicData : Loc_pointer;
|
||||
data_Max : constant Integer := padded_row_Size * Height - 1;
|
||||
|
||||
-- Workaround for the severe xxx'Read xxx'Write performance
|
||||
-- problems in the GNAT and ObjectAda compilers (as in 2009)
|
||||
-- This is possible if and only if Byte = Stream_Element and
|
||||
-- arrays types are both packed the same way.
|
||||
--
|
||||
type Byte_array is array (Integer range <>) of aliased GLUByte;
|
||||
|
||||
subtype Size_Test_a is Byte_Array (1..19);
|
||||
subtype Size_Test_b is ada.Streams.Stream_Element_array (1 .. 19);
|
||||
|
||||
Workaround_possible: constant Boolean := Size_Test_a'Size = Size_Test_b'Size
|
||||
and then Size_Test_a'Alignment = Size_Test_b'Alignment;
|
||||
begin
|
||||
Tasks.check;
|
||||
|
||||
pPicData:= convert (PicData (0)'Address);
|
||||
|
||||
GLReadPixels (0, 0,
|
||||
GLSizei (width),
|
||||
GLSizei (height),
|
||||
(if with_Alpha then to_GL (openGL.Texture.BGRA)
|
||||
else to_GL (openGL.Texture.BGR)),
|
||||
GL.GL_UNSIGNED_BYTE,
|
||||
pPicData);
|
||||
Errors.log;
|
||||
|
||||
if Workaround_possible
|
||||
then
|
||||
declare
|
||||
use ada.Streams;
|
||||
|
||||
SE_Buffer : Stream_Element_array (0 .. Stream_Element_Offset (PicData'Last));
|
||||
|
||||
for SE_Buffer'Address use PicData'Address;
|
||||
pragma Import (Ada, SE_Buffer);
|
||||
begin
|
||||
ada.Streams.write (to_Stream.all, SE_Buffer (0 .. Stream_Element_Offset (data_Max)));
|
||||
end;
|
||||
|
||||
else
|
||||
temp_Bitmap_type'write (to_Stream, PicData (0 .. data_Max));
|
||||
end if;
|
||||
|
||||
end write_raw_Frame;
|
||||
|
||||
|
||||
|
||||
--------------
|
||||
-- Bitmap File
|
||||
--
|
||||
|
||||
type U8 is mod 2 ** 8; for U8 'Size use 8;
|
||||
type U16 is mod 2 ** 16; for U16'Size use 16;
|
||||
type U32 is mod 2 ** 32; for U32'Size use 32;
|
||||
|
||||
type I32 is range -2 ** 31 .. 2 ** 31 - 1;
|
||||
for I32'Size use 32;
|
||||
|
||||
|
||||
|
||||
generic
|
||||
type Number is mod <>;
|
||||
S : Stream_Access;
|
||||
procedure write_Intel_x86_Number (N : in Number);
|
||||
|
||||
procedure write_Intel_x86_Number (N : in Number)
|
||||
is
|
||||
M : Number := N;
|
||||
Bytes : constant Integer := Number'Size / 8;
|
||||
begin
|
||||
for i in 1 .. bytes
|
||||
loop
|
||||
U8'write (S, U8 (M mod 256));
|
||||
M := M / 256;
|
||||
end loop;
|
||||
end write_Intel_x86_Number;
|
||||
|
||||
|
||||
|
||||
subtype FxPt2dot30 is U32;
|
||||
|
||||
type CIExyz is
|
||||
record
|
||||
ciexyzX : FxPt2dot30;
|
||||
ciexyzY : FxPt2dot30;
|
||||
ciexyzZ : FxPt2dot30;
|
||||
end record;
|
||||
|
||||
type CIExyzTriple is
|
||||
record
|
||||
ciexyzRed : CIExyz;
|
||||
ciexyzGreen : CIExyz;
|
||||
ciexyzBlue : CIExyz;
|
||||
end record;
|
||||
|
||||
type BitMapFileHeader is
|
||||
record
|
||||
bfType : U16;
|
||||
bfSize : U32;
|
||||
bfReserved1 : U16 := 0;
|
||||
bfReserved2 : U16 := 0;
|
||||
bfOffBits : U32;
|
||||
end record;
|
||||
pragma pack (BitMapFileHeader);
|
||||
for BitMapFileHeader'Size use 8 * 14;
|
||||
|
||||
type BitMapInfoHeader is
|
||||
record
|
||||
biSize : U32;
|
||||
biWidth : I32;
|
||||
biHeight : I32;
|
||||
biPlanes : U16;
|
||||
biBitCount : U16;
|
||||
biCompression : U32;
|
||||
biSizeImage : U32;
|
||||
biXPelsPerMeter : I32 := 0;
|
||||
biYPelsPerMeter : I32 := 0;
|
||||
biClrUsed : U32 := 0;
|
||||
biClrImportant : U32 := 0;
|
||||
end record;
|
||||
pragma pack (BitMapInfoHeader);
|
||||
for BitMapInfoHeader'Size use 8 * 40;
|
||||
|
||||
type BitMapV4Header is
|
||||
record
|
||||
Core : BitMapInfoHeader;
|
||||
bV4RedMask : U32;
|
||||
bV4GreenMask : U32;
|
||||
bV4BlueMask : U32;
|
||||
bV4AlphaMask : U32;
|
||||
bV4CSType : U32;
|
||||
bV4Endpoints : CIExyzTriple;
|
||||
bV4GammaRed : U32;
|
||||
bV4GammaGreen : U32;
|
||||
bV4GammaBlue : U32;
|
||||
end record;
|
||||
pragma pack (BitMapV4Header);
|
||||
for BitMapV4Header'Size use 8 * 108;
|
||||
|
||||
|
||||
|
||||
procedure write_BMP_Header (to_Stream : in Stream_Access;
|
||||
Width, Height : in GL.GLint;
|
||||
with_Alpha : in Boolean)
|
||||
is
|
||||
use GL,
|
||||
GL.Binding,
|
||||
Texture;
|
||||
|
||||
FileHeader : BitMapFileHeader;
|
||||
FileInfo : BitMapV4Header;
|
||||
|
||||
begin
|
||||
FileHeader.bfType := 16#4D42#; -- 'BM'
|
||||
|
||||
FileInfo.Core.biWidth := I32 (Width);
|
||||
FileInfo.Core.biHeight := I32 (Height);
|
||||
FileInfo.Core.biPlanes := 1;
|
||||
|
||||
if with_Alpha
|
||||
then
|
||||
FileHeader.bfOffBits := BitMapFileHeader'Size / 8
|
||||
+ BitMapV4Header 'Size / 8;
|
||||
FileInfo.Core.biSize := BitMapV4Header'Size / 8;
|
||||
FileInfo.Core.biBitCount := 32;
|
||||
FileInfo.Core.biCompression := 3;
|
||||
FileInfo.Core.biSizeImage := U32 ( 4 -- 4-byte padding for '.bmp/.avi' formats.
|
||||
* Integer (Float'Ceiling (Float (FileInfo.Core.biWidth)))
|
||||
* Integer (FileInfo.Core.biHeight));
|
||||
|
||||
FileInfo.bV4RedMask := 16#00FF0000#;
|
||||
FileInfo.bV4GreenMask := 16#0000FF00#;
|
||||
FileInfo.bV4BlueMask := 16#000000FF#;
|
||||
FileInfo.bV4AlphaMask := 16#FF000000#;
|
||||
FileInfo.bV4CSType := 0;
|
||||
FileInfo.bV4Endpoints := (others => (others => 0));
|
||||
FileInfo.bV4GammaRed := 0;
|
||||
FileInfo.bV4GammaGreen := 0;
|
||||
FileInfo.bV4GammaBlue := 0;
|
||||
|
||||
else
|
||||
FileHeader.bfOffBits := BitMapFileHeader'Size / 8
|
||||
+ BitMapInfoHeader'Size / 8;
|
||||
FileInfo.Core.biSize := BitMapInfoHeader'Size / 8;
|
||||
FileInfo.Core.biBitCount := 24;
|
||||
FileInfo.Core.biCompression := 0;
|
||||
FileInfo.Core.biSizeImage := U32 ( 4 -- 4-byte padding for '.bmp/.avi' formats.
|
||||
* Integer (Float'Ceiling (Float (FileInfo.Core.biWidth) * 3.0 / 4.0))
|
||||
* Integer (FileInfo.Core.biHeight));
|
||||
end if;
|
||||
|
||||
FileHeader.bfSize := FileHeader.bfOffBits + FileInfo.Core.biSizeImage;
|
||||
|
||||
declare
|
||||
procedure write_Intel is new write_Intel_x86_Number (U16, to_Stream);
|
||||
procedure write_Intel is new write_Intel_x86_Number (U32, to_Stream);
|
||||
function convert is new ada.unchecked_Conversion (I32, U32);
|
||||
begin
|
||||
-- ** Endian-safe: ** --
|
||||
write_Intel (FileHeader.bfType);
|
||||
write_Intel (FileHeader.bfSize);
|
||||
write_Intel (FileHeader.bfReserved1);
|
||||
write_Intel (FileHeader.bfReserved2);
|
||||
write_Intel (FileHeader.bfOffBits);
|
||||
--
|
||||
write_Intel ( FileInfo.Core.biSize);
|
||||
write_Intel (convert (FileInfo.Core.biWidth));
|
||||
write_Intel (convert (FileInfo.Core.biHeight));
|
||||
write_Intel ( FileInfo.Core.biPlanes);
|
||||
write_Intel ( FileInfo.Core.biBitCount);
|
||||
write_Intel ( FileInfo.Core.biCompression);
|
||||
write_Intel ( FileInfo.Core.biSizeImage);
|
||||
write_Intel (convert (FileInfo.Core.biXPelsPerMeter));
|
||||
write_Intel (convert (FileInfo.Core.biYPelsPerMeter));
|
||||
write_Intel ( FileInfo.Core.biClrUsed);
|
||||
write_Intel ( FileInfo.Core.biClrImportant);
|
||||
|
||||
if with_Alpha
|
||||
then
|
||||
write_Intel (FileInfo.bV4RedMask);
|
||||
write_Intel (FileInfo.bV4GreenMask);
|
||||
write_Intel (FileInfo.bV4BlueMask);
|
||||
write_Intel (FileInfo.bV4AlphaMask);
|
||||
write_Intel (FileInfo.bV4CSType);
|
||||
|
||||
write_Intel (FileInfo.bV4Endpoints.ciexyzRed.ciexyzX);
|
||||
write_Intel (FileInfo.bV4Endpoints.ciexyzRed.ciexyzY);
|
||||
write_Intel (FileInfo.bV4Endpoints.ciexyzRed.ciexyzZ);
|
||||
|
||||
write_Intel (FileInfo.bV4Endpoints.ciexyzGreen.ciexyzX);
|
||||
write_Intel (FileInfo.bV4Endpoints.ciexyzGreen.ciexyzY);
|
||||
write_Intel (FileInfo.bV4Endpoints.ciexyzGreen.ciexyzZ);
|
||||
|
||||
write_Intel (FileInfo.bV4Endpoints.ciexyzBlue.ciexyzX);
|
||||
write_Intel (FileInfo.bV4Endpoints.ciexyzBlue.ciexyzY);
|
||||
write_Intel (FileInfo.bV4Endpoints.ciexyzBlue.ciexyzZ);
|
||||
|
||||
write_Intel (FileInfo.bV4GammaRed);
|
||||
write_Intel (FileInfo.bV4GammaGreen);
|
||||
write_Intel (FileInfo.bV4GammaBlue);
|
||||
end if;
|
||||
end;
|
||||
end write_BMP_Header;
|
||||
|
||||
|
||||
|
||||
-------------
|
||||
-- Save Image
|
||||
--
|
||||
|
||||
procedure save (image_Filename : in String;
|
||||
the_Image : in Image)
|
||||
is
|
||||
use GL,
|
||||
GL.Binding,
|
||||
ada.Streams.Stream_IO;
|
||||
|
||||
File : ada.Streams.Stream_IO.File_type;
|
||||
S : ada.Streams.Stream_IO.Stream_access;
|
||||
|
||||
Size : Extent_2D := (Width => the_Image'Length (2),
|
||||
Height => the_Image'Length (1));
|
||||
|
||||
begin
|
||||
create (File, out_File, image_Filename);
|
||||
|
||||
S := Stream (File);
|
||||
|
||||
write_BMP_Header (to_Stream => S,
|
||||
Width => GLint (Size.Width),
|
||||
Height => GLint (Size.Height),
|
||||
with_Alpha => True);
|
||||
|
||||
for r in 1 .. Index_t (Size.Height)
|
||||
loop
|
||||
for c in 1 .. Index_t (Size.Width)
|
||||
loop
|
||||
color_Value'write (S, the_Image (r, c).Blue);
|
||||
color_Value'write (S, the_Image (r, c).Green);
|
||||
color_Value'write (S, the_Image (r, c).Red);
|
||||
color_Value'write (S, 255);
|
||||
end loop;
|
||||
end loop;
|
||||
|
||||
close (File);
|
||||
|
||||
exception
|
||||
when others =>
|
||||
if is_Open (File)
|
||||
then
|
||||
close (File);
|
||||
end if;
|
||||
|
||||
raise;
|
||||
end Save;
|
||||
|
||||
|
||||
-------------
|
||||
-- Screenshot
|
||||
--
|
||||
|
||||
procedure Screenshot (Filename : in String;
|
||||
with_Alpha : in Boolean := False)
|
||||
is
|
||||
use GL,
|
||||
GL.Binding,
|
||||
ada.Streams.Stream_IO;
|
||||
|
||||
File : ada.Streams.Stream_IO.File_type;
|
||||
S : ada.Streams.Stream_IO.Stream_access;
|
||||
|
||||
Viewport : array (0 .. 3) of aliased GLint;
|
||||
|
||||
begin
|
||||
Tasks.check;
|
||||
|
||||
glGetIntegerv (GL_VIEWPORT,
|
||||
Viewport (0)'unchecked_Access);
|
||||
Errors.log;
|
||||
|
||||
create (File, out_File, Filename);
|
||||
|
||||
S := Stream (File);
|
||||
|
||||
write_BMP_Header (to_Stream => S,
|
||||
Width => Viewport (2),
|
||||
Height => Viewport (3),
|
||||
with_Alpha => with_Alpha);
|
||||
|
||||
write_raw_Frame (to_Stream => S,
|
||||
Width => Integer (Viewport (2)),
|
||||
Height => Integer (Viewport (3)),
|
||||
with_Alpha => with_Alpha);
|
||||
close (File);
|
||||
|
||||
exception
|
||||
when others =>
|
||||
if is_Open (File)
|
||||
then
|
||||
close (File);
|
||||
end if;
|
||||
|
||||
raise;
|
||||
end Screenshot;
|
||||
|
||||
|
||||
|
||||
----------------
|
||||
-- Video Capture
|
||||
--
|
||||
|
||||
-- We define global variables since it is not expected
|
||||
-- that more that one capture is taken at the same time.
|
||||
--
|
||||
avi : ada.Streams.Stream_IO.File_type;
|
||||
frames : Natural;
|
||||
rate : Positive;
|
||||
width, height : Positive;
|
||||
bmp_size : U32;
|
||||
|
||||
procedure write_RIFF_Headers
|
||||
is
|
||||
-- Written 1st time to take place (but # of frames unknown)
|
||||
-- Written 2nd time for setting # of frames, sizes, etc.
|
||||
--
|
||||
calc_bmp_size : constant U32 := U32 (((width)) * height * 3);
|
||||
-- !! stuff to multiple of 4 !!
|
||||
index_size : constant U32 := U32 (frames) * 16;
|
||||
movie_size : constant U32 := 4 + U32 (frames) * (calc_bmp_size + 8);
|
||||
second_list_size : constant U32 := 4 + 64 + 48;
|
||||
first_list_size : constant U32 := (4 + 64) + (8 + second_list_size);
|
||||
file_size : constant U32 := 8 + (8 + first_list_size) + (4 + movie_size) + (8 + index_size);
|
||||
Stream : constant Stream_access := ada.Streams.Stream_IO.Stream (avi);
|
||||
|
||||
procedure write_Intel is new write_Intel_x86_Number (U16, Stream);
|
||||
procedure write_Intel is new write_Intel_x86_Number (U32, Stream);
|
||||
|
||||
microseconds_per_frame : constant U32 := U32 (1_000_000.0 / long_Float (rate));
|
||||
begin
|
||||
bmp_size := calc_bmp_size;
|
||||
|
||||
String'write (Stream, "RIFF");
|
||||
U32 'write (Stream, file_size);
|
||||
String'write (Stream, "AVI ");
|
||||
String'write (Stream, "LIST");
|
||||
write_Intel (first_list_size);
|
||||
String'write (Stream, "hdrl");
|
||||
String'write (Stream, "avih");
|
||||
write_Intel (U32' (56));
|
||||
|
||||
-- Begin of AVI Header
|
||||
write_Intel (microseconds_per_frame);
|
||||
write_Intel (U32'(0)); -- MaxBytesPerSec
|
||||
write_Intel (U32'(0)); -- Reserved1
|
||||
write_Intel (U32'(16)); -- Flags (16 = has an index)
|
||||
write_Intel (U32 (frames));
|
||||
write_Intel (U32'(0)); -- InitialFrames
|
||||
write_Intel (U32'(1)); -- Streams
|
||||
write_Intel (bmp_size);
|
||||
write_Intel (U32 (width));
|
||||
write_Intel (U32 (height));
|
||||
write_Intel (U32'(0)); -- Scale
|
||||
write_Intel (U32'(0)); -- Rate
|
||||
write_Intel (U32'(0)); -- Start
|
||||
write_Intel (U32'(0)); -- Length
|
||||
-- End of AVI Header
|
||||
|
||||
String'write (Stream, "LIST");
|
||||
write_Intel (second_list_size);
|
||||
String'write (Stream, "strl");
|
||||
|
||||
-- Begin of Str
|
||||
String'write (Stream, "strh");
|
||||
write_Intel (U32'(56));
|
||||
String'write (Stream, "vids");
|
||||
String'write (Stream, "DIB ");
|
||||
write_Intel (U32'(0)); -- flags
|
||||
write_Intel (U32'(0)); -- priority
|
||||
write_Intel (U32'(0)); -- initial frames
|
||||
write_Intel (microseconds_per_frame); -- Scale
|
||||
write_Intel (U32'(1_000_000)); -- Rate
|
||||
write_Intel (U32'(0)); -- Start
|
||||
write_Intel (U32 (frames)); -- Length
|
||||
write_Intel (bmp_size); -- SuggestedBufferSize
|
||||
write_Intel (U32'(0)); -- Quality
|
||||
write_Intel (U32'(0)); -- SampleSize
|
||||
write_Intel (U32'(0));
|
||||
write_Intel (U16 (width));
|
||||
write_Intel (U16 (height));
|
||||
-- End of Str
|
||||
|
||||
String'write (Stream, "strf");
|
||||
write_Intel (U32'(40));
|
||||
|
||||
-- Begin of BMI
|
||||
write_Intel (U32'(40)); -- BM header size (like BMP)
|
||||
write_Intel (U32 (width));
|
||||
write_Intel (U32 (height));
|
||||
write_Intel (U16'(1)); -- Planes
|
||||
write_Intel (U16'(24)); -- BitCount
|
||||
write_Intel (U32'(0)); -- Compression
|
||||
write_Intel (bmp_size); -- SizeImage
|
||||
write_Intel (U32'(3780)); -- XPelsPerMeter
|
||||
write_Intel (U32'(3780)); -- YPelsPerMeter
|
||||
write_Intel (U32'(0)); -- ClrUsed
|
||||
write_Intel (U32'(0)); -- ClrImportant
|
||||
-- End of BMI
|
||||
|
||||
String'write (Stream, "LIST");
|
||||
write_Intel (movie_size);
|
||||
String'write (Stream, "movi");
|
||||
end Write_RIFF_headers;
|
||||
|
||||
|
||||
|
||||
procedure start_Capture (AVI_Name : String;
|
||||
frame_Rate : Positive)
|
||||
is
|
||||
use GL,
|
||||
GL.Binding;
|
||||
Viewport : array (0 .. 3) of aliased GLint;
|
||||
begin
|
||||
Tasks.check;
|
||||
|
||||
create (Avi, out_File, AVI_Name);
|
||||
|
||||
Frames := 0;
|
||||
Rate := frame_Rate;
|
||||
|
||||
glGetIntegerv (GL_VIEWPORT,
|
||||
Viewport (0)'unchecked_Access);
|
||||
Errors.log;
|
||||
|
||||
Width := Positive (Viewport (2));
|
||||
Height := Positive (Viewport (3));
|
||||
-- NB: GL viewport resizing should be blocked during the video capture !
|
||||
write_RIFF_Headers;
|
||||
end start_Capture;
|
||||
|
||||
|
||||
|
||||
procedure capture_Frame
|
||||
is
|
||||
S : constant Stream_Access := Stream (Avi);
|
||||
procedure Write_Intel is new Write_Intel_x86_number (U32, s);
|
||||
begin
|
||||
String'write (S, "00db");
|
||||
write_Intel (bmp_Size);
|
||||
write_raw_Frame (S, Width, Height, with_Alpha => False);
|
||||
|
||||
Frames := Frames + 1;
|
||||
end capture_Frame;
|
||||
|
||||
|
||||
|
||||
procedure stop_Capture
|
||||
is
|
||||
index_Size : constant U32 := U32 (Frames) * 16;
|
||||
S : constant Stream_Access := Stream (Avi);
|
||||
ChunkOffset : U32 := 4;
|
||||
|
||||
procedure write_Intel is new write_Intel_x86_Number (U32, S);
|
||||
begin
|
||||
-- Write the index section
|
||||
--
|
||||
String'write (S, "idx1");
|
||||
write_Intel (index_Size);
|
||||
|
||||
for f in 1 .. Frames
|
||||
loop
|
||||
String'write (S, "00db");
|
||||
write_Intel (U32'(16)); -- Keyframe.
|
||||
write_Intel (ChunkOffset);
|
||||
ChunkOffset := ChunkOffset + bmp_Size + 8;
|
||||
write_Intel (bmp_Size);
|
||||
end loop;
|
||||
|
||||
Set_Index (avi, 1); -- Go back to file beginning.
|
||||
write_RIFF_Headers; -- Rewrite headers with correct data.
|
||||
close (Avi);
|
||||
end stop_Capture;
|
||||
|
||||
|
||||
end openGL.IO;
|
||||
171
3-mid/opengl/source/lean/io/opengl-io.ads
Normal file
171
3-mid/opengl/source/lean/io/opengl-io.ads
Normal file
@@ -0,0 +1,171 @@
|
||||
with
|
||||
openGL.Texture,
|
||||
|
||||
ada.Strings.unbounded,
|
||||
ada.Streams.Stream_IO,
|
||||
ada.unchecked_Deallocation;
|
||||
|
||||
package openGL.IO
|
||||
--
|
||||
-- Provides I/O functions for openGL.
|
||||
--
|
||||
is
|
||||
subtype Text is ada.Strings.unbounded.unbounded_String;
|
||||
|
||||
|
||||
------------------
|
||||
-- General Vertex
|
||||
--
|
||||
|
||||
null_Id : constant long_Index_t;
|
||||
|
||||
type Vertex is
|
||||
record
|
||||
site_Id,
|
||||
coord_Id,
|
||||
normal_Id,
|
||||
weights_Id : long_Index_t;
|
||||
end record;
|
||||
|
||||
type Vertices is array (long_Index_t range <>) of aliased Vertex;
|
||||
type Vertices_view is access all Vertices;
|
||||
|
||||
|
||||
--------
|
||||
-- Face
|
||||
--
|
||||
|
||||
type facet_Kind is (Triangle, Quad, Polygon);
|
||||
|
||||
type Face (Kind : facet_Kind := Triangle) is
|
||||
record
|
||||
case Kind
|
||||
is
|
||||
when Triangle => Tri : Vertices (1 .. 3);
|
||||
when Quad => Quad : Vertices (1 .. 4);
|
||||
when Polygon => Poly : Vertices_view;
|
||||
end case;
|
||||
end record;
|
||||
|
||||
type Faces is array (long_Index_t range <>) of Face;
|
||||
|
||||
|
||||
procedure destroy (Self : in out Face);
|
||||
function Vertices_of (Self : in Face) return Vertices;
|
||||
|
||||
procedure set_Vertex_in (Self : in out Face; Which : in long_Index_t;
|
||||
To : in Vertex);
|
||||
|
||||
--------------------
|
||||
-- Rigging/Skinning
|
||||
--
|
||||
|
||||
type bone_Id is range 0 .. 200;
|
||||
|
||||
type bone_Weight is
|
||||
record
|
||||
Bone : bone_Id;
|
||||
Weight : Real;
|
||||
end record;
|
||||
|
||||
type bone_Weights is array (long_Index_t range <>) of bone_Weight;
|
||||
type bone_Weights_view is access bone_Weights;
|
||||
type bone_Weights_array is array (long_Index_t range <>) of bone_Weights_view;
|
||||
|
||||
|
||||
---------
|
||||
-- Views
|
||||
--
|
||||
|
||||
type many_Sites_view is access all openGL.many_Sites;
|
||||
type many_Coords_view is access all openGL.many_Coordinates_2D;
|
||||
type many_Normals_view is access all openGL.many_Normals;
|
||||
type bone_Weights_array_view is access all bone_Weights_array;
|
||||
type Faces_view is access all IO.Faces;
|
||||
|
||||
procedure free is new ada.unchecked_Deallocation (many_Sites, IO.many_Sites_view);
|
||||
procedure free is new ada.unchecked_Deallocation (many_Coordinates_2D, IO.many_Coords_view);
|
||||
procedure free is new ada.unchecked_Deallocation (many_Normals, IO.many_Normals_view);
|
||||
procedure free is new ada.unchecked_Deallocation (IO.Faces, IO.Faces_view);
|
||||
|
||||
|
||||
-----------------
|
||||
--- General Model
|
||||
--
|
||||
|
||||
type Model is
|
||||
record
|
||||
Sites : many_Sites_view;
|
||||
Coords : many_Coords_view;
|
||||
Normals : many_Normals_view;
|
||||
Weights : bone_Weights_array_view;
|
||||
Faces : Faces_view;
|
||||
end record;
|
||||
|
||||
procedure destroy (Self : in out Model);
|
||||
|
||||
|
||||
--------------
|
||||
-- Heightmaps
|
||||
--
|
||||
|
||||
type height_Map_view is access all height_Map;
|
||||
|
||||
function to_height_Map (image_Filename : in asset_Name;
|
||||
Scale : in Real := 1.0) return height_Map_view;
|
||||
|
||||
----------
|
||||
-- Images
|
||||
--
|
||||
|
||||
function fetch_Image (Stream : in ada.Streams.Stream_IO.Stream_access;
|
||||
try_TGA : in Boolean) return openGL.Image;
|
||||
pragma Obsolescent (fetch_Image, "use 'openGL.Images.fetch_Image' instead");
|
||||
|
||||
function to_Image (image_Filename : in asset_Name) return Image;
|
||||
function to_lucid_Image (image_Filename : in asset_Name) return lucid_Image;
|
||||
function to_lucid_Image (image_Filename : in asset_Name;
|
||||
is_Lucid : access Boolean) return lucid_Image;
|
||||
|
||||
procedure save (image_Filename : in String;
|
||||
the_Image : in Image);
|
||||
|
||||
|
||||
------------
|
||||
-- Textures
|
||||
--
|
||||
|
||||
function to_Texture (image_Filename : in asset_Name) return Texture.Object;
|
||||
|
||||
|
||||
---------------
|
||||
-- Screenshots
|
||||
--
|
||||
|
||||
function current_Frame return Image;
|
||||
|
||||
procedure Screenshot (Filename : in String; with_Alpha : in Boolean := False);
|
||||
--
|
||||
-- Stores the image of the current, active viewport (in RGB or RGBA Bitmap format).
|
||||
|
||||
|
||||
-----------------
|
||||
-- Video Capture
|
||||
--
|
||||
|
||||
procedure start_capture (AVI_Name : in String;
|
||||
frame_Rate : in Positive);
|
||||
--
|
||||
-- Prepare for video capture (RGB uncompressed, AVI format).
|
||||
|
||||
procedure capture_Frame;
|
||||
--
|
||||
-- Captures the current active viewport.
|
||||
|
||||
procedure stop_capture;
|
||||
|
||||
|
||||
|
||||
private
|
||||
null_Id : constant long_Index_t := 0;
|
||||
end openGL.IO;
|
||||
133
3-mid/opengl/source/lean/light/opengl-light.adb
Normal file
133
3-mid/opengl/source/lean/light/opengl-light.adb
Normal file
@@ -0,0 +1,133 @@
|
||||
package body openGL.Light
|
||||
is
|
||||
|
||||
function Id (Self : in Item) return light.Id_t
|
||||
is
|
||||
begin
|
||||
return Self.Id;
|
||||
end Id;
|
||||
|
||||
|
||||
procedure Id_is (Self : in out Item; Now : in light.Id_t)
|
||||
is
|
||||
begin
|
||||
Self.Id := Now;
|
||||
end Id_is;
|
||||
|
||||
|
||||
function Kind (Self : in Item) return light.Kind_t
|
||||
is
|
||||
begin
|
||||
return Self.Kind;
|
||||
end Kind;
|
||||
|
||||
|
||||
procedure Kind_is (Self : in out Item; Now : in light.Kind_t)
|
||||
is
|
||||
begin
|
||||
Self.Kind := Now;
|
||||
end Kind_is;
|
||||
|
||||
|
||||
function is_On (Self : in Item) return Boolean
|
||||
is
|
||||
begin
|
||||
return Self.On;
|
||||
end is_On;
|
||||
|
||||
|
||||
procedure is_On (Self : in out Item; Now : in Boolean := True)
|
||||
is
|
||||
begin
|
||||
Self.On := Now;
|
||||
end is_On;
|
||||
|
||||
|
||||
|
||||
function Site (Self : in Item) return openGL.Site
|
||||
is
|
||||
begin
|
||||
return Self.Site;
|
||||
end Site;
|
||||
|
||||
|
||||
procedure Site_is (Self : in out Item; Now : in openGL.Site)
|
||||
is
|
||||
begin
|
||||
Self.Site := Now;
|
||||
end Site_is;
|
||||
|
||||
|
||||
function Color (Self : in Item) return openGL.Color
|
||||
is
|
||||
begin
|
||||
return Self.Color;
|
||||
end Color;
|
||||
|
||||
|
||||
function Attenuation (Self : in Item) return Real
|
||||
is
|
||||
begin
|
||||
return Self.Attenuation;
|
||||
end Attenuation;
|
||||
|
||||
|
||||
function ambient_Coefficient (Self : in Item) return Real
|
||||
is
|
||||
begin
|
||||
return Self.ambient_Coefficient;
|
||||
end ambient_Coefficient;
|
||||
|
||||
|
||||
function cone_Angle (Self : in Item) return Degrees
|
||||
is
|
||||
begin
|
||||
return Self.cone_Angle;
|
||||
end cone_Angle;
|
||||
|
||||
|
||||
function cone_Direction (Self : in Item) return Vector_3
|
||||
is
|
||||
begin
|
||||
return Self.cone_Direction;
|
||||
end cone_Direction;
|
||||
|
||||
|
||||
|
||||
procedure Color_is (Self : in out Item; Now : in openGL.Color)
|
||||
is
|
||||
begin
|
||||
Self.Color := Now;
|
||||
end Color_is;
|
||||
|
||||
|
||||
procedure Attenuation_is (Self : in out Item; Now : in Real)
|
||||
is
|
||||
begin
|
||||
Self.Attenuation := Now;
|
||||
end Attenuation_is;
|
||||
|
||||
|
||||
procedure ambient_Coefficient_is (Self : in out Item; Now : in Real)
|
||||
is
|
||||
begin
|
||||
Self.ambient_Coefficient := Now;
|
||||
end ambient_Coefficient_is;
|
||||
|
||||
|
||||
|
||||
procedure cone_Angle_is (Self : in out Item; Now : in Degrees)
|
||||
is
|
||||
begin
|
||||
Self.cone_Angle := Now;
|
||||
end cone_Angle_is;
|
||||
|
||||
|
||||
procedure cone_Direction_is (Self : in out Item; Now : in Vector_3)
|
||||
is
|
||||
begin
|
||||
Self.cone_Direction := Now;
|
||||
end cone_Direction_is;
|
||||
|
||||
|
||||
end openGL.Light;
|
||||
66
3-mid/opengl/source/lean/light/opengl-light.ads
Normal file
66
3-mid/opengl/source/lean/light/opengl-light.ads
Normal file
@@ -0,0 +1,66 @@
|
||||
with
|
||||
openGL.Palette;
|
||||
|
||||
|
||||
package openGL.Light
|
||||
--
|
||||
-- Models a light.
|
||||
--
|
||||
is
|
||||
type Item is tagged private;
|
||||
type Items is array (Positive range <>) of Item;
|
||||
|
||||
|
||||
--------------
|
||||
--- Attributes
|
||||
--
|
||||
type Id_t is new Natural;
|
||||
type Kind_t is (Diffuse, Direct);
|
||||
|
||||
null_Id : constant Id_t;
|
||||
|
||||
function Id (Self : in Item) return light.Id_t;
|
||||
procedure Id_is (Self : in out Item; Now : in light.Id_t);
|
||||
|
||||
function Kind (Self : in Item) return light.Kind_t;
|
||||
procedure Kind_is (Self : in out Item; Now : in light.Kind_t);
|
||||
|
||||
function is_On (Self : in Item) return Boolean;
|
||||
procedure is_On (Self : in out Item; Now : in Boolean := True);
|
||||
|
||||
function Site (Self : in Item) return openGL.Site;
|
||||
procedure Site_is (Self : in out Item; Now : in openGL.Site);
|
||||
|
||||
function Color (Self : in Item) return Color;
|
||||
function Attenuation (Self : in Item) return Real;
|
||||
function ambient_Coefficient (Self : in Item) return Real;
|
||||
function cone_Angle (Self : in Item) return Degrees;
|
||||
function cone_Direction (Self : in Item) return Vector_3;
|
||||
|
||||
procedure Color_is (Self : in out Item; Now : in openGL.Color);
|
||||
procedure Attenuation_is (Self : in out Item; Now : in Real);
|
||||
procedure ambient_Coefficient_is (Self : in out Item; Now : in Real);
|
||||
procedure cone_Angle_is (Self : in out Item; Now : in Degrees);
|
||||
procedure cone_Direction_is (Self : in out Item; Now : in Vector_3);
|
||||
|
||||
|
||||
|
||||
private
|
||||
|
||||
null_Id : constant Id_t := Id_t'First;
|
||||
|
||||
type Item is tagged
|
||||
record
|
||||
Id : light.Id_t := null_Id;
|
||||
Kind : light.Kind_t := Direct;
|
||||
On : Boolean := True;
|
||||
Site : openGL.Site := [0.0, 0.0, 1.0]; -- The GL default.
|
||||
|
||||
Color : openGL.Color := Palette.White;
|
||||
Attenuation : Real := 0.1;
|
||||
ambient_Coefficient : Real := 0.1;
|
||||
cone_Angle : Degrees := 2.0;
|
||||
cone_Direction : Vector_3 := [0.0, 0.0, -1.0];
|
||||
end record;
|
||||
|
||||
end openGL.Light;
|
||||
495
3-mid/opengl/source/lean/model/opengl-model-any.adb
Normal file
495
3-mid/opengl/source/lean/model/opengl-model-any.adb
Normal file
@@ -0,0 +1,495 @@
|
||||
with
|
||||
openGL.Primitive.short_indexed,
|
||||
openGL.Primitive. indexed,
|
||||
openGL.Primitive.long_indexed,
|
||||
|
||||
openGL.Geometry.lit_textured,
|
||||
openGL.Geometry.lit_colored_textured_skinned,
|
||||
|
||||
openGL.Texture,
|
||||
openGL.Palette,
|
||||
|
||||
openGL.IO.wavefront,
|
||||
openGL.IO.collada,
|
||||
openGL.IO.lat_long_Radius,
|
||||
|
||||
ada.Strings.fixed,
|
||||
ada.Containers.hashed_Maps,
|
||||
|
||||
ada.unchecked_Deallocation;
|
||||
|
||||
|
||||
package body openGL.Model.any
|
||||
is
|
||||
|
||||
type lit_textured_skinned_Geometry_view is access all openGL.Geometry.lit_colored_textured_skinned.item'Class;
|
||||
|
||||
|
||||
---------
|
||||
--- Forge
|
||||
--
|
||||
|
||||
function to_Model (Model : in asset_Name;
|
||||
Texture : in asset_Name;
|
||||
Texture_is_lucid : in Boolean) return openGL.Model.any.item
|
||||
is
|
||||
begin
|
||||
return Self : openGL.Model.any.item := (openGL.Model.item with
|
||||
Model,
|
||||
Texture,
|
||||
Texture_is_lucid,
|
||||
Geometry => null)
|
||||
do
|
||||
Self.Bounds.Ball := 1.0;
|
||||
end return;
|
||||
end to_Model;
|
||||
|
||||
|
||||
function new_Model (Model : in asset_Name;
|
||||
Texture : in asset_Name;
|
||||
Texture_is_lucid : in Boolean) return openGL.Model.any.view
|
||||
is
|
||||
begin
|
||||
return new openGL.Model.any.item' (to_Model (Model, Texture, Texture_is_lucid));
|
||||
end new_Model;
|
||||
|
||||
|
||||
--------------
|
||||
--- Attributes
|
||||
--
|
||||
|
||||
function model_Name (Self : in Item) return asset_Name
|
||||
is
|
||||
begin
|
||||
return Self.Model;
|
||||
end model_Name;
|
||||
|
||||
|
||||
use openGL.IO;
|
||||
|
||||
function Hash (Self : in io.Vertex) return ada.Containers.Hash_type
|
||||
is
|
||||
begin
|
||||
return ada.Containers.Hash_type (Self.site_Id + 3 * Self.coord_Id + 5 * Self.normal_Id + 7 * Self.weights_Id);
|
||||
end Hash;
|
||||
|
||||
package io_vertex_Maps_of_gl_vertex_id is new ada.containers.Hashed_Maps (io.Vertex,
|
||||
long_Index_t,
|
||||
Hash,
|
||||
"=");
|
||||
subtype io_vertex_Map_of_gl_vertex_id is io_vertex_Maps_of_gl_vertex_id.Map;
|
||||
|
||||
type any_Vertex is
|
||||
record
|
||||
Site : Vector_3;
|
||||
Normal : Vector_3;
|
||||
Coords : Coordinate_2D;
|
||||
Shine : Real;
|
||||
Bones : bone_Weights (1 .. 4);
|
||||
end record;
|
||||
|
||||
type any_Vertex_array is array (long_Index_t range <>) of aliased any_Vertex;
|
||||
type any_Vertex_array_view is access all any_Vertex_array;
|
||||
|
||||
procedure deallocate is new ada.unchecked_Deallocation (any_Vertex_array,
|
||||
any_Vertex_array_view);
|
||||
|
||||
|
||||
function to_lit_textured_Vertices (From : in any_Vertex_array) return Geometry.lit_textured.Vertex_large_array
|
||||
is
|
||||
Result : Geometry.lit_textured.Vertex_large_array (From'Range);
|
||||
begin
|
||||
for i in From'Range
|
||||
loop
|
||||
Result (i) := (Site => From (i).Site,
|
||||
Normal => From (i).Normal,
|
||||
Coords => From (i).Coords,
|
||||
Shine => From (i).Shine);
|
||||
end loop;
|
||||
|
||||
return Result;
|
||||
end to_lit_textured_Vertices;
|
||||
|
||||
|
||||
|
||||
function to_lit_textured_skinned_Vertices (From : in any_Vertex_array) return Geometry.lit_colored_textured_skinned.Vertex_array
|
||||
is
|
||||
use Palette;
|
||||
Result : Geometry.lit_colored_textured_skinned.Vertex_array (From'Range);
|
||||
begin
|
||||
for i in From'Range
|
||||
loop
|
||||
Result (i) := (Site => From (i).Site,
|
||||
Normal => From (i).Normal,
|
||||
Coords => From (i).Coords,
|
||||
Shine => From (i).Shine,
|
||||
Color => (+White, opaque_Value),
|
||||
bone_Ids => [1 => Real (From (i).Bones (1).Bone),
|
||||
2 => Real (From (i).Bones (2).Bone),
|
||||
3 => Real (From (i).Bones (3).Bone),
|
||||
4 => Real (From (i).Bones (4).Bone)],
|
||||
bone_Weights => [1 => From (i).Bones (1).Weight,
|
||||
2 => From (i).Bones (2).Weight,
|
||||
3 => From (i).Bones (3).Weight,
|
||||
4 => From (i).Bones (4).Weight]);
|
||||
end loop;
|
||||
|
||||
return Result;
|
||||
end to_lit_textured_skinned_Vertices;
|
||||
|
||||
|
||||
|
||||
overriding
|
||||
function to_GL_Geometries (Self : access Item; Textures : access Texture.name_Map_of_texture'Class;
|
||||
Fonts : in Font.font_id_Map_of_font) return Geometry.views
|
||||
is
|
||||
pragma unreferenced (Textures, Fonts);
|
||||
begin
|
||||
Self.build_GL_Geometries;
|
||||
return [1 => Self.Geometry];
|
||||
end to_GL_Geometries;
|
||||
|
||||
|
||||
|
||||
procedure build_GL_Geometries (Self : in out Item)
|
||||
is
|
||||
use Geometry;
|
||||
|
||||
model_Name : constant String := to_String (Self.Model);
|
||||
|
||||
function load_Model return io.Model
|
||||
is
|
||||
use ada.Strings.fixed;
|
||||
begin
|
||||
if Tail (model_Name, 4) = ".obj" then return wavefront .to_Model (model_Name);
|
||||
elsif Tail (model_Name, 4) = ".dae" then return collada .to_Model (model_Name);
|
||||
elsif Tail (model_Name, 4) = ".tab" then return lat_long_Radius.to_Model (model_Name);
|
||||
else raise unsupported_model_Format with "Model => '" & model_Name & "'";
|
||||
end if;
|
||||
end load_Model;
|
||||
|
||||
the_Model : openGL.io.Model := load_Model;
|
||||
the_Map : io_vertex_Map_of_gl_vertex_id;
|
||||
|
||||
the_Vertices : any_Vertex_array_view := new any_Vertex_array' (1 .. 100_000 => <>);
|
||||
vertex_Count : openGL.long_Index_t := 0;
|
||||
|
||||
tri_Count : Index_t := 0;
|
||||
Normals_known : Boolean := False;
|
||||
|
||||
-- TODO: Use one set of gl face vertices and 2 sets of indices (1 for tris and 1 for quads).
|
||||
|
||||
begin
|
||||
Self.Bounds := null_Bounds;
|
||||
|
||||
-- 1st pass: - Set our openGL face vertices.
|
||||
-- - Build 'io vertex' to 'openGL face vertex_Id' map.
|
||||
--
|
||||
for f in the_Model.Faces'Range
|
||||
loop
|
||||
declare
|
||||
use io_vertex_Maps_of_gl_vertex_id;
|
||||
|
||||
the_model_Face : io.Face renames the_Model.Faces (f);
|
||||
|
||||
begin
|
||||
if the_model_Face.Kind = Triangle
|
||||
or the_model_Face.Kind = Quad
|
||||
then
|
||||
declare
|
||||
the_io_Vertices : constant io.Vertices := Vertices_of (the_model_Face);
|
||||
Cursor : io_vertex_Maps_of_gl_vertex_id.Cursor;
|
||||
begin
|
||||
case the_model_Face.Kind
|
||||
is
|
||||
when Triangle => tri_Count := tri_Count + 1;
|
||||
when Quad => tri_Count := tri_Count + 2;
|
||||
when Polygon => null;
|
||||
end case;
|
||||
|
||||
for v in the_io_Vertices'Range
|
||||
loop
|
||||
Cursor := the_Map.find (the_io_Vertices (v));
|
||||
|
||||
if not has_Element (Cursor)
|
||||
then -- We do not know about this vertex yet, so add it.
|
||||
vertex_Count := vertex_Count + 1;
|
||||
|
||||
declare
|
||||
the_io_Vertex : io.Vertex renames the_io_Vertices (v);
|
||||
the_gl_Vertex : any_Vertex renames the_Vertices (vertex_Count);
|
||||
begin
|
||||
the_gl_Vertex.Site := the_Model.Sites (the_io_Vertex.site_Id);
|
||||
|
||||
Self.Bounds.Box := Self.Bounds.Box or the_gl_Vertex.Site;
|
||||
Self.Bounds.Ball := Real'Max (Self.Bounds.Ball,
|
||||
abs (the_gl_Vertex.Site));
|
||||
|
||||
if the_io_Vertex.coord_Id /= null_Id
|
||||
then the_gl_Vertex.Coords := the_Model.Coords (the_io_Vertex.coord_Id);
|
||||
else the_gl_Vertex.Coords := (0.0, 0.0);
|
||||
end if;
|
||||
|
||||
if the_io_Vertex.normal_Id /= null_Id
|
||||
then the_gl_Vertex.Normal := the_Model.Normals (the_io_Vertex.normal_Id);
|
||||
the_gl_Vertex.Shine := default_Shine;
|
||||
normals_Known := True;
|
||||
else the_gl_Vertex.Normal := [0.0, 0.0, 0.0];
|
||||
end if;
|
||||
|
||||
if the_Model.Weights /= null
|
||||
and the_io_Vertex.weights_Id /= null_Id
|
||||
then
|
||||
declare
|
||||
the_Weights : bone_Weights renames the_Model.Weights (the_io_Vertex.weights_Id).all;
|
||||
begin
|
||||
if the_Weights'Length > 0
|
||||
then
|
||||
the_gl_Vertex.Bones (1) := the_Weights (1);
|
||||
--
|
||||
-- nb: Only using the first 4 bones atm.
|
||||
|
||||
if the_Weights'Length >= 2
|
||||
then the_gl_Vertex.Bones (2) := the_Weights (2);
|
||||
else the_gl_Vertex.Bones (2) := (0, 0.0);
|
||||
end if;
|
||||
|
||||
if the_Weights'Length >= 3
|
||||
then the_gl_Vertex.Bones (3) := the_Weights (3);
|
||||
else the_gl_Vertex.Bones (3) := (0, 0.0);
|
||||
end if;
|
||||
|
||||
if the_Weights'Length >= 4
|
||||
then the_gl_Vertex.Bones (4) := the_Weights (4);
|
||||
else the_gl_Vertex.Bones (4) := (0, 0.0);
|
||||
end if;
|
||||
|
||||
else
|
||||
the_gl_Vertex.Bones := [1 => (0, 0.0),
|
||||
2 => (0, 0.0),
|
||||
3 => (0, 0.0),
|
||||
4 => (0, 0.0)];
|
||||
end if;
|
||||
end;
|
||||
|
||||
else
|
||||
the_gl_Vertex.Bones := [1 => (0, 0.0),
|
||||
2 => (0, 0.0),
|
||||
3 => (0, 0.0),
|
||||
4 => (0, 0.0)];
|
||||
end if;
|
||||
|
||||
the_Map.insert (the_io_Vertex, vertex_Count); -- 'vertex_Count' provides the index of the current vertex.
|
||||
end;
|
||||
end if;
|
||||
|
||||
end loop;
|
||||
end;
|
||||
|
||||
end if;
|
||||
end;
|
||||
end loop;
|
||||
|
||||
-- We now have our gl face vertices built and mapped to each model vertex.
|
||||
|
||||
|
||||
-- 2nd pass: - Set the triangle faceted indices.
|
||||
-- - Set the quad faceted indices.
|
||||
--
|
||||
declare
|
||||
tri_indices_Count : long_Index_t := 0;
|
||||
tri_indices_Last : constant long_Index_t := long_Index_t (tri_Count) * 3;
|
||||
tri_Indices : aliased long_Indices (1 .. tri_indices_Last);
|
||||
|
||||
procedure add_to_Tri (the_Vertex : in io.Vertex)
|
||||
is
|
||||
begin
|
||||
tri_indices_Count := tri_indices_Count + 1;
|
||||
tri_Indices (tri_indices_Count) := the_Map.Element (the_Vertex);
|
||||
end add_to_Tri;
|
||||
|
||||
begin
|
||||
for f in the_Model.Faces'Range
|
||||
loop
|
||||
declare
|
||||
the_model_Face : io.Face renames the_Model.Faces (f);
|
||||
the_io_Vertices : constant io.Vertices := Vertices_of (the_model_Face);
|
||||
begin
|
||||
case the_model_Face.Kind
|
||||
is
|
||||
when Triangle =>
|
||||
for v in the_io_Vertices'Range
|
||||
loop
|
||||
add_to_Tri (the_io_Vertices (v));
|
||||
end loop;
|
||||
|
||||
when Quad =>
|
||||
add_to_Tri (the_io_Vertices (1));
|
||||
add_to_Tri (the_io_Vertices (2));
|
||||
add_to_Tri (the_io_Vertices (3));
|
||||
|
||||
add_to_Tri (the_io_Vertices (3));
|
||||
add_to_Tri (the_io_Vertices (4));
|
||||
add_to_Tri (the_io_Vertices (1));
|
||||
|
||||
when Polygon =>
|
||||
null;
|
||||
end case;
|
||||
end;
|
||||
end loop;
|
||||
|
||||
pragma assert (tri_indices_Count = tri_indices_Last);
|
||||
|
||||
|
||||
-- Determine which geometry class is required and create the geometry.
|
||||
--
|
||||
if the_Model.Weights = null
|
||||
then
|
||||
declare
|
||||
use Geometry.lit_textured;
|
||||
|
||||
my_Vertices : aliased lit_textured.Vertex_large_array
|
||||
:= to_lit_textured_Vertices (the_Vertices (1 .. vertex_Count));
|
||||
|
||||
my_Geometry : constant Geometry.lit_textured.view
|
||||
:= lit_textured.new_Geometry;
|
||||
begin
|
||||
if not normals_Known
|
||||
then
|
||||
set_Normals:
|
||||
declare
|
||||
type Normals_view is access all Normals;
|
||||
|
||||
function get_Sites return Sites
|
||||
is
|
||||
Result : Sites := [1 .. my_Vertices'Length => <>];
|
||||
begin
|
||||
for i in Result'Range
|
||||
loop
|
||||
Result (i) := my_Vertices (long_Index_t (i)).Site;
|
||||
end loop;
|
||||
|
||||
return Result;
|
||||
end get_Sites;
|
||||
|
||||
the_Sites : constant openGL.Sites := get_Sites;
|
||||
the_Normals : Normals_view := Geometry.Normals_of (Primitive.Triangles,
|
||||
tri_Indices,
|
||||
the_Sites);
|
||||
procedure deallocate is new ada.unchecked_Deallocation (Normals, Normals_view);
|
||||
|
||||
begin
|
||||
for i in my_Vertices'Range
|
||||
loop
|
||||
my_Vertices (i).Normal := the_Normals (Index_t (i));
|
||||
my_Vertices (i).Shine := default_Shine;
|
||||
end loop;
|
||||
|
||||
deallocate (the_Normals);
|
||||
end set_Normals;
|
||||
end if;
|
||||
|
||||
my_Geometry.Vertices_are (now => my_Vertices);
|
||||
Self.Geometry := Geometry.view (my_Geometry);
|
||||
end;
|
||||
|
||||
else -- Is skinned.
|
||||
declare
|
||||
use Geometry.lit_colored_textured_skinned;
|
||||
|
||||
my_Vertices : aliased constant lit_colored_textured_skinned.Vertex_array
|
||||
:= to_lit_textured_skinned_Vertices (the_Vertices (1 .. vertex_Count));
|
||||
|
||||
my_Geometry : constant lit_textured_skinned_Geometry_view
|
||||
:= lit_colored_textured_skinned.new_Geometry;
|
||||
begin
|
||||
my_Geometry.Vertices_are (now => my_Vertices);
|
||||
Self.Geometry := Geometry.view (my_Geometry);
|
||||
end;
|
||||
end if;
|
||||
|
||||
deallocate (the_Vertices);
|
||||
destroy (the_Model);
|
||||
|
||||
-- Set the geometry texture.
|
||||
--
|
||||
if Self.Texture /= null_Asset
|
||||
then
|
||||
if Self.has_lucid_Texture
|
||||
then
|
||||
declare
|
||||
use Texture;
|
||||
the_Image : constant lucid_Image
|
||||
:= io.to_lucid_Image (Self.Texture);
|
||||
|
||||
the_Texture : constant Texture.object
|
||||
:= Forge.to_Texture (the_Image);
|
||||
|
||||
begin
|
||||
Self.Geometry.Texture_is (the_Texture);
|
||||
end;
|
||||
else
|
||||
declare
|
||||
use Texture;
|
||||
the_Image : constant Image := io.to_Image (Self.Texture);
|
||||
the_Texture : constant Texture.object := Forge.to_Texture (the_Image);
|
||||
begin
|
||||
Self.Geometry.Texture_is (the_Texture);
|
||||
end;
|
||||
end if;
|
||||
end if;
|
||||
|
||||
-- Add any facia to the geometry.
|
||||
--
|
||||
if tri_Indices'Length > 0
|
||||
then
|
||||
if vertex_Count <= long_Index_t (short_Index_t'Last)
|
||||
then
|
||||
declare
|
||||
the_Primitive : constant Primitive.short_indexed.view
|
||||
:= Primitive.short_indexed.new_Primitive (Primitive.Triangles,
|
||||
tri_Indices);
|
||||
begin
|
||||
Self.Geometry.add (Primitive.view (the_Primitive));
|
||||
end;
|
||||
|
||||
elsif vertex_Count <= long_Index_t (Index_t'Last)
|
||||
then
|
||||
declare
|
||||
the_Primitive : constant Primitive.indexed.view
|
||||
:= Primitive.indexed.new_Primitive (primitive.Triangles,
|
||||
tri_Indices);
|
||||
begin
|
||||
Self.Geometry.add (Primitive.view (the_Primitive));
|
||||
end;
|
||||
|
||||
else
|
||||
if openGL.Profile /= Desk
|
||||
then
|
||||
raise Model_too_complex with "Only the 'Desk' openGL profile allows models with more than 2**16 - 1 vertices.";
|
||||
end if;
|
||||
|
||||
declare
|
||||
the_Primitive : constant Primitive.long_indexed.view
|
||||
:= Primitive.long_indexed.new_Primitive (primitive.Triangles,
|
||||
tri_Indices);
|
||||
begin
|
||||
Self.Geometry.add (Primitive.view (the_Primitive));
|
||||
end;
|
||||
end if;
|
||||
end if;
|
||||
|
||||
|
||||
if Geometry_3d.Extent (Self.Bounds.Box, 3) = 0.0
|
||||
then
|
||||
Self.Bounds.Box.Lower (3) := Self.Bounds.Box.Lower (3) - 0.2; -- TODO: This is dubious at best.
|
||||
end if;
|
||||
|
||||
Self.Geometry.is_Transparent (now => False);
|
||||
Self.Geometry.Label_is (to_String (Self.Model) & "-" & to_String (Self.Texture));
|
||||
end;
|
||||
|
||||
end build_GL_Geometries;
|
||||
|
||||
|
||||
end openGL.Model.any;
|
||||
58
3-mid/opengl/source/lean/model/opengl-model-any.ads
Normal file
58
3-mid/opengl/source/lean/model/opengl-model-any.ads
Normal file
@@ -0,0 +1,58 @@
|
||||
with
|
||||
openGL.Geometry;
|
||||
|
||||
|
||||
package openGL.Model.any
|
||||
--
|
||||
-- Provides a general 3D model.
|
||||
--
|
||||
-- This model is largely used by the IO importers of various model formats (ie collada, wavefront, etc).
|
||||
--
|
||||
is
|
||||
type Item is new Model.item with private;
|
||||
type View is access all Item'Class;
|
||||
|
||||
|
||||
---------
|
||||
--- Forge
|
||||
--
|
||||
|
||||
function new_Model (Model : in asset_Name;
|
||||
Texture : in asset_Name;
|
||||
Texture_is_lucid : in Boolean) return openGL.Model.any.view;
|
||||
|
||||
--------------
|
||||
--- Attributes
|
||||
--
|
||||
|
||||
function model_Name (Self : in Item) return asset_Name;
|
||||
|
||||
overriding
|
||||
function to_GL_Geometries (Self : access Item; Textures : access Texture.name_Map_of_texture'Class;
|
||||
Fonts : in Font.font_id_Map_of_font) return Geometry.views;
|
||||
--
|
||||
-- Raises unsupported_model_Format when the model is not a :
|
||||
-- - wavefront '.obj'
|
||||
-- - collada '.dae'
|
||||
-- - lat_long_radius '.tab'
|
||||
|
||||
unsupported_model_Format : exception;
|
||||
|
||||
|
||||
|
||||
private
|
||||
|
||||
type Item is new Model.item with
|
||||
record
|
||||
Model : asset_Name := null_Asset; -- A wavefront '.obj' or collada '.dae' file. -- TODO: Rename to 'model_Name'.
|
||||
|
||||
Texture : asset_Name := null_Asset; -- The models texture image.
|
||||
has_lucid_Texture : Boolean := False;
|
||||
|
||||
Geometry : openGL.Geometry.view;
|
||||
end record;
|
||||
|
||||
procedure build_GL_Geometries (Self : in out Item);
|
||||
|
||||
|
||||
end openGL.Model.any;
|
||||
162
3-mid/opengl/source/lean/model/opengl-model-arrow-colored.adb
Normal file
162
3-mid/opengl/source/lean/model/opengl-model-arrow-colored.adb
Normal file
@@ -0,0 +1,162 @@
|
||||
with
|
||||
openGL.Primitive.indexed;
|
||||
|
||||
package body openGL.Model.arrow.colored
|
||||
is
|
||||
---------
|
||||
--- Forge
|
||||
--
|
||||
|
||||
function to_Arrow (Color : in openGL.Color := Palette.White;
|
||||
line_Width : in Real := 1.0;
|
||||
End_1,
|
||||
End_2 : in Vector_3 := Origin_3D) return Item
|
||||
is
|
||||
Self : Model.arrow.colored.item;
|
||||
begin
|
||||
Self.Color := Color;
|
||||
Self.line_Width := line_Width;
|
||||
|
||||
Self.Vertices (1).Site := End_1; -- Main line.
|
||||
Self.Vertices (2).Site := End_2; --
|
||||
|
||||
Self.Vertices (3).Site := End_2; -- Side bits.
|
||||
Self.Vertices (4).Site := End_2; --
|
||||
|
||||
Self.set_side_Bits;
|
||||
|
||||
return Self;
|
||||
end to_Arrow;
|
||||
|
||||
|
||||
function new_Arrow (Color : in openGL.Color := Palette.White;
|
||||
line_Width : in Real := 1.0;
|
||||
End_1,
|
||||
End_2 : in Vector_3 := Origin_3D) return View
|
||||
is
|
||||
begin
|
||||
return new Arrow.colored.item' (to_Arrow (Color, line_Width, End_1, End_2));
|
||||
end new_Arrow;
|
||||
|
||||
|
||||
--------------
|
||||
--- Attributes
|
||||
--
|
||||
|
||||
overriding
|
||||
function to_GL_Geometries (Self : access Item; Textures : access Texture.name_Map_of_texture'Class;
|
||||
Fonts : in Font.font_id_Map_of_font) return Geometry.views
|
||||
is
|
||||
pragma unreferenced (Textures, Fonts);
|
||||
|
||||
use openGL.Geometry.colored;
|
||||
|
||||
Color : constant openGL.rgb_Color := +Self.Color;
|
||||
indices_Count : constant long_Index_t := 2;
|
||||
the_Indices : aliased Indices := [1 .. indices_Count => <>];
|
||||
the_Primitive : Primitive.indexed.view;
|
||||
begin
|
||||
Geometry.free (Self.Geometry);
|
||||
Self.Geometry := Geometry.colored.new_Geometry;
|
||||
|
||||
set_Colors:
|
||||
begin
|
||||
Self.Vertices (1).Color := (primary => Color, Alpha => opaque_Value);
|
||||
Self.Vertices (2).Color := (primary => Color, Alpha => opaque_Value);
|
||||
Self.Vertices (3).Color := (primary => Color, Alpha => opaque_Value);
|
||||
Self.Vertices (4).Color := (primary => Color, Alpha => opaque_Value);
|
||||
end set_Colors;
|
||||
|
||||
Self.Geometry.is_Transparent (False);
|
||||
Self.Geometry.Vertices_are (Self.Vertices);
|
||||
|
||||
-- Main line.
|
||||
--
|
||||
Self.Geometry.free_Primitives;
|
||||
|
||||
the_Indices := [1, 2];
|
||||
the_Primitive := Primitive.indexed.new_Primitive (Primitive.Lines, the_Indices, line_Width => Self.line_Width);
|
||||
Self.Geometry.add (Primitive.view (the_Primitive));
|
||||
|
||||
-- Left bit.
|
||||
--
|
||||
the_Indices := [2, 3];
|
||||
the_Primitive := Primitive.indexed.new_Primitive (Primitive.Lines, the_Indices, line_Width => Self.line_Width);
|
||||
Self.Geometry.add (Primitive.view (the_Primitive));
|
||||
|
||||
-- Right bit.
|
||||
--
|
||||
the_Indices := [2, 4];
|
||||
the_Primitive := Primitive.indexed.new_Primitive (Primitive.Lines, the_Indices, line_Width => Self.line_Width);
|
||||
Self.Geometry.add (Primitive.view (the_Primitive));
|
||||
|
||||
Self.set_side_Bits;
|
||||
|
||||
return [1 => Self.Geometry];
|
||||
end to_GL_Geometries;
|
||||
|
||||
|
||||
|
||||
procedure set_side_Bits (Self : in out Item)
|
||||
is
|
||||
use linear_Algebra_3d;
|
||||
|
||||
End_1 : Vector_3 renames Self.Vertices (1).Site;
|
||||
End_2 : Vector_3 renames Self.Vertices (2).Site;
|
||||
|
||||
polar_Coords : constant Geometry_2d.polar_Site := Geometry_2d.to_Polar (to_Vector_2 (End_2 - End_1));
|
||||
|
||||
the_Angle : constant Radians := polar_Coords.Angle;
|
||||
bit_Length : constant Real := abs (End_2 - End_1) * 0.1;
|
||||
|
||||
left_bit_Offset : constant Geometry_2d.Site := Geometry_2d.to_Site ((Angle => the_Angle + to_Radians (135.0),
|
||||
Extent => bit_Length));
|
||||
right_bit_Offset : constant Geometry_2d.Site := Geometry_2d.to_Site ((Angle => the_Angle + to_Radians (135.0 + 90.0),
|
||||
Extent => bit_Length));
|
||||
|
||||
left_bit_End : constant Vector_3 := End_2 + to_Vector_3 ( left_bit_Offset);
|
||||
right_bit_End : constant Vector_3 := End_2 + to_Vector_3 (right_bit_Offset);
|
||||
begin
|
||||
Self.Vertices (3).Site := left_bit_End; -- Left bit.
|
||||
Self.Vertices (4).Site := right_bit_End; -- Right bit.
|
||||
end set_side_Bits;
|
||||
|
||||
|
||||
|
||||
function End_Site (Self : in Item; for_End : in Integer) return Vector_3
|
||||
is
|
||||
begin
|
||||
return Self.Vertices (Index_t (for_End)).Site;
|
||||
end End_Site;
|
||||
|
||||
|
||||
procedure End_Site_is (Self : in out Item; Now : in Vector_3;
|
||||
for_End : in Integer)
|
||||
is
|
||||
begin
|
||||
Self.Vertices (Index_t (for_End)).Site := Now;
|
||||
Self.set_side_Bits;
|
||||
Self.is_Modified := True;
|
||||
end End_Site_is;
|
||||
|
||||
|
||||
|
||||
overriding
|
||||
procedure modify (Self : in out Item)
|
||||
is
|
||||
begin
|
||||
Self.Geometry.Vertices_are (Self.Vertices);
|
||||
Self.set_Bounds;
|
||||
Self.is_Modified := False;
|
||||
end modify;
|
||||
|
||||
|
||||
overriding
|
||||
function is_Modified (Self : in Item) return Boolean
|
||||
is
|
||||
begin
|
||||
return Self.is_Modified;
|
||||
end is_Modified;
|
||||
|
||||
|
||||
end openGL.Model.arrow.colored;
|
||||
@@ -0,0 +1,61 @@
|
||||
with
|
||||
openGL.geometry.colored,
|
||||
openGL.Font,
|
||||
openGL.Palette;
|
||||
|
||||
|
||||
package openGL.Model.arrow.colored
|
||||
--
|
||||
-- Models a colored arrow.
|
||||
--
|
||||
is
|
||||
type Item is new openGL.Model.arrow.item with private;
|
||||
type View is access all Item'Class;
|
||||
|
||||
|
||||
---------
|
||||
--- Forge
|
||||
--
|
||||
|
||||
function new_Arrow (Color : in openGL.Color := Palette.White;
|
||||
line_Width : in Real := 1.0;
|
||||
End_1,
|
||||
End_2 : in Vector_3 := Origin_3D) return View;
|
||||
|
||||
--------------
|
||||
--- Attributes
|
||||
--
|
||||
|
||||
overriding
|
||||
function to_GL_Geometries (Self : access Item; Textures : access Texture.name_Map_of_texture'Class;
|
||||
Fonts : in Font.font_id_Map_of_font) return Geometry.views;
|
||||
|
||||
procedure end_Site_is (Self : in out Item; Now : in Vector_3;
|
||||
for_End : in Integer);
|
||||
function end_Site (Self : in Item; for_End : in Integer) return Vector_3;
|
||||
|
||||
overriding
|
||||
procedure modify (Self : in out Item);
|
||||
|
||||
overriding
|
||||
function is_Modified (Self : in Item) return Boolean;
|
||||
|
||||
|
||||
|
||||
private
|
||||
|
||||
type Item is new openGL.Model.arrow.item with
|
||||
record
|
||||
Color : openGL.Color;
|
||||
line_Width : Real;
|
||||
|
||||
Vertices : aliased Geometry.colored.Vertex_array (1 .. 4);
|
||||
Geometry : access Geometry.colored.item'Class;
|
||||
|
||||
is_Modified : Boolean := False;
|
||||
end record;
|
||||
|
||||
procedure set_side_Bits (Self : in out Item);
|
||||
|
||||
|
||||
end openGL.Model.arrow.colored;
|
||||
14
3-mid/opengl/source/lean/model/opengl-model-arrow.ads
Normal file
14
3-mid/opengl/source/lean/model/opengl-model-arrow.ads
Normal file
@@ -0,0 +1,14 @@
|
||||
package openGL.Model.arrow
|
||||
--
|
||||
-- Models an arrow.
|
||||
--
|
||||
is
|
||||
type Item is abstract new Model.item with private;
|
||||
|
||||
|
||||
|
||||
private
|
||||
|
||||
type Item is abstract new Model.item with null record;
|
||||
|
||||
end openGL.Model.arrow;
|
||||
@@ -0,0 +1,137 @@
|
||||
with
|
||||
openGL.Primitive.indexed,
|
||||
openGL.IO;
|
||||
|
||||
|
||||
package body openGL.Model.billboard.colored
|
||||
is
|
||||
---------
|
||||
--- Forge
|
||||
--
|
||||
|
||||
function new_Billboard (Size : in Size_t := default_Size;
|
||||
Plane : in billboard.Plane;
|
||||
Color : in lucid_Color;
|
||||
Texture : in asset_Name) return View
|
||||
is
|
||||
Self : constant View := new Item;
|
||||
begin
|
||||
Self.define (Size);
|
||||
|
||||
Self.Plane := Plane;
|
||||
Self.Color := Color;
|
||||
Self.Texture_Name := Texture;
|
||||
|
||||
return Self;
|
||||
end new_Billboard;
|
||||
|
||||
|
||||
--------------
|
||||
--- Attributes
|
||||
--
|
||||
|
||||
overriding
|
||||
function to_GL_Geometries (Self : access Item; Textures : access Texture.name_Map_of_texture'Class;
|
||||
Fonts : in Font.font_id_Map_of_font) return Geometry.views
|
||||
is
|
||||
pragma unreferenced (Textures, Fonts);
|
||||
|
||||
use Geometry,
|
||||
Geometry.colored,
|
||||
Texture;
|
||||
|
||||
the_Indices : aliased constant Indices := (1, 2, 3, 4);
|
||||
the_Sites : constant billboard.Sites := vertex_Sites (Self.Plane,
|
||||
Self.Width,
|
||||
Self.Height);
|
||||
|
||||
function new_Face (Vertices : access Geometry.colored.Vertex_array) return Geometry.colored.view
|
||||
is
|
||||
use openGL.Primitive;
|
||||
|
||||
the_Geometry : constant Geometry.colored.view := Geometry.colored.new_Geometry;
|
||||
the_Primitive : constant Primitive.view := Primitive.indexed.new_Primitive (triangle_Fan,
|
||||
the_Indices).all'Access;
|
||||
begin
|
||||
the_Geometry.Vertices_are (Vertices.all);
|
||||
the_Geometry.add (the_Primitive);
|
||||
the_Geometry.is_Transparent;
|
||||
|
||||
return the_Geometry;
|
||||
end new_Face;
|
||||
|
||||
Color : constant rgba_Color := +Self.Color;
|
||||
the_Face : Geometry.colored.view;
|
||||
|
||||
begin
|
||||
declare
|
||||
the_Vertices : constant access Geometry.colored.Vertex_array := Self.Vertices;
|
||||
begin
|
||||
the_Vertices.all := Geometry.colored.Vertex_array'
|
||||
(1 => (site => the_Sites (1), color => Color),
|
||||
2 => (site => the_Sites (2), color => Color),
|
||||
3 => (site => the_Sites (3), color => Color),
|
||||
4 => (site => the_Sites (4), color => Color));
|
||||
|
||||
the_Face := new_Face (Vertices => the_Vertices);
|
||||
|
||||
if Self.texture_Name /= null_Asset
|
||||
then
|
||||
Self.Texture := IO.to_Texture (Self.texture_Name);
|
||||
end if;
|
||||
|
||||
if Self.Texture /= null_Object
|
||||
then
|
||||
the_Face.Texture_is (Self.Texture);
|
||||
end if;
|
||||
end;
|
||||
|
||||
Self.Geometry := the_Face;
|
||||
|
||||
return (1 => Geometry.view (the_Face));
|
||||
end to_GL_Geometries;
|
||||
|
||||
|
||||
|
||||
procedure Color_is (Self : in out Item; Now : in lucid_Color)
|
||||
is
|
||||
begin
|
||||
Self.Color := Now;
|
||||
|
||||
for i in Self.Vertices'Range
|
||||
loop
|
||||
Self.Vertices (i).Color := +Now;
|
||||
end loop;
|
||||
|
||||
Self.is_Modified := True;
|
||||
end Color_is;
|
||||
|
||||
|
||||
|
||||
procedure Texture_Coords_are (Self : in out Item; Now : in Coordinates)
|
||||
is
|
||||
begin
|
||||
Self.texture_Coords := Now;
|
||||
Self.needs_Rebuild := True;
|
||||
end Texture_Coords_are;
|
||||
|
||||
|
||||
|
||||
overriding
|
||||
procedure modify (Self : in out Item)
|
||||
is
|
||||
begin
|
||||
Self.Geometry.Vertices_are (Self.Vertices.all);
|
||||
Self.is_Modified := False;
|
||||
end modify;
|
||||
|
||||
|
||||
overriding
|
||||
function is_Modified (Self : in Item) return Boolean
|
||||
is
|
||||
begin
|
||||
return Self.is_Modified;
|
||||
end is_Modified;
|
||||
|
||||
|
||||
end openGL.Model.billboard.colored;
|
||||
@@ -0,0 +1,61 @@
|
||||
with
|
||||
openGL.Geometry.colored,
|
||||
openGL.Texture,
|
||||
openGL.Font,
|
||||
openGL.Palette;
|
||||
|
||||
|
||||
package openGL.Model.billboard.colored
|
||||
--
|
||||
-- Models a colored, textured billboard.
|
||||
--
|
||||
is
|
||||
type Item is new Model.billboard.item with private;
|
||||
type View is access all Item'Class;
|
||||
|
||||
|
||||
---------
|
||||
--- Forge
|
||||
--
|
||||
|
||||
function new_Billboard (Size : in Size_t := default_Size;
|
||||
Plane : in billboard.Plane;
|
||||
Color : in lucid_Color;
|
||||
Texture : in asset_Name) return View;
|
||||
|
||||
--------------
|
||||
--- Attributes
|
||||
--
|
||||
|
||||
overriding
|
||||
function to_GL_Geometries (Self : access Item; Textures : access Texture.name_Map_of_texture'Class;
|
||||
Fonts : in Font.font_id_Map_of_font) return Geometry.views;
|
||||
|
||||
procedure Color_is (Self : in out Item; Now : in lucid_Color);
|
||||
procedure Texture_Coords_are (Self : in out Item; Now : in Coordinates);
|
||||
|
||||
overriding
|
||||
procedure modify (Self : in out Item);
|
||||
|
||||
overriding
|
||||
function is_Modified (Self : in Item) return Boolean;
|
||||
|
||||
|
||||
|
||||
private
|
||||
|
||||
type Item is new Model.billboard.item with
|
||||
record
|
||||
Color : lucid_Color := (Palette.White, Opaque);
|
||||
|
||||
texture_Name : asset_Name := null_Asset;
|
||||
Texture : openGL.Texture.Object := openGL.Texture.null_Object; -- The texture to be applied to the billboard face.
|
||||
texture_Coords : Coordinates := ((0.0, 0.0), (1.0, 0.0), (1.0, 1.0), (0.0, 1.0));
|
||||
|
||||
is_Modified : Boolean := False;
|
||||
|
||||
Vertices : access Geometry.colored.Vertex_array := new geometry.colored.Vertex_array (1 .. 4);
|
||||
Geometry : access Geometry.colored.item'Class;
|
||||
end record;
|
||||
|
||||
end openGL.Model.billboard.colored;
|
||||
@@ -0,0 +1,139 @@
|
||||
with
|
||||
openGL.Primitive.indexed,
|
||||
openGL.IO;
|
||||
|
||||
|
||||
package body openGL.Model.billboard.colored_textured
|
||||
is
|
||||
type Geometry_view is access all Geometry.colored_textured.item'Class;
|
||||
|
||||
---------
|
||||
--- Forge
|
||||
--
|
||||
|
||||
function new_Billboard (Size : in Size_t := default_Size;
|
||||
Plane : in billboard.Plane;
|
||||
Color : in lucid_Color;
|
||||
Texture : in asset_Name) return View
|
||||
is
|
||||
Self : constant View := new Item;
|
||||
begin
|
||||
Self.define (Size);
|
||||
|
||||
Self.Plane := Plane;
|
||||
Self.Color := Color;
|
||||
Self.Texture_Name := Texture;
|
||||
|
||||
return Self;
|
||||
end new_Billboard;
|
||||
|
||||
|
||||
--------------
|
||||
--- Attributes
|
||||
--
|
||||
|
||||
overriding
|
||||
function to_GL_Geometries (Self : access Item; Textures : access Texture.name_Map_of_texture'Class;
|
||||
Fonts : in Font.font_id_Map_of_font) return Geometry.views
|
||||
is
|
||||
pragma unreferenced (Textures, Fonts);
|
||||
|
||||
use Geometry,
|
||||
Geometry.colored_textured,
|
||||
Texture;
|
||||
|
||||
the_Indices : aliased constant Indices := [1, 2, 3, 4];
|
||||
the_Sites : constant billboard.Sites := vertex_Sites (Self.Plane,
|
||||
Self.Width,
|
||||
Self.Height);
|
||||
|
||||
function new_Face (Vertices : access Geometry.colored_textured.Vertex_array) return Geometry_view
|
||||
is
|
||||
use openGL.Primitive;
|
||||
|
||||
the_Geometry : constant Geometry_view := Geometry.colored_textured.new_Geometry;
|
||||
the_Primitive : constant Primitive.view := Primitive.indexed.new_Primitive (triangle_Fan,
|
||||
the_Indices).all'Access;
|
||||
begin
|
||||
the_Geometry.Vertices_are (Vertices.all);
|
||||
the_Geometry.add (the_Primitive);
|
||||
the_Geometry.is_Transparent;
|
||||
|
||||
return the_Geometry;
|
||||
end new_Face;
|
||||
|
||||
Color : constant rgba_Color := +Self.Color;
|
||||
the_Face : Geometry_view;
|
||||
|
||||
begin
|
||||
declare
|
||||
the_Vertices : constant access Geometry.colored_textured.Vertex_array := Self.Vertices;
|
||||
begin
|
||||
the_Vertices.all := Geometry.colored_textured.Vertex_array'
|
||||
(1 => (site => the_Sites (1), color => Color, coords => (Self.texture_Coords (1))),
|
||||
2 => (site => the_Sites (2), color => Color, coords => (Self.texture_Coords (2))),
|
||||
3 => (site => the_Sites (3), color => Color, coords => (Self.texture_Coords (3))),
|
||||
4 => (site => the_Sites (4), color => Color, coords => (Self.texture_Coords (4))));
|
||||
|
||||
the_Face := new_Face (Vertices => the_Vertices);
|
||||
|
||||
if Self.texture_Name /= null_Asset
|
||||
then
|
||||
Self.Texture := IO.to_Texture (Self.texture_Name);
|
||||
end if;
|
||||
|
||||
if Self.Texture /= null_Object
|
||||
then
|
||||
the_Face.Texture_is (Self.Texture);
|
||||
end if;
|
||||
end;
|
||||
|
||||
Self.Geometry := the_Face;
|
||||
|
||||
return [1 => Geometry.view (the_Face)];
|
||||
end to_GL_Geometries;
|
||||
|
||||
|
||||
|
||||
procedure Color_is (Self : in out Item; Now : in lucid_Color)
|
||||
is
|
||||
begin
|
||||
Self.Color := Now;
|
||||
|
||||
for i in Self.Vertices'Range
|
||||
loop
|
||||
Self.Vertices (i).Color := +Now;
|
||||
end loop;
|
||||
|
||||
Self.is_Modified := True;
|
||||
end Color_is;
|
||||
|
||||
|
||||
|
||||
procedure Texture_Coords_are (Self : in out Item; Now : in Coordinates)
|
||||
is
|
||||
begin
|
||||
Self.texture_Coords := Now;
|
||||
Self.needs_Rebuild := True;
|
||||
end Texture_Coords_are;
|
||||
|
||||
|
||||
|
||||
overriding
|
||||
procedure modify (Self : in out Item)
|
||||
is
|
||||
begin
|
||||
Self.Geometry.Vertices_are (Self.Vertices.all);
|
||||
Self.is_Modified := False;
|
||||
end modify;
|
||||
|
||||
|
||||
overriding
|
||||
function is_Modified (Self : in Item) return Boolean
|
||||
is
|
||||
begin
|
||||
return Self.is_Modified;
|
||||
end is_Modified;
|
||||
|
||||
|
||||
end openGL.Model.billboard.colored_textured;
|
||||
@@ -0,0 +1,61 @@
|
||||
with
|
||||
openGL.Geometry.colored_textured,
|
||||
openGL.Texture,
|
||||
openGL.Font,
|
||||
openGL.Palette;
|
||||
|
||||
|
||||
package openGL.Model.billboard.colored_textured
|
||||
--
|
||||
-- Models a colored, textured billboard.
|
||||
--
|
||||
is
|
||||
type Item is new Model.billboard.item with private;
|
||||
type View is access all Item'Class;
|
||||
|
||||
|
||||
---------
|
||||
--- Forge
|
||||
--
|
||||
|
||||
function new_Billboard (Size : in Size_t := default_Size;
|
||||
Plane : in billboard.Plane;
|
||||
Color : in lucid_Color;
|
||||
Texture : in asset_Name) return View;
|
||||
|
||||
--------------
|
||||
--- Attributes
|
||||
--
|
||||
|
||||
overriding
|
||||
function to_GL_Geometries (Self : access Item; Textures : access Texture.name_Map_of_texture'Class;
|
||||
Fonts : in Font.font_id_Map_of_font) return Geometry.views;
|
||||
|
||||
procedure Color_is (Self : in out Item; Now : in lucid_Color);
|
||||
procedure Texture_Coords_are (Self : in out Item; Now : in Coordinates);
|
||||
|
||||
overriding
|
||||
procedure modify (Self : in out Item);
|
||||
|
||||
overriding
|
||||
function is_Modified (Self : in Item) return Boolean;
|
||||
|
||||
|
||||
|
||||
private
|
||||
|
||||
type Item is new Model.billboard.item with
|
||||
record
|
||||
Color : lucid_Color := (Palette.White, Opaque);
|
||||
|
||||
texture_Name : asset_Name := null_Asset;
|
||||
Texture : openGL.Texture.Object := openGL.Texture.null_Object; -- The texture to be applied to the billboard face.
|
||||
texture_Coords : Coordinates := [(0.0, 0.0), (1.0, 0.0), (1.0, 1.0), (0.0, 1.0)];
|
||||
|
||||
is_Modified : Boolean := False;
|
||||
|
||||
Vertices : Geometry.colored_textured.Vertex_array_view := new geometry.colored_textured.Vertex_array (1 .. 4);
|
||||
Geometry : access Geometry.colored_textured.item'Class;
|
||||
end record;
|
||||
|
||||
end openGL.Model.billboard.colored_textured;
|
||||
@@ -0,0 +1,198 @@
|
||||
with
|
||||
openGL.Primitive.indexed,
|
||||
openGL.Geometry.textured,
|
||||
openGL.io,
|
||||
|
||||
ada.unchecked_Deallocation;
|
||||
|
||||
|
||||
package body openGL.Model.billboard.textured
|
||||
is
|
||||
---------
|
||||
--- Forge
|
||||
--
|
||||
|
||||
package body Forge
|
||||
is
|
||||
function new_Billboard (Size : in Size_t := default_Size;
|
||||
Plane : in billboard.Plane;
|
||||
Texture : in asset_Name;
|
||||
Lucid : in Boolean := False) return View
|
||||
is
|
||||
Self : constant View := new Item (Lucid);
|
||||
begin
|
||||
Self.Plane := Plane;
|
||||
Self.Texture_Name := Texture;
|
||||
Self.define (Size);
|
||||
|
||||
return Self;
|
||||
end new_Billboard;
|
||||
end Forge;
|
||||
|
||||
|
||||
--------------
|
||||
--- Attributes
|
||||
--
|
||||
|
||||
overriding
|
||||
function to_GL_Geometries (Self : access Item; Textures : access openGL.Texture.name_Map_of_texture'Class;
|
||||
Fonts : in Font.font_id_Map_of_font) return Geometry.views
|
||||
is
|
||||
pragma unreferenced (Textures, Fonts);
|
||||
|
||||
use Geometry,
|
||||
Geometry.textured,
|
||||
openGL.Texture;
|
||||
|
||||
the_Indices : aliased constant Indices := [1, 2, 3, 4];
|
||||
the_Sites : constant billboard.Sites := vertex_Sites (Self.Plane,
|
||||
Self.Width,
|
||||
Self.Height);
|
||||
|
||||
function new_Face (Vertices : in Geometry.textured.Vertex_array) return Geometry.textured.view
|
||||
is
|
||||
use Primitive;
|
||||
|
||||
the_Geometry : constant Geometry.textured.view := Geometry.textured.new_Geometry;
|
||||
the_Primitive : constant Primitive.view := Primitive.indexed.new_Primitive (triangle_Fan,
|
||||
the_Indices).all'Access;
|
||||
begin
|
||||
the_Geometry.Vertices_are (Vertices);
|
||||
the_Geometry.add (the_Primitive);
|
||||
the_Geometry.is_Transparent;
|
||||
|
||||
return the_Geometry;
|
||||
end new_Face;
|
||||
|
||||
the_Face : Geometry.textured.view;
|
||||
|
||||
begin
|
||||
declare
|
||||
the_Vertices : constant Geometry.textured.Vertex_array
|
||||
:= [1 => (site => the_Sites (1), coords => Self.texture_Coords (1)),
|
||||
2 => (site => the_Sites (2), coords => Self.texture_Coords (2)),
|
||||
3 => (site => the_Sites (3), coords => Self.texture_Coords (3)),
|
||||
4 => (site => the_Sites (4), coords => Self.texture_Coords (4))];
|
||||
begin
|
||||
the_Face := new_Face (Vertices => the_Vertices);
|
||||
|
||||
if Self.texture_Name /= null_Asset
|
||||
then
|
||||
Self.Texture := IO.to_Texture (Self.texture_Name);
|
||||
end if;
|
||||
|
||||
if Self.Lucid
|
||||
then
|
||||
if Self.lucid_Image /= null
|
||||
then
|
||||
if Self.Texture /= null_Object
|
||||
then
|
||||
set_Image (Self.Texture, Self.lucid_Image.all);
|
||||
else
|
||||
Self.Texture := openGL.Texture.Forge.to_Texture (Self.lucid_Image.all);
|
||||
end if;
|
||||
end if;
|
||||
else
|
||||
if Self.Image /= null
|
||||
then
|
||||
if Self.Texture /= null_Object
|
||||
then
|
||||
Self.Texture.set_Image (Self.Image.all);
|
||||
else
|
||||
Self.Texture := openGL.Texture.Forge.to_Texture (Self.Image.all);
|
||||
end if;
|
||||
end if;
|
||||
end if;
|
||||
|
||||
if Self.Texture /= null_Object
|
||||
then
|
||||
the_Face.Texture_is (Self.Texture);
|
||||
end if;
|
||||
end;
|
||||
|
||||
return [1 => the_Face.all'Access];
|
||||
end to_GL_Geometries;
|
||||
|
||||
|
||||
|
||||
procedure Texture_is (Self : in out Item; Now : in openGL.Texture.Object)
|
||||
is
|
||||
begin
|
||||
Self.Texture := Now;
|
||||
end Texture_is;
|
||||
|
||||
|
||||
function Texture (Self : in Item) return openGL.Texture.Object
|
||||
is
|
||||
begin
|
||||
return Self.Texture;
|
||||
end Texture;
|
||||
|
||||
|
||||
|
||||
procedure Texture_Coords_are (Self : in out Item; Now : in Coordinates)
|
||||
is
|
||||
begin
|
||||
Self.texture_Coords := Now;
|
||||
Self.needs_Rebuild := True;
|
||||
end Texture_Coords_are;
|
||||
|
||||
|
||||
|
||||
procedure Size_is (Self : in out Item; Now : in Size_t)
|
||||
is
|
||||
begin
|
||||
Self.Size := Now;
|
||||
Self.needs_Rebuild := True;
|
||||
end Size_is;
|
||||
|
||||
|
||||
|
||||
procedure Image_is (Self : in out Item; Now : in Image)
|
||||
is
|
||||
procedure deallocate is new ada.unchecked_Deallocation (Image,
|
||||
Image_view);
|
||||
begin
|
||||
if Self.Image = null
|
||||
then
|
||||
Self.Image := new Image' (Now);
|
||||
|
||||
elsif Self.Image'Length (1) = Now'Length (1)
|
||||
and Self.Image'Length (2) = Now'Length (2)
|
||||
then
|
||||
Self.Image.all := Now;
|
||||
|
||||
else
|
||||
deallocate (Self.Image);
|
||||
Self.Image := new Image' (Now);
|
||||
end if;
|
||||
|
||||
Self.needs_Rebuild := True;
|
||||
end Image_is;
|
||||
|
||||
|
||||
|
||||
procedure Image_is (Self : in out Item; Now : in lucid_Image)
|
||||
is
|
||||
procedure deallocate is new ada.unchecked_Deallocation (lucid_Image,
|
||||
lucid_Image_view);
|
||||
begin
|
||||
if Self.lucid_Image = null
|
||||
then
|
||||
Self.lucid_Image := new lucid_Image' (Now);
|
||||
|
||||
elsif Self.lucid_Image'Length (1) = Now'Length (1)
|
||||
and Self.lucid_Image'Length (2) = Now'Length (2)
|
||||
then
|
||||
Self.lucid_Image.all := Now;
|
||||
|
||||
else
|
||||
deallocate (Self.lucid_Image);
|
||||
Self.lucid_Image := new lucid_Image' (Now);
|
||||
end if;
|
||||
|
||||
Self.needs_Rebuild := True;
|
||||
end Image_is;
|
||||
|
||||
|
||||
end openGL.Model.billboard.textured;
|
||||
@@ -0,0 +1,64 @@
|
||||
with
|
||||
openGL.Geometry,
|
||||
openGL.Texture;
|
||||
|
||||
|
||||
package openGL.Model.billboard.textured
|
||||
--
|
||||
-- Models a textured billboard.
|
||||
--
|
||||
is
|
||||
type Item (Lucid : Boolean) is new Model.billboard.item with private;
|
||||
type View is access all Item'Class;
|
||||
|
||||
type Image_view is access Image;
|
||||
type lucid_Image_view is access lucid_Image;
|
||||
|
||||
|
||||
---------
|
||||
--- Forge
|
||||
--
|
||||
|
||||
package Forge
|
||||
is
|
||||
function new_Billboard (Size : in Size_t := default_Size;
|
||||
Plane : in billboard.Plane;
|
||||
Texture : in asset_Name;
|
||||
Lucid : in Boolean := False) return View;
|
||||
end Forge;
|
||||
|
||||
|
||||
--------------
|
||||
--- Attributes
|
||||
--
|
||||
|
||||
overriding
|
||||
function to_GL_Geometries (Self : access Item; Textures : access Texture.name_Map_of_texture'Class;
|
||||
Fonts : in Font.font_id_Map_of_font) return Geometry.views;
|
||||
|
||||
procedure Texture_is (Self : in out Item; Now : in Texture.Object);
|
||||
function Texture (Self : in Item) return Texture.Object;
|
||||
|
||||
procedure Texture_Coords_are (Self : in out Item; Now : in Coordinates);
|
||||
procedure Size_is (Self : in out Item; Now : in Size_t);
|
||||
|
||||
procedure Image_is (Self : in out Item; Now : in Image);
|
||||
procedure Image_is (Self : in out Item; Now : in lucid_Image);
|
||||
|
||||
|
||||
|
||||
private
|
||||
|
||||
type Item (Lucid : Boolean) is new Model.billboard.item with
|
||||
record
|
||||
texture_Name : asset_Name := null_Asset;
|
||||
Texture : openGL.Texture.Object := openGL.Texture.null_Object; -- The texture to be applied to the billboard face.
|
||||
texture_Coords : Coordinates := [(0.0, 0.0), (1.0, 0.0), (1.0, 1.0), (0.0, 1.0)]; -- TODO: Should be constant/static ?
|
||||
|
||||
case Lucid is
|
||||
when True => lucid_Image : lucid_Image_view;
|
||||
when False => Image : Image_view;
|
||||
end case;
|
||||
end record;
|
||||
|
||||
end openGL.Model.billboard.textured;
|
||||
67
3-mid/opengl/source/lean/model/opengl-model-billboard.adb
Normal file
67
3-mid/opengl/source/lean/model/opengl-model-billboard.adb
Normal file
@@ -0,0 +1,67 @@
|
||||
package body openGL.Model.billboard
|
||||
is
|
||||
|
||||
---------
|
||||
--- Forge
|
||||
--
|
||||
|
||||
procedure define (Self : out Item; Size : Size_t := default_Size)
|
||||
is
|
||||
begin
|
||||
Self.Size := Size;
|
||||
end define;
|
||||
|
||||
|
||||
|
||||
--------------
|
||||
--- Attributes
|
||||
--
|
||||
|
||||
function Size (Self : in Item) return Size_t
|
||||
is
|
||||
begin
|
||||
return Self.Size;
|
||||
end Size;
|
||||
|
||||
|
||||
|
||||
function Width (Self : in Item) return Real
|
||||
is
|
||||
begin
|
||||
return Self.Size.Width;
|
||||
end Width;
|
||||
|
||||
|
||||
|
||||
function Height (Self : in Item) return Real
|
||||
is
|
||||
begin
|
||||
return Self.Size.Height;
|
||||
end Height;
|
||||
|
||||
|
||||
|
||||
function vertex_Sites (for_Plane : in Plane;
|
||||
Width, Height : in Real) return Sites
|
||||
is
|
||||
half_Width : constant Real := Width / 2.0;
|
||||
half_Height : constant Real := Height / 2.0;
|
||||
|
||||
the_Sites : constant array (Plane) of Sites := [xy => [[-half_Width, -half_Height, 0.0],
|
||||
[ half_Width, -half_Height, 0.0],
|
||||
[ half_Width, half_Height, 0.0],
|
||||
[-half_Width, half_Height, 0.0]],
|
||||
xz => [[-half_Width, 0.0, 1.0],
|
||||
[ half_Width, 0.0, 1.0],
|
||||
[ half_Width, 0.0, -1.0],
|
||||
[-half_Width, 0.0, -1.0]],
|
||||
yz => [[ 0.0, -half_Height, half_Width],
|
||||
[ 0.0, -half_Height, -half_Width],
|
||||
[ 0.0, half_Height, -half_Width],
|
||||
[ 0.0, half_Height, half_Width]]];
|
||||
begin
|
||||
return the_Sites (for_Plane);
|
||||
end vertex_Sites;
|
||||
|
||||
|
||||
end openGL.Model.billboard;
|
||||
57
3-mid/opengl/source/lean/model/opengl-model-billboard.ads
Normal file
57
3-mid/opengl/source/lean/model/opengl-model-billboard.ads
Normal file
@@ -0,0 +1,57 @@
|
||||
package openGL.Model.billboard
|
||||
--
|
||||
-- Models a rectangle capable of displaying an image.
|
||||
--
|
||||
is
|
||||
type Item is abstract new Model.item with private;
|
||||
|
||||
type Plane is (xy, xz, yz);
|
||||
|
||||
type Size_t is
|
||||
record
|
||||
Width : Real;
|
||||
Height : Real;
|
||||
end record;
|
||||
|
||||
type Coordinates is array (1 .. 4) of Coordinate_2D;
|
||||
|
||||
|
||||
---------
|
||||
--- Forge
|
||||
--
|
||||
|
||||
default_Size : constant Size_t;
|
||||
|
||||
procedure define (Self : out Item; Size : Size_t := default_Size);
|
||||
|
||||
|
||||
--------------
|
||||
--- Attributes
|
||||
--
|
||||
|
||||
function Size (Self : in Item) return Size_t;
|
||||
function Width (Self : in Item) return Real;
|
||||
function Height (Self : in Item) return Real;
|
||||
|
||||
|
||||
|
||||
private
|
||||
|
||||
type Item is abstract new Model.item with
|
||||
record
|
||||
Plane : billboard.Plane := xy;
|
||||
Size : Size_t;
|
||||
end record;
|
||||
|
||||
|
||||
subtype site_Id is Index_t range 1 .. 4;
|
||||
subtype Sites is Vector_3_array (site_Id'Range);
|
||||
|
||||
function vertex_Sites (for_Plane : in Plane;
|
||||
Width, Height : in Real) return Sites;
|
||||
|
||||
Normal : constant Vector_3 := [0.0, 0.0, 1.0];
|
||||
default_Size : constant Size_t := (Width => 1.0,
|
||||
Height => 1.0);
|
||||
|
||||
end openGL.Model.billboard;
|
||||
145
3-mid/opengl/source/lean/model/opengl-model-box-colored.adb
Normal file
145
3-mid/opengl/source/lean/model/opengl-model-box-colored.adb
Normal file
@@ -0,0 +1,145 @@
|
||||
with
|
||||
openGL.Primitive.indexed,
|
||||
openGL.Geometry.colored;
|
||||
|
||||
|
||||
package body openGL.Model.box.colored
|
||||
is
|
||||
---------
|
||||
--- Forge
|
||||
--
|
||||
|
||||
function new_Box (Size : in Vector_3;
|
||||
Faces : in colored.Faces) return View
|
||||
is
|
||||
Self : constant View := new Item;
|
||||
begin
|
||||
Self.Faces := Faces;
|
||||
Self.Size := Size;
|
||||
|
||||
return Self;
|
||||
end new_Box;
|
||||
|
||||
|
||||
--------------
|
||||
--- Attributes
|
||||
--
|
||||
|
||||
overriding
|
||||
function to_GL_Geometries (Self : access Item; Textures : access Texture.name_Map_of_texture'Class;
|
||||
Fonts : in Font.font_id_Map_of_font) return Geometry.views
|
||||
is
|
||||
pragma unreferenced (Textures, Fonts);
|
||||
use Geometry;
|
||||
|
||||
the_Sites : constant box.Sites := Self.vertex_Sites;
|
||||
the_Indices : aliased constant Indices := [1, 2, 3, 4];
|
||||
|
||||
|
||||
function new_Face (Vertices : access Geometry.colored.Vertex_array) return Geometry.colored.view
|
||||
is
|
||||
use Geometry.colored,
|
||||
Primitive;
|
||||
|
||||
the_Geometry : constant Geometry.colored .view := Geometry.colored.new_Geometry;
|
||||
the_Primitive : constant Primitive.indexed.view := Primitive.indexed.new_Primitive (triangle_Fan,
|
||||
the_Indices);
|
||||
begin
|
||||
the_Geometry.Vertices_are (Vertices.all);
|
||||
the_Geometry.add (Primitive.view (the_Primitive));
|
||||
the_Geometry.is_Transparent (now => False);
|
||||
|
||||
return the_Geometry;
|
||||
end new_Face;
|
||||
|
||||
|
||||
front_Face : Geometry.colored.view;
|
||||
rear_Face : Geometry.colored.view;
|
||||
upper_Face : Geometry.colored.view;
|
||||
lower_Face : Geometry.colored.view;
|
||||
left_Face : Geometry.colored.view;
|
||||
right_Face : Geometry.colored.view;
|
||||
|
||||
begin
|
||||
-- Front
|
||||
--
|
||||
declare
|
||||
the_Vertices : aliased Geometry.colored.Vertex_array
|
||||
:= [1 => (Site => the_Sites ( Left_Lower_Front), Color => +Self.Faces (Front).Colors (1)),
|
||||
2 => (Site => the_Sites (Right_Lower_Front), Color => +Self.Faces (Front).Colors (2)),
|
||||
3 => (Site => the_Sites (Right_Upper_Front), Color => +Self.Faces (Front).Colors (3)),
|
||||
4 => (Site => the_Sites ( Left_Upper_Front), Color => +Self.Faces (Front).Colors (4))];
|
||||
begin
|
||||
front_Face := new_Face (Vertices => the_Vertices'Access);
|
||||
end;
|
||||
|
||||
-- Rear
|
||||
--
|
||||
declare
|
||||
the_Vertices : aliased Geometry.colored.Vertex_array
|
||||
:= [1 => (Site => the_Sites (Right_Lower_Rear), Color => +Self.Faces (Rear).Colors (1)),
|
||||
2 => (Site => the_Sites ( Left_Lower_Rear), Color => +Self.Faces (Rear).Colors (2)),
|
||||
3 => (Site => the_Sites ( Left_Upper_Rear), Color => +Self.Faces (Rear).Colors (3)),
|
||||
4 => (Site => the_Sites (Right_Upper_Rear), Color => +Self.Faces (Rear).Colors (4))];
|
||||
begin
|
||||
rear_Face := new_Face (Vertices => the_Vertices'Access);
|
||||
end;
|
||||
|
||||
-- Upper
|
||||
--
|
||||
declare
|
||||
the_Vertices : aliased Geometry.colored.Vertex_array
|
||||
:= [1 => (Site => the_Sites ( Left_Upper_Front), Color => +Self.Faces (Upper).Colors (1)),
|
||||
2 => (Site => the_Sites (Right_Upper_Front), Color => +Self.Faces (Upper).Colors (2)),
|
||||
3 => (Site => the_Sites (Right_Upper_Rear), Color => +Self.Faces (Upper).Colors (3)),
|
||||
4 => (Site => the_Sites ( Left_Upper_Rear), Color => +Self.Faces (Upper).Colors (4))];
|
||||
begin
|
||||
upper_Face := new_Face (Vertices => the_Vertices'Access);
|
||||
end;
|
||||
|
||||
-- Lower
|
||||
--
|
||||
declare
|
||||
the_Vertices : aliased Geometry.colored.Vertex_array
|
||||
:= [1 => (Site => the_Sites (Right_Lower_Front), Color => +Self.Faces (Lower).Colors (1)),
|
||||
2 => (Site => the_Sites ( Left_Lower_Front), Color => +Self.Faces (Lower).Colors (2)),
|
||||
3 => (Site => the_Sites ( Left_Lower_Rear), Color => +Self.Faces (Lower).Colors (3)),
|
||||
4 => (Site => the_Sites (Right_Lower_Rear), Color => +Self.Faces (Lower).Colors (4))];
|
||||
begin
|
||||
lower_Face := new_Face (Vertices => the_Vertices'Access);
|
||||
end;
|
||||
|
||||
-- Left
|
||||
--
|
||||
declare
|
||||
the_Vertices : aliased Geometry.colored.Vertex_array
|
||||
:= [1 => (Site => the_Sites (Left_Lower_Rear), Color => +Self.Faces (Left).Colors (1)),
|
||||
2 => (Site => the_Sites (Left_Lower_Front), Color => +Self.Faces (Left).Colors (2)),
|
||||
3 => (Site => the_Sites (Left_Upper_Front), Color => +Self.Faces (Left).Colors (3)),
|
||||
4 => (Site => the_Sites (Left_Upper_Rear), Color => +Self.Faces (Left).Colors (4))];
|
||||
begin
|
||||
left_Face := new_Face (Vertices => the_Vertices'Access);
|
||||
end;
|
||||
|
||||
-- Right
|
||||
--
|
||||
declare
|
||||
the_Vertices : aliased Geometry.colored.Vertex_array
|
||||
:= [1 => (Site => the_Sites (Right_Lower_Front), Color => +Self.Faces (Right).Colors (1)),
|
||||
2 => (Site => the_Sites (Right_Lower_Rear), Color => +Self.Faces (Right).Colors (2)),
|
||||
3 => (Site => the_Sites (Right_Upper_Rear), Color => +Self.Faces (Right).Colors (3)),
|
||||
4 => (Site => the_Sites (Right_Upper_Front), Color => +Self.Faces (Right).Colors (4))];
|
||||
begin
|
||||
right_Face := new_Face (Vertices => the_Vertices'Access);
|
||||
end;
|
||||
|
||||
return [Geometry.view (front_Face),
|
||||
Geometry.view ( rear_Face),
|
||||
Geometry.view (upper_Face),
|
||||
Geometry.view (lower_Face),
|
||||
Geometry.view ( left_Face),
|
||||
Geometry.view (right_Face)];
|
||||
end to_GL_Geometries;
|
||||
|
||||
|
||||
end openGL.Model.box.colored;
|
||||
49
3-mid/opengl/source/lean/model/opengl-model-box-colored.ads
Normal file
49
3-mid/opengl/source/lean/model/opengl-model-box-colored.ads
Normal file
@@ -0,0 +1,49 @@
|
||||
with
|
||||
openGL.Font,
|
||||
openGL.Geometry;
|
||||
|
||||
|
||||
package openGL.Model.box.colored
|
||||
--
|
||||
-- Models a colored box.
|
||||
--
|
||||
-- Each face may be separately colored via each of its 4 vertices.
|
||||
--
|
||||
is
|
||||
type Item is new Model.box.item with private;
|
||||
type View is access all Item'Class;
|
||||
|
||||
|
||||
type Face is
|
||||
record
|
||||
Colors : lucid_Colors (1 .. 4); -- The color of each of the faces 4 vertices.
|
||||
end record;
|
||||
|
||||
type Faces is array (Side) of Face;
|
||||
|
||||
|
||||
---------
|
||||
--- Forge
|
||||
--
|
||||
|
||||
function new_Box (Size : in Vector_3;
|
||||
Faces : in colored.Faces) return View;
|
||||
|
||||
|
||||
--------------
|
||||
--- Attributes
|
||||
--
|
||||
|
||||
overriding
|
||||
function to_GL_Geometries (Self : access Item; Textures : access Texture.name_Map_of_texture'Class;
|
||||
Fonts : in Font.font_id_Map_of_font) return Geometry.views;
|
||||
|
||||
|
||||
private
|
||||
|
||||
type Item is new Model.box.item with
|
||||
record
|
||||
Faces : colored.Faces;
|
||||
end record;
|
||||
|
||||
end openGL.Model.box.colored;
|
||||
151
3-mid/opengl/source/lean/model/opengl-model-box-lit_colored.adb
Normal file
151
3-mid/opengl/source/lean/model/opengl-model-box-lit_colored.adb
Normal file
@@ -0,0 +1,151 @@
|
||||
with
|
||||
openGL.Geometry.lit_colored,
|
||||
openGL.Primitive.indexed;
|
||||
|
||||
|
||||
package body openGL.Model.box.lit_colored
|
||||
is
|
||||
---------
|
||||
--- Forge
|
||||
--
|
||||
|
||||
function new_Box (Size : in Vector_3;
|
||||
Faces : in lit_colored.Faces) return View
|
||||
is
|
||||
Self : constant View := new Item;
|
||||
begin
|
||||
Self.Faces := Faces;
|
||||
Self.Size := Size;
|
||||
|
||||
return Self;
|
||||
end new_Box;
|
||||
|
||||
|
||||
--------------
|
||||
--- Attributes
|
||||
--
|
||||
|
||||
overriding
|
||||
function to_GL_Geometries (Self : access Item; Textures : access Texture.name_Map_of_texture'Class;
|
||||
Fonts : in Font.font_id_Map_of_font) return Geometry.views
|
||||
is
|
||||
pragma unreferenced (Fonts, Textures);
|
||||
|
||||
use Geometry.lit_colored;
|
||||
|
||||
the_Sites : constant box.Sites := Self.vertex_Sites;
|
||||
the_Indices : aliased constant Indices := (1, 2, 3, 4);
|
||||
|
||||
|
||||
function new_Face (Vertices : access geometry.lit_colored.Vertex_array) return Geometry.lit_colored.view
|
||||
is
|
||||
use openGL.Primitive;
|
||||
|
||||
the_Geometry : constant Geometry.lit_colored.view := Geometry.lit_colored.new_Geometry;
|
||||
the_Primitive : constant Primitive.view := Primitive.indexed.new_Primitive
|
||||
(triangle_Fan,
|
||||
the_Indices).all'Access;
|
||||
begin
|
||||
the_Geometry.Vertices_are (Vertices.all);
|
||||
the_Geometry.add (the_Primitive);
|
||||
|
||||
return the_Geometry;
|
||||
end new_Face;
|
||||
|
||||
|
||||
front_Face : Geometry.lit_colored.view;
|
||||
rear_Face : Geometry.lit_colored.view;
|
||||
upper_Face : Geometry.lit_colored.view;
|
||||
lower_Face : Geometry.lit_colored.view;
|
||||
left_Face : Geometry.lit_colored.view;
|
||||
right_Face : Geometry.lit_colored.view;
|
||||
|
||||
begin
|
||||
-- Front
|
||||
--
|
||||
declare
|
||||
the_Vertices : aliased Geometry.lit_colored.Vertex_array
|
||||
:= (1 => (Site => the_Sites ( Left_Lower_Front), Normal => front_Normal, Color => +Self.Faces (Front).Colors (1), Shine => default_Shine),
|
||||
2 => (Site => the_Sites (Right_Lower_Front), Normal => front_Normal, Color => +Self.Faces (Front).Colors (2), Shine => default_Shine),
|
||||
3 => (Site => the_Sites (right_upper_front), Normal => front_Normal, Color => +Self.Faces (Front).Colors (3), Shine => default_Shine),
|
||||
4 => (Site => the_Sites ( Left_Upper_Front), Normal => front_Normal, Color => +Self.Faces (Front).Colors (4), Shine => default_Shine));
|
||||
begin
|
||||
front_Face := new_Face (Vertices => the_Vertices'Access);
|
||||
end;
|
||||
|
||||
|
||||
-- Rear
|
||||
--
|
||||
declare
|
||||
the_Vertices : aliased Geometry.lit_colored.Vertex_array
|
||||
:= (1 => (Site => the_Sites (Right_Lower_Rear), Normal => rear_Normal, Color => +Self.Faces (Rear).Colors (1), Shine => default_Shine),
|
||||
2 => (Site => the_Sites ( Left_Lower_Rear), Normal => rear_Normal, Color => +Self.Faces (Rear).Colors (2), Shine => default_Shine),
|
||||
3 => (Site => the_Sites ( Left_Upper_Rear), Normal => rear_Normal, Color => +Self.Faces (Rear).Colors (3), Shine => default_Shine),
|
||||
4 => (Site => the_Sites (Right_Upper_Rear), Normal => rear_Normal, Color => +Self.Faces (Rear).Colors (4), Shine => default_Shine));
|
||||
begin
|
||||
rear_Face := new_Face (Vertices => the_Vertices'Access);
|
||||
end;
|
||||
|
||||
|
||||
-- Upper
|
||||
--
|
||||
declare
|
||||
the_Vertices : aliased Geometry.lit_colored.Vertex_array
|
||||
:= (1 => (Site => the_Sites ( Left_Upper_Front), Normal => upper_Normal, Color => +Self.Faces (Upper).Colors (1), Shine => default_Shine),
|
||||
2 => (Site => the_Sites (Right_Upper_Front), Normal => upper_Normal, Color => +Self.Faces (Upper).Colors (2), Shine => default_Shine),
|
||||
3 => (Site => the_Sites (Right_Upper_Rear), Normal => upper_Normal, Color => +Self.Faces (Upper).Colors (3), Shine => default_Shine),
|
||||
4 => (Site => the_Sites ( Left_Upper_Rear), Normal => upper_Normal, Color => +Self.Faces (Upper).Colors (4), Shine => default_Shine));
|
||||
begin
|
||||
upper_Face := new_Face (Vertices => the_Vertices'Access);
|
||||
end;
|
||||
|
||||
|
||||
-- Lower
|
||||
--
|
||||
declare
|
||||
the_Vertices : aliased Geometry.lit_colored.Vertex_array
|
||||
:= (1 => (Site => the_Sites (Right_Lower_Front), Normal => lower_Normal, Color => +Self.Faces (Lower).Colors (1), Shine => default_Shine),
|
||||
2 => (Site => the_Sites ( Left_Lower_Front), Normal => lower_Normal, Color => +Self.Faces (Lower).Colors (2), Shine => default_Shine),
|
||||
3 => (Site => the_Sites ( Left_Lower_Rear), Normal => lower_Normal, Color => +Self.Faces (Lower).Colors (3), Shine => default_Shine),
|
||||
4 => (Site => the_Sites (Right_Lower_Rear), Normal => lower_Normal, Color => +Self.Faces (Lower).Colors (4), Shine => default_Shine));
|
||||
begin
|
||||
lower_Face := new_Face (Vertices => the_Vertices'Access);
|
||||
end;
|
||||
|
||||
|
||||
-- Left
|
||||
--
|
||||
declare
|
||||
the_Vertices : aliased Geometry.lit_colored.Vertex_array
|
||||
:= (1 => (Site => the_Sites (Left_Lower_Rear), Normal => left_Normal, Color => +Self.Faces (Left).Colors (1), Shine => default_Shine),
|
||||
2 => (Site => the_Sites (Left_Lower_Front), Normal => left_Normal, Color => +Self.Faces (Left).Colors (2), Shine => default_Shine),
|
||||
3 => (Site => the_Sites (Left_Upper_Front), Normal => left_Normal, Color => +Self.Faces (Left).Colors (3), Shine => default_Shine),
|
||||
4 => (Site => the_Sites (Left_Upper_Rear), Normal => left_Normal, Color => +Self.Faces (Left).Colors (4), Shine => default_Shine));
|
||||
begin
|
||||
left_Face := new_Face (Vertices => the_Vertices'Access);
|
||||
end;
|
||||
|
||||
|
||||
-- Right
|
||||
--
|
||||
declare
|
||||
the_Vertices : aliased Geometry.lit_colored.Vertex_array
|
||||
:= (1 => (Site => the_Sites (Right_Lower_Front), Normal => right_Normal, Color => +Self.Faces (Right).Colors (1), Shine => default_Shine),
|
||||
2 => (Site => the_Sites (Right_Lower_Rear), Normal => right_Normal, Color => +Self.Faces (Right).Colors (2), Shine => default_Shine),
|
||||
3 => (Site => the_Sites (Right_Upper_Rear), Normal => right_Normal, Color => +Self.Faces (Right).Colors (3), Shine => default_Shine),
|
||||
4 => (Site => the_Sites (Right_Upper_Front), Normal => right_Normal, Color => +Self.Faces (Right).Colors (4), Shine => default_Shine));
|
||||
begin
|
||||
right_Face := new_Face (Vertices => the_Vertices'Access);
|
||||
end;
|
||||
|
||||
|
||||
return (1 => front_Face.all'Access,
|
||||
2 => rear_Face.all'Access,
|
||||
3 => upper_Face.all'Access,
|
||||
4 => lower_Face.all'Access,
|
||||
5 => left_Face.all'Access,
|
||||
6 => right_Face.all'Access);
|
||||
end to_GL_Geometries;
|
||||
|
||||
|
||||
end openGL.Model.box.lit_colored;
|
||||
@@ -0,0 +1,50 @@
|
||||
with
|
||||
openGL.Geometry,
|
||||
openGL.Font,
|
||||
openGL.Texture;
|
||||
|
||||
|
||||
package openGL.Model.Box.lit_colored
|
||||
--
|
||||
-- Models a lit and colored box.
|
||||
--
|
||||
-- Each face may be separately colored via each of its 4 vertices.
|
||||
--
|
||||
is
|
||||
type Item is new Model.box.item with private;
|
||||
type View is access all Item'Class;
|
||||
|
||||
|
||||
type Face is
|
||||
record
|
||||
Colors : lucid_Colors (1 .. 4); -- The color of each faces 4 vertices.
|
||||
end record;
|
||||
|
||||
type Faces is array (Side) of Face;
|
||||
|
||||
|
||||
---------
|
||||
--- Forge
|
||||
--
|
||||
|
||||
function new_Box (Size : in Vector_3;
|
||||
Faces : in lit_colored.Faces) return View;
|
||||
|
||||
|
||||
--------------
|
||||
--- Attributes
|
||||
--
|
||||
|
||||
overriding
|
||||
function to_GL_Geometries (Self : access Item; Textures : access Texture.name_Map_of_texture'Class;
|
||||
Fonts : in Font.font_id_Map_of_font) return Geometry.views;
|
||||
|
||||
|
||||
private
|
||||
|
||||
type Item is new Model.box.item with
|
||||
record
|
||||
Faces : lit_colored.Faces;
|
||||
end record;
|
||||
|
||||
end openGL.Model.Box.lit_colored;
|
||||
@@ -0,0 +1,192 @@
|
||||
with
|
||||
openGL.Geometry.lit_colored_textured,
|
||||
openGL.Primitive.indexed;
|
||||
|
||||
|
||||
package body openGL.Model.box.lit_colored_textured
|
||||
is
|
||||
type Geometry_view is access all Geometry.lit_colored_textured.item'Class;
|
||||
|
||||
|
||||
---------
|
||||
--- Forge
|
||||
--
|
||||
|
||||
function new_Box (Size : in Vector_3;
|
||||
Faces : in lit_colored_textured.Faces) return View
|
||||
is
|
||||
Self : constant View := new Item;
|
||||
begin
|
||||
Self.Faces := Faces;
|
||||
Self.Size := Size;
|
||||
|
||||
return Self;
|
||||
end new_Box;
|
||||
|
||||
|
||||
--------------
|
||||
--- Attributes
|
||||
--
|
||||
|
||||
overriding
|
||||
function to_GL_Geometries (Self : access Item; Textures : access Texture.name_Map_of_texture'Class;
|
||||
Fonts : in Font.font_id_Map_of_font) return Geometry.views
|
||||
is
|
||||
pragma unreferenced (Fonts);
|
||||
|
||||
use Geometry.lit_colored_textured,
|
||||
Texture;
|
||||
|
||||
the_Sites : constant box.Sites := Self.vertex_Sites;
|
||||
the_Indices : aliased constant Indices := [1, 2, 3, 4];
|
||||
|
||||
|
||||
function new_Face (Vertices : access geometry.lit_colored_textured.Vertex_array) return Geometry_view
|
||||
is
|
||||
use openGL.Primitive;
|
||||
|
||||
the_Geometry : constant Geometry_view := Geometry.lit_colored_textured.new_Geometry
|
||||
(texture_is_Alpha => False);
|
||||
the_Primitive : constant Primitive.view := Primitive.indexed.new_Primitive
|
||||
(triangle_Fan,
|
||||
the_Indices).all'Access;
|
||||
begin
|
||||
the_Geometry.Vertices_are (Vertices.all);
|
||||
the_Geometry.add (the_Primitive);
|
||||
|
||||
return the_Geometry;
|
||||
end new_Face;
|
||||
|
||||
|
||||
front_Face : Geometry_view;
|
||||
rear_Face : Geometry_view;
|
||||
upper_Face : Geometry_view;
|
||||
lower_Face : Geometry_view;
|
||||
left_Face : Geometry_view;
|
||||
right_Face : Geometry_view;
|
||||
|
||||
begin
|
||||
-- Front
|
||||
--
|
||||
declare
|
||||
the_Vertices : aliased Geometry.lit_colored_textured.Vertex_array
|
||||
:= [1 => (Site => the_Sites ( Left_Lower_Front), Normal => front_Normal, Color => +Self.Faces (Front).Colors (1), Coords => (0.0, 0.0), Shine => default_Shine),
|
||||
2 => (Site => the_Sites (Right_Lower_Front), Normal => front_Normal, Color => +Self.Faces (Front).Colors (2), Coords => (1.0, 0.0), Shine => default_Shine),
|
||||
3 => (Site => the_Sites (right_upper_front), Normal => front_Normal, Color => +Self.Faces (Front).Colors (3), Coords => (1.0, 1.0), Shine => default_Shine),
|
||||
4 => (Site => the_Sites ( Left_Upper_Front), Normal => front_Normal, Color => +Self.Faces (Front).Colors (4), Coords => (0.0, 1.0), Shine => default_Shine)];
|
||||
begin
|
||||
front_Face := new_Face (Vertices => the_Vertices'Access);
|
||||
|
||||
if Self.Faces (Front).texture_Name /= null_Asset
|
||||
then
|
||||
front_Face.Texture_is (Textures.fetch (Self.Faces (Front).texture_Name));
|
||||
front_Face.is_Transparent (now => front_Face.Texture.is_Transparent);
|
||||
end if;
|
||||
end;
|
||||
|
||||
|
||||
-- Rear
|
||||
--
|
||||
declare
|
||||
the_Vertices : aliased Geometry.lit_colored_textured.Vertex_array
|
||||
:= [1 => (Site => the_Sites (Right_Lower_Rear), Normal => rear_Normal, Color => +Self.Faces (Rear).Colors (1), Coords => (0.0, 0.0), Shine => default_Shine),
|
||||
2 => (Site => the_Sites ( Left_Lower_Rear), Normal => rear_Normal, Color => +Self.Faces (Rear).Colors (2), Coords => (1.0, 0.0), Shine => default_Shine),
|
||||
3 => (Site => the_Sites ( Left_Upper_Rear), Normal => rear_Normal, Color => +Self.Faces (Rear).Colors (3), Coords => (1.0, 1.0), Shine => default_Shine),
|
||||
4 => (Site => the_Sites (Right_Upper_Rear), Normal => rear_Normal, Color => +Self.Faces (Rear).Colors (4), Coords => (0.0, 1.0), Shine => default_Shine)];
|
||||
begin
|
||||
rear_Face := new_Face (Vertices => the_Vertices'Access);
|
||||
|
||||
if Self.Faces (Rear).texture_Name /= null_Asset
|
||||
then
|
||||
rear_Face.Texture_is (Textures.fetch (Self.Faces (Rear).texture_Name));
|
||||
rear_Face.is_Transparent (now => rear_Face.Texture.is_Transparent);
|
||||
end if;
|
||||
end;
|
||||
|
||||
|
||||
-- Upper
|
||||
--
|
||||
declare
|
||||
the_Vertices : aliased Geometry.lit_colored_textured.Vertex_array
|
||||
:= [1 => (Site => the_Sites ( Left_Upper_Front), Normal => upper_Normal, Color => +Self.Faces (Upper).Colors (1), Coords => (0.0, 0.0), Shine => default_Shine),
|
||||
2 => (Site => the_Sites (Right_Upper_Front), Normal => upper_Normal, Color => +Self.Faces (Upper).Colors (2), Coords => (1.0, 0.0), Shine => default_Shine),
|
||||
3 => (Site => the_Sites (Right_Upper_Rear), Normal => upper_Normal, Color => +Self.Faces (Upper).Colors (3), Coords => (1.0, 1.0), Shine => default_Shine),
|
||||
4 => (Site => the_Sites ( Left_Upper_Rear), Normal => upper_Normal, Color => +Self.Faces (Upper).Colors (4), Coords => (0.0, 1.0), Shine => default_Shine)];
|
||||
begin
|
||||
upper_Face := new_Face (Vertices => the_Vertices'Access);
|
||||
|
||||
if Self.Faces (Upper).texture_Name /= null_Asset
|
||||
then
|
||||
upper_Face.Texture_is (Textures.fetch (Self.Faces (Upper).texture_Name));
|
||||
upper_Face.is_Transparent (now => upper_Face.Texture.is_Transparent);
|
||||
end if;
|
||||
end;
|
||||
|
||||
|
||||
-- Lower
|
||||
--
|
||||
declare
|
||||
the_Vertices : aliased Geometry.lit_colored_textured.Vertex_array
|
||||
:= [1 => (Site => the_Sites (Right_Lower_Front), Normal => lower_Normal, Color => +Self.Faces (Lower).Colors (1), Coords => (0.0, 0.0), Shine => default_Shine),
|
||||
2 => (Site => the_Sites ( Left_Lower_Front), Normal => lower_Normal, Color => +Self.Faces (Lower).Colors (2), Coords => (1.0, 0.0), Shine => default_Shine),
|
||||
3 => (Site => the_Sites ( Left_Lower_Rear), Normal => lower_Normal, Color => +Self.Faces (Lower).Colors (3), Coords => (1.0, 1.0), Shine => default_Shine),
|
||||
4 => (Site => the_Sites (Right_Lower_Rear), Normal => lower_Normal, Color => +Self.Faces (Lower).Colors (4), Coords => (0.0, 1.0), Shine => default_Shine)];
|
||||
begin
|
||||
lower_Face := new_Face (Vertices => the_Vertices'Access);
|
||||
|
||||
if Self.Faces (Lower).texture_Name /= null_Asset
|
||||
then
|
||||
lower_Face.Texture_is (Textures.fetch (Self.Faces (Lower).texture_Name));
|
||||
lower_Face.is_Transparent (now => lower_Face.Texture.is_Transparent);
|
||||
end if;
|
||||
end;
|
||||
|
||||
|
||||
-- Left
|
||||
--
|
||||
declare
|
||||
the_Vertices : aliased Geometry.lit_colored_textured.Vertex_array
|
||||
:= [1 => (Site => the_Sites (Left_Lower_Rear), Normal => left_Normal, Color => +Self.Faces (Left).Colors (1), Coords => (0.0, 0.0), Shine => default_Shine),
|
||||
2 => (Site => the_Sites (Left_Lower_Front), Normal => left_Normal, Color => +Self.Faces (Left).Colors (2), Coords => (1.0, 0.0), Shine => default_Shine),
|
||||
3 => (Site => the_Sites (Left_Upper_Front), Normal => left_Normal, Color => +Self.Faces (Left).Colors (3), Coords => (1.0, 1.0), Shine => default_Shine),
|
||||
4 => (Site => the_Sites (Left_Upper_Rear), Normal => left_Normal, Color => +Self.Faces (Left).Colors (4), Coords => (0.0, 1.0), Shine => default_Shine)];
|
||||
begin
|
||||
left_Face := new_Face (Vertices => the_Vertices'Access);
|
||||
|
||||
if Self.Faces (Left).texture_Name /= null_Asset
|
||||
then
|
||||
left_Face.Texture_is (Textures.fetch (Self.Faces (Left).texture_Name));
|
||||
left_Face.is_Transparent (now => left_Face.Texture.is_Transparent);
|
||||
end if;
|
||||
end;
|
||||
|
||||
|
||||
-- Right
|
||||
--
|
||||
declare
|
||||
the_Vertices : aliased Geometry.lit_colored_textured.Vertex_array
|
||||
:= [1 => (Site => the_Sites (Right_Lower_Front), Normal => right_Normal, Color => +Self.Faces (Right).Colors (1), Coords => (0.0, 0.0), Shine => default_Shine),
|
||||
2 => (Site => the_Sites (Right_Lower_Rear), Normal => right_Normal, Color => +Self.Faces (Right).Colors (2), Coords => (1.0, 0.0), Shine => default_Shine),
|
||||
3 => (Site => the_Sites (Right_Upper_Rear), Normal => right_Normal, Color => +Self.Faces (Right).Colors (3), Coords => (1.0, 1.0), Shine => default_Shine),
|
||||
4 => (Site => the_Sites (Right_Upper_Front), Normal => right_Normal, Color => +Self.Faces (Right).Colors (4), Coords => (0.0, 1.0), Shine => default_Shine)];
|
||||
begin
|
||||
right_Face := new_Face (Vertices => the_Vertices'Access);
|
||||
|
||||
if Self.Faces (Right).texture_Name /= null_Asset
|
||||
then
|
||||
right_Face.Texture_is (Textures.fetch (Self.Faces (Right).texture_Name));
|
||||
right_Face.is_Transparent (now => right_Face.Texture.is_Transparent);
|
||||
end if;
|
||||
end;
|
||||
|
||||
|
||||
return [1 => front_Face.all'Access,
|
||||
2 => rear_Face.all'Access,
|
||||
3 => upper_Face.all'Access,
|
||||
4 => lower_Face.all'Access,
|
||||
5 => left_Face.all'Access,
|
||||
6 => right_Face.all'Access];
|
||||
end to_GL_Geometries;
|
||||
|
||||
|
||||
end openGL.Model.box.lit_colored_textured;
|
||||
@@ -0,0 +1,52 @@
|
||||
with
|
||||
openGL.Geometry,
|
||||
openGL.Font,
|
||||
openGL.Texture;
|
||||
|
||||
|
||||
package openGL.Model.Box.lit_colored_textured
|
||||
--
|
||||
-- Models a lit, colored and textured box.
|
||||
--
|
||||
-- Each face may be separately colored via each of its 4 vertices.
|
||||
-- Each face may have a separate texture.
|
||||
--
|
||||
is
|
||||
type Item is new Model.box.item with private;
|
||||
type View is access all Item'Class;
|
||||
|
||||
|
||||
type Face is
|
||||
record
|
||||
Colors : lucid_Colors (1 .. 4); -- The color of each faces 4 vertices.
|
||||
texture_Name : asset_Name := null_Asset; -- The texture applied to the face.
|
||||
end record;
|
||||
|
||||
type Faces is array (Side) of Face;
|
||||
|
||||
|
||||
---------
|
||||
--- Forge
|
||||
--
|
||||
|
||||
function new_Box (Size : in Vector_3;
|
||||
Faces : in lit_colored_textured.Faces) return View;
|
||||
|
||||
|
||||
--------------
|
||||
--- Attributes
|
||||
--
|
||||
|
||||
overriding
|
||||
function to_GL_Geometries (Self : access Item; Textures : access Texture.name_Map_of_texture'Class;
|
||||
Fonts : in Font.font_id_Map_of_font) return Geometry.views;
|
||||
|
||||
|
||||
private
|
||||
|
||||
type Item is new Model.box.item with
|
||||
record
|
||||
Faces : lit_colored_textured.Faces;
|
||||
end record;
|
||||
|
||||
end openGL.Model.Box.lit_colored_textured;
|
||||
187
3-mid/opengl/source/lean/model/opengl-model-box-lit_textured.adb
Normal file
187
3-mid/opengl/source/lean/model/opengl-model-box-lit_textured.adb
Normal file
@@ -0,0 +1,187 @@
|
||||
with
|
||||
openGL.Geometry.lit_textured,
|
||||
openGL.Primitive.indexed;
|
||||
|
||||
|
||||
package body openGL.Model.box.lit_textured
|
||||
is
|
||||
---------
|
||||
--- Forge
|
||||
--
|
||||
|
||||
function new_Box (Size : in Vector_3;
|
||||
Faces : in lit_textured.Faces) return View
|
||||
is
|
||||
Self : constant View := new Item;
|
||||
begin
|
||||
Self.Faces := Faces;
|
||||
Self.Size := Size;
|
||||
|
||||
return Self;
|
||||
end new_Box;
|
||||
|
||||
|
||||
--------------
|
||||
--- Attributes
|
||||
--
|
||||
|
||||
overriding
|
||||
function to_GL_Geometries (Self : access Item; Textures : access Texture.name_Map_of_texture'Class;
|
||||
Fonts : in Font.font_id_Map_of_font) return Geometry.views
|
||||
is
|
||||
pragma unreferenced (Fonts);
|
||||
|
||||
use Geometry.lit_textured;
|
||||
|
||||
the_Sites : constant box.Sites := Self.vertex_Sites;
|
||||
the_Indices : aliased constant Indices := [1, 2, 3, 4];
|
||||
|
||||
|
||||
function new_Face (Vertices : in geometry.lit_textured.Vertex_array) return Geometry.lit_textured.view
|
||||
is
|
||||
use openGL.Primitive;
|
||||
|
||||
the_Geometry : constant Geometry.lit_textured.view := Geometry.lit_textured.new_Geometry;
|
||||
the_Primitive : constant Primitive.view := Primitive.indexed.new_Primitive
|
||||
(triangle_Fan,
|
||||
the_Indices).all'Access;
|
||||
begin
|
||||
the_Geometry.Vertices_are (Vertices);
|
||||
the_Geometry.add (the_Primitive);
|
||||
|
||||
return the_Geometry;
|
||||
end new_Face;
|
||||
|
||||
|
||||
front_Face : Geometry.lit_textured.view;
|
||||
rear_Face : Geometry.lit_textured.view;
|
||||
upper_Face : Geometry.lit_textured.view;
|
||||
lower_Face : Geometry.lit_textured.view;
|
||||
left_Face : Geometry.lit_textured.view;
|
||||
right_Face : Geometry.lit_textured.view;
|
||||
|
||||
begin
|
||||
-- Front
|
||||
--
|
||||
declare
|
||||
the_Vertices : constant Geometry.lit_textured.Vertex_array
|
||||
:= [1 => (Site => the_Sites ( Left_Lower_Front), Normal => front_Normal, Coords => (0.0, 0.0), Shine => default_Shine),
|
||||
2 => (Site => the_Sites (Right_Lower_Front), Normal => front_Normal, Coords => (1.0, 0.0), Shine => default_Shine),
|
||||
3 => (Site => the_Sites (right_upper_front), Normal => front_Normal, Coords => (1.0, 1.0), Shine => default_Shine),
|
||||
4 => (Site => the_Sites ( Left_Upper_Front), Normal => front_Normal, Coords => (0.0, 1.0), Shine => default_Shine)];
|
||||
begin
|
||||
front_Face := new_Face (Vertices => the_Vertices);
|
||||
|
||||
if Self.Faces (Front).texture_Name /= null_Asset
|
||||
then
|
||||
front_Face.Texture_is (Textures.fetch (Self.Faces (Front).texture_Name));
|
||||
front_Face.is_Transparent (now => front_Face.Texture.is_Transparent);
|
||||
end if;
|
||||
end;
|
||||
|
||||
|
||||
-- Rear
|
||||
--
|
||||
declare
|
||||
the_Vertices : constant Geometry.lit_textured.Vertex_array
|
||||
:= [1 => (Site => the_Sites (Right_Lower_Rear), Normal => rear_Normal, Coords => (0.0, 0.0), Shine => default_Shine),
|
||||
2 => (Site => the_Sites ( Left_Lower_Rear), Normal => rear_Normal, Coords => (1.0, 0.0), Shine => default_Shine),
|
||||
3 => (Site => the_Sites ( Left_Upper_Rear), Normal => rear_Normal, Coords => (1.0, 1.0), Shine => default_Shine),
|
||||
4 => (Site => the_Sites (Right_Upper_Rear), Normal => rear_Normal, Coords => (0.0, 1.0), Shine => default_Shine)];
|
||||
begin
|
||||
rear_Face := new_Face (Vertices => the_Vertices);
|
||||
|
||||
if Self.Faces (Rear).texture_Name /= null_Asset
|
||||
then
|
||||
rear_Face.Texture_is (Textures.fetch (Self.Faces (Rear).texture_Name));
|
||||
rear_Face.is_Transparent (now => rear_Face.Texture.is_Transparent);
|
||||
end if;
|
||||
end;
|
||||
|
||||
|
||||
-- Upper
|
||||
--
|
||||
declare
|
||||
the_Vertices : constant Geometry.lit_textured.Vertex_array
|
||||
:= [1 => (Site => the_Sites ( Left_Upper_Front), Normal => upper_Normal, Coords => (0.0, 0.0), Shine => default_Shine),
|
||||
2 => (Site => the_Sites (Right_Upper_Front), Normal => upper_Normal, Coords => (1.0, 0.0), Shine => default_Shine),
|
||||
3 => (Site => the_Sites (Right_Upper_Rear), Normal => upper_Normal, Coords => (1.0, 1.0), Shine => default_Shine),
|
||||
4 => (Site => the_Sites ( Left_Upper_Rear), Normal => upper_Normal, Coords => (0.0, 1.0), Shine => default_Shine)];
|
||||
begin
|
||||
upper_Face := new_Face (Vertices => the_Vertices);
|
||||
|
||||
if Self.Faces (Upper).texture_Name /= null_Asset
|
||||
then
|
||||
upper_Face.Texture_is (Textures.fetch (Self.Faces (Upper).texture_Name));
|
||||
upper_Face.is_Transparent (now => upper_Face.Texture.is_Transparent);
|
||||
end if;
|
||||
end;
|
||||
|
||||
|
||||
-- Lower
|
||||
--
|
||||
declare
|
||||
the_Vertices : constant Geometry.lit_textured.Vertex_array
|
||||
:= [1 => (Site => the_Sites (Right_Lower_Front), Normal => lower_Normal, Coords => (0.0, 0.0), Shine => default_Shine),
|
||||
2 => (Site => the_Sites ( Left_Lower_Front), Normal => lower_Normal, Coords => (1.0, 0.0), Shine => default_Shine),
|
||||
3 => (Site => the_Sites ( Left_Lower_Rear), Normal => lower_Normal, Coords => (1.0, 1.0), Shine => default_Shine),
|
||||
4 => (Site => the_Sites (Right_Lower_Rear), Normal => lower_Normal, Coords => (0.0, 1.0), Shine => default_Shine)];
|
||||
begin
|
||||
lower_Face := new_Face (Vertices => the_Vertices);
|
||||
|
||||
if Self.Faces (Lower).texture_Name /= null_Asset
|
||||
then
|
||||
lower_Face.Texture_is (Textures.fetch (Self.Faces (Lower).texture_Name));
|
||||
lower_Face.is_Transparent (now => lower_Face.Texture.is_Transparent);
|
||||
end if;
|
||||
end;
|
||||
|
||||
|
||||
-- Left
|
||||
--
|
||||
declare
|
||||
the_Vertices : constant Geometry.lit_textured.Vertex_array
|
||||
:= [1 => (Site => the_Sites (Left_Lower_Rear), Normal => left_Normal, Coords => (0.0, 0.0), Shine => default_Shine),
|
||||
2 => (Site => the_Sites (Left_Lower_Front), Normal => left_Normal, Coords => (1.0, 0.0), Shine => default_Shine),
|
||||
3 => (Site => the_Sites (Left_Upper_Front), Normal => left_Normal, Coords => (1.0, 1.0), Shine => default_Shine),
|
||||
4 => (Site => the_Sites (Left_Upper_Rear), Normal => left_Normal, Coords => (0.0, 1.0), Shine => default_Shine)];
|
||||
begin
|
||||
left_Face := new_Face (Vertices => the_Vertices);
|
||||
|
||||
if Self.Faces (Left).texture_Name /= null_Asset
|
||||
then
|
||||
left_Face.Texture_is (Textures.fetch (Self.Faces (Left).texture_Name));
|
||||
left_Face.is_Transparent (now => left_Face.Texture.is_Transparent);
|
||||
end if;
|
||||
end;
|
||||
|
||||
|
||||
-- Right
|
||||
--
|
||||
declare
|
||||
the_Vertices : constant Geometry.lit_textured.Vertex_array
|
||||
:= [1 => (Site => the_Sites (Right_Lower_Front), Normal => right_Normal, Coords => (0.0, 0.0), Shine => default_Shine),
|
||||
2 => (Site => the_Sites (Right_Lower_Rear), Normal => right_Normal, Coords => (1.0, 0.0), Shine => default_Shine),
|
||||
3 => (Site => the_Sites (Right_Upper_Rear), Normal => right_Normal, Coords => (1.0, 1.0), Shine => default_Shine),
|
||||
4 => (Site => the_Sites (Right_Upper_Front), Normal => right_Normal, Coords => (0.0, 1.0), Shine => default_Shine)];
|
||||
begin
|
||||
right_Face := new_Face (Vertices => the_Vertices);
|
||||
|
||||
if Self.Faces (Right).texture_Name /= null_Asset
|
||||
then
|
||||
right_Face.Texture_is (Textures.fetch (Self.Faces (Right).texture_Name));
|
||||
right_Face.is_Transparent (now => right_Face.Texture.is_Transparent);
|
||||
end if;
|
||||
end;
|
||||
|
||||
|
||||
return [1 => front_Face.all'Access,
|
||||
2 => rear_Face.all'Access,
|
||||
3 => upper_Face.all'Access,
|
||||
4 => lower_Face.all'Access,
|
||||
5 => left_Face.all'Access,
|
||||
6 => right_Face.all'Access];
|
||||
end to_GL_Geometries;
|
||||
|
||||
|
||||
end openGL.Model.box.lit_textured;
|
||||
@@ -0,0 +1,49 @@
|
||||
with
|
||||
openGL.Geometry,
|
||||
openGL.Font;
|
||||
|
||||
|
||||
package openGL.Model.Box.lit_textured
|
||||
--
|
||||
-- Models a lit and textured box.
|
||||
--
|
||||
-- Each face may have a separate texture.
|
||||
--
|
||||
is
|
||||
type Item is new Model.box.item with private;
|
||||
type View is access all Item'Class;
|
||||
|
||||
|
||||
type Face is
|
||||
record
|
||||
texture_Name : asset_Name := null_Asset; -- The texture applied to the face.
|
||||
end record;
|
||||
|
||||
type Faces is array (Side) of Face;
|
||||
|
||||
|
||||
---------
|
||||
--- Forge
|
||||
--
|
||||
|
||||
function new_Box (Size : in Vector_3;
|
||||
Faces : in lit_textured.Faces) return View;
|
||||
|
||||
|
||||
--------------
|
||||
--- Attributes
|
||||
--
|
||||
|
||||
overriding
|
||||
function to_GL_Geometries (Self : access Item; Textures : access Texture.name_Map_of_texture'Class;
|
||||
Fonts : in Font.font_id_Map_of_font) return Geometry.views;
|
||||
|
||||
|
||||
private
|
||||
|
||||
type Item is new Model.box.item with
|
||||
record
|
||||
Faces : lit_textured.Faces;
|
||||
end record;
|
||||
|
||||
end openGL.Model.Box.lit_textured;
|
||||
194
3-mid/opengl/source/lean/model/opengl-model-box-textured.adb
Normal file
194
3-mid/opengl/source/lean/model/opengl-model-box-textured.adb
Normal file
@@ -0,0 +1,194 @@
|
||||
with
|
||||
openGL.Geometry.textured,
|
||||
openGL.Primitive.indexed;
|
||||
|
||||
|
||||
package body openGL.Model.box.textured
|
||||
is
|
||||
---------
|
||||
--- Forge
|
||||
--
|
||||
|
||||
function new_Box (Size : in Vector_3;
|
||||
Faces : in textured.Faces;
|
||||
is_Skybox : in Boolean := False) return View
|
||||
is
|
||||
Self : constant View := new Item;
|
||||
begin
|
||||
Self.Faces := Faces;
|
||||
Self.is_Skybox := is_Skybox;
|
||||
Self.Size := Size;
|
||||
|
||||
return Self;
|
||||
end new_Box;
|
||||
|
||||
|
||||
--------------
|
||||
--- Attributes
|
||||
--
|
||||
|
||||
overriding
|
||||
function to_GL_Geometries (Self : access Item; Textures : access Texture.name_Map_of_texture'Class;
|
||||
Fonts : in Font.font_id_Map_of_font) return Geometry.views
|
||||
is
|
||||
pragma unreferenced (Fonts);
|
||||
|
||||
use Geometry.textured,
|
||||
Texture;
|
||||
|
||||
the_Sites : constant box.Sites := Self.vertex_Sites;
|
||||
the_Indices : aliased Indices := [1, 2, 3, 4];
|
||||
|
||||
|
||||
function new_Face (Vertices : in Geometry.textured.Vertex_array) return Geometry.textured.view
|
||||
is
|
||||
use Primitive;
|
||||
|
||||
the_Geometry : constant Geometry.textured.view := Geometry.textured.new_Geometry;
|
||||
the_Primitive : constant Primitive.view := Primitive.indexed.new_Primitive (triangle_Fan,
|
||||
the_Indices).all'Access;
|
||||
begin
|
||||
the_Geometry.Vertices_are (Vertices);
|
||||
the_Geometry.add (the_Primitive);
|
||||
|
||||
return the_Geometry;
|
||||
end new_Face;
|
||||
|
||||
|
||||
front_Face : Geometry.textured.view;
|
||||
rear_Face : Geometry.textured.view;
|
||||
upper_Face : Geometry.textured.view;
|
||||
lower_Face : Geometry.textured.view;
|
||||
left_Face : Geometry.textured.view;
|
||||
right_Face : Geometry.textured.view;
|
||||
|
||||
begin
|
||||
if Self.is_Skybox
|
||||
then
|
||||
the_Indices := [4, 3, 2, 1];
|
||||
end if;
|
||||
|
||||
-- Front
|
||||
--
|
||||
declare
|
||||
the_Vertices : constant Geometry.textured.Vertex_array
|
||||
:= [1 => (Site => the_Sites ( left_lower_front), Coords => (0.0, 0.0)),
|
||||
2 => (Site => the_Sites (right_lower_front), Coords => (1.0, 0.0)),
|
||||
3 => (Site => the_Sites (right_upper_front), Coords => (1.0, 1.0)),
|
||||
4 => (Site => the_Sites ( left_upper_front), Coords => (0.0, 1.0))];
|
||||
begin
|
||||
front_Face := new_Face (Vertices => the_Vertices);
|
||||
|
||||
if Self.Faces (Front).texture_Name /= null_Asset
|
||||
then
|
||||
front_Face.Texture_is (Textures.fetch (Self.Faces (Front).texture_Name));
|
||||
front_Face.is_Transparent (now => front_Face.Texture.is_Transparent);
|
||||
end if;
|
||||
end;
|
||||
|
||||
|
||||
-- Rear
|
||||
--
|
||||
declare
|
||||
the_Vertices : constant Geometry.textured.Vertex_array
|
||||
:= [1 => (Site => the_Sites (Right_Lower_Rear), Coords => (0.0, 0.0)),
|
||||
2 => (Site => the_Sites ( Left_Lower_Rear), Coords => (1.0, 0.0)),
|
||||
3 => (Site => the_Sites ( Left_Upper_Rear), Coords => (1.0, 1.0)),
|
||||
4 => (Site => the_Sites (Right_Upper_Rear), Coords => (0.0, 1.0))];
|
||||
begin
|
||||
rear_Face := new_Face (Vertices => the_Vertices);
|
||||
|
||||
if Self.Faces (Rear).texture_Name /= null_Asset
|
||||
then
|
||||
rear_Face.Texture_is (Textures.fetch (Self.Faces (Front).texture_Name));
|
||||
rear_Face.is_Transparent (now => rear_Face.Texture.is_Transparent);
|
||||
end if;
|
||||
end;
|
||||
|
||||
|
||||
-- Upper
|
||||
--
|
||||
declare
|
||||
the_Vertices : constant Geometry.textured.Vertex_array
|
||||
:= [1 => (Site => the_Sites ( Left_Upper_Front), Coords => (0.0, 0.0)),
|
||||
2 => (Site => the_Sites (Right_Upper_Front), Coords => (1.0, 0.0)),
|
||||
3 => (Site => the_Sites (Right_Upper_Rear), Coords => (1.0, 1.0)),
|
||||
4 => (Site => the_Sites ( Left_Upper_Rear), Coords => (0.0, 1.0))];
|
||||
begin
|
||||
upper_Face := new_Face (Vertices => the_Vertices);
|
||||
|
||||
if Self.Faces (Upper).texture_Name /= null_Asset
|
||||
then
|
||||
upper_Face.Texture_is (Textures.fetch (Self.Faces (Front).texture_Name));
|
||||
upper_Face.is_Transparent (now => upper_Face.Texture.is_Transparent);
|
||||
end if;
|
||||
end;
|
||||
|
||||
|
||||
-- Lower
|
||||
--
|
||||
declare
|
||||
the_Vertices : constant Geometry.textured.Vertex_array
|
||||
:= [1 => (Site => the_Sites (Right_Lower_Front), Coords => (0.0, 0.0)),
|
||||
2 => (Site => the_Sites ( Left_Lower_Front), Coords => (1.0, 0.0)),
|
||||
3 => (Site => the_Sites ( Left_Lower_Rear), Coords => (1.0, 1.0)),
|
||||
4 => (Site => the_Sites (Right_Lower_Rear), Coords => (0.0, 1.0))];
|
||||
begin
|
||||
lower_Face := new_Face (Vertices => the_Vertices);
|
||||
|
||||
if Self.Faces (Lower).texture_Name /= null_Asset
|
||||
then
|
||||
lower_Face.Texture_is (Textures.fetch (Self.Faces (Front).texture_Name));
|
||||
lower_Face.is_Transparent (now => lower_Face.Texture.is_Transparent);
|
||||
end if;
|
||||
end;
|
||||
|
||||
|
||||
-- Left
|
||||
--
|
||||
declare
|
||||
the_Vertices : constant Geometry.textured.Vertex_array
|
||||
:= [1 => (Site => the_Sites (Left_Lower_Rear), Coords => (0.0, 0.0)),
|
||||
2 => (Site => the_Sites (Left_Lower_Front), Coords => (1.0, 0.0)),
|
||||
3 => (Site => the_Sites (Left_Upper_Front), Coords => (1.0, 1.0)),
|
||||
4 => (Site => the_Sites (Left_Upper_Rear), Coords => (0.0, 1.0))];
|
||||
begin
|
||||
left_Face := new_Face (Vertices => the_Vertices);
|
||||
|
||||
if Self.Faces (Left).texture_Name /= null_Asset
|
||||
then
|
||||
left_Face.Texture_is (Textures.fetch (Self.Faces (Front).texture_Name));
|
||||
left_Face.is_Transparent (now => left_Face.Texture.is_Transparent);
|
||||
end if;
|
||||
end;
|
||||
|
||||
|
||||
-- Right
|
||||
--
|
||||
declare
|
||||
the_Vertices : constant Geometry.textured.Vertex_array
|
||||
:= [1 => (Site => the_Sites (Right_Lower_Front), Coords => (0.0, 0.0)),
|
||||
2 => (Site => the_Sites (Right_Lower_Rear), Coords => (1.0, 0.0)),
|
||||
3 => (Site => the_Sites (Right_Upper_Rear), Coords => (1.0, 1.0)),
|
||||
4 => (Site => the_Sites (Right_Upper_Front), Coords => (0.0, 1.0))];
|
||||
begin
|
||||
right_Face := new_Face (Vertices => the_Vertices);
|
||||
|
||||
if Self.Faces (Right).texture_Name /= null_Asset
|
||||
then
|
||||
right_Face.Texture_is (Textures.fetch (Self.Faces (Front).texture_Name));
|
||||
right_Face.is_Transparent (now => right_Face.Texture.is_Transparent);
|
||||
end if;
|
||||
end;
|
||||
|
||||
|
||||
return [1 => front_Face.all'Access,
|
||||
2 => rear_Face.all'Access,
|
||||
3 => upper_Face.all'Access,
|
||||
4 => lower_Face.all'Access,
|
||||
5 => left_Face.all'Access,
|
||||
6 => right_Face.all'Access];
|
||||
end to_GL_Geometries;
|
||||
|
||||
|
||||
end openGL.Model.box.textured;
|
||||
52
3-mid/opengl/source/lean/model/opengl-model-box-textured.ads
Normal file
52
3-mid/opengl/source/lean/model/opengl-model-box-textured.ads
Normal file
@@ -0,0 +1,52 @@
|
||||
with
|
||||
openGL.Geometry,
|
||||
openGL.Font,
|
||||
openGL.Texture;
|
||||
|
||||
|
||||
package openGL.Model.Box.textured
|
||||
--
|
||||
-- Models a textured box.
|
||||
--
|
||||
-- Each face may have a separate texture.
|
||||
--
|
||||
is
|
||||
type Item is new Model.box.item with private;
|
||||
type View is access all Item'Class;
|
||||
|
||||
|
||||
type Face is
|
||||
record
|
||||
texture_Name : asset_Name := null_Asset;
|
||||
end record;
|
||||
|
||||
type Faces is array (Side) of Face;
|
||||
|
||||
|
||||
---------
|
||||
--- Forge
|
||||
--
|
||||
|
||||
function new_Box (Size : in Vector_3;
|
||||
Faces : in textured.Faces;
|
||||
is_Skybox : in Boolean := False) return View;
|
||||
|
||||
|
||||
--------------
|
||||
--- Attributes
|
||||
--
|
||||
|
||||
overriding
|
||||
function to_GL_Geometries (Self : access Item; Textures : access Texture.name_Map_of_texture'Class;
|
||||
Fonts : in Font.font_id_Map_of_font) return Geometry.views;
|
||||
|
||||
|
||||
private
|
||||
|
||||
type Item is new Model.box.item with
|
||||
record
|
||||
Faces : textured.Faces;
|
||||
is_Skybox : Boolean := False;
|
||||
end record;
|
||||
|
||||
end openGL.Model.Box.textured;
|
||||
37
3-mid/opengl/source/lean/model/opengl-model-box.adb
Normal file
37
3-mid/opengl/source/lean/model/opengl-model-box.adb
Normal file
@@ -0,0 +1,37 @@
|
||||
package body openGL.Model.box
|
||||
is
|
||||
--------------
|
||||
--- Attributes
|
||||
--
|
||||
|
||||
function vertex_Sites (Self : in Item'Class) return Sites
|
||||
is
|
||||
left_Offset : constant Real := -0.5;
|
||||
right_Offset : constant Real := 0.5;
|
||||
|
||||
lower_Offset : constant Real := -0.5;
|
||||
upper_Offset : constant Real := 0.5;
|
||||
|
||||
front_Offset : constant Real := 0.5;
|
||||
rear_Offset : constant Real := -0.5;
|
||||
begin
|
||||
return [Left_Lower_Front => Scaled ([ left_Offset, lower_Offset, front_Offset], by => Self.Size),
|
||||
Right_Lower_Front => Scaled ([right_Offset, lower_Offset, front_Offset], by => Self.Size),
|
||||
Right_Upper_Front => Scaled ([right_Offset, upper_Offset, front_Offset], by => Self.Size),
|
||||
Left_Upper_Front => Scaled ([ left_Offset, upper_Offset, front_Offset], by => Self.Size),
|
||||
Right_Lower_Rear => Scaled ([right_Offset, lower_Offset, rear_Offset], by => Self.Size),
|
||||
Left_Lower_Rear => Scaled ([ left_Offset, lower_Offset, rear_Offset], by => Self.Size),
|
||||
Left_Upper_Rear => Scaled ([ left_Offset, upper_Offset, rear_Offset], by => Self.Size),
|
||||
Right_Upper_Rear => Scaled ([right_Offset, upper_Offset, rear_Offset], by => Self.Size)];
|
||||
end vertex_Sites;
|
||||
|
||||
|
||||
|
||||
function Size (Self : in Item) return Vector_3
|
||||
is
|
||||
begin
|
||||
return Self.Size;
|
||||
end Size;
|
||||
|
||||
|
||||
end openGL.Model.box;
|
||||
41
3-mid/opengl/source/lean/model/opengl-model-box.ads
Normal file
41
3-mid/opengl/source/lean/model/opengl-model-box.ads
Normal file
@@ -0,0 +1,41 @@
|
||||
package openGL.Model.box
|
||||
--
|
||||
-- Provides an abstract model of a box.
|
||||
--
|
||||
is
|
||||
type Item is abstract new Model.item with private;
|
||||
|
||||
type Side is (Front, Rear,
|
||||
Upper, Lower,
|
||||
Left, Right);
|
||||
|
||||
function Size (Self : in Item) return Vector_3;
|
||||
|
||||
|
||||
|
||||
private
|
||||
|
||||
type Item is abstract new Model.item with
|
||||
record
|
||||
Size : Vector_3;
|
||||
end record;
|
||||
|
||||
|
||||
type site_Id is ( Left_Lower_Front, Right_Lower_Front,
|
||||
Right_Upper_Front, Left_Upper_Front,
|
||||
Right_Lower_Rear, Left_Lower_Rear,
|
||||
Left_Upper_Rear, Right_Upper_Rear);
|
||||
|
||||
type Sites is array (site_Id) of Site;
|
||||
|
||||
|
||||
front_Normal : constant Vector_3 := [ 0.0, 0.0, 1.0];
|
||||
rear_Normal : constant Vector_3 := [ 0.0, 0.0, -1.0];
|
||||
upper_Normal : constant Vector_3 := [ 0.0, 1.0, 0.0];
|
||||
lower_Normal : constant Vector_3 := [ 0.0, -1.0, 0.0];
|
||||
left_Normal : constant Vector_3 := [-1.0, 0.0, 0.0];
|
||||
right_Normal : constant Vector_3 := [ 1.0, 0.0, 0.0];
|
||||
|
||||
function vertex_Sites (Self : in Item'Class) return Sites;
|
||||
|
||||
end openGL.Model.box;
|
||||
@@ -0,0 +1,371 @@
|
||||
with
|
||||
openGL.Geometry.lit_colored,
|
||||
openGL.Texture,
|
||||
openGL.Primitive.indexed;
|
||||
|
||||
|
||||
package body openGL.Model.capsule.lit_colored
|
||||
is
|
||||
---------
|
||||
--- Forge
|
||||
--
|
||||
|
||||
function new_Capsule (Radius : in Real;
|
||||
Height : in Real;
|
||||
Color : in lucid_Color) return View
|
||||
is
|
||||
Self : constant View := new Item;
|
||||
begin
|
||||
Self.Radius := Radius;
|
||||
Self.Height := Height;
|
||||
Self.Color := +Color;
|
||||
|
||||
return Self;
|
||||
end new_Capsule;
|
||||
|
||||
|
||||
--------------
|
||||
--- Attributes
|
||||
--
|
||||
|
||||
overriding
|
||||
function to_GL_Geometries (Self : access Item; Textures : access Texture.name_Map_of_texture'Class;
|
||||
Fonts : in Font.font_id_Map_of_font) return Geometry.views
|
||||
is
|
||||
pragma unreferenced (Textures, Fonts);
|
||||
|
||||
use Geometry,
|
||||
Geometry.lit_colored,
|
||||
real_Functions;
|
||||
|
||||
Length : constant Real := Self.Height;
|
||||
Radius : constant Real := Self.Radius;
|
||||
|
||||
quality_Level : constant Index_t := 4;
|
||||
sides_Count : constant Index_t := Index_t (quality_Level * 4); -- Number of sides to the cylinder (divisible by 4):
|
||||
|
||||
type Edge is -- A 'shaft' edge.
|
||||
record
|
||||
Fore : Site;
|
||||
Aft : Site;
|
||||
end record;
|
||||
|
||||
type Edges is array (Index_t range 1 .. sides_Count) of Edge;
|
||||
type arch_Edges is array (Index_t range 1 .. quality_Level) of Sites (1 .. sides_Count);
|
||||
|
||||
tmp,
|
||||
nx, ny, nz,
|
||||
start_nx,
|
||||
start_ny : Real;
|
||||
a : constant Real := Pi * 2.0 / Real (sides_Count);
|
||||
ca : constant Real := Cos (a);
|
||||
sa : constant Real := Sin (a);
|
||||
L : constant Real := Length * 0.5;
|
||||
|
||||
the_Edges : Edges;
|
||||
|
||||
the_shaft_Geometry : constant Geometry.lit_colored.view
|
||||
:= Geometry.lit_colored.new_Geometry;
|
||||
|
||||
|
||||
cap_1_Geometry : Geometry.lit_colored.view;
|
||||
cap_2_Geometry : Geometry.lit_colored.view;
|
||||
|
||||
begin
|
||||
-- Define capsule shaft,
|
||||
--
|
||||
declare
|
||||
vertex_Count : constant Index_t := Index_t (sides_Count * 2 + 2); -- 2 triangles per side plus 2 since we cannot share the first and last edge.
|
||||
indices_Count : constant long_Index_t := long_Index_t (sides_Count * 2 * 3); -- 2 triangles per side with 3 vertices per triangle.
|
||||
|
||||
the_Vertices : aliased Geometry.lit_colored.Vertex_array := (1 .. vertex_Count => <>);
|
||||
the_Indices : aliased Indices := (1 .. indices_Count => <>);
|
||||
|
||||
begin
|
||||
ny := 1.0;
|
||||
nz := 0.0; -- Normal vector = (0.0, ny, nz)
|
||||
|
||||
-- Set vertices.
|
||||
--
|
||||
declare
|
||||
use linear_Algebra;
|
||||
|
||||
S : Real := 0.0;
|
||||
S_delta : constant Real := 1.0 / Real (sides_Count);
|
||||
|
||||
i : Index_t := 1;
|
||||
begin
|
||||
for Each in 1 .. Index_t (Edges'Length)
|
||||
loop
|
||||
the_Edges (Each).Fore (1) := ny * Radius;
|
||||
the_Edges (Each).Fore (2) := nz * Radius;
|
||||
the_Edges (Each).Fore (3) := L;
|
||||
|
||||
the_Edges (Each).Aft (1) := ny * Radius;
|
||||
the_Edges (Each).Aft (2) := nz * Radius;
|
||||
the_Edges (Each).Aft (3) := -L;
|
||||
|
||||
-- Rotate ny, nz.
|
||||
--
|
||||
tmp := ca * ny - sa * nz;
|
||||
nz := sa * ny + ca * nz;
|
||||
ny := tmp;
|
||||
|
||||
the_Vertices (i).Site := the_Edges (Each).Fore;
|
||||
the_Vertices (i).Normal := Normalised ((the_Vertices (i).Site (1),
|
||||
the_Vertices (i).Site (2),
|
||||
0.0));
|
||||
the_Vertices (i).Color := Self.Color;
|
||||
the_Vertices (i).Shine := 0.5;
|
||||
i := i + 1;
|
||||
|
||||
the_Vertices (i).Site := the_Edges (Each).Aft;
|
||||
the_Vertices (i).Normal := the_Vertices (i - 1).Normal;
|
||||
the_Vertices (i).Color := Self.Color;
|
||||
the_Vertices (i).Shine := 0.5;
|
||||
i := i + 1;
|
||||
|
||||
S := S + S_delta;
|
||||
end loop;
|
||||
|
||||
the_Vertices (i).Site := the_Edges (1).Fore;
|
||||
the_Vertices (i).Normal := Normalised ((the_Vertices (i).Site (1),
|
||||
the_Vertices (i).Site (2),
|
||||
0.0));
|
||||
the_Vertices (i).Color := Self.Color;
|
||||
the_Vertices (i).Shine := 0.5;
|
||||
i := i + 1;
|
||||
|
||||
the_Vertices (i).Site := the_Edges (1).Aft;
|
||||
the_Vertices (i).Normal := the_Vertices (i - 1).Normal;
|
||||
the_Vertices (i).Color := Self.Color;
|
||||
the_Vertices (i).Shine := 0.5;
|
||||
end;
|
||||
|
||||
-- Set indices.
|
||||
--
|
||||
declare
|
||||
i : long_Index_t := 1;
|
||||
Start : Index_t := 1;
|
||||
begin
|
||||
for Each in 1 .. long_Index_t (sides_Count)
|
||||
loop
|
||||
the_Indices (i) := Start; i := i + 1;
|
||||
the_Indices (i) := Start + 1; i := i + 1;
|
||||
the_Indices (i) := Start + 2; i := i + 1;
|
||||
|
||||
the_Indices (i) := Start + 1; i := i + 1;
|
||||
the_Indices (i) := Start + 3; i := i + 1;
|
||||
the_Indices (i) := Start + 2; i := i + 1;
|
||||
|
||||
Start := Start + 2;
|
||||
end loop;
|
||||
end;
|
||||
|
||||
Vertices_are (the_shaft_Geometry.all, the_Vertices);
|
||||
|
||||
declare
|
||||
the_Primitive : constant Primitive.indexed.view
|
||||
:= Primitive.indexed.new_Primitive (primitive.Triangles,
|
||||
the_Indices);
|
||||
begin
|
||||
the_shaft_Geometry.add (Primitive.view (the_Primitive));
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
declare
|
||||
function new_Cap (is_Fore : Boolean) return Geometry.lit_colored.view
|
||||
is
|
||||
use linear_Algebra;
|
||||
|
||||
cap_Geometry : constant Geometry.lit_colored.view
|
||||
:= Geometry.lit_colored.new_Geometry;
|
||||
|
||||
hoop_Count : constant Index_t := quality_Level;
|
||||
vertex_Count : constant Index_t := Index_t (Edges'Length * hoop_Count + 1); -- A vertex for each edge of each hoop, + 1 for the pole.
|
||||
indices_Count : constant long_Index_t := long_Index_t ( (hoop_count - 1) * sides_Count * 2 * 3 -- For each hoop, 2 triangles per side with 3 vertices per triangle
|
||||
+ sides_Count * 3); -- plus the extra indices for the pole triangles.
|
||||
|
||||
the_Vertices : aliased Geometry.lit_colored.Vertex_array := (1 .. vertex_Count => <>);
|
||||
the_Indices : aliased Indices := (1 .. indices_Count => <>);
|
||||
|
||||
the_arch_Edges : arch_Edges;
|
||||
i : Index_t := 1;
|
||||
|
||||
pole_Site : constant Site := (if is_Fore then (0.0, 0.0, L + Radius)
|
||||
else (0.0, 0.0, -L - Radius));
|
||||
|
||||
Degrees_90 : constant := Pi / 2.0;
|
||||
Degrees_360 : constant := Pi * 2.0;
|
||||
|
||||
latitude_Count : constant := hoop_Count + 1;
|
||||
longitude_Count : constant := Edges'Length;
|
||||
|
||||
latitude_Spacing : constant Real := Degrees_90 / Real (latitude_Count - 1);
|
||||
longitude_Spacing : constant Real := Degrees_360 / Real (longitude_Count);
|
||||
|
||||
a, b : Real := 0.0; -- Angular 'cursors' used to track lat/long for texture coords.
|
||||
begin
|
||||
if not is_Fore
|
||||
then
|
||||
a := Degrees_360;
|
||||
end if;
|
||||
|
||||
-- Set the vertices.
|
||||
--
|
||||
start_nx := 0.0;
|
||||
start_ny := 1.0;
|
||||
|
||||
for each_Hoop in 1 .. quality_Level
|
||||
loop
|
||||
-- Get n=start_n.
|
||||
--
|
||||
nx := start_nx;
|
||||
ny := start_ny;
|
||||
nz := 0.0;
|
||||
|
||||
for Each in 1 .. sides_Count
|
||||
loop
|
||||
the_arch_Edges (each_Hoop) (Each) (1) := ny * Radius;
|
||||
the_arch_Edges (each_Hoop) (Each) (2) := nz * Radius;
|
||||
the_arch_Edges (each_Hoop) (Each) (3) := (if is_Fore then nx * Radius + L
|
||||
else nx * Radius - L);
|
||||
-- Rotate ny, nz.
|
||||
--
|
||||
tmp := ca * ny - sa * nz;
|
||||
nz := sa * ny + ca * nz;
|
||||
ny := tmp;
|
||||
|
||||
the_Vertices (i).Site := the_arch_Edges (each_Hoop) (Each);
|
||||
the_Vertices (i).Normal := Normalised ((the_Vertices (i).Site (1),
|
||||
the_Vertices (i).Site (2),
|
||||
(if is_Fore then the_Vertices (i).Site (3) - L
|
||||
else the_Vertices (i).Site (3) + L)));
|
||||
the_Vertices (i).Color := Self.Color;
|
||||
the_Vertices (i).Shine := 0.5;
|
||||
i := i + 1;
|
||||
a := (if is_Fore then a + longitude_Spacing
|
||||
else a - longitude_Spacing);
|
||||
end loop;
|
||||
|
||||
declare
|
||||
tmp : constant Real := start_nx;
|
||||
begin
|
||||
if is_Fore
|
||||
then
|
||||
start_nx := ca * start_nx + sa * start_ny;
|
||||
start_ny := -sa * tmp + ca * start_ny;
|
||||
else
|
||||
start_nx := ca * start_nx - sa * start_ny;
|
||||
start_ny := sa * tmp + ca * start_ny;
|
||||
end if;
|
||||
end;
|
||||
|
||||
a := (if is_Fore then 0.0
|
||||
else Degrees_360);
|
||||
b := b + latitude_Spacing;
|
||||
end loop;
|
||||
|
||||
-- Add pole vertex.
|
||||
--
|
||||
the_Vertices (i).Site := pole_Site;
|
||||
the_Vertices (i).Normal := Normalised (pole_Site);
|
||||
the_Vertices (i).Color := Self.Color;
|
||||
the_Vertices (i).Shine := 0.5;
|
||||
|
||||
-- Set indices.
|
||||
--
|
||||
declare
|
||||
i : long_Index_t := 1;
|
||||
Start : Index_t := 1;
|
||||
hoop_Start : Index_t := 1;
|
||||
pole_Index : constant Index_t := vertex_Count;
|
||||
|
||||
begin
|
||||
for each_Hoop in 1 .. quality_Level
|
||||
loop
|
||||
for Each in 1 .. sides_Count
|
||||
loop
|
||||
declare
|
||||
function next_hoop_Vertex return Index_t
|
||||
is
|
||||
begin
|
||||
if Each = sides_Count then return hoop_Start;
|
||||
else return Start + 1;
|
||||
end if;
|
||||
end next_hoop_Vertex;
|
||||
begin
|
||||
if each_Hoop = quality_Level
|
||||
then
|
||||
if is_Fore
|
||||
then
|
||||
the_Indices (i) := Start; i := i + 1;
|
||||
the_Indices (i) := next_hoop_Vertex; i := i + 1;
|
||||
the_Indices (i) := pole_Index; i := i + 1;
|
||||
else
|
||||
the_Indices (i) := Start; i := i + 1;
|
||||
the_Indices (i) := pole_Index; i := i + 1;
|
||||
the_Indices (i) := next_hoop_Vertex; i := i + 1;
|
||||
end if;
|
||||
else
|
||||
declare
|
||||
v1 : constant Index_t := Start;
|
||||
v2 : constant Index_t := next_hoop_Vertex;
|
||||
v3 : constant Index_t := v1 + sides_Count;
|
||||
v4 : constant Index_t := v2 + sides_Count;
|
||||
begin
|
||||
if is_Fore
|
||||
then
|
||||
the_Indices (i) := v1; i := i + 1;
|
||||
the_Indices (i) := v2; i := i + 1;
|
||||
the_Indices (i) := v3; i := i + 1;
|
||||
|
||||
the_Indices (i) := v2; i := i + 1;
|
||||
the_Indices (i) := v4; i := i + 1;
|
||||
the_Indices (i) := v3; i := i + 1;
|
||||
else
|
||||
the_Indices (i) := v1; i := i + 1;
|
||||
the_Indices (i) := v3; i := i + 1;
|
||||
the_Indices (i) := v2; i := i + 1;
|
||||
|
||||
the_Indices (i) := v2; i := i + 1;
|
||||
the_Indices (i) := v3; i := i + 1;
|
||||
the_Indices (i) := v4; i := i + 1;
|
||||
end if;
|
||||
end;
|
||||
end if;
|
||||
|
||||
Start := Start + 1;
|
||||
end;
|
||||
end loop;
|
||||
|
||||
hoop_Start := hoop_Start + sides_Count;
|
||||
end loop;
|
||||
|
||||
Vertices_are (cap_Geometry.all, the_Vertices);
|
||||
|
||||
declare
|
||||
the_Primitive : constant Primitive.indexed.view
|
||||
:= Primitive.indexed.new_Primitive (Primitive.Triangles,
|
||||
the_Indices);
|
||||
begin
|
||||
cap_Geometry.add (Primitive.view (the_Primitive));
|
||||
end;
|
||||
end;
|
||||
|
||||
return cap_Geometry;
|
||||
end new_Cap;
|
||||
|
||||
begin
|
||||
cap_1_Geometry := new_Cap (is_Fore => True);
|
||||
cap_2_Geometry := new_Cap (is_Fore => False);
|
||||
end;
|
||||
|
||||
return (1 => the_shaft_Geometry.all'Access,
|
||||
2 => cap_1_Geometry.all'Access,
|
||||
3 => cap_2_Geometry.all'Access);
|
||||
end to_GL_Geometries;
|
||||
|
||||
|
||||
end openGL.Model.capsule.lit_colored;
|
||||
@@ -0,0 +1,41 @@
|
||||
with
|
||||
openGL.Geometry;
|
||||
|
||||
|
||||
package openGL.Model.capsule.lit_colored
|
||||
--
|
||||
-- Models a lit and colored capsule.
|
||||
--
|
||||
is
|
||||
type Item is new Model.capsule.item with private;
|
||||
type View is access all Item'Class;
|
||||
|
||||
|
||||
---------
|
||||
--- Forge
|
||||
--
|
||||
|
||||
function new_Capsule (Radius : in Real;
|
||||
Height : in Real;
|
||||
Color : in lucid_Color) return View;
|
||||
|
||||
--------------
|
||||
--- Attributes
|
||||
--
|
||||
|
||||
overriding
|
||||
function to_GL_Geometries (Self : access Item; Textures : access Texture.name_Map_of_texture'Class;
|
||||
Fonts : in Font.font_id_Map_of_font) return Geometry.views;
|
||||
|
||||
|
||||
|
||||
private
|
||||
|
||||
type Item is new Model.capsule.item with
|
||||
record
|
||||
Radius : Real;
|
||||
Height : Real;
|
||||
Color : rgba_Color;
|
||||
end record;
|
||||
|
||||
end openGL.Model.capsule.lit_colored;
|
||||
@@ -0,0 +1,412 @@
|
||||
with
|
||||
openGL.Geometry.lit_colored_textured,
|
||||
openGL.Texture,
|
||||
openGL.IO,
|
||||
openGL.Primitive.indexed;
|
||||
|
||||
|
||||
package body openGL.Model.capsule.lit_colored_textured
|
||||
is
|
||||
---------
|
||||
--- Forge
|
||||
--
|
||||
|
||||
function new_Capsule (Radius : in Real;
|
||||
Height : in Real;
|
||||
Color : in lucid_Color;
|
||||
Image : in asset_Name := null_Asset) return View
|
||||
is
|
||||
Self : constant View := new Item;
|
||||
begin
|
||||
Self.Radius := Radius;
|
||||
Self.Height := Height;
|
||||
|
||||
Self.Color := +Color;
|
||||
Self.Image := Image;
|
||||
|
||||
return Self;
|
||||
end new_Capsule;
|
||||
|
||||
|
||||
--------------
|
||||
--- Attributes
|
||||
--
|
||||
|
||||
type Geometry_view is access all Geometry.lit_colored_textured.item'Class;
|
||||
|
||||
|
||||
overriding
|
||||
function to_GL_Geometries (Self : access Item; Textures : access Texture.name_Map_of_texture'Class;
|
||||
Fonts : in Font.font_id_Map_of_font) return Geometry.views
|
||||
is
|
||||
pragma unreferenced (Textures, Fonts);
|
||||
|
||||
use Geometry,
|
||||
Geometry.lit_colored_textured,
|
||||
real_Functions;
|
||||
|
||||
Length : constant Real := Self.Height;
|
||||
Radius : constant Real := Self.Radius;
|
||||
|
||||
quality_Level : constant Index_t := 4;
|
||||
sides_Count : constant Index_t := Index_t (quality_Level * 4); -- Number of sides to the cylinder (divisible by 4):
|
||||
|
||||
type Edge is -- A 'shaft' edge.
|
||||
record
|
||||
Fore : Site;
|
||||
Aft : Site;
|
||||
end record;
|
||||
|
||||
type Edges is array (Index_t range 1 .. sides_Count) of Edge;
|
||||
type arch_Edges is array (Index_t range 1 .. quality_Level) of Sites (1 .. sides_Count);
|
||||
|
||||
tmp,
|
||||
nx, ny, nz,
|
||||
start_nx,
|
||||
start_ny : Real;
|
||||
a : constant Real := Pi * 2.0 / Real (sides_Count);
|
||||
ca : constant Real := Cos (a);
|
||||
sa : constant Real := Sin (a);
|
||||
L : constant Real := Length * 0.5;
|
||||
|
||||
the_Edges : Edges;
|
||||
|
||||
the_shaft_Geometry : constant Geometry_view
|
||||
:= Geometry_view (Geometry.lit_colored_textured.new_Geometry (texture_is_Alpha => False));
|
||||
|
||||
cap_1_Geometry : Geometry_view;
|
||||
cap_2_Geometry : Geometry_view;
|
||||
|
||||
begin
|
||||
-- Define capsule shaft,
|
||||
--
|
||||
declare
|
||||
vertex_Count : constant Index_t := Index_t (sides_Count * 2 + 2); -- 2 triangles per side plus 2 since we cannot share the first and last edge.
|
||||
indices_Count : constant long_Index_t := long_Index_t (sides_Count * 2 * 3); -- 2 triangles per side with 3 vertices per triangle.
|
||||
|
||||
the_Vertices : aliased Geometry.lit_colored_textured.Vertex_array := [1 .. vertex_Count => <>];
|
||||
the_Indices : aliased Indices := [1 .. indices_Count => <>];
|
||||
|
||||
begin
|
||||
ny := 1.0;
|
||||
nz := 0.0; -- Normal vector = (0.0, ny, nz)
|
||||
|
||||
-- Set vertices.
|
||||
--
|
||||
declare
|
||||
use linear_Algebra;
|
||||
|
||||
S : Real := 0.0;
|
||||
S_delta : constant Real := 1.0 / Real (sides_Count);
|
||||
|
||||
i : Index_t := 1;
|
||||
begin
|
||||
for Each in 1 .. Index_t (Edges'Length)
|
||||
loop
|
||||
the_Edges (Each).Fore (1) := ny * Radius;
|
||||
the_Edges (Each).Fore (2) := nz * Radius;
|
||||
the_Edges (Each).Fore (3) := L;
|
||||
|
||||
the_Edges (Each).Aft (1) := ny * Radius;
|
||||
the_Edges (Each).Aft (2) := nz * Radius;
|
||||
the_Edges (Each).Aft (3) := -L;
|
||||
|
||||
-- Rotate ny, nz.
|
||||
--
|
||||
tmp := ca * ny - sa * nz;
|
||||
nz := sa * ny + ca * nz;
|
||||
ny := tmp;
|
||||
|
||||
the_Vertices (i).Site := the_Edges (Each).Fore;
|
||||
the_Vertices (i).Normal := Normalised ([the_Vertices (i).Site (1),
|
||||
the_Vertices (i).Site (2),
|
||||
0.0]);
|
||||
the_Vertices (i).Color := Self.Color;
|
||||
the_Vertices (i).Shine := 0.5;
|
||||
the_Vertices (i).Coords := (s => S,
|
||||
t => 1.0);
|
||||
i := i + 1;
|
||||
|
||||
the_Vertices (i).Site := the_Edges (Each).Aft;
|
||||
the_Vertices (i).Normal := the_Vertices (i - 1).Normal;
|
||||
the_Vertices (i).Color := Self.Color;
|
||||
the_Vertices (i).Shine := 0.5;
|
||||
the_Vertices (i).Coords := (s => S,
|
||||
t => 0.0);
|
||||
i := i + 1;
|
||||
|
||||
S := S + S_delta;
|
||||
end loop;
|
||||
|
||||
the_Vertices (i).Site := the_Edges (1).Fore;
|
||||
the_Vertices (i).Normal := Normalised ([the_Vertices (i).Site (1),
|
||||
the_Vertices (i).Site (2),
|
||||
0.0]);
|
||||
the_Vertices (i).Color := Self.Color;
|
||||
the_Vertices (i).Shine := 0.5;
|
||||
the_Vertices (i).Coords := (s => S,
|
||||
t => 1.0);
|
||||
i := i + 1;
|
||||
|
||||
the_Vertices (i).Site := the_Edges (1).Aft;
|
||||
the_Vertices (i).Normal := the_Vertices (i - 1).Normal;
|
||||
the_Vertices (i).Color := Self.Color;
|
||||
the_Vertices (i).Shine := 0.5;
|
||||
the_Vertices (i).Coords := (s => S,
|
||||
t => 0.0);
|
||||
end;
|
||||
|
||||
-- Set indices.
|
||||
--
|
||||
declare
|
||||
i : long_Index_t := 1;
|
||||
Start : Index_t := 1;
|
||||
begin
|
||||
for Each in 1 .. long_Index_t (sides_Count)
|
||||
loop
|
||||
the_Indices (i) := Start; i := i + 1;
|
||||
the_Indices (i) := Start + 1; i := i + 1;
|
||||
the_Indices (i) := Start + 2; i := i + 1;
|
||||
|
||||
the_Indices (i) := Start + 1; i := i + 1;
|
||||
the_Indices (i) := Start + 3; i := i + 1;
|
||||
the_Indices (i) := Start + 2; i := i + 1;
|
||||
|
||||
Start := Start + 2;
|
||||
end loop;
|
||||
end;
|
||||
|
||||
if Self.Image /= null_Asset
|
||||
then
|
||||
set_Texture:
|
||||
declare
|
||||
use Texture;
|
||||
the_Image : constant Image := IO.to_Image (Self.Image);
|
||||
the_Texture : constant Texture.object := Forge.to_Texture (the_Image);
|
||||
begin
|
||||
the_shaft_Geometry.Texture_is (the_Texture);
|
||||
end set_Texture;
|
||||
end if;
|
||||
|
||||
Vertices_are (the_shaft_Geometry.all, the_Vertices);
|
||||
|
||||
declare
|
||||
the_Primitive : constant Primitive.indexed.view
|
||||
:= Primitive.indexed.new_Primitive (primitive.Triangles,
|
||||
the_Indices);
|
||||
begin
|
||||
the_shaft_Geometry.add (Primitive.view (the_Primitive));
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
declare
|
||||
function new_Cap (is_Fore : Boolean) return Geometry_view
|
||||
is
|
||||
use linear_Algebra;
|
||||
|
||||
cap_Geometry : constant Geometry_view
|
||||
:= Geometry.lit_colored_textured.new_Geometry (texture_is_Alpha => False);
|
||||
|
||||
hoop_Count : constant Index_t := quality_Level;
|
||||
vertex_Count : constant Index_t := Index_t (Edges'Length * hoop_Count + 1); -- A vertex for each edge of each hoop, + 1 for the pole.
|
||||
indices_Count : constant long_Index_t := long_Index_t ( (hoop_count - 1) * sides_Count * 2 * 3 -- For each hoop, 2 triangles per side with 3 vertices per triangle
|
||||
+ sides_Count * 3); -- plus the extra indices for the pole triangles.
|
||||
|
||||
the_Vertices : aliased Geometry.lit_colored_textured.Vertex_array := [1 .. vertex_Count => <>];
|
||||
the_Indices : aliased Indices := [1 .. indices_Count => <>];
|
||||
|
||||
the_arch_Edges : arch_Edges;
|
||||
i : Index_t := 1;
|
||||
|
||||
pole_Site : constant Site := (if is_Fore then [0.0, 0.0, L + Radius]
|
||||
else [0.0, 0.0, -L - Radius]);
|
||||
|
||||
Degrees_90 : constant := Pi / 2.0;
|
||||
Degrees_360 : constant := Pi * 2.0;
|
||||
|
||||
latitude_Count : constant := hoop_Count + 1;
|
||||
longitude_Count : constant := Edges'Length;
|
||||
|
||||
latitude_Spacing : constant Real := Degrees_90 / Real (latitude_Count - 1);
|
||||
longitude_Spacing : constant Real := Degrees_360 / Real (longitude_Count);
|
||||
|
||||
a, b : Real := 0.0; -- Angular 'cursors' used to track lat/long for texture coords.
|
||||
begin
|
||||
if not is_Fore
|
||||
then
|
||||
a := Degrees_360;
|
||||
end if;
|
||||
|
||||
-- Set the vertices.
|
||||
--
|
||||
start_nx := 0.0;
|
||||
start_ny := 1.0;
|
||||
|
||||
for each_Hoop in 1 .. quality_Level
|
||||
loop
|
||||
-- Get n=start_n.
|
||||
--
|
||||
nx := start_nx;
|
||||
ny := start_ny;
|
||||
nz := 0.0;
|
||||
|
||||
for Each in 1 .. sides_Count
|
||||
loop
|
||||
the_arch_Edges (each_Hoop) (Each) (1) := ny * Radius;
|
||||
the_arch_Edges (each_Hoop) (Each) (2) := nz * Radius;
|
||||
the_arch_Edges (each_Hoop) (Each) (3) := (if is_Fore then nx * Radius + L
|
||||
else nx * Radius - L);
|
||||
-- Rotate ny, nz.
|
||||
--
|
||||
tmp := ca * ny - sa * nz;
|
||||
nz := sa * ny + ca * nz;
|
||||
ny := tmp;
|
||||
|
||||
the_Vertices (i).Site := the_arch_Edges (each_Hoop) (Each);
|
||||
the_Vertices (i).Normal := Normalised ([the_Vertices (i).Site (1),
|
||||
the_Vertices (i).Site (2),
|
||||
(if is_Fore then the_Vertices (i).Site (3) - L
|
||||
else the_Vertices (i).Site (3) + L)]);
|
||||
the_Vertices (i).Color := Self.Color;
|
||||
the_Vertices (i).Shine := 0.5;
|
||||
the_Vertices (i).Coords := (s => a / Degrees_360,
|
||||
t => b / Degrees_90);
|
||||
i := i + 1;
|
||||
a := (if is_Fore then a + longitude_Spacing
|
||||
else a - longitude_Spacing);
|
||||
end loop;
|
||||
|
||||
declare
|
||||
tmp : constant Real := start_nx;
|
||||
begin
|
||||
if is_Fore
|
||||
then
|
||||
start_nx := ca * start_nx + sa * start_ny;
|
||||
start_ny := -sa * tmp + ca * start_ny;
|
||||
else
|
||||
start_nx := ca * start_nx - sa * start_ny;
|
||||
start_ny := sa * tmp + ca * start_ny;
|
||||
end if;
|
||||
end;
|
||||
|
||||
a := (if is_Fore then 0.0
|
||||
else Degrees_360);
|
||||
b := b + latitude_Spacing;
|
||||
end loop;
|
||||
|
||||
-- Add pole vertex.
|
||||
--
|
||||
the_Vertices (i).Site := pole_Site;
|
||||
the_Vertices (i).Normal := Normalised (pole_Site);
|
||||
the_Vertices (i).Color := Self.Color;
|
||||
the_Vertices (i).Shine := 0.5;
|
||||
the_Vertices (i).Coords := (s => 0.5,
|
||||
t => 1.0);
|
||||
-- Set indices.
|
||||
--
|
||||
declare
|
||||
i : long_Index_t := 1;
|
||||
Start : Index_t := 1;
|
||||
hoop_Start : Index_t := 1;
|
||||
pole_Index : constant Index_t := vertex_Count;
|
||||
|
||||
begin
|
||||
for each_Hoop in 1 .. quality_Level
|
||||
loop
|
||||
for Each in 1 .. sides_Count
|
||||
loop
|
||||
declare
|
||||
function next_hoop_Vertex return Index_t
|
||||
is
|
||||
begin
|
||||
if Each = sides_Count then return hoop_Start;
|
||||
else return Start + 1;
|
||||
end if;
|
||||
end next_hoop_Vertex;
|
||||
begin
|
||||
if each_Hoop = quality_Level
|
||||
then
|
||||
if is_Fore
|
||||
then
|
||||
the_Indices (i) := Start; i := i + 1;
|
||||
the_Indices (i) := next_hoop_Vertex; i := i + 1;
|
||||
the_Indices (i) := pole_Index; i := i + 1;
|
||||
else
|
||||
the_Indices (i) := Start; i := i + 1;
|
||||
the_Indices (i) := pole_Index; i := i + 1;
|
||||
the_Indices (i) := next_hoop_Vertex; i := i + 1;
|
||||
end if;
|
||||
else
|
||||
declare
|
||||
v1 : constant Index_t := Start;
|
||||
v2 : constant Index_t := next_hoop_Vertex;
|
||||
v3 : constant Index_t := v1 + sides_Count;
|
||||
v4 : constant Index_t := v2 + sides_Count;
|
||||
begin
|
||||
if is_Fore
|
||||
then
|
||||
the_Indices (i) := v1; i := i + 1;
|
||||
the_Indices (i) := v2; i := i + 1;
|
||||
the_Indices (i) := v3; i := i + 1;
|
||||
|
||||
the_Indices (i) := v2; i := i + 1;
|
||||
the_Indices (i) := v4; i := i + 1;
|
||||
the_Indices (i) := v3; i := i + 1;
|
||||
else
|
||||
the_Indices (i) := v1; i := i + 1;
|
||||
the_Indices (i) := v3; i := i + 1;
|
||||
the_Indices (i) := v2; i := i + 1;
|
||||
|
||||
the_Indices (i) := v2; i := i + 1;
|
||||
the_Indices (i) := v3; i := i + 1;
|
||||
the_Indices (i) := v4; i := i + 1;
|
||||
end if;
|
||||
end;
|
||||
end if;
|
||||
|
||||
Start := Start + 1;
|
||||
end;
|
||||
end loop;
|
||||
|
||||
hoop_Start := hoop_Start + sides_Count;
|
||||
end loop;
|
||||
|
||||
if Self.Image /= null_Asset
|
||||
then
|
||||
set_the_Texture:
|
||||
declare
|
||||
use Texture;
|
||||
the_Image : constant Image := IO.to_Image (Self.Image);
|
||||
the_Texture : constant Texture.object := Forge.to_Texture (the_Image);
|
||||
begin
|
||||
cap_Geometry.Texture_is (the_Texture);
|
||||
end set_the_Texture;
|
||||
end if;
|
||||
|
||||
Vertices_are (cap_Geometry.all, the_Vertices);
|
||||
|
||||
declare
|
||||
the_Primitive : constant Primitive.indexed.view
|
||||
:= Primitive.indexed.new_Primitive (Primitive.Triangles,
|
||||
the_Indices);
|
||||
begin
|
||||
cap_Geometry.add (Primitive.view (the_Primitive));
|
||||
end;
|
||||
end;
|
||||
|
||||
return cap_Geometry;
|
||||
end new_Cap;
|
||||
|
||||
begin
|
||||
cap_1_Geometry := new_Cap (is_Fore => True);
|
||||
cap_2_Geometry := new_Cap (is_Fore => False);
|
||||
end;
|
||||
|
||||
return [1 => the_shaft_Geometry.all'Access,
|
||||
2 => cap_1_Geometry.all'Access,
|
||||
3 => cap_2_Geometry.all'Access];
|
||||
end to_GL_Geometries;
|
||||
|
||||
|
||||
end openGL.Model.capsule.lit_colored_textured;
|
||||
@@ -0,0 +1,44 @@
|
||||
with
|
||||
openGL.Geometry;
|
||||
|
||||
|
||||
package openGL.Model.capsule.lit_colored_textured
|
||||
--
|
||||
-- Models a lit, colored and textured capsule.
|
||||
--
|
||||
is
|
||||
type Item is new Model.capsule.item with private;
|
||||
type View is access all Item'Class;
|
||||
|
||||
|
||||
---------
|
||||
--- Forge
|
||||
--
|
||||
|
||||
function new_Capsule (Radius : in Real;
|
||||
Height : in Real;
|
||||
Color : in lucid_Color;
|
||||
Image : in asset_Name := null_Asset) return View;
|
||||
|
||||
--------------
|
||||
--- Attributes
|
||||
--
|
||||
|
||||
overriding
|
||||
function to_GL_Geometries (Self : access Item; Textures : access Texture.name_Map_of_texture'Class;
|
||||
Fonts : in Font.font_id_Map_of_font) return Geometry.views;
|
||||
|
||||
|
||||
|
||||
private
|
||||
|
||||
type Item is new Model.capsule.item with
|
||||
record
|
||||
Radius : Real;
|
||||
Height : Real;
|
||||
|
||||
Color : rgba_Color;
|
||||
Image : asset_Name := null_Asset;
|
||||
end record;
|
||||
|
||||
end openGL.Model.capsule.lit_colored_textured;
|
||||
@@ -0,0 +1,403 @@
|
||||
with
|
||||
openGL.Geometry.lit_textured,
|
||||
openGL.Texture,
|
||||
openGL.IO,
|
||||
openGL.Primitive.indexed;
|
||||
|
||||
|
||||
package body openGL.Model.capsule.lit_textured
|
||||
is
|
||||
---------
|
||||
--- Forge
|
||||
--
|
||||
|
||||
function new_Capsule (Radius : in Real;
|
||||
Height : in Real;
|
||||
Image : in asset_Name := null_Asset) return View
|
||||
is
|
||||
Self : constant View := new Item;
|
||||
begin
|
||||
Self.Radius := Radius;
|
||||
Self.Height := Height;
|
||||
Self.Image := Image;
|
||||
|
||||
return Self;
|
||||
end new_Capsule;
|
||||
|
||||
|
||||
--------------
|
||||
--- Attributes
|
||||
--
|
||||
|
||||
-- type Geometry_view is access all Geometry.lit_textured.item'Class;
|
||||
|
||||
|
||||
overriding
|
||||
function to_GL_Geometries (Self : access Item; Textures : access Texture.name_Map_of_texture'Class;
|
||||
Fonts : in Font.font_id_Map_of_font) return Geometry.views
|
||||
is
|
||||
pragma unreferenced (Textures, Fonts);
|
||||
|
||||
use Geometry,
|
||||
Geometry.lit_textured,
|
||||
real_Functions;
|
||||
|
||||
Length : constant Real := Self.Height;
|
||||
Radius : constant Real := Self.Radius;
|
||||
|
||||
quality_Level : constant Index_t := 4;
|
||||
sides_Count : constant Index_t := Index_t (quality_Level * 4); -- Number of sides to the cylinder (divisible by 4):
|
||||
|
||||
type Edge is -- A 'shaft' edge.
|
||||
record
|
||||
Fore : Site;
|
||||
Aft : Site;
|
||||
end record;
|
||||
|
||||
type Edges is array (Index_t range 1 .. sides_Count) of Edge;
|
||||
type arch_Edges is array (Index_t range 1 .. quality_Level) of Sites (1 .. sides_Count);
|
||||
|
||||
tmp,
|
||||
nx, ny, nz,
|
||||
start_nx,
|
||||
start_ny : Real;
|
||||
a : constant Real := Pi * 2.0 / Real (sides_Count);
|
||||
ca : constant Real := Cos (a);
|
||||
sa : constant Real := Sin (a);
|
||||
L : constant Real := Length * 0.5;
|
||||
|
||||
the_Edges : Edges;
|
||||
|
||||
the_shaft_Geometry : constant Geometry.lit_textured.view
|
||||
:= Geometry.lit_textured.new_Geometry;
|
||||
|
||||
cap_1_Geometry : Geometry.lit_textured.view;
|
||||
cap_2_Geometry : Geometry.lit_textured.view;
|
||||
|
||||
begin
|
||||
-- Define capsule shaft,
|
||||
--
|
||||
declare
|
||||
vertex_Count : constant Index_t := Index_t (sides_Count * 2 + 2); -- 2 triangles per side plus 2 since we cannot share the first and last edge.
|
||||
indices_Count : constant long_Index_t := long_Index_t (sides_Count * 2 * 3); -- 2 triangles per side with 3 vertices per triangle.
|
||||
|
||||
the_Vertices : aliased Geometry.lit_textured.Vertex_array := [1 .. vertex_Count => <>];
|
||||
the_Indices : aliased Indices := [1 .. indices_Count => <>];
|
||||
|
||||
begin
|
||||
ny := 1.0;
|
||||
nz := 0.0; -- Normal vector = (0.0, ny, nz)
|
||||
|
||||
-- Set vertices.
|
||||
--
|
||||
declare
|
||||
use linear_Algebra;
|
||||
|
||||
S : Real := 0.0;
|
||||
S_delta : constant Real := 1.0 / Real (sides_Count);
|
||||
|
||||
i : Index_t := 1;
|
||||
begin
|
||||
for Each in 1 .. Index_t (Edges'Length)
|
||||
loop
|
||||
the_Edges (Each).Fore (1) := ny * Radius;
|
||||
the_Edges (Each).Fore (2) := nz * Radius;
|
||||
the_Edges (Each).Fore (3) := L;
|
||||
|
||||
the_Edges (Each).Aft (1) := ny * Radius;
|
||||
the_Edges (Each).Aft (2) := nz * Radius;
|
||||
the_Edges (Each).Aft (3) := -L;
|
||||
|
||||
-- Rotate ny, nz.
|
||||
--
|
||||
tmp := ca * ny - sa * nz;
|
||||
nz := sa * ny + ca * nz;
|
||||
ny := tmp;
|
||||
|
||||
the_Vertices (i).Site := the_Edges (Each).Fore;
|
||||
the_Vertices (i).Shine := 0.5;
|
||||
the_Vertices (i).Normal := Normalised ([the_Vertices (i).Site (1),
|
||||
the_Vertices (i).Site (2),
|
||||
0.0]);
|
||||
the_Vertices (i).Coords := (s => S,
|
||||
t => 1.0);
|
||||
i := i + 1;
|
||||
|
||||
the_Vertices (i).Site := the_Edges (Each).Aft;
|
||||
the_Vertices (i).Shine := 0.5;
|
||||
the_Vertices (i).Normal := the_Vertices (i - 1).Normal;
|
||||
the_Vertices (i).Coords := (s => S,
|
||||
t => 0.0);
|
||||
i := i + 1;
|
||||
|
||||
S := S + S_delta;
|
||||
end loop;
|
||||
|
||||
the_Vertices (i).Site := the_Edges (1).Fore;
|
||||
the_Vertices (i).Shine := 0.5;
|
||||
the_Vertices (i).Normal := Normalised ([the_Vertices (i).Site (1),
|
||||
the_Vertices (i).Site (2),
|
||||
0.0]);
|
||||
the_Vertices (i).Coords := (s => S,
|
||||
t => 1.0);
|
||||
i := i + 1;
|
||||
|
||||
the_Vertices (i).Site := the_Edges (1).Aft;
|
||||
the_Vertices (i).Shine := 0.5;
|
||||
the_Vertices (i).Normal := the_Vertices (i - 1).Normal;
|
||||
the_Vertices (i).Coords := (s => S,
|
||||
t => 0.0);
|
||||
end;
|
||||
|
||||
-- Set indices.
|
||||
--
|
||||
declare
|
||||
i : long_Index_t := 1;
|
||||
Start : Index_t := 1;
|
||||
begin
|
||||
for Each in 1 .. long_Index_t (sides_Count)
|
||||
loop
|
||||
the_Indices (i) := Start; i := i + 1;
|
||||
the_Indices (i) := Start + 1; i := i + 1;
|
||||
the_Indices (i) := Start + 2; i := i + 1;
|
||||
|
||||
the_Indices (i) := Start + 1; i := i + 1;
|
||||
the_Indices (i) := Start + 3; i := i + 1;
|
||||
the_Indices (i) := Start + 2; i := i + 1;
|
||||
|
||||
Start := Start + 2;
|
||||
end loop;
|
||||
end;
|
||||
|
||||
if Self.Image /= null_Asset
|
||||
then
|
||||
set_Texture:
|
||||
declare
|
||||
use Texture;
|
||||
the_Image : constant Image := IO.to_Image (Self.Image);
|
||||
the_Texture : constant Texture.object := Forge.to_Texture (the_Image);
|
||||
begin
|
||||
the_shaft_Geometry.Texture_is (the_Texture);
|
||||
end set_Texture;
|
||||
end if;
|
||||
|
||||
Vertices_are (the_shaft_Geometry.all, the_Vertices);
|
||||
|
||||
declare
|
||||
the_Primitive : constant Primitive.indexed.view
|
||||
:= Primitive.indexed.new_Primitive (primitive.Triangles,
|
||||
the_Indices);
|
||||
begin
|
||||
the_shaft_Geometry.add (Primitive.view (the_Primitive));
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
declare
|
||||
function new_Cap (is_Fore : Boolean) return Geometry.lit_textured.view
|
||||
is
|
||||
use linear_Algebra;
|
||||
|
||||
cap_Geometry : constant Geometry.lit_textured.view
|
||||
:= Geometry.lit_textured.new_Geometry;
|
||||
|
||||
hoop_Count : constant Index_t := quality_Level;
|
||||
vertex_Count : constant Index_t := Index_t (Edges'Length * hoop_Count + 1); -- A vertex for each edge of each hoop, + 1 for the pole.
|
||||
indices_Count : constant long_Index_t := long_Index_t ( (hoop_count - 1) * sides_Count * 2 * 3 -- For each hoop, 2 triangles per side with 3 vertices per triangle
|
||||
+ sides_Count * 3); -- plus the extra indices for the pole triangles.
|
||||
|
||||
the_Vertices : aliased Geometry.lit_textured.Vertex_array := [1 .. vertex_Count => <>];
|
||||
the_Indices : aliased Indices := [1 .. indices_Count => <>];
|
||||
|
||||
the_arch_Edges : arch_Edges;
|
||||
i : Index_t := 1;
|
||||
|
||||
pole_Site : constant Site := (if is_Fore then [0.0, 0.0, L + Radius]
|
||||
else [0.0, 0.0, -L - Radius]);
|
||||
|
||||
Degrees_90 : constant := Pi / 2.0;
|
||||
Degrees_360 : constant := Pi * 2.0;
|
||||
|
||||
latitude_Count : constant := hoop_Count + 1;
|
||||
longitude_Count : constant := Edges'Length;
|
||||
|
||||
latitude_Spacing : constant Real := Degrees_90 / Real (latitude_Count - 1);
|
||||
longitude_Spacing : constant Real := Degrees_360 / Real (longitude_Count);
|
||||
|
||||
a, b : Real := 0.0; -- Angular 'cursors' used to track lat/long for texture coords.
|
||||
begin
|
||||
if not is_Fore
|
||||
then
|
||||
a := Degrees_360;
|
||||
end if;
|
||||
|
||||
-- Set the vertices.
|
||||
--
|
||||
start_nx := 0.0;
|
||||
start_ny := 1.0;
|
||||
|
||||
for each_Hoop in 1 .. quality_Level
|
||||
loop
|
||||
-- Get n=start_n.
|
||||
--
|
||||
nx := start_nx;
|
||||
ny := start_ny;
|
||||
nz := 0.0;
|
||||
|
||||
for Each in 1 .. sides_Count
|
||||
loop
|
||||
the_arch_Edges (each_Hoop) (Each) (1) := ny * Radius;
|
||||
the_arch_Edges (each_Hoop) (Each) (2) := nz * Radius;
|
||||
the_arch_Edges (each_Hoop) (Each) (3) := (if is_Fore then nx * Radius + L
|
||||
else nx * Radius - L);
|
||||
-- Rotate ny, nz.
|
||||
--
|
||||
tmp := ca * ny - sa * nz;
|
||||
nz := sa * ny + ca * nz;
|
||||
ny := tmp;
|
||||
|
||||
the_Vertices (i).Site := the_arch_Edges (each_Hoop) (Each);
|
||||
the_Vertices (i).Shine := 0.5;
|
||||
the_Vertices (i).Normal := Normalised ([the_Vertices (i).Site (1),
|
||||
the_Vertices (i).Site (2),
|
||||
(if is_Fore then the_Vertices (i).Site (3) - L
|
||||
else the_Vertices (i).Site (3) + L)]);
|
||||
the_Vertices (i).Coords := (s => a / Degrees_360,
|
||||
t => b / Degrees_90);
|
||||
i := i + 1;
|
||||
a := (if is_Fore then a + longitude_Spacing
|
||||
else a - longitude_Spacing);
|
||||
end loop;
|
||||
|
||||
declare
|
||||
tmp : constant Real := start_nx;
|
||||
begin
|
||||
if is_Fore
|
||||
then
|
||||
start_nx := ca * start_nx + sa * start_ny;
|
||||
start_ny := -sa * tmp + ca * start_ny;
|
||||
else
|
||||
start_nx := ca * start_nx - sa * start_ny;
|
||||
start_ny := sa * tmp + ca * start_ny;
|
||||
end if;
|
||||
end;
|
||||
|
||||
a := (if is_Fore then 0.0
|
||||
else Degrees_360);
|
||||
b := b + latitude_Spacing;
|
||||
end loop;
|
||||
|
||||
-- Add pole vertex.
|
||||
--
|
||||
the_Vertices (i).Site := pole_Site;
|
||||
the_Vertices (i).Shine := 0.5;
|
||||
the_Vertices (i).Normal := Normalised (pole_Site);
|
||||
the_Vertices (i).Coords := (s => 0.5,
|
||||
t => 1.0);
|
||||
-- Set indices.
|
||||
--
|
||||
declare
|
||||
i : long_Index_t := 1;
|
||||
Start : Index_t := 1;
|
||||
hoop_Start : Index_t := 1;
|
||||
pole_Index : constant Index_t := vertex_Count;
|
||||
|
||||
begin
|
||||
for each_Hoop in 1 .. quality_Level
|
||||
loop
|
||||
for Each in 1 .. sides_Count
|
||||
loop
|
||||
declare
|
||||
function next_hoop_Vertex return Index_t
|
||||
is
|
||||
begin
|
||||
if Each = sides_Count then return hoop_Start;
|
||||
else return Start + 1;
|
||||
end if;
|
||||
end next_hoop_Vertex;
|
||||
begin
|
||||
if each_Hoop = quality_Level
|
||||
then
|
||||
if is_Fore
|
||||
then
|
||||
the_Indices (i) := Start; i := i + 1;
|
||||
the_Indices (i) := next_hoop_Vertex; i := i + 1;
|
||||
the_Indices (i) := pole_Index; i := i + 1;
|
||||
else
|
||||
the_Indices (i) := Start; i := i + 1;
|
||||
the_Indices (i) := pole_Index; i := i + 1;
|
||||
the_Indices (i) := next_hoop_Vertex; i := i + 1;
|
||||
end if;
|
||||
else
|
||||
declare
|
||||
v1 : constant Index_t := Start;
|
||||
v2 : constant Index_t := next_hoop_Vertex;
|
||||
v3 : constant Index_t := v1 + sides_Count;
|
||||
v4 : constant Index_t := v2 + sides_Count;
|
||||
begin
|
||||
if is_Fore
|
||||
then
|
||||
the_Indices (i) := v1; i := i + 1;
|
||||
the_Indices (i) := v2; i := i + 1;
|
||||
the_Indices (i) := v3; i := i + 1;
|
||||
|
||||
the_Indices (i) := v2; i := i + 1;
|
||||
the_Indices (i) := v4; i := i + 1;
|
||||
the_Indices (i) := v3; i := i + 1;
|
||||
else
|
||||
the_Indices (i) := v1; i := i + 1;
|
||||
the_Indices (i) := v3; i := i + 1;
|
||||
the_Indices (i) := v2; i := i + 1;
|
||||
|
||||
the_Indices (i) := v2; i := i + 1;
|
||||
the_Indices (i) := v3; i := i + 1;
|
||||
the_Indices (i) := v4; i := i + 1;
|
||||
end if;
|
||||
end;
|
||||
end if;
|
||||
|
||||
Start := Start + 1;
|
||||
end;
|
||||
end loop;
|
||||
|
||||
hoop_Start := hoop_Start + sides_Count;
|
||||
end loop;
|
||||
|
||||
if Self.Image /= null_Asset
|
||||
then
|
||||
set_the_Texture:
|
||||
declare
|
||||
use Texture;
|
||||
the_Image : constant Image := IO.to_Image (Self.Image);
|
||||
the_Texture : constant Texture.object := Forge.to_Texture (the_Image);
|
||||
begin
|
||||
cap_Geometry.Texture_is (the_Texture);
|
||||
end set_the_Texture;
|
||||
end if;
|
||||
|
||||
Vertices_are (cap_Geometry.all, the_Vertices);
|
||||
|
||||
declare
|
||||
the_Primitive : constant Primitive.indexed.view
|
||||
:= Primitive.indexed.new_Primitive (Primitive.Triangles,
|
||||
the_Indices);
|
||||
begin
|
||||
cap_Geometry.add (Primitive.view (the_Primitive));
|
||||
end;
|
||||
end;
|
||||
|
||||
return cap_Geometry;
|
||||
end new_Cap;
|
||||
|
||||
begin
|
||||
cap_1_Geometry := new_Cap (is_Fore => True);
|
||||
cap_2_Geometry := new_Cap (is_Fore => False);
|
||||
end;
|
||||
|
||||
return [1 => the_shaft_Geometry.all'Access,
|
||||
2 => cap_1_Geometry.all'Access,
|
||||
3 => cap_2_Geometry.all'Access];
|
||||
end to_GL_Geometries;
|
||||
|
||||
|
||||
end openGL.Model.capsule.lit_textured;
|
||||
@@ -0,0 +1,42 @@
|
||||
with
|
||||
openGL.Geometry;
|
||||
|
||||
|
||||
package openGL.Model.capsule.lit_textured
|
||||
--
|
||||
-- Models a lit and textured capsule.
|
||||
--
|
||||
is
|
||||
type Item is new Model.capsule.item with private;
|
||||
type View is access all Item'Class;
|
||||
|
||||
|
||||
---------
|
||||
--- Forge
|
||||
--
|
||||
|
||||
function new_Capsule (Radius : in Real;
|
||||
Height : in Real;
|
||||
Image : in asset_Name := null_Asset) return View;
|
||||
|
||||
--------------
|
||||
--- Attributes
|
||||
--
|
||||
|
||||
overriding
|
||||
function to_GL_Geometries (Self : access Item; Textures : access Texture.name_Map_of_texture'Class;
|
||||
Fonts : in Font.font_id_Map_of_font) return Geometry.views;
|
||||
|
||||
|
||||
|
||||
private
|
||||
|
||||
type Item is new Model.capsule.item with
|
||||
record
|
||||
Radius : Real;
|
||||
Height : Real;
|
||||
|
||||
Image : asset_Name := null_Asset;
|
||||
end record;
|
||||
|
||||
end openGL.Model.capsule.lit_textured;
|
||||
377
3-mid/opengl/source/lean/model/opengl-model-capsule-textured.adb
Normal file
377
3-mid/opengl/source/lean/model/opengl-model-capsule-textured.adb
Normal file
@@ -0,0 +1,377 @@
|
||||
with
|
||||
openGL.Geometry.textured,
|
||||
openGL.Texture,
|
||||
openGL.IO,
|
||||
openGL.Primitive.indexed;
|
||||
|
||||
|
||||
package body openGL.Model.capsule.textured
|
||||
is
|
||||
---------
|
||||
--- Forge
|
||||
--
|
||||
|
||||
function new_Capsule (Radius : in Real;
|
||||
Height : in Real;
|
||||
Image : in asset_Name := null_Asset) return View
|
||||
is
|
||||
Self : constant View := new Item;
|
||||
begin
|
||||
Self.Radius := Radius;
|
||||
Self.Height := Height;
|
||||
Self.Image := Image;
|
||||
|
||||
return Self;
|
||||
end new_Capsule;
|
||||
|
||||
|
||||
--------------
|
||||
--- Attributes
|
||||
--
|
||||
|
||||
overriding
|
||||
function to_GL_Geometries (Self : access Item; Textures : access Texture.name_Map_of_texture'Class;
|
||||
Fonts : in Font.font_id_Map_of_font) return Geometry.views
|
||||
is
|
||||
pragma unreferenced (Textures, Fonts);
|
||||
|
||||
use --Geometry,
|
||||
Geometry.textured,
|
||||
real_Functions;
|
||||
|
||||
Length : constant Real := Self.Height;
|
||||
Radius : constant Real := Self.Radius;
|
||||
|
||||
quality_Level : constant Index_t := 4;
|
||||
sides_Count : constant Index_t := Index_t (quality_Level * 4); -- Number of sides to the cylinder (divisible by 4):
|
||||
|
||||
type Edge is -- A 'shaft' edge.
|
||||
record
|
||||
Fore : Site;
|
||||
Aft : Site;
|
||||
end record;
|
||||
|
||||
type Edges is array (Index_t range 1 .. sides_Count) of Edge;
|
||||
type arch_Edges is array (Index_t range 1 .. quality_Level) of Sites (1 .. sides_Count);
|
||||
|
||||
tmp,
|
||||
nx, ny, nz,
|
||||
start_nx,
|
||||
start_ny : Real;
|
||||
a : constant Real := Pi * 2.0 / Real (sides_Count);
|
||||
ca : constant Real := Cos (a);
|
||||
sa : constant Real := Sin (a);
|
||||
L : constant Real := Length * 0.5;
|
||||
|
||||
the_Edges : Edges;
|
||||
|
||||
the_shaft_Geometry : constant Geometry.textured.view
|
||||
:= Geometry.textured.new_Geometry;
|
||||
|
||||
cap_1_Geometry : Geometry.textured.view;
|
||||
cap_2_Geometry : Geometry.textured.view;
|
||||
|
||||
begin
|
||||
-- Define capsule shaft,
|
||||
--
|
||||
declare
|
||||
vertex_Count : constant Index_t := Index_t (sides_Count * 2 + 2); -- 2 triangles per side plus 2 since we cannot share the first and last edge.
|
||||
indices_Count : constant long_Index_t := long_Index_t (sides_Count * 2 * 3); -- 2 triangles per side with 3 vertices per triangle.
|
||||
|
||||
the_Vertices : aliased Geometry.textured.Vertex_array := (1 .. vertex_Count => <>);
|
||||
the_Indices : aliased Indices := (1 .. indices_Count => <>);
|
||||
|
||||
begin
|
||||
ny := 1.0;
|
||||
nz := 0.0; -- Normal vector = (0.0, ny, nz)
|
||||
|
||||
-- Set vertices.
|
||||
--
|
||||
declare
|
||||
S : Real := 0.0;
|
||||
S_delta : constant Real := 1.0 / Real (sides_Count);
|
||||
|
||||
i : Index_t := 1;
|
||||
begin
|
||||
for Each in 1 .. Index_t (Edges'Length)
|
||||
loop
|
||||
the_Edges (Each).Fore (1) := ny * Radius;
|
||||
the_Edges (Each).Fore (2) := nz * Radius;
|
||||
the_Edges (Each).Fore (3) := L;
|
||||
|
||||
the_Edges (Each).Aft (1) := ny * Radius;
|
||||
the_Edges (Each).Aft (2) := nz * Radius;
|
||||
the_Edges (Each).Aft (3) := -L;
|
||||
|
||||
-- Rotate ny, nz.
|
||||
--
|
||||
tmp := ca * ny - sa * nz;
|
||||
nz := sa * ny + ca * nz;
|
||||
ny := tmp;
|
||||
|
||||
the_Vertices (i).Site := the_Edges (Each).Fore;
|
||||
the_Vertices (i).Coords := (s => S,
|
||||
t => 1.0);
|
||||
i := i + 1;
|
||||
|
||||
the_Vertices (i).Site := the_Edges (Each).Aft;
|
||||
the_Vertices (i).Coords := (s => S,
|
||||
t => 0.0);
|
||||
i := i + 1;
|
||||
|
||||
S := S + S_delta;
|
||||
end loop;
|
||||
|
||||
the_Vertices (i).Site := the_Edges (1).Fore;
|
||||
the_Vertices (i).Coords := (s => S,
|
||||
t => 1.0);
|
||||
i := i + 1;
|
||||
|
||||
the_Vertices (i).Site := the_Edges (1).Aft;
|
||||
the_Vertices (i).Coords := (s => S,
|
||||
t => 0.0);
|
||||
end;
|
||||
|
||||
-- Set indices.
|
||||
--
|
||||
declare
|
||||
i : long_Index_t := 1;
|
||||
Start : Index_t := 1;
|
||||
begin
|
||||
for Each in 1 .. long_Index_t (sides_Count)
|
||||
loop
|
||||
the_Indices (i) := Start; i := i + 1;
|
||||
the_Indices (i) := Start + 1; i := i + 1;
|
||||
the_Indices (i) := Start + 2; i := i + 1;
|
||||
|
||||
the_Indices (i) := Start + 1; i := i + 1;
|
||||
the_Indices (i) := Start + 3; i := i + 1;
|
||||
the_Indices (i) := Start + 2; i := i + 1;
|
||||
|
||||
Start := Start + 2;
|
||||
end loop;
|
||||
end;
|
||||
|
||||
if Self.Image /= null_Asset
|
||||
then
|
||||
set_Texture:
|
||||
declare
|
||||
use Texture;
|
||||
the_Image : constant Image := IO.to_Image (Self.Image);
|
||||
the_Texture : constant Texture.object := Forge.to_Texture (the_Image);
|
||||
begin
|
||||
the_shaft_Geometry.Texture_is (the_Texture);
|
||||
end set_Texture;
|
||||
end if;
|
||||
|
||||
Vertices_are (the_shaft_Geometry.all, the_Vertices);
|
||||
|
||||
declare
|
||||
the_Primitive : constant Primitive.indexed.view
|
||||
:= Primitive.indexed.new_Primitive (primitive.Triangles,
|
||||
the_Indices);
|
||||
begin
|
||||
the_shaft_Geometry.add (Primitive.view (the_Primitive));
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
declare
|
||||
function new_Cap (is_Fore : Boolean) return Geometry.textured.view
|
||||
is
|
||||
cap_Geometry : constant Geometry.textured.view
|
||||
:= Geometry.textured.new_Geometry;
|
||||
|
||||
hoop_Count : constant Index_t := quality_Level;
|
||||
vertex_Count : constant Index_t := Index_t (Edges'Length * hoop_Count + 1); -- A vertex for each edge of each hoop, + 1 for the pole.
|
||||
indices_Count : constant long_Index_t := long_Index_t ( (hoop_count - 1) * sides_Count * 2 * 3 -- For each hoop, 2 triangles per side with 3 vertices per triangle
|
||||
+ sides_Count * 3); -- plus the extra indices for the pole triangles.
|
||||
|
||||
the_Vertices : aliased Geometry.textured.Vertex_array := (1 .. vertex_Count => <>);
|
||||
the_Indices : aliased Indices := (1 .. indices_Count => <>);
|
||||
|
||||
the_arch_Edges : arch_Edges;
|
||||
i : Index_t := 1;
|
||||
|
||||
pole_Site : constant Site := (if is_Fore then (0.0, 0.0, L + Radius)
|
||||
else (0.0, 0.0, -L - Radius));
|
||||
|
||||
Degrees_90 : constant := Pi / 2.0;
|
||||
Degrees_360 : constant := Pi * 2.0;
|
||||
|
||||
latitude_Count : constant := hoop_Count + 1;
|
||||
longitude_Count : constant := Edges'Length;
|
||||
|
||||
latitude_Spacing : constant Real := Degrees_90 / Real (latitude_Count - 1);
|
||||
longitude_Spacing : constant Real := Degrees_360 / Real (longitude_Count);
|
||||
|
||||
a, b : Real := 0.0; -- Angular 'cursors' used to track lat/long for texture coords.
|
||||
begin
|
||||
if not is_Fore
|
||||
then
|
||||
a := Degrees_360;
|
||||
end if;
|
||||
|
||||
-- Set the vertices.
|
||||
--
|
||||
start_nx := 0.0;
|
||||
start_ny := 1.0;
|
||||
|
||||
for each_Hoop in 1 .. quality_Level
|
||||
loop
|
||||
-- Get n=start_n.
|
||||
--
|
||||
nx := start_nx;
|
||||
ny := start_ny;
|
||||
nz := 0.0;
|
||||
|
||||
for Each in 1 .. sides_Count
|
||||
loop
|
||||
the_arch_Edges (each_Hoop) (Each) (1) := ny * Radius;
|
||||
the_arch_Edges (each_Hoop) (Each) (2) := nz * Radius;
|
||||
the_arch_Edges (each_Hoop) (Each) (3) := (if is_Fore then nx * Radius + L
|
||||
else nx * Radius - L);
|
||||
-- Rotate ny, nz.
|
||||
--
|
||||
tmp := ca * ny - sa * nz;
|
||||
nz := sa * ny + ca * nz;
|
||||
ny := tmp;
|
||||
|
||||
the_Vertices (i).Site := the_arch_Edges (each_Hoop) (Each);
|
||||
the_Vertices (i).Coords := (s => a / Degrees_360,
|
||||
t => b / Degrees_90);
|
||||
i := i + 1;
|
||||
a := (if is_Fore then a + longitude_Spacing
|
||||
else a - longitude_Spacing);
|
||||
end loop;
|
||||
|
||||
declare
|
||||
tmp : constant Real := start_nx;
|
||||
begin
|
||||
if is_Fore
|
||||
then
|
||||
start_nx := ca * start_nx + sa * start_ny;
|
||||
start_ny := -sa * tmp + ca * start_ny;
|
||||
else
|
||||
start_nx := ca * start_nx - sa * start_ny;
|
||||
start_ny := sa * tmp + ca * start_ny;
|
||||
end if;
|
||||
end;
|
||||
|
||||
a := (if is_Fore then 0.0
|
||||
else Degrees_360);
|
||||
b := b + latitude_Spacing;
|
||||
end loop;
|
||||
|
||||
-- Add pole vertex.
|
||||
--
|
||||
the_Vertices (i).Site := pole_Site;
|
||||
the_Vertices (i).Coords := (s => 0.5,
|
||||
t => 1.0);
|
||||
-- Set indices.
|
||||
--
|
||||
declare
|
||||
i : long_Index_t := 1;
|
||||
Start : Index_t := 1;
|
||||
hoop_Start : Index_t := 1;
|
||||
pole_Index : constant Index_t := vertex_Count;
|
||||
|
||||
begin
|
||||
for each_Hoop in 1 .. quality_Level
|
||||
loop
|
||||
for Each in 1 .. sides_Count
|
||||
loop
|
||||
declare
|
||||
function next_hoop_Vertex return Index_t
|
||||
is
|
||||
begin
|
||||
if Each = sides_Count then return hoop_Start;
|
||||
else return Start + 1;
|
||||
end if;
|
||||
end next_hoop_Vertex;
|
||||
begin
|
||||
if each_Hoop = quality_Level
|
||||
then
|
||||
if is_Fore
|
||||
then
|
||||
the_Indices (i) := Start; i := i + 1;
|
||||
the_Indices (i) := next_hoop_Vertex; i := i + 1;
|
||||
the_Indices (i) := pole_Index; i := i + 1;
|
||||
else
|
||||
the_Indices (i) := Start; i := i + 1;
|
||||
the_Indices (i) := pole_Index; i := i + 1;
|
||||
the_Indices (i) := next_hoop_Vertex; i := i + 1;
|
||||
end if;
|
||||
else
|
||||
declare
|
||||
v1 : constant Index_t := Start;
|
||||
v2 : constant Index_t := next_hoop_Vertex;
|
||||
v3 : constant Index_t := v1 + sides_Count;
|
||||
v4 : constant Index_t := v2 + sides_Count;
|
||||
begin
|
||||
if is_Fore
|
||||
then
|
||||
the_Indices (i) := v1; i := i + 1;
|
||||
the_Indices (i) := v2; i := i + 1;
|
||||
the_Indices (i) := v3; i := i + 1;
|
||||
|
||||
the_Indices (i) := v2; i := i + 1;
|
||||
the_Indices (i) := v4; i := i + 1;
|
||||
the_Indices (i) := v3; i := i + 1;
|
||||
else
|
||||
the_Indices (i) := v1; i := i + 1;
|
||||
the_Indices (i) := v3; i := i + 1;
|
||||
the_Indices (i) := v2; i := i + 1;
|
||||
|
||||
the_Indices (i) := v2; i := i + 1;
|
||||
the_Indices (i) := v3; i := i + 1;
|
||||
the_Indices (i) := v4; i := i + 1;
|
||||
end if;
|
||||
end;
|
||||
end if;
|
||||
|
||||
Start := Start + 1;
|
||||
end;
|
||||
end loop;
|
||||
|
||||
hoop_Start := hoop_Start + sides_Count;
|
||||
end loop;
|
||||
|
||||
if Self.Image /= null_Asset
|
||||
then
|
||||
set_the_Texture:
|
||||
declare
|
||||
use Texture;
|
||||
the_Image : constant Image := IO.to_Image (Self.Image);
|
||||
the_Texture : constant Texture.object := Forge.to_Texture (the_Image);
|
||||
begin
|
||||
cap_Geometry.Texture_is (the_Texture);
|
||||
end set_the_Texture;
|
||||
end if;
|
||||
|
||||
Vertices_are (cap_Geometry.all, the_Vertices);
|
||||
|
||||
declare
|
||||
the_Primitive : constant Primitive.indexed.view
|
||||
:= Primitive.indexed.new_Primitive (Primitive.Triangles,
|
||||
the_Indices);
|
||||
begin
|
||||
cap_Geometry.add (Primitive.view (the_Primitive));
|
||||
end;
|
||||
end;
|
||||
|
||||
return cap_Geometry;
|
||||
end new_Cap;
|
||||
|
||||
begin
|
||||
cap_1_Geometry := new_Cap (is_Fore => True);
|
||||
cap_2_Geometry := new_Cap (is_Fore => False);
|
||||
end;
|
||||
|
||||
return (1 => the_shaft_Geometry.all'Access,
|
||||
2 => cap_1_Geometry.all'Access,
|
||||
3 => cap_2_Geometry.all'Access);
|
||||
end to_GL_Geometries;
|
||||
|
||||
|
||||
end openGL.Model.capsule.textured;
|
||||
@@ -0,0 +1,42 @@
|
||||
with
|
||||
openGL.Geometry;
|
||||
|
||||
|
||||
package openGL.Model.capsule.textured
|
||||
--
|
||||
-- Models a lit and textured capsule.
|
||||
--
|
||||
is
|
||||
type Item is new Model.capsule.item with private;
|
||||
type View is access all Item'Class;
|
||||
|
||||
|
||||
---------
|
||||
--- Forge
|
||||
--
|
||||
|
||||
function new_Capsule (Radius : in Real;
|
||||
Height : in Real;
|
||||
Image : in asset_Name := null_Asset) return View;
|
||||
|
||||
--------------
|
||||
--- Attributes
|
||||
--
|
||||
|
||||
overriding
|
||||
function to_GL_Geometries (Self : access Item; Textures : access Texture.name_Map_of_texture'Class;
|
||||
Fonts : in Font.font_id_Map_of_font) return Geometry.views;
|
||||
|
||||
|
||||
|
||||
private
|
||||
|
||||
type Item is new Model.capsule.item with
|
||||
record
|
||||
Radius : Real;
|
||||
Height : Real;
|
||||
|
||||
Image : asset_Name := null_Asset;
|
||||
end record;
|
||||
|
||||
end openGL.Model.capsule.textured;
|
||||
9
3-mid/opengl/source/lean/model/opengl-model-capsule.ads
Normal file
9
3-mid/opengl/source/lean/model/opengl-model-capsule.ads
Normal file
@@ -0,0 +1,9 @@
|
||||
package openGL.Model.capsule
|
||||
--
|
||||
-- Provides an abstract base class for capsule models.
|
||||
--
|
||||
is
|
||||
|
||||
type Item is abstract new openGL.Model.item with null record;
|
||||
|
||||
end openGL.Model.capsule;
|
||||
172
3-mid/opengl/source/lean/model/opengl-model-grid.adb
Normal file
172
3-mid/opengl/source/lean/model/opengl-model-grid.adb
Normal file
@@ -0,0 +1,172 @@
|
||||
with
|
||||
openGL.Palette,
|
||||
openGL.Primitive.non_indexed;
|
||||
|
||||
|
||||
package body openGL.Model.grid
|
||||
is
|
||||
|
||||
function Line_Count (Extent : in Positive) return Positive
|
||||
is
|
||||
begin
|
||||
if Extent mod 2 /= 0
|
||||
then
|
||||
return Extent;
|
||||
else
|
||||
return Extent + 1;
|
||||
end if;
|
||||
end Line_Count;
|
||||
|
||||
|
||||
---------
|
||||
--- Forge
|
||||
--
|
||||
|
||||
function to_grid_Model (Color : openGL.Color;
|
||||
Width : Integer;
|
||||
Height : Integer) return Item
|
||||
is
|
||||
Self : Item;
|
||||
|
||||
vertex_Count : constant Positive := ( line_Count (Width)
|
||||
+ line_Count (Height)) * 2;
|
||||
|
||||
half_Width : constant Real := Real (Width) / 2.0;
|
||||
half_Height : constant Real := Real (Height) / 2.0;
|
||||
begin
|
||||
Self.Color := +Color;
|
||||
Self.Width := Width;
|
||||
Self.Height := Height;
|
||||
Self.Bounds := (Ball => <>,
|
||||
Box => (lower => [-half_Width, -half_Height, -0.01],
|
||||
upper => [ half_Width, half_Height, 0.01]));
|
||||
set_Ball_from_Box (Self.Bounds);
|
||||
|
||||
Self.Vertices := new Geometry.colored.Vertex_array (1 .. Index_t (vertex_Count));
|
||||
|
||||
return Self;
|
||||
end to_grid_Model;
|
||||
|
||||
|
||||
function new_grid_Model (Color : openGL.Color;
|
||||
Width : Integer;
|
||||
Height : Integer) return View
|
||||
is
|
||||
begin
|
||||
return new Item' (to_grid_Model (Color, Width, Height));
|
||||
end new_grid_Model;
|
||||
|
||||
|
||||
|
||||
--------------
|
||||
--- Attributes
|
||||
--
|
||||
|
||||
overriding
|
||||
function to_GL_Geometries (Self : access Item; Textures : access Texture.name_Map_of_texture'Class;
|
||||
Fonts : in Font.font_id_Map_of_font) return Geometry.views
|
||||
is
|
||||
pragma unreferenced (Textures, Fonts);
|
||||
|
||||
use Palette,
|
||||
Geometry.colored;
|
||||
|
||||
the_Primitive : Primitive.non_indexed.view;
|
||||
|
||||
begin
|
||||
if Self.Geometry = null
|
||||
then
|
||||
Self.Geometry := Geometry.colored.new_Geometry;
|
||||
end if;
|
||||
|
||||
set_Sites :
|
||||
declare
|
||||
row_Count : constant Positive := line_Count (Self.Height);
|
||||
col_Count : constant Positive := line_Count (Self.Width);
|
||||
vertex_Count : Index_t := 0;
|
||||
|
||||
half_Width : constant Real := Real (Self.Width) / 2.0;
|
||||
half_Height : constant Real := Real (Self.Height) / 2.0;
|
||||
|
||||
x_Adjust,
|
||||
y_Adjust : Real;
|
||||
|
||||
Color : openGL.rgb_Color := Self.Color;
|
||||
|
||||
begin
|
||||
if Self.Width mod 2 = 0
|
||||
then x_Adjust := 0.0;
|
||||
else x_Adjust := 0.5;
|
||||
end if;
|
||||
|
||||
if Self.Height mod 2 = 0
|
||||
then y_Adjust := 0.0;
|
||||
else y_Adjust := 0.5;
|
||||
end if;
|
||||
|
||||
for Row in 1 .. row_Count
|
||||
loop
|
||||
if Row = row_Count / 2 + 1
|
||||
then
|
||||
Color := +White;
|
||||
end if;
|
||||
|
||||
vertex_Count := vertex_Count + 1;
|
||||
Self.Vertices (vertex_Count).Site := [-half_Width,
|
||||
Real (Row - 1) - half_Height + y_Adjust,
|
||||
0.16];
|
||||
Self.Vertices (vertex_Count).Color := (primary => Color,
|
||||
Alpha => opaque_Value);
|
||||
|
||||
vertex_Count := vertex_Count + 1;
|
||||
Self.Vertices (vertex_Count).Site := [half_Width,
|
||||
Real (Row - 1) - half_Height + y_Adjust,
|
||||
0.16];
|
||||
Self.Vertices (vertex_Count).Color := (primary => Color,
|
||||
Alpha => opaque_Value);
|
||||
if Row = row_Count / 2 + 1
|
||||
then
|
||||
Color := Self.Color;
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
for Col in 1 .. col_Count
|
||||
loop
|
||||
if Col = col_Count / 2 + 1
|
||||
then
|
||||
Color := +White;
|
||||
end if;
|
||||
|
||||
vertex_Count := vertex_Count + 1;
|
||||
Self.Vertices (vertex_Count).Site := [Real (Col - 1) - half_Width + x_Adjust,
|
||||
-half_Height,
|
||||
0.16];
|
||||
Self.Vertices (vertex_Count).Color := (primary => Color,
|
||||
Alpha => opaque_Value);
|
||||
|
||||
vertex_Count := vertex_Count + 1;
|
||||
Self.Vertices (vertex_Count).Site := [Real (Col - 1) - half_Width + x_Adjust,
|
||||
half_Height,
|
||||
0.16];
|
||||
Self.Vertices (vertex_Count).Color := (primary => Color,
|
||||
Alpha => opaque_Value);
|
||||
if Col = col_Count / 2 + 1
|
||||
then
|
||||
Color := Self.Color;
|
||||
end if;
|
||||
end loop;
|
||||
end set_Sites;
|
||||
|
||||
Self.Geometry.is_Transparent (False);
|
||||
Vertices_are (Self.Geometry.all,
|
||||
Self.Vertices.all);
|
||||
|
||||
the_Primitive := Primitive.non_indexed.new_Primitive (openGL.primitive.Lines,
|
||||
Self.Vertices'Length);
|
||||
Self.Geometry.add (Primitive.view (the_Primitive));
|
||||
|
||||
return [1 => Self.Geometry.all'Access];
|
||||
end to_GL_Geometries;
|
||||
|
||||
|
||||
end openGL.Model.grid;
|
||||
43
3-mid/opengl/source/lean/model/opengl-model-grid.ads
Normal file
43
3-mid/opengl/source/lean/model/opengl-model-grid.ads
Normal file
@@ -0,0 +1,43 @@
|
||||
with
|
||||
openGL.Geometry.colored;
|
||||
|
||||
|
||||
package openGL.Model.grid
|
||||
--
|
||||
-- Models a grid.
|
||||
--
|
||||
-- TODO: Rename to 'line_Grid'.
|
||||
is
|
||||
type Item is new Model.item with private;
|
||||
type View is access all Item'Class;
|
||||
|
||||
|
||||
---------
|
||||
--- Forge
|
||||
--
|
||||
|
||||
function new_grid_Model (Color : openGL.Color;
|
||||
Width : Integer;
|
||||
Height : Integer) return View;
|
||||
|
||||
--------------
|
||||
--- Attributes
|
||||
--
|
||||
|
||||
overriding
|
||||
function to_GL_Geometries (Self : access Item; Textures : access Texture.name_Map_of_texture'Class;
|
||||
Fonts : in Font.font_id_Map_of_font) return Geometry.views;
|
||||
|
||||
|
||||
private
|
||||
|
||||
type Item is new Model.item with
|
||||
record
|
||||
Color : openGL.rgb_Color;
|
||||
Vertices : openGL.Geometry.colored.Vertex_array_view;
|
||||
Geometry : openGL.Geometry.colored.view;
|
||||
Width,
|
||||
Height : Positive;
|
||||
end record;
|
||||
|
||||
end openGL.Model.grid;
|
||||
552
3-mid/opengl/source/lean/model/opengl-model-hex_grid.adb
Normal file
552
3-mid/opengl/source/lean/model/opengl-model-hex_grid.adb
Normal file
@@ -0,0 +1,552 @@
|
||||
with
|
||||
openGL.Geometry.colored,
|
||||
openGL.Primitive.indexed,
|
||||
|
||||
float_Math.Geometry.d2.Hexagon,
|
||||
|
||||
ada.Containers.hashed_Maps,
|
||||
ada.unchecked_Deallocation;
|
||||
|
||||
|
||||
package body openGL.Model.hex_grid
|
||||
is
|
||||
--------
|
||||
-- Forge
|
||||
--
|
||||
|
||||
function new_Grid (heights_Asset : in asset_Name;
|
||||
Heights : in height_Map_view;
|
||||
Color : in lucid_Color := (palette.White,
|
||||
Opaque)) return View
|
||||
is
|
||||
the_Model : constant View := new Item' (Model.item with
|
||||
heights_Asset => heights_Asset,
|
||||
Heights => Heights,
|
||||
Color => +Color);
|
||||
begin
|
||||
the_Model.set_Bounds;
|
||||
return the_Model;
|
||||
end new_Grid;
|
||||
|
||||
|
||||
|
||||
overriding
|
||||
procedure destroy (Self : in out Item)
|
||||
is
|
||||
procedure deallocate is new ada.unchecked_Deallocation (height_Map,
|
||||
height_Map_view);
|
||||
begin
|
||||
destroy (Model.item (Self));
|
||||
deallocate (Self.Heights);
|
||||
end destroy;
|
||||
|
||||
|
||||
|
||||
-------------
|
||||
-- Attributes
|
||||
--
|
||||
|
||||
package hexagon_Geometry renames Geometry_2d.Hexagon;
|
||||
|
||||
|
||||
-- site_Map_of_vertex_Id
|
||||
--
|
||||
|
||||
function Hash (From : in Geometry_2d.Site) return ada.Containers.Hash_type
|
||||
is
|
||||
use ada.Containers;
|
||||
|
||||
type Fix is delta 0.00_1 range 0.0 .. 1000.0;
|
||||
|
||||
cell_Size : constant Fix := 0.5;
|
||||
grid_Width : constant := 10;
|
||||
begin
|
||||
return Hash_type (Fix (From (1)) / cell_Size)
|
||||
+ Hash_type (Fix (From (2)) / cell_Size) * grid_Width;
|
||||
end Hash;
|
||||
|
||||
|
||||
|
||||
function Equivalent (S1, S2 : Geometry_2d.Site) return Boolean
|
||||
is
|
||||
Tolerance : constant := 0.1;
|
||||
begin
|
||||
return abs (S2 (1) - S1 (1)) < Tolerance
|
||||
and abs (S2 (2) - S1 (2)) < Tolerance;
|
||||
end Equivalent;
|
||||
|
||||
|
||||
|
||||
type Coordinates_array is array (Index_t range <>) of hexagon_Geometry.Coordinates;
|
||||
|
||||
type hex_Vertex is
|
||||
record
|
||||
shared_Hexes : Coordinates_array (1 .. 3);
|
||||
shared_Count : Index_t := 0;
|
||||
|
||||
Site : Geometry_3d.Site;
|
||||
end record;
|
||||
|
||||
type hex_Vertices is array (Index_t range <>) of hex_Vertex;
|
||||
|
||||
|
||||
|
||||
package site_Maps_of_vertex_Id is new ada.Containers.hashed_Maps (Key_type => Geometry_2d.Site,
|
||||
Element_type => Index_t,
|
||||
Hash => Hash,
|
||||
equivalent_Keys => Equivalent,
|
||||
"=" => "=");
|
||||
|
||||
overriding
|
||||
function to_GL_Geometries (Self : access Item; Textures : access Texture.name_Map_of_texture'Class;
|
||||
Fonts : in Font.font_id_Map_of_font) return Geometry.views
|
||||
is
|
||||
pragma Unreferenced (Textures, Fonts);
|
||||
|
||||
use Geometry,
|
||||
Geometry.colored,
|
||||
Geometry_2d;
|
||||
|
||||
site_Map_of_vertex_Id : site_Maps_of_vertex_Id.Map;
|
||||
next_free_vertex_Id : Index_t := 0;
|
||||
|
||||
|
||||
function fetch_Id (S : in geometry_2d.Site) return Index_t
|
||||
is
|
||||
use site_Maps_of_vertex_Id;
|
||||
C : constant Cursor := site_Map_of_vertex_Id.Find (S);
|
||||
begin
|
||||
if has_Element (C)
|
||||
then
|
||||
return Element (C);
|
||||
else
|
||||
next_free_vertex_Id := @ + 1;
|
||||
site_Map_of_vertex_Id.insert (S, next_free_vertex_Id);
|
||||
|
||||
return next_free_vertex_Id;
|
||||
end if;
|
||||
end fetch_Id;
|
||||
|
||||
|
||||
Heights : height_Map_view renames Self.Heights;
|
||||
|
||||
row_Count : constant Index_t := Heights'Length (1);
|
||||
col_Count : constant Index_t := Heights'Length (2);
|
||||
|
||||
the_Grid : constant hexagon_Geometry.Grid := Hexagon.to_Grid (Rows => Positive (row_Count),
|
||||
Cols => Positive (col_Count),
|
||||
circumRadius => 1.0);
|
||||
zigzag_Count : constant Index_t := col_Count + 1;
|
||||
|
||||
first_zigzag_vertex_Count : constant Index_t := row_Count * 2 + 1;
|
||||
mid_zigzag_vertex_Count : constant Index_t := row_Count * 2 + 2;
|
||||
last_zigzag_vertex_Count : constant Index_t := row_Count * 2 + 1;
|
||||
|
||||
zigzags_vertex_Count : constant Index_t := first_zigzag_vertex_Count
|
||||
+ (mid_zigzag_vertex_Count) * (zigzag_Count - 2)
|
||||
+ last_zigzag_vertex_Count;
|
||||
zigzag_joiner_vertex_Count : constant Index_t := col_Count * 2;
|
||||
|
||||
|
||||
vertex_Count : constant Index_t := zigzags_vertex_Count
|
||||
+ zigzag_joiner_vertex_Count;
|
||||
|
||||
hex_Vertices : hex_Grid.hex_Vertices (1 .. zigzags_vertex_Count);
|
||||
|
||||
zigzags_indices_Count : constant long_Index_t := long_Index_t (vertex_Count);
|
||||
|
||||
gl_Vertices : aliased Geometry.colored.Vertex_array (1 .. vertex_Count);
|
||||
|
||||
hex_Count : constant long_Index_t := long_Index_t (col_Count * row_Count * 2);
|
||||
|
||||
zigzags_Indices : aliased Indices (1 .. zigzags_indices_Count);
|
||||
tops_Indices : aliased Indices (1 .. hex_Count
|
||||
+ long_Index_t (col_Count * 2));
|
||||
|
||||
zigzags_Geometry : constant Geometry.colored.view := Geometry.colored.new_Geometry;
|
||||
tops_Geometry : constant Geometry.colored.view := Geometry.colored.new_Geometry;
|
||||
|
||||
|
||||
min_Site : Site := [Real'Last, Real'Last, Real'Last];
|
||||
max_Site : Site := [Real'First, Real'First, Real'First];
|
||||
|
||||
begin
|
||||
|
||||
find_shared_Hexes_per_Vertex:
|
||||
begin
|
||||
for Row in 1 .. row_Count
|
||||
loop
|
||||
|
||||
for Col in 1 .. col_Count
|
||||
loop
|
||||
|
||||
for Which in hexagon_Geometry.vertex_Id
|
||||
loop
|
||||
declare
|
||||
use hexagon_Geometry;
|
||||
Site : constant Geometry_2d.Site := vertex_Site (the_Grid,
|
||||
hex_Id => [Positive (Row),
|
||||
Positive (Col)],
|
||||
Which => Which);
|
||||
|
||||
vertex_Id : constant Index_t := fetch_Id (S => Site);
|
||||
the_Vertex : hex_Vertex renames hex_Vertices (vertex_Id);
|
||||
C : constant Index_t := the_Vertex.shared_Count + 1;
|
||||
begin
|
||||
the_Vertex.shared_Count := C;
|
||||
the_Vertex.shared_Hexes (C) := [Positive (Row),
|
||||
Positive (Col)];
|
||||
the_Vertex.Site := [Site (1),
|
||||
0.0,
|
||||
Site (2)];
|
||||
end;
|
||||
end loop;
|
||||
|
||||
end loop;
|
||||
|
||||
end loop;
|
||||
end find_shared_Hexes_per_Vertex;
|
||||
|
||||
|
||||
set_Height_for_each_Vertex:
|
||||
begin
|
||||
for Row in 1 .. row_Count
|
||||
loop
|
||||
|
||||
for Col in 1 .. col_Count
|
||||
loop
|
||||
|
||||
for Which in hexagon_Geometry.vertex_Id
|
||||
loop
|
||||
declare
|
||||
use hexagon_Geometry;
|
||||
Site : constant Geometry_2d.Site := vertex_Site (the_Grid,
|
||||
hex_Id => [Positive (Row),
|
||||
Positive (Col)],
|
||||
Which => Which);
|
||||
Height : Real := 0.0;
|
||||
vertex_Id : constant Index_t := fetch_Id (S => Site);
|
||||
the_Vertex : hex_Vertex renames hex_Vertices (vertex_Id);
|
||||
begin
|
||||
for Each in 1 .. the_Vertex.shared_Count
|
||||
loop
|
||||
Height := Height + Heights (Row, Col);
|
||||
end loop;
|
||||
|
||||
Height := Height / Real (the_Vertex.shared_Count);
|
||||
the_Vertex.Site := [Site (1),
|
||||
Height,
|
||||
Site (2)];
|
||||
|
||||
min_Site := [Real'Min (min_Site (1), the_Vertex.Site (1)),
|
||||
Real'Min (min_Site (2), the_Vertex.Site (2)),
|
||||
Real'Min (min_Site (3), the_Vertex.Site (3))];
|
||||
|
||||
max_Site := [Real'Max (min_Site (1), the_Vertex.Site (1)),
|
||||
Real'Max (min_Site (2), the_Vertex.Site (2)),
|
||||
Real'Max (min_Site (3), the_Vertex.Site (3))];
|
||||
end;
|
||||
end loop;
|
||||
|
||||
end loop;
|
||||
|
||||
end loop;
|
||||
end set_Height_for_each_Vertex;
|
||||
|
||||
|
||||
set_GL_Vertices:
|
||||
declare
|
||||
Center : constant Site := [(max_Site (1) - min_Site (1)) / 2.0,
|
||||
(max_Site (2) - min_Site (2)) / 2.0,
|
||||
(max_Site (3) - min_Site (3)) / 2.0];
|
||||
|
||||
vertex_Id : Index_t := 0;
|
||||
Color : constant rgba_Color := Self.Color;
|
||||
begin
|
||||
--- Add hex vertices.
|
||||
--
|
||||
for i in hex_Vertices'Range
|
||||
loop
|
||||
vertex_Id := vertex_Id + 1;
|
||||
|
||||
gl_Vertices (vertex_Id).Site := hex_Vertices (vertex_Id).Site - Center;
|
||||
gl_Vertices (vertex_Id).Color := Color;
|
||||
end loop;
|
||||
|
||||
--- Add joiner vertices.
|
||||
--
|
||||
for i in 1 .. col_Count
|
||||
loop
|
||||
declare
|
||||
use hexagon_Geometry;
|
||||
|
||||
Site : Geometry_2d.Site := vertex_Site (the_Grid,
|
||||
hex_Id => [Row => Positive (row_Count),
|
||||
Col => Positive (i)],
|
||||
Which => 3);
|
||||
hex_vertex_Id : Index_t := fetch_Id (Site);
|
||||
begin
|
||||
vertex_Id := vertex_Id + 1;
|
||||
gl_Vertices (vertex_Id) := (Site => hex_Vertices (hex_vertex_Id).Site - Center,
|
||||
Color => (Primary => Color.Primary,
|
||||
Alpha => 0));
|
||||
|
||||
Site := vertex_Site (the_Grid,
|
||||
hex_Id => [Row => 1,
|
||||
Col => Positive (i)],
|
||||
Which => 6);
|
||||
|
||||
hex_vertex_Id := fetch_Id (Site);
|
||||
vertex_Id := vertex_Id + 1;
|
||||
gl_Vertices (vertex_Id) := (Site => hex_Vertices (hex_vertex_Id).Site - Center,
|
||||
Color => (Primary => Color.Primary,
|
||||
Alpha => 0));
|
||||
end;
|
||||
end loop;
|
||||
end set_GL_Vertices;
|
||||
|
||||
|
||||
set_zigzags_GL_Indices:
|
||||
declare
|
||||
Cursor : long_Index_t := 0;
|
||||
joiners_vertex_Id : Index_t := zigzags_vertex_Count;
|
||||
|
||||
|
||||
procedure add_zigzag_Vertex (Row, Col : in Positive;
|
||||
hex_Vertex : in Hexagon.vertex_Id)
|
||||
is
|
||||
use hexagon_Geometry;
|
||||
|
||||
Site : constant Geometry_2d.Site := vertex_Site (the_Grid,
|
||||
hex_Id => [Row, Col],
|
||||
Which => hex_Vertex);
|
||||
begin
|
||||
Cursor := Cursor + 1;
|
||||
zigzags_Indices (Cursor) := fetch_Id (S => Site);
|
||||
end add_zigzag_Vertex;
|
||||
|
||||
|
||||
procedure add_joiner_vertex_Pair
|
||||
is
|
||||
begin
|
||||
Cursor := Cursor + 1;
|
||||
joiners_vertex_Id := joiners_vertex_Id + 1;
|
||||
zigzags_Indices (Cursor) := joiners_vertex_Id;
|
||||
|
||||
Cursor := Cursor + 1;
|
||||
joiners_vertex_Id := joiners_vertex_Id + 1;
|
||||
zigzags_Indices (Cursor) := joiners_vertex_Id;
|
||||
end add_joiner_vertex_Pair;
|
||||
|
||||
|
||||
begin
|
||||
--- Fist zigzag
|
||||
--
|
||||
add_zigzag_Vertex (Row => 1, Col => 1, hex_Vertex => 5);
|
||||
|
||||
for Row in 1 .. Positive (row_Count)
|
||||
loop
|
||||
add_zigzag_Vertex (Row, Col => 1, hex_Vertex => 4);
|
||||
add_zigzag_Vertex (Row, Col => 1, hex_Vertex => 3);
|
||||
end loop;
|
||||
|
||||
add_joiner_vertex_Pair;
|
||||
|
||||
|
||||
--- Middles zigzags
|
||||
--
|
||||
|
||||
for zz in 2 .. Positive (zigzag_Count) - 1
|
||||
loop
|
||||
declare
|
||||
odd_Zigzag : constant Boolean := zz mod 2 = 1;
|
||||
begin
|
||||
if odd_Zigzag
|
||||
then
|
||||
add_zigzag_Vertex (Row => 1, Col => Positive (zz), hex_Vertex => 5);
|
||||
|
||||
else -- Even zigzag.
|
||||
add_zigzag_Vertex (Row => 1, Col => Positive (zz - 1), hex_Vertex => 6);
|
||||
end if;
|
||||
|
||||
|
||||
for Row in 1 .. Positive (row_Count)
|
||||
loop
|
||||
if odd_Zigzag
|
||||
then
|
||||
add_zigzag_Vertex (Row, Col => zz, hex_Vertex => 4);
|
||||
add_zigzag_Vertex (Row, Col => zz, hex_Vertex => 3);
|
||||
|
||||
if Row = Positive (row_Count) -- Last row.
|
||||
then
|
||||
add_zigzag_Vertex (Row, Col => zz - 1, hex_Vertex => 2);
|
||||
end if;
|
||||
|
||||
else -- Even zigzag.
|
||||
add_zigzag_Vertex (Row, Col => zz, hex_Vertex => 5);
|
||||
add_zigzag_Vertex (Row, Col => zz, hex_Vertex => 4);
|
||||
|
||||
if Row = Positive (row_Count) -- Last row.
|
||||
then
|
||||
add_zigzag_Vertex (Row, Col => zz, hex_Vertex => 3);
|
||||
end if;
|
||||
end if;
|
||||
end loop;
|
||||
end;
|
||||
|
||||
add_joiner_vertex_Pair;
|
||||
end loop;
|
||||
|
||||
|
||||
--- Last zigzag
|
||||
--
|
||||
add_zigzag_Vertex (Row => 1, Col => Positive (col_Count), hex_Vertex => 6);
|
||||
|
||||
for Row in 1 .. Positive (row_Count)
|
||||
loop
|
||||
add_zigzag_Vertex (Row, Positive (col_Count), hex_Vertex => 1);
|
||||
add_zigzag_Vertex (Row, Positive (col_Count), hex_Vertex => 2);
|
||||
end loop;
|
||||
|
||||
end set_zigzags_GL_Indices;
|
||||
|
||||
|
||||
zigzags_Geometry.is_Transparent (False);
|
||||
zigzags_Geometry.Vertices_are (gl_Vertices);
|
||||
|
||||
|
||||
set_tops_GL_Indices:
|
||||
declare
|
||||
Cursor : long_Index_t := 0;
|
||||
begin
|
||||
for Col in 1 .. col_Count
|
||||
loop
|
||||
for Row in 1 .. row_Count
|
||||
loop
|
||||
declare
|
||||
use hexagon_Geometry;
|
||||
Site : Geometry_2d.Site := vertex_Site (the_Grid,
|
||||
hex_Id => [Positive (Row),
|
||||
Positive (Col)],
|
||||
Which => 5);
|
||||
begin
|
||||
Cursor := Cursor + 1;
|
||||
tops_Indices (Cursor) := fetch_Id (Site);
|
||||
|
||||
Site := vertex_Site (the_Grid,
|
||||
hex_Id => [Positive (Row),
|
||||
Positive (Col)],
|
||||
Which => 6);
|
||||
|
||||
Cursor := Cursor + 1;
|
||||
tops_Indices (Cursor) := fetch_Id (Site);
|
||||
|
||||
if Row = row_Count -- Last row, so do bottoms.
|
||||
then
|
||||
Site := vertex_Site (the_Grid,
|
||||
hex_Id => [Positive (Row),
|
||||
Positive (Col)],
|
||||
Which => 3);
|
||||
|
||||
Cursor := Cursor + 1;
|
||||
tops_Indices (Cursor) := fetch_Id (Site);
|
||||
|
||||
Site := vertex_Site (the_Grid,
|
||||
hex_Id => [Positive (Row),
|
||||
Positive (Col)],
|
||||
Which => 2);
|
||||
|
||||
Cursor := Cursor + 1;
|
||||
tops_Indices (Cursor) := fetch_Id (Site);
|
||||
end if;
|
||||
end;
|
||||
end loop;
|
||||
end loop;
|
||||
end set_tops_GL_Indices;
|
||||
|
||||
|
||||
tops_Geometry.is_Transparent (False);
|
||||
tops_Geometry.Vertices_are (gl_Vertices);
|
||||
|
||||
|
||||
add_zigzag_Geometry:
|
||||
declare
|
||||
the_Primitive : constant Primitive.indexed.view
|
||||
:= Primitive.indexed.new_Primitive (Primitive.line_Strip,
|
||||
zigzags_Indices);
|
||||
begin
|
||||
zigzags_Geometry.add (Primitive.view (the_Primitive));
|
||||
end add_zigzag_Geometry;
|
||||
|
||||
|
||||
add_tops_Geometry:
|
||||
declare
|
||||
the_Primitive : constant Primitive.indexed.view
|
||||
:= Primitive.indexed.new_Primitive (Primitive.Lines,
|
||||
tops_Indices);
|
||||
begin
|
||||
tops_Geometry.add (Primitive.view (the_Primitive));
|
||||
end add_tops_Geometry;
|
||||
|
||||
|
||||
return [1 => Geometry.view (zigzags_Geometry),
|
||||
2 => Geometry.view ( tops_Geometry)];
|
||||
end to_GL_Geometries;
|
||||
|
||||
|
||||
|
||||
-- TODO: This is an approximation based on a rectangular grid.
|
||||
-- Do a correct calculation based on the hexagon grid vertices.
|
||||
--
|
||||
overriding
|
||||
procedure set_Bounds (Self : in out Item)
|
||||
is
|
||||
Heights : height_Map_view renames Self.Heights;
|
||||
|
||||
row_Count : constant Index_t := Heights'Length (1) - 1;
|
||||
col_Count : constant Index_t := Heights'Length (2) - 1;
|
||||
|
||||
vertex_Count : constant Index_t := Heights'Length (1) * Heights'Length (2);
|
||||
|
||||
the_Sites : aliased Sites (1 .. vertex_Count);
|
||||
|
||||
the_Bounds : openGL.Bounds := null_Bounds;
|
||||
|
||||
begin
|
||||
set_Sites:
|
||||
declare
|
||||
vert_Id : Index_t := 0;
|
||||
the_height_Range : constant Vector_2 := height_Extent (Heights.all);
|
||||
Middle : constant Real := (the_height_Range (1) + the_height_Range (2))
|
||||
/ 2.0;
|
||||
begin
|
||||
for Row in 1 .. row_Count + 1
|
||||
loop
|
||||
for Col in 1 .. col_Count + 1
|
||||
loop
|
||||
vert_Id := vert_Id + 1;
|
||||
the_Sites (vert_Id) := [Real (Col) - Real (col_Count) / 2.0 - 1.0,
|
||||
Heights (Row, Col) - Middle,
|
||||
Real (Row) - Real (row_Count) / 2.0 - 1.0];
|
||||
|
||||
the_Bounds.Box.Lower (1) := Real'Min (the_Bounds.Box.Lower (1), the_Sites (vert_Id) (1));
|
||||
the_Bounds.Box.Lower (2) := Real'Min (the_Bounds.Box.Lower (2), the_Sites (vert_Id) (2));
|
||||
the_Bounds.Box.Lower (3) := Real'Min (the_Bounds.Box.Lower (3), the_Sites (vert_Id) (3));
|
||||
|
||||
the_Bounds.Box.Upper (1) := Real'Max (the_Bounds.Box.Upper (1), the_Sites (vert_Id) (1));
|
||||
the_Bounds.Box.Upper (2) := Real'Max (the_Bounds.Box.Upper (2), the_Sites (vert_Id) (2));
|
||||
the_Bounds.Box.Upper (3) := Real'Max (the_Bounds.Box.Upper (3), the_Sites (vert_Id) (3));
|
||||
|
||||
the_Bounds.Ball := Real'Max (the_Bounds.Ball,
|
||||
abs (the_Sites (vert_Id)));
|
||||
end loop;
|
||||
end loop;
|
||||
|
||||
the_Bounds.Ball := the_Bounds.Ball * 1.1; -- TODO: Why the '* 1.1' ?
|
||||
end set_Sites;
|
||||
|
||||
Self.Bounds := the_Bounds;
|
||||
end set_Bounds;
|
||||
|
||||
|
||||
end openGL.Model.hex_grid;
|
||||
53
3-mid/opengl/source/lean/model/opengl-model-hex_grid.ads
Normal file
53
3-mid/opengl/source/lean/model/opengl-model-hex_grid.ads
Normal file
@@ -0,0 +1,53 @@
|
||||
with
|
||||
openGL.Geometry,
|
||||
openGL.Palette;
|
||||
|
||||
|
||||
package openGL.Model.hex_grid
|
||||
--
|
||||
-- Models a regular hexagon grid.
|
||||
--
|
||||
is
|
||||
type Item is new Model.item with private;
|
||||
type View is access all Item'Class;
|
||||
|
||||
|
||||
type height_Map_view is access all height_Map;
|
||||
|
||||
|
||||
---------
|
||||
--- Forge
|
||||
--
|
||||
|
||||
function new_Grid (heights_Asset : in asset_Name;
|
||||
Heights : in height_Map_view;
|
||||
Color : in lucid_Color := (palette.White,
|
||||
Opaque)) return View;
|
||||
overriding
|
||||
procedure destroy (Self : in out Item);
|
||||
|
||||
|
||||
--------------
|
||||
--- Attributes
|
||||
--
|
||||
|
||||
overriding
|
||||
function to_GL_Geometries (Self : access Item; Textures : access Texture.name_Map_of_texture'Class;
|
||||
Fonts : in Font.font_id_Map_of_font) return Geometry.views;
|
||||
|
||||
|
||||
private
|
||||
|
||||
type Item is new Model.item with
|
||||
record
|
||||
heights_Asset : asset_Name := null_Asset;
|
||||
Heights : height_Map_view;
|
||||
Color : rgba_Color;
|
||||
end record;
|
||||
|
||||
|
||||
overriding
|
||||
procedure set_Bounds (Self : in out Item);
|
||||
|
||||
|
||||
end openGL.Model.hex_grid;
|
||||
@@ -0,0 +1,79 @@
|
||||
with
|
||||
openGL.Geometry.lit_colored,
|
||||
openGL.Primitive.indexed;
|
||||
|
||||
|
||||
package body openGL.Model.hexagon.lit_colored
|
||||
is
|
||||
---------
|
||||
--- Forge
|
||||
--
|
||||
|
||||
function new_Hexagon (Radius : in Real;
|
||||
Face : in lit_colored.Face) return View
|
||||
is
|
||||
Self : constant View := new Item;
|
||||
begin
|
||||
Self.Radius := Radius;
|
||||
Self.Face := Face;
|
||||
|
||||
return Self;
|
||||
end new_Hexagon;
|
||||
|
||||
|
||||
--------------
|
||||
--- Attributes
|
||||
--
|
||||
|
||||
overriding
|
||||
function to_GL_Geometries (Self : access Item; Textures : access Texture.name_Map_of_texture'Class;
|
||||
Fonts : in Font.font_id_Map_of_font) return Geometry.views
|
||||
is
|
||||
pragma unreferenced (Textures, Fonts);
|
||||
|
||||
use Geometry.lit_colored;
|
||||
|
||||
the_Sites : constant hexagon.Sites := vertex_Sites (Self.Radius);
|
||||
the_Indices : aliased constant Indices := [1, 2, 3, 4, 5, 6, 7, 2];
|
||||
|
||||
|
||||
function new_Face (Vertices : in geometry.lit_colored.Vertex_array) return Geometry.lit_colored.view
|
||||
is
|
||||
use Primitive;
|
||||
|
||||
the_Geometry : constant Geometry.lit_colored.view
|
||||
:= Geometry.lit_colored.new_Geometry;
|
||||
|
||||
the_Primitive : constant Primitive.indexed.view
|
||||
:= Primitive.indexed.new_Primitive (triangle_Fan, the_Indices);
|
||||
begin
|
||||
the_Geometry.Vertices_are (Vertices);
|
||||
the_Geometry.add (Primitive.view (the_Primitive));
|
||||
|
||||
return the_Geometry;
|
||||
end new_Face;
|
||||
|
||||
|
||||
upper_Face : Geometry.lit_colored.view;
|
||||
|
||||
begin
|
||||
-- Upper Face
|
||||
--
|
||||
declare
|
||||
the_Vertices : constant Geometry.lit_colored.Vertex_array
|
||||
:= [1 => (Site => [0.0, 0.0, 0.0], Normal => Normal, Color => +Self.Face.center_Color, Shine => default_Shine),
|
||||
2 => (Site => the_Sites (1), Normal => Normal, Color => +Self.Face.Colors (1), Shine => default_Shine),
|
||||
3 => (Site => the_Sites (2), Normal => Normal, Color => +Self.Face.Colors (2), Shine => default_Shine),
|
||||
4 => (Site => the_Sites (3), Normal => Normal, Color => +Self.Face.Colors (3), Shine => default_Shine),
|
||||
5 => (Site => the_Sites (4), Normal => Normal, Color => +Self.Face.Colors (4), Shine => default_Shine),
|
||||
6 => (Site => the_Sites (5), Normal => Normal, Color => +Self.Face.Colors (5), Shine => default_Shine),
|
||||
7 => (Site => the_Sites (6), Normal => Normal, Color => +Self.Face.Colors (6), Shine => default_Shine)];
|
||||
begin
|
||||
upper_Face := new_Face (Vertices => the_Vertices);
|
||||
end;
|
||||
|
||||
return [1 => upper_Face.all'Access];
|
||||
end to_GL_Geometries;
|
||||
|
||||
|
||||
end openGL.Model.hexagon.lit_colored;
|
||||
@@ -0,0 +1,45 @@
|
||||
with
|
||||
openGL.Geometry,
|
||||
openGL.Texture;
|
||||
|
||||
|
||||
package openGL.Model.hexagon.lit_colored
|
||||
--
|
||||
-- Models a lit and colored hexagon.
|
||||
--
|
||||
is
|
||||
type Item is new Model.item with private;
|
||||
type View is access all Item'Class;
|
||||
|
||||
type Face is
|
||||
record
|
||||
center_Color : lucid_Color; -- The color at the center of the hex.
|
||||
Colors : lucid_Colors (1 .. 6); -- The color at each of the hexes 6 vertices.
|
||||
end record;
|
||||
|
||||
|
||||
---------
|
||||
--- Forge
|
||||
--
|
||||
|
||||
function new_Hexagon (Radius : in Real;
|
||||
Face : in lit_colored.Face) return View;
|
||||
|
||||
|
||||
--------------
|
||||
--- Attributes
|
||||
--
|
||||
|
||||
overriding
|
||||
function to_GL_Geometries (Self : access Item; Textures : access Texture.name_Map_of_texture'Class;
|
||||
Fonts : in Font.font_id_Map_of_font) return Geometry.views;
|
||||
|
||||
|
||||
private
|
||||
|
||||
type Item is new Model.hexagon.item with
|
||||
record
|
||||
Face : lit_colored.Face;
|
||||
end record;
|
||||
|
||||
end openGL.Model.hexagon.lit_colored;
|
||||
@@ -0,0 +1,89 @@
|
||||
with
|
||||
openGL.Geometry.lit_colored_textured,
|
||||
openGL.Primitive.indexed;
|
||||
|
||||
|
||||
package body openGL.Model.hexagon.lit_colored_textured
|
||||
is
|
||||
|
||||
type Geometry_view is access all Geometry.lit_colored_textured.item'Class;
|
||||
|
||||
|
||||
---------
|
||||
--- Forge
|
||||
--
|
||||
|
||||
function new_Hexagon (Radius : in Real;
|
||||
Face : in lit_colored_textured.Face) return View
|
||||
is
|
||||
Self : constant View := new Item;
|
||||
begin
|
||||
Self.Radius := Radius;
|
||||
Self.Face := Face;
|
||||
|
||||
return Self;
|
||||
end new_Hexagon;
|
||||
|
||||
|
||||
--------------
|
||||
--- Attributes
|
||||
--
|
||||
|
||||
overriding
|
||||
function to_GL_Geometries (Self : access Item; Textures : access Texture.name_Map_of_texture'Class;
|
||||
Fonts : in Font.font_id_Map_of_font) return Geometry.views
|
||||
is
|
||||
pragma unreferenced (Textures, Fonts);
|
||||
|
||||
use Geometry.lit_colored_textured,
|
||||
Texture;
|
||||
|
||||
the_Sites : constant hexagon.Sites := vertex_Sites (Self.Radius);
|
||||
the_Indices : aliased constant Indices := (1, 2, 3, 4, 5, 6, 7, 2);
|
||||
|
||||
|
||||
function new_Face (Vertices : in geometry.lit_colored_textured.Vertex_array) return Geometry_view
|
||||
is
|
||||
use Primitive;
|
||||
|
||||
the_Geometry : constant Geometry_view
|
||||
:= Geometry.lit_colored_textured.new_Geometry (texture_is_Alpha => False);
|
||||
|
||||
the_Primitive : constant Primitive.indexed.view
|
||||
:= Primitive.indexed.new_Primitive (triangle_Fan, the_Indices);
|
||||
begin
|
||||
the_Geometry.Vertices_are (Vertices);
|
||||
the_Geometry.add (Primitive.view (the_Primitive));
|
||||
|
||||
return the_Geometry;
|
||||
end new_Face;
|
||||
|
||||
|
||||
upper_Face : Geometry_view;
|
||||
|
||||
begin
|
||||
-- Upper Face
|
||||
--
|
||||
declare
|
||||
the_Vertices : constant Geometry.lit_colored_textured.Vertex_array
|
||||
:= (1 => (Site => (0.0, 0.0, 0.0), Normal => Normal, Color => +Self.Face.center_Color, Coords => (0.0, 0.0), Shine => default_Shine),
|
||||
2 => (Site => the_Sites (1), Normal => Normal, Color => +Self.Face.Colors (1), Coords => (0.0, 0.0), Shine => default_Shine),
|
||||
3 => (Site => the_Sites (2), Normal => Normal, Color => +Self.Face.Colors (2), Coords => (1.0, 0.0), Shine => default_Shine),
|
||||
4 => (Site => the_Sites (3), Normal => Normal, Color => +Self.Face.Colors (3), Coords => (1.0, 1.0), Shine => default_Shine),
|
||||
5 => (Site => the_Sites (4), Normal => Normal, Color => +Self.Face.Colors (4), Coords => (0.0, 1.0), Shine => default_Shine),
|
||||
6 => (Site => the_Sites (5), Normal => Normal, color => +Self.Face.Colors (5), Coords => (0.0, 1.0), Shine => default_Shine),
|
||||
7 => (Site => the_Sites (6), Normal => Normal, Color => +Self.Face.Colors (6), Coords => (0.0, 1.0), Shine => default_Shine));
|
||||
begin
|
||||
upper_Face := new_Face (Vertices => the_Vertices);
|
||||
|
||||
if Self.Face.Texture /= null_Object
|
||||
then
|
||||
upper_Face.Texture_is (Self.Face.Texture);
|
||||
end if;
|
||||
end;
|
||||
|
||||
return (1 => upper_Face.all'Access);
|
||||
end to_GL_Geometries;
|
||||
|
||||
|
||||
end openGL.Model.hexagon.lit_colored_textured;
|
||||
@@ -0,0 +1,46 @@
|
||||
with
|
||||
openGL.Geometry,
|
||||
openGL.Texture;
|
||||
|
||||
|
||||
package openGL.Model.hexagon.lit_colored_textured
|
||||
--
|
||||
-- Models a lit, colored and textured hexagon.
|
||||
--
|
||||
is
|
||||
type Item is new Model.item with private;
|
||||
type View is access all Item'Class;
|
||||
|
||||
type Face is
|
||||
record
|
||||
center_Color : lucid_Color; -- The color at the center of the hex.
|
||||
Colors : lucid_Colors (1 .. 6); -- The color at each of the hexes 6 vertices.
|
||||
Texture : openGL.Texture.Object := openGL.Texture.null_Object; -- The texture to be applied to the hex..
|
||||
end record;
|
||||
|
||||
|
||||
---------
|
||||
--- Forge
|
||||
--
|
||||
|
||||
function new_Hexagon (Radius : in Real;
|
||||
Face : in lit_colored_textured.Face) return View;
|
||||
|
||||
|
||||
--------------
|
||||
--- Attributes
|
||||
--
|
||||
|
||||
overriding
|
||||
function to_GL_Geometries (Self : access Item; Textures : access Texture.name_Map_of_texture'Class;
|
||||
Fonts : in Font.font_id_Map_of_font) return Geometry.views;
|
||||
|
||||
|
||||
private
|
||||
|
||||
type Item is new Model.hexagon.item with
|
||||
record
|
||||
Face : lit_colored_textured.Face;
|
||||
end record;
|
||||
|
||||
end openGL.Model.hexagon.lit_colored_textured;
|
||||
@@ -0,0 +1,85 @@
|
||||
with
|
||||
openGL.Geometry.lit_textured,
|
||||
openGL.Primitive.indexed;
|
||||
|
||||
|
||||
package body openGL.Model.hexagon.lit_textured
|
||||
is
|
||||
---------
|
||||
--- Forge
|
||||
--
|
||||
|
||||
function new_Hexagon (Radius : in Real;
|
||||
Face : in lit_textured.Face) return View
|
||||
is
|
||||
Self : constant View := new Item;
|
||||
begin
|
||||
Self.Radius := Radius;
|
||||
Self.Face := Face;
|
||||
|
||||
return Self;
|
||||
end new_Hexagon;
|
||||
|
||||
|
||||
--------------
|
||||
--- Attributes
|
||||
--
|
||||
|
||||
overriding
|
||||
function to_GL_Geometries (Self : access Item; Textures : access Texture.name_Map_of_texture'Class;
|
||||
Fonts : in Font.font_id_Map_of_font) return Geometry.views
|
||||
is
|
||||
pragma unreferenced (Textures, Fonts);
|
||||
|
||||
use Geometry.lit_textured,
|
||||
Texture;
|
||||
|
||||
the_Sites : constant hexagon.Sites := vertex_Sites (Self.Radius);
|
||||
the_Indices : aliased constant Indices := (1, 2, 3, 4, 5, 6, 7, 2);
|
||||
|
||||
|
||||
function new_Face (Vertices : in geometry.lit_textured.Vertex_array) return Geometry.lit_textured.view
|
||||
is
|
||||
use Primitive;
|
||||
|
||||
the_Geometry : constant Geometry.lit_textured.view
|
||||
:= Geometry.lit_textured.new_Geometry;
|
||||
|
||||
the_Primitive : constant Primitive.indexed.view
|
||||
:= Primitive.indexed.new_Primitive (triangle_Fan, the_Indices);
|
||||
begin
|
||||
the_Geometry.Vertices_are (Vertices);
|
||||
the_Geometry.add (Primitive.view (the_Primitive));
|
||||
|
||||
return the_Geometry;
|
||||
end new_Face;
|
||||
|
||||
|
||||
upper_Face : Geometry.lit_textured.view;
|
||||
|
||||
begin
|
||||
-- Upper Face
|
||||
--
|
||||
declare
|
||||
the_Vertices : constant Geometry.lit_textured.Vertex_array
|
||||
:= (1 => (Site => (0.0, 0.0, 0.0), Normal => Normal, Coords => (0.0, 0.0), Shine => default_Shine),
|
||||
2 => (Site => the_Sites (1), Normal => Normal, Coords => (0.0, 0.0), Shine => default_Shine),
|
||||
3 => (Site => the_Sites (2), Normal => Normal, Coords => (1.0, 0.0), Shine => default_Shine),
|
||||
4 => (Site => the_Sites (3), Normal => Normal, Coords => (1.0, 1.0), Shine => default_Shine),
|
||||
5 => (Site => the_Sites (4), Normal => Normal, Coords => (0.0, 1.0), Shine => default_Shine),
|
||||
6 => (Site => the_Sites (5), Normal => Normal, Coords => (0.0, 1.0), Shine => default_Shine),
|
||||
7 => (Site => the_Sites (6), Normal => Normal, Coords => (0.0, 1.0), Shine => default_Shine));
|
||||
begin
|
||||
upper_Face := new_Face (Vertices => the_Vertices);
|
||||
|
||||
if Self.Face.Texture /= null_Object
|
||||
then
|
||||
upper_Face.Texture_is (Self.Face.Texture);
|
||||
end if;
|
||||
end;
|
||||
|
||||
return (1 => upper_Face.all'Access);
|
||||
end to_GL_Geometries;
|
||||
|
||||
|
||||
end openGL.Model.hexagon.lit_textured;
|
||||
@@ -0,0 +1,44 @@
|
||||
with
|
||||
openGL.Geometry,
|
||||
openGL.Texture;
|
||||
|
||||
|
||||
package openGL.Model.hexagon.lit_textured
|
||||
--
|
||||
-- Models a lit, colored and textured hexagon.
|
||||
--
|
||||
is
|
||||
type Item is new Model.item with private;
|
||||
type View is access all Item'Class;
|
||||
|
||||
type Face is
|
||||
record
|
||||
Texture : openGL.Texture.Object := openGL.Texture.null_Object; -- The texture to be applied to the hex.
|
||||
end record;
|
||||
|
||||
|
||||
---------
|
||||
--- Forge
|
||||
--
|
||||
|
||||
function new_Hexagon (Radius : in Real;
|
||||
Face : in lit_textured.Face) return View;
|
||||
|
||||
|
||||
--------------
|
||||
--- Attributes
|
||||
--
|
||||
|
||||
overriding
|
||||
function to_GL_Geometries (Self : access Item; Textures : access Texture.name_Map_of_texture'Class;
|
||||
Fonts : in Font.font_id_Map_of_font) return Geometry.views;
|
||||
|
||||
|
||||
private
|
||||
|
||||
type Item is new Model.hexagon.item with
|
||||
record
|
||||
Face : lit_textured.Face;
|
||||
end record;
|
||||
|
||||
end openGL.Model.hexagon.lit_textured;
|
||||
24
3-mid/opengl/source/lean/model/opengl-model-hexagon.adb
Normal file
24
3-mid/opengl/source/lean/model/opengl-model-hexagon.adb
Normal file
@@ -0,0 +1,24 @@
|
||||
package body openGL.Model.hexagon
|
||||
is
|
||||
|
||||
function vertex_Sites (Radius : in Real) return Sites
|
||||
is
|
||||
use linear_Algebra_3d;
|
||||
|
||||
the_Site : Vector_3 := [Radius, 0.0, 0.0];
|
||||
Rotation : constant Matrix_3x3 := y_Rotation_from (to_Radians (60.0));
|
||||
|
||||
the_Sites : Sites;
|
||||
|
||||
begin
|
||||
for i in the_Sites'Range
|
||||
loop
|
||||
the_Sites (i) := the_Site;
|
||||
the_Site := Rotation * the_Site;
|
||||
end loop;
|
||||
|
||||
return the_Sites;
|
||||
end vertex_Sites;
|
||||
|
||||
|
||||
end openGL.Model.hexagon;
|
||||
25
3-mid/opengl/source/lean/model/opengl-model-hexagon.ads
Normal file
25
3-mid/opengl/source/lean/model/opengl-model-hexagon.ads
Normal file
@@ -0,0 +1,25 @@
|
||||
package openGL.Model.hexagon
|
||||
--
|
||||
-- Provides an abstract model of a hexagon.
|
||||
--
|
||||
is
|
||||
type Item is abstract new Model.item with private;
|
||||
|
||||
|
||||
subtype site_Id is Integer range 1 .. 6;
|
||||
type Sites is array (site_Id) of Vector_3;
|
||||
|
||||
function vertex_Sites (Radius : in Real) return Sites;
|
||||
|
||||
|
||||
|
||||
private
|
||||
|
||||
type Item is abstract new Model.item with
|
||||
record
|
||||
Radius : Real := 1.0;
|
||||
end record;
|
||||
|
||||
Normal : constant Vector_3 := [0.0, 0.0, 1.0];
|
||||
|
||||
end openGL.Model.Hexagon;
|
||||
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue
Block a user