Add initial prototype.

This commit is contained in:
Rod Kay
2022-07-31 17:34:54 +10:00
commit 54a53b2ac0
1421 changed files with 358874 additions and 0 deletions

View File

@@ -0,0 +1,129 @@
with
openGL.Frustum;
package body openGL.Culler.frustum
is
---------
--- Forge
--
procedure define (Self : in out Item)
is
begin
Self.vanish_point_size_Min.Value_is (0.00_12);
end define;
--------------
--- Attributes
--
overriding
procedure add (Self : in out Item; the_Visual : in Visual.view)
is
begin
null;
end add;
overriding
procedure rid (Self : in out Item; the_Visual : in Visual.view)
is
begin
null;
end rid;
overriding
function object_Count (Self : in Item) return Natural
is
pragma unreferenced (Self);
begin
return 0;
end object_Count;
function vanish_point_size_Min (Self : in Item'Class) return Real
is
begin
return Self.vanish_point_size_Min.Value;
end vanish_point_size_Min;
procedure vanish_point_size_Min_is (Self : in out Item'Class; Now : in Real)
is
begin
Self.vanish_point_size_Min.Value_is (Now);
end vanish_point_size_Min_is;
overriding
function cull (Self : in Item; the_Visuals : in Visual.views;
camera_Frustum : in openGL.frustum.Plane_array;
camera_Site : in Vector_3) return Visual.views
is
visible_Objects : Visual.views (the_Visuals'Range);
Last : Natural := 0;
the_Object : Visual.view;
the_vanish_point_size_Min : constant Real := Self.vanish_point_size_Min.Value;
begin
-- Apply 'frustum' and 'apparent size' culling.
--
for i in the_Visuals'Range
loop
the_Object := the_Visuals (i);
declare
use openGL.Frustum,
Visual;
the_Size : constant Real := the_Object.Model.Bounds.Ball;
the_Distance : constant Real := abs (camera_Site - Site_of (the_Object.all));
apparent_Size : Real;
function is_visible_for_Plane (Which : in openGL.frustum.plane_Id) return Boolean
is
the_Site : Vector_3 renames Site_of (the_Object.all);
plane_Distance : constant Real := camera_Frustum (Which) (1) * the_Site (1)
+ camera_Frustum (Which) (2) * the_Site (2)
+ camera_Frustum (Which) (3) * the_Site (3)
+ camera_Frustum (Which) (4);
begin
return plane_Distance + the_Size > 0.0;
end is_visible_for_plane;
begin
if the_Distance /= 0.0 -- The visual is on same site as camera.
and the_Size /= 0.0 -- The visual bounds are known.
then
apparent_Size := the_Size / the_Distance;
else
apparent_Size := Real'Last;
end if;
if apparent_Size > the_vanish_point_size_Min
and is_visible_for_Plane (Left)
and is_visible_for_Plane (Right)
and is_visible_for_Plane (High)
and is_visible_for_Plane (Low)
then
Last := Last + 1;
visible_Objects (Last) := the_Object;
the_Object.apparent_Size_is (apparent_Size);
end if;
end;
end loop;
return visible_Objects (1 .. Last);
end cull;
end openGL.Culler.frustum;

View File

@@ -0,0 +1,55 @@
with
ada.unchecked_Conversion;
package openGL.Culler.frustum
--
-- Provides a frustrum culler.
--
is
type Item is new Culler.Item with private;
type View is access all Item'Class;
---------
--- Forge
--
procedure define (Self : in out Item);
--------------
--- Attributes
--
overriding
procedure add (Self : in out Item; the_Visual : in Visual.view);
overriding
procedure rid (Self : in out Item; the_Visual : in Visual.view);
overriding
function object_Count (Self : in Item) return Natural;
overriding
function cull (Self : in Item; the_Visuals : in Visual.views;
camera_Frustum : in openGL.frustum.Plane_array;
camera_Site : in Vector_3) return Visual.views;
function vanish_point_size_Min (Self : in Item'Class) return Real;
procedure vanish_point_size_Min_is (Self : in out Item'Class; Now : in Real);
--
-- Visuals whose projected size falls below this minimum will not be displayed.
private
type Item is new Culler.item with
record
countDown : Natural := 0;
frame_Count : Natural := 0;
vanish_point_size_Min : safe_Real;
end record;
end openGL.Culler.frustum;

View File

@@ -0,0 +1,17 @@
package body openGL.Culler
is
procedure Viewer_is (Self : in out Item'Class; Now : in Renderer.lean.view)
is
begin
Self.Viewer := Now.all'Access;
end Viewer_is;
function Viewer (Self : in Item'Class) return Renderer.lean.view
is
begin
return Self.Viewer;
end Viewer;
end openGL.Culler;

View File

@@ -0,0 +1,45 @@
with
openGL.Renderer.lean,
openGL.Visual,
openGL.Frustum;
package openGL.Culler
--
-- Provides a base class for cullers.
--
is
type Item is abstract tagged limited private;
type View is access all Item'Class;
--------------
--- Attributes
--
procedure add (Self : in out Item; the_Visual : in Visual.view) is abstract;
procedure rid (Self : in out Item; the_Visual : in Visual.view) is abstract;
function object_Count (Self : in Item) return Natural is abstract;
function Viewer (Self : in Item'Class) return Renderer.lean.view;
procedure Viewer_is (Self : in out Item'Class; Now : in Renderer.lean.view);
--------------
-- Operations
--
function cull (Self : in Item; the_Visuals : in Visual.views;
camera_Frustum : in frustum.Plane_array;
camera_Site : in Vector_3) return Visual.views
is abstract;
private
type Item is abstract tagged limited
record
Viewer : Renderer.lean.view;
end record;
end openGL.Culler;

View File

@@ -0,0 +1,109 @@
with
openGL.Camera,
openGL.Texture,
ada.unchecked_Deallocation;
package body openGL.Impostor.simple
is
procedure free (Self : in out View)
is
procedure deallocate is new ada.unchecked_Deallocation (Item'Class, View);
begin
if Self /= null
then
destroy (Self.all);
deallocate (Self);
end if;
end free;
overriding
function current_Camera_look_at_Rotation (Self : in Item) return Matrix_3x3
is
begin
return Self.current_Camera_look_at_Rotation;
end current_Camera_look_at_Rotation;
overriding
function update_Required (Self : access Item; the_Camera : access Camera.item'Class) return Boolean
is
use linear_Algebra_3d;
begin
-- Look directly at target so it will be rendered in the centre of the viewport.
--
Self.current_Camera_look_at_Rotation := get_Rotation (look_at (the_Camera.Site,
get_Translation (Self.Target.Transform),
-- get_Translation (Self.Target.model_Transform),
[0.0, 1.0, 0.0]));
Self.current_pixel_Region := Self.get_pixel_Region (camera_Spin => Self.current_Camera_look_at_Rotation,
camera_Site => the_Camera.Site,
camera_projection_Transform => the_Camera.projection_Transform,
camera_Viewport => the_Camera.Viewport);
declare
update_Required : Boolean := Self.general_Update_required (the_Camera.Site,
Self.current_pixel_Region);
begin
if not update_Required
and then Self.size_Update_required (Self.current_pixel_Region)
then
update_Required := True;
end if;
if Update_required
then
Self.current_Width_pixels := Self.current_pixel_Region.Width; -- Cache current state.
Self.current_Height_pixels := Self.current_pixel_Region.Height;
Self.current_copy_X := Self.current_pixel_Region.X;
Self.current_copy_Y := Self.current_pixel_Region.Y;
Self.current_copy_Width := Self.current_pixel_Region.Width;
Self.current_copy_Height := Self.current_pixel_Region.Height;
end if;
return update_Required;
end;
end update_Required;
overriding
procedure pre_update (Self : in out Item; the_Camera : access Camera.item'Class)
is
begin
Self.camera_world_Rotation_original := the_Camera.Spin;
the_Camera.Spin_is (Self.current_Camera_look_at_Rotation);
end pre_update;
overriding
procedure update (Self : in out Item; the_Camera : access Camera.item'Class;
texture_Pool : in Texture.Pool_view)
is
world_Rotation_original : constant Matrix_3x3 := the_Camera.Spin;
begin
the_Camera.Spin_is (Self.current_Camera_look_at_Rotation);
Impostor.item (Self).update (the_Camera, texture_Pool); -- Base class 'update'.
the_Camera.Spin_is (world_Rotation_original);
end update;
overriding
procedure post_update (Self : in out Item; the_Camera : access Camera.item'Class)
is
begin
the_Camera.Spin_is (Self.camera_world_Rotation_original);
end post_update;
end openGL.Impostor.simple;

View File

@@ -0,0 +1,37 @@
package openGL.Impostor.simple
--
-- Can impostor any 'visual'.
--
is
type Item is new Impostor.item with private;
type View is access all Item'Class;
overriding
function current_Camera_look_at_Rotation (Self : in Item) return Matrix_3x3;
overriding
function update_Required (Self : access Item; the_Camera : access Camera.item'Class) return Boolean;
overriding
procedure pre_update (Self : in out Item; the_Camera : access Camera.item'Class);
overriding
procedure update (Self : in out Item; the_Camera : access Camera.item'Class;
texture_Pool : in Texture.Pool_view);
overriding
procedure post_update (Self : in out Item; the_Camera : access Camera.item'Class);
procedure free (Self : in out View);
private
type Item is new Impostor.item with
record
current_Camera_look_at_Rotation : Matrix_3x3;
camera_world_Rotation_original : Matrix_3x3;
end record;
end openGL.Impostor.simple;

View File

@@ -0,0 +1,230 @@
with
openGL.Camera,
openGL.Texture,
ada.unchecked_Deallocation;
package body openGL.Impostor.terrain
is
overriding
procedure set_Target (Self : in out Item; Target : in openGL.Visual.view)
is
begin
set_Target (openGL.impostor.item (Self), Target); -- Base class call.
Self.expand_X := 0.02;
Self.expand_Y := 0.02;
end set_Target;
procedure free (Self : in out View)
is
procedure deallocate is new ada.unchecked_Deallocation (Item'Class, View);
begin
destroy (Self.all);
deallocate (Self);
end free;
overriding
function current_Camera_look_at_Rotation (Self : in Item) return Matrix_3x3
is
begin
return Self.current_Camera_look_at_Rotation;
end current_Camera_look_at_Rotation;
overriding
function update_Required (Self : access Item; the_Camera : access Camera.item'Class) return Boolean
is
begin
Self.current_pixel_Region := Self.get_pixel_Region (camera_Spin => the_Camera.Spin,
camera_Site => the_Camera.Site,
camera_projection_Transform => the_Camera.projection_Transform,
camera_Viewport => the_Camera.Viewport);
declare
use GL;
use type GL.glInt;
update_Required : Boolean := Self.general_Update_required (the_Camera.Site, Self.current_pixel_Region);
copy_x_Offset : gl.glInt := 0;
copy_y_Offset : gl.glInt := 0;
copy_X : gl.glInt := Self.current_pixel_Region.X;
copy_Y : gl.glInt := Self.current_pixel_Region.Y;
copy_Width : gl.glSizeI := Self.current_pixel_Region.Width;
copy_Height : gl.glSizeI := Self.current_pixel_Region.Height;
viewport_Width : constant Integer := the_Camera.Viewport.Max (1) - the_Camera.Viewport.Min (1) + 1;
viewport_Height : constant Integer := the_Camera.Viewport.Max (2) - the_Camera.Viewport.Min (2) + 1;
Complete_left : Boolean;
Complete_right : Boolean;
Complete_top : Boolean;
Complete_bottom : Boolean;
now_Complete : Boolean;
begin
if copy_X < 0
then
copy_x_Offset := -copy_X;
copy_X := 0;
copy_Width := copy_Width - glSizeI (copy_x_Offset);
Complete_left := False;
Complete_right := True;
if copy_Width < 1
then
Self.is_Valid := False;
return False; -- NB: Short circuit return !
end if;
elsif copy_X + glInt (copy_Width) > glInt (Viewport_Width)
then
copy_Width := glSizeI (viewport_Width) - glSizeI (copy_X);
Complete_left := True;
Complete_right := False;
if copy_Width < 1
then
Self.is_Valid := False;
return False; -- NB: Short circuit return !
end if;
else
Complete_left := True;
Complete_right := True;
end if;
if copy_Y < 0
then
copy_y_Offset := -copy_Y;
copy_Y := 0;
copy_Height := copy_Height - glSizeI (copy_y_Offset);
Complete_top := True;
Complete_bottom := False;
if copy_Height < 1
then
Self.is_Valid := False;
return False; -- NB: Short circuit return !
end if;
elsif copy_Y + glInt (copy_Height) > glInt (Viewport_Height)
then
copy_Height := glSizeI (viewport_Height) - glSizeI (copy_Y);
Complete_top := False;
Complete_bottom := True;
if copy_Height < 1
then
Self.is_Valid := False;
return False; -- NB: Short circuit return !
end if;
else
Complete_top := True;
Complete_bottom := True;
end if;
now_Complete := Complete_left
and Complete_right
and Complete_top
and Complete_bottom;
if not update_Required
then -- Only do further tests if update not already required.
if Self.prior_Complete
then
if now_Complete
and then Self.size_Update_required (Self.current_pixel_Region)
then
update_Required := True;
end if;
else
if copy_Width > Self.prior_copy_Width
then
update_Required := True;
end if;
if copy_Height > Self.prior_copy_Height
then
update_Required := True;
end if;
end if;
end if;
if update_Required
then
Self.current_Width_pixels := Self.current_pixel_Region.Width; -- Cache current state.
Self.current_Height_pixels := Self.current_pixel_Region.Height;
Self.current_copy_X_Offset := copy_X_Offset;
Self.current_copy_Y_Offset := copy_Y_Offset;
Self.current_copy_X := copy_X;
Self.current_copy_Y := copy_Y;
Self.current_copy_Width := copy_Width;
Self.current_copy_Height := copy_Height;
Self.current_Complete := now_Complete;
Self.prior_copy_Width := Self.current_copy_Width; -- Set prior state.
Self.prior_copy_Height := Self.current_copy_Height;
Self.prior_Complete := Self.current_Complete;
end if;
Self.is_Valid := True;
Self.current_Camera_look_at_Rotation := the_Camera.Spin;
return update_Required;
end;
end update_Required;
overriding
procedure pre_update (Self : in out Item; the_Camera : access Camera.item'Class)
is
pragma unreferenced (the_Camera);
begin
Self.expand_X := 0.0;
Self.expand_Y := 0.0;
end pre_update;
overriding
procedure update (Self : in out Item; the_Camera : access Camera.item'Class;
texture_Pool : in Texture.Pool_view)
is
begin
Self.expand_X := 0.0;
Self.expand_Y := 0.0;
Impostor.item (Self).update (the_Camera, texture_Pool); -- Base class 'update'.
end update;
overriding
procedure post_update (Self : in out Item; the_Camera : access Camera.item'Class)
is
begin
null;
end post_update;
end openGL.Impostor.terrain;

View File

@@ -0,0 +1,46 @@
package openGL.Impostor.terrain
--
-- Handles impostoring of terrain 'visuals', which has greater image precision needs, to help avoid border cracks.
--
is
type Item is new Impostor.item with private;
type View is access all Item'Class;
overriding
procedure set_Target (Self : in out Item; Target : in openGL.Visual.view);
overriding
function current_Camera_look_at_Rotation
(Self : in Item) return Matrix_3x3;
overriding
function update_Required (Self : access Item; the_Camera : access Camera.item'Class) return Boolean;
overriding
procedure update (Self : in out Item; the_Camera : access Camera.item'Class;
texture_Pool : in Texture.Pool_view);
overriding
procedure pre_update (Self : in out Item; the_Camera : access Camera.item'Class);
overriding
procedure post_update (Self : in out Item; the_Camera : access Camera.item'Class);
procedure free (Self : in out View);
private
type Item is new Impostor.item with
record
current_Complete : Boolean;
prior_copy_Width : gl.glSizeI := 0;
prior_copy_Height : gl.glSizeI := 0;
prior_Complete : Boolean := False;
current_Camera_look_at_Rotation : Matrix_3x3 := Identity_3x3;
end record;
end openGL.Impostor.terrain;

View File

@@ -0,0 +1,334 @@
with
openGL.Camera,
openGL.Model.billboard.textured,
ada.unchecked_Deallocation;
package body openGL.Impostor
is
---------
--- Forge
--
procedure destroy (Self : in out Item)
is
use openGL.Visual,
Model,
Texture;
the_Model : Model.view := Self.Visual.Model;
the_Texture : Texture.Object := Model.billboard.textured.view (the_Model).Texture;
begin
free (the_Texture);
free (the_Model);
free (Self.Visual);
end destroy;
procedure free (Self : in out View)
is
procedure deallocate is new ada.unchecked_Deallocation (Item'Class, View);
begin
if Self /= null then
destroy (Self.all);
deallocate (Self);
end if;
end free;
--------------
--- Attributes
--
procedure Visual_is (Self : in out Item; Now : in openGL.Visual.view)
is
begin
Self.Visual := Now;
end Visual_is;
function Visual (Self : access Item) return openGL.Visual.view
is
begin
return Self.Visual;
end Visual;
function get_Target (Self : in Item) return openGL.Visual.view
is
begin
return Self.Target;
end get_Target;
procedure set_Target (Self : in out Item; Target : in openGL.Visual.view)
is
use type openGL.Visual.view;
Width : constant Real := Target.Model.Bounds.Ball * 2.00;
Height : constant Real := Target.Model.Bounds.Ball * 2.00;
begin
if Self.Visual = null
then
Self.Visual := new openGL.Visual.item;
end if;
Self.Target := Target;
Self.is_Terrain := Target.is_Terrain;
Self.Visual.Model_is (Model.billboard.textured.Forge.new_Billboard (Size => (Width => Width,
Height => Height),
Plane => Model.billboard.xy,
Texture => null_Asset).all'Access);
Self.Visual.Transform_is (Target.Transform);
-- Self.Visual.model_Transform_is (Target.model_Transform);
end set_Target;
function target_camera_Distance (Self : in Item'Class) return Real
is
begin
return Self.target_camera_Distance;
end target_camera_Distance;
function is_Valid (Self : in Item'Class) return Boolean
is
begin
return Self.is_Valid;
end is_Valid;
function never_Updated (Self : in Item'Class) return Boolean
is
begin
return Self.never_Updated;
end never_Updated;
function frame_Count_since_last_update (Self : in Item'Class) return Natural
is
begin
return Natural (Self.freshen_Count);
end frame_Count_since_last_update;
function face_Count (Self : in Item) return Natural
is
pragma unreferenced (Self);
begin
return 1;
end face_Count;
procedure set_Alpha (Self : in out Item; Alpha : in Real)
is
begin
null; -- TODO
end set_Alpha;
function Bounds (Self : in Item) return openGL.Bounds
is
pragma Unreferenced (Self);
begin
return (others => <>); -- TODO
end Bounds;
pragma Unreferenced (Bounds);
function is_Transparent (Self : in Item) return Boolean
is
pragma unreferenced (Self);
begin
return True;
end is_Transparent;
-- Update trigger configuration.
--
procedure set_freshen_count_update_trigger_Mod (Self : in out Item; To : in Positive)
is
begin
Self.freshen_count_update_trigger_Mod := Counter (To);
end set_freshen_count_update_trigger_Mod;
function get_freshen_count_update_trigger_Mod (Self : in Item) return Positive
is
begin
return Positive (Self.freshen_count_update_trigger_Mod);
end get_freshen_count_update_trigger_Mod;
procedure set_size_update_trigger_Delta (Self : in out Item; To : in Positive)
is
begin
Self.size_update_trigger_Delta := gl.glSizeI (To);
end set_size_update_trigger_Delta;
function get_size_update_trigger_Delta (Self : in Item) return Positive
is
begin
return Positive (Self.size_update_trigger_Delta);
end get_size_update_trigger_Delta;
function general_Update_required (Self : access Item; the_Camera_Site : in Vector_3;
the_pixel_Region : in pixel_Region) return Boolean
is
pragma unreferenced (the_pixel_Region);
use linear_Algebra_3d;
use type gl.GLsizei;
Camera_has_moved : constant Boolean := the_Camera_Site /= Self.prior_camera_Position;
Target_has_moved : constant Boolean := get_Translation (Self.Target.Transform) /= Self.prior_target_Position;
-- Target_has_moved : constant Boolean := get_Translation (Self.Target.model_Transform) /= Self.prior_target_Position;
begin
Self.freshen_Count := Self.freshen_Count + 1;
if Self.freshen_Count > Self.freshen_count_update_trigger_Mod
then
return True;
end if;
if Camera_has_moved
and then abs (Angle (the_Camera_Site,
Self.prior_target_Position,
Self.prior_camera_Position)) > to_Radians (15.0)
then
return True;
end if;
if Target_has_moved
and then abs (Angle (get_Translation (Self.Target.Transform),
-- and then abs (Angle (get_Translation (Self.Target.model_Transform),
Self.prior_camera_Position,
Self.prior_target_Position)) > to_Radians (15.0)
then
return True;
end if;
if Self.prior_pixel_Region.Width > 40 -- Ignore target rotation triggered updates when target is small on screen.
and then Self.prior_pixel_Region.Height > 40 --
and then Self.prior_target_Rotation /= get_Rotation (Self.Target.Transform)
-- and then Self.prior_target_Rotation /= get_Rotation (Self.Target.model_Transform)
then
return True;
end if;
return False;
end general_Update_required;
function size_Update_required (Self : access Item; the_pixel_Region : in pixel_Region) return Boolean
is
use GL;
use type gl.GLsizei;
begin
return abs (the_pixel_Region.Width - Self.prior_Width_Pixels) > Self.size_update_trigger_Delta
or abs (the_pixel_Region.Height - Self.prior_Height_pixels) > Self.size_update_trigger_Delta;
end size_Update_required;
function get_pixel_Region (Self : access Item'Class; camera_Spin : in Matrix_3x3;
camera_Site : in Vector_3;
camera_projection_Transform : in Matrix_4x4;
camera_Viewport : in linear_Algebra_3d.Rectangle) return pixel_Region
is
use linear_Algebra_3D;
-- target_Centre : constant Vector_3 := camera_Spin * ( get_Translation (Self.Target.model_Transform)
target_Centre : constant Vector_3 := camera_Spin * ( get_Translation (Self.Target.Transform)
- camera_Site);
target_lower_Left : constant Vector_3 := target_Centre - [Self.Target.Model.Bounds.Ball,
Self.Target.Model.Bounds.Ball,
0.0];
target_Centre_proj : constant Vector_4 := target_Centre * camera_projection_Transform;
target_Lower_Left_proj : constant Vector_4 := target_lower_Left * camera_projection_Transform;
target_Centre_norm : constant Vector_3 := [target_Centre_proj (1) / target_Centre_proj (4),
target_Centre_proj (2) / target_Centre_proj (4),
target_Centre_proj (3) / target_Centre_proj (4)];
target_Lower_Left_norm : constant Vector_3 := [target_Lower_Left_proj (1) / target_Lower_Left_proj (4),
target_Lower_Left_proj (2) / target_Lower_Left_proj (4),
target_Lower_Left_proj (3) / target_Lower_Left_proj (4)];
target_Centre_norm_0to1 : constant Vector_3 := [target_Centre_norm (1) * 0.5 + 0.5,
target_Centre_norm (2) * 0.5 + 0.5,
target_Centre_norm (3) * 0.5 + 0.5];
target_Lower_Left_norm_0to1 : constant Vector_3 := [target_Lower_Left_norm (1) * 0.5 + 0.5,
target_Lower_Left_norm (2) * 0.5 + 0.5,
target_Lower_Left_norm (3) * 0.5 + 0.5];
viewport_Width : constant Integer := camera_Viewport.Max (1) - camera_Viewport.Min (1) + 1;
viewport_Height : constant Integer := camera_Viewport.Max (2) - camera_Viewport.Min (2) + 1;
Width : constant Real := 2.0 * Real (viewport_Width) * ( target_Centre_norm_0to1 (1)
- target_Lower_Left_norm_0to1 (1));
Width_pixels : constant gl.glSizei := gl.glSizei ( Integer (Real (viewport_Width) * target_Lower_Left_norm_0to1 (1) + Width)
- Integer (Real (viewport_Width) * target_Lower_Left_norm_0to1 (1))
+ 1);
Height : constant Real := 2.0 * Real (viewport_Height) * ( target_Centre_norm_0to1 (2)
- target_Lower_Left_norm_0to1 (2));
Height_pixels : constant gl.glSizei := gl.glSizei ( Integer (Real (viewport_Height) * target_Lower_Left_norm_0to1 (2) + Height)
- Integer (Real (viewport_Height) * target_Lower_Left_norm_0to1 (2))
+ 1);
use type gl.GLsizei;
begin
Self.all.target_camera_Distance := abs (target_Centre); -- NB: Cache distance from camera to target.
return (X => gl.glInt (target_Lower_Left_norm_0to1 (1) * Real (Viewport_Width)) - 0,
Y => gl.glInt (target_Lower_Left_norm_0to1 (2) * Real (viewport_Height)) - 0,
Width => Width_pixels + 0,
Height => Height_pixels + 0);
end get_pixel_Region;
--------------
-- Operations
--
procedure update (Self : in out Item; the_Camera : access Camera.item'Class;
texture_Pool : in texture.Pool_view)
is
pragma unreferenced (the_Camera, texture_Pool);
use openGL.Visual;
-- Width_size : constant openGL.texture.Size := to_Size (Natural (Self.current_Width_pixels));
-- Height_size : constant openGL.texture.Size := to_Size (Natural (Self.current_Height_pixels));
-- texture_Width : constant gl.glSizei := power_of_2_Ceiling (Natural (Self.current_Width_pixels ));
-- texture_Height : constant gl.glSizei := power_of_2_Ceiling (Natural (Self.current_Height_pixels));
the_Model : constant Model.billboard.textured.view := Model.billboard.textured.view (Self.Visual.Model);
-- GL_Error : Boolean;
begin
Self.Visual.all := Self.Target.all;
Self.Visual.Model_is (the_Model.all'Access);
end update;
end openGL.Impostor;

View File

@@ -0,0 +1,168 @@
with
openGL.Texture,
openGL.Visual;
limited
with
openGL.Camera;
package openGL.Impostor
--
-- Contains a 2D image of another openGL visual.
--
is
type Counter is mod 2**32;
type pixel_Region is
record
X, Y : gl.glInt;
Width, Height : gl.glSizeI;
end record;
type Item is abstract tagged -- TODO: Make private.
record
Target : openGL.Visual.view;
Visual : openGL.Visual.view;
freshen_Count : Counter := 0;
freshen_count_update_trigger_Mod : Counter := 150;
size_update_trigger_Delta : gl.glSizeI := 2;
expand_X, expand_Y : Real := 0.03;
never_Updated : Boolean := True;
is_Valid : Boolean := True; -- True when rendered target has both width and height > 0.
-- (NB: Always true for simple impostors.)
-- Current state.
--
current_pixel_Region : pixel_Region;
current_Width_pixels,
current_Height_pixels : gl.glSizei;
current_copy_X_Offset,
current_copy_Y_Offset : gl.glInt := 0;
current_copy_X,
current_copy_Y : gl.glInt;
current_copy_Width,
current_copy_Height : gl.glSizeI;
target_camera_Distance : Real;
target_camera_Distance_less_frame_Count : Real;
-- Prior state.
--
prior_pixel_Region : pixel_Region := (X => 0, Y => 0, Width => gl.glSizeI'First, Height => gl.glSizeI'First);
prior_Width_pixels : gl.glSizei := 0;
prior_Height_pixels : gl.glSizei := 0;
prior_target_Rotation : Matrix_3x3 := Identity_3x3;
prior_target_Position : Vector_3 := [0.0, 0.0, 0.0];
prior_camera_Position : Vector_3 := [1.0, 1.0, 1.0];
is_Terrain : Boolean := False;
end record;
type View is access all Item'Class;
type Views is array (Positive range <>) of View;
---------
--- Forge
--
procedure destroy (Self : in out Item);
procedure free (Self : in out View);
--------------
--- Attributes
--
procedure set_Target (Self : in out Item; Target : in Visual.view);
function get_Target (Self : in Item) return Visual.view;
procedure Visual_is (Self : in out Item; Now : in Visual.view);
function Visual (Self : access Item) return Visual.view;
function current_Camera_look_at_Rotation (Self : in Item) return Matrix_3x3
is abstract;
function update_Required (Self : access Item; the_Camera : access Camera.item'Class) return Boolean
is abstract;
--
-- NB: Caches current pixel_Region as a side-effect.
function is_Valid (Self : in Item'Class) return Boolean;
--
-- True when rendered target has width and height greater than 0.
function never_Updated (Self : in Item'Class) return Boolean;
--
-- True when 'update' has never been called for the impostor.
function frame_Count_since_last_update (Self : in Item'Class) return Natural;
function target_camera_Distance (Self : in Item'Class) return Real;
--
-- Returns the distance from the camera to the target, when 'update_required' was last called.
-- Update trigger configuration.
--
procedure set_freshen_count_update_trigger_Mod (Self : in out Item; To : in Positive);
function get_freshen_count_update_trigger_Mod (Self : in Item) return Positive;
--
-- Periodic freshen trigger.
procedure set_size_update_trigger_Delta (Self : in out Item; To : in Positive);
function get_size_update_trigger_Delta (Self : in Item) return Positive;
--
-- Update due to change in size of targets pixel rectangle.
-- Base class subprograms
--
function is_Transparent (Self : in Item) return Boolean;
procedure set_Alpha (Self : in out Item; Alpha : in Real);
function face_Count (Self : in Item) return Natural;
procedure pre_update (Self : in out Item; the_Camera : access Camera.item'Class)
is abstract;
procedure update (Self : in out Item; the_Camera : access Camera.item'Class;
texture_Pool : in texture.Pool_view);
--
-- Renders the impostor to a cleared framebuffer and copies the image to the impostors texture.
procedure post_update (Self : in out Item; the_Camera : access Camera.item'Class)
is abstract;
private
function get_pixel_Region (Self : access Item'Class; camera_Spin : in Matrix_3x3;
camera_Site : in Vector_3;
camera_projection_Transform : in Matrix_4x4;
camera_Viewport : in linear_Algebra_3d.Rectangle) return pixel_Region;
--
-- Calculate and return the smallest rectangular screen region which encloses the target, when rendered by the_Camera.
function general_Update_required (Self : access Item; the_Camera_Site : in Vector_3;
the_pixel_Region : in pixel_Region) return Boolean;
function size_Update_required (Self : access Item; the_pixel_Region : in pixel_Region) return Boolean;
end openGL.Impostor;

View File

@@ -0,0 +1,274 @@
with
openGL.Camera,
openGL.Impostor.simple,
openGL.Impostor.terrain,
ada.Containers.generic_Array_sort,
ada.unchecked_Deallocation;
package body openGL.Impostorer
is
---------
--- Forge
--
procedure define (Self : in out Item)
is
begin
Self.impostor_size_Min.Value_is (0.0625);
end define;
procedure destruct (Self : in out Item)
is
procedure deallocate is new ada.unchecked_Deallocation (impostor_load_Balancer.Slots,
impostor_load_Balancer.Slots_view);
begin
deallocate (Self.impostor_load_Slots);
declare
use Impostor,
visual_Maps_of_impostor;
the_Impostor : Impostor.view;
Cursor : visual_Maps_of_impostor.Cursor := Self.visual_Map_of_imposter.First;
begin
while has_Element (Cursor)
loop
the_Impostor := Element (Cursor);
Self.Renderer.free (the_Impostor);
next (Cursor);
end loop;
end;
end destruct;
--------------
--- Attributes
--
function impostor_Count (Self : in Item) return Natural
is
begin
return Natural (Self.visual_Map_of_imposter.Length);
end impostor_Count;
function impostor_size_Min (Self : in Item'Class) return Real
is
begin
return Self.impostor_size_Min.Value;
end impostor_size_Min;
procedure impostor_size_Min_is (Self : in out Item'Class; Now : in Real)
is
begin
Self.impostor_size_Min.Value_is (Now);
end impostor_size_Min_is;
function Camera (Self : in Item'Class) return access openGL.Camera.item'Class
is
begin
return Self.Camera;
end Camera;
procedure Camera_is (Self : in out Item'Class; Now : access openGL.Camera.item'Class)
is
begin
Self.Camera := Camera_view (Now);
end Camera_is;
function Renderer (Self : in Item'Class) return openGL.Renderer.lean.view
is
begin
return openGL.Renderer.lean.view (Self.Renderer);
end Renderer;
procedure Renderer_is (Self : in out Item'Class; Now : in openGL.Renderer.lean.view)
is
begin
Self.Renderer := Renderer_view (Now);
end Renderer_is;
--------------
-- Operations
--
procedure substitute (Self : in out Item; the_Visuals : in out openGL.Visual.views;
Camera : access openGL.Camera.item'Class)
is
begin
-- Find whether visual or imposter is used, for each object.
--
declare
transposed_camera_Attitude : constant Matrix_3x3 := Transpose (Camera.Spin);
Impostor_updates : openGL.Renderer.lean.impostor_Updates (1 .. 20_000);
impostor_updates_Last : Natural := 0;
procedure add (the_Impostor : in Impostor.view)
is
begin
impostor_updates_Last := impostor_updates_Last + 1;
Impostor_updates (impostor_updates_Last) := (Impostor => the_Impostor,
current_Width_pixels => the_Impostor.current_Width_pixels,
current_Height_pixels => the_Impostor.current_Height_pixels,
current_copy_x_Offset => the_Impostor.current_copy_X_Offset,
current_copy_y_Offset => the_Impostor.current_copy_Y_Offset,
current_copy_X => the_Impostor.current_copy_X,
current_copy_Y => the_Impostor.current_copy_Y,
current_copy_Width => the_Impostor.current_copy_Width,
current_copy_Height => the_Impostor.current_copy_Height,
current_Camera_look_at_Rotation => the_Impostor.current_Camera_look_at_Rotation);
the_Impostor.freshen_Count := 0;
the_Impostor.never_Updated := False;
end add;
the_impostor_size_Min : constant Real := Self.impostor_size_Min.Value;
begin
for Each in Self.impostor_load_Slots'Range
loop
Self.impostor_load_Slots (Each).impostors_Count := 0; -- Empty each slot's contents.
end loop;
for i in the_Visuals'Range
loop
declare
the_Visual : Visual .view renames the_Visuals (i);
the_Impostor : Impostor.view;
begin
-- Replace the visual with the impostors visual, if the visuals apparent size is small enough.
--
if the_Visual.apparent_Size < the_impostor_size_Min
then -- Use impostor.
-- Find or create the impostor for the visual.
--
declare
use visual_Maps_of_impostor;
begin
the_Impostor := Self.visual_Map_of_imposter.Element (the_Visual);
exception
when constraint_Error => -- No impostor exists for this visual yet, so create one.
if the_Visual.is_Terrain
then
the_Impostor := new Impostor.terrain.item;
else
the_Impostor := new Impostor.simple.item;
the_Impostor.set_size_update_trigger_Delta (to => 10);
the_Impostor.set_freshen_count_update_trigger_Mod (to => 250);
end if;
the_Impostor.set_Target (the_Visual);
Self.visual_Map_of_imposter.insert (the_Visual, the_Impostor);
end;
declare
use Visual;
impostor_Target : Visual.view renames the_Visual;
Impostor_update_required : constant Boolean := the_Impostor.update_Required (Camera);
Impostor_is_valid : constant Boolean := the_Impostor.is_Valid;
Impostor_never_updated : constant Boolean := the_Impostor.never_Updated;
begin
if Impostor_is_valid
then
if Impostor_update_required
then
the_Impostor.target_camera_Distance_less_frame_Count := the_Impostor.target_camera_Distance
- Real (the_Impostor.frame_Count_since_last_update);
if Impostor_never_updated
then
add (the_Impostor);
else
declare -- Add impostor to appropriate load balancing slot.
target_face_Count : constant Positive := impostor_Target.face_Count;
function Slot_Id return Positive
is
begin
for Each in Self.impostor_load_Slots'Range
loop
if target_face_Count <= Self.impostor_load_Slots (Each).max_Faces
then
return Each;
end if;
end loop;
raise Program_Error;
end Slot_Id;
the_Slot : impostor_load_Balancer.Slot renames Self.impostor_load_Slots (Slot_Id);
begin
the_Slot.impostors_Count := the_Slot.impostors_Count + 1;
the_Slot.Impostors (the_Slot.impostors_Count) := the_Impostor;
end;
end if;
end if;
the_Impostor.Visual.Site_is (Site_of (the_Visual.all));
the_Impostor.Visual.Spin_is (transposed_camera_Attitude);
the_Visuals (i) := the_Impostor.Visual; -- Replace the visual with the impostor.
end if;
end;
else -- Don't use impostor.
null;
end if;
end;
end loop;
-- Add the load balanced impostor updates.
--
for i in Self.impostor_load_Slots'Range
loop
declare
the_Slot : impostor_load_Balancer.Slot renames Self.impostor_load_Slots (i);
num_Updates : constant Natural := Natural'Min (the_Slot.max_Updates,
the_Slot.impostors_Count);
function "<" (Left, Right : in Impostor.view) return Boolean
is
begin
return Left .target_camera_Distance_less_frame_Count -- Subtracting 'frame count' allows distant targets a chance of
< Right.target_camera_Distance_less_frame_Count; -- update. (TODO: Need some sort of user-settable scale parameter
end "<"; -- to allow for very large scales such as space).
procedure sort is new ada.Containers.generic_Array_sort (Positive,
Impostor.view,
Impostor.views);
begin
sort (the_Slot.Impostors (1 .. the_Slot.impostors_Count));
for Each in 1 .. num_Updates
loop
add (the_Slot.Impostors (Each));
end loop;
end;
end loop;
Self.Renderer.queue_Impostor_updates (Impostor_updates (1 .. impostor_updates_Last),
Camera);
end;
end substitute;
end openGL.Impostorer;

View File

@@ -0,0 +1,117 @@
with
openGL.Impostor,
openGL.Visual,
openGL.Renderer.lean;
limited
with
openGL.Camera;
private
with
ada.Containers.hashed_Maps,
ada.unchecked_Conversion;
package openGL.Impostorer
--
-- Provides an impostoring system.
--
is
type Item is tagged limited private;
type View is access all Item'Class;
---------
--- Forge
--
procedure define (Self : in out Item);
procedure destruct (Self : in out Item);
--------------
--- Attributes
--
function impostor_Count (Self : in Item) return Natural;
function impostor_size_Min (Self : in Item'Class) return Real;
procedure impostor_size_Min_is (Self : in out Item'Class; Now : in Real);
--
-- Visuals whose projected size falls below this minimum will be substituted with impostors.
procedure Camera_is (Self : in out Item'Class; Now : access Camera.item'Class);
function Camera (Self : in Item'Class) return access Camera.item'Class;
procedure Renderer_is (Self : in out Item'Class; Now : in Renderer.lean.view);
function Renderer (Self : in Item'Class) return Renderer.lean.view;
--------------
-- Operations
--
procedure substitute (Self : in out Item; the_Visuals : in out Visual.views;
Camera : access openGL.Camera.item'Class);
private
-- visual_Maps_of_impostor
--
use type Visual .view,
Impostor.view;
function Hash is new ada.unchecked_Conversion (Visual.view, ada.Containers.Hash_type);
package visual_Maps_of_impostor is new ada.Containers.hashed_Maps (Visual .view,
Impostor.view,
Hash => Hash,
equivalent_Keys => "=");
subtype visual_Map_of_impostor is visual_Maps_of_impostor.Map;
-- impostor_load_Balancer
--
package impostor_load_Balancer
is
type Slot is
record
max_Faces : Positive;
max_Updates : Positive;
Impostors : Impostor.views (1 .. 20_000);
impostors_Count : Natural := 0;
end record;
type Slots is array (Positive range <>) of Slot;
type Slots_view is access all Slots;
end impostor_load_Balancer;
default_Slots : aliased impostor_load_Balancer.Slots := [1 => (max_Faces => 100, max_Updates => 20, others => <>),
2 => (max_Faces => 1000, max_Updates => 15, others => <>),
3 => (max_Faces => Positive'Last, max_Updates => 12, others => <>)];
-- Impostorer
--
type Camera_view is access all openGL.Camera .item'Class;
type Renderer_view is access all openGL.Renderer.lean.item'Class;
type Item is tagged limited
record
impostor_size_Min : safe_Real;
visual_Map_of_imposter : visual_Maps_of_impostor.Map;
impostor_load_Slots : impostor_load_Balancer.Slots_view := new impostor_load_Balancer.Slots' (default_Slots);
Camera : Camera_view;
Renderer : Renderer_view;
end record;
end openGL.Impostorer;

View File

@@ -0,0 +1,25 @@
package body openGL.Renderer.lean.forge
is
function to_Renderer return Renderer.lean.item
is
begin
return the_Renderer : Renderer.lean.item
do
the_Renderer.define;
end return;
end to_Renderer;
function new_Renderer return Renderer.lean.view
is
Self : constant Renderer.lean.view := new Renderer.lean.item;
begin
Self.define;
return Self;
end new_Renderer;
end openGL.Renderer.lean.forge;

View File

@@ -0,0 +1,10 @@
package openGL.Renderer.lean.forge
--
-- Provides constructors for the lean renderer.
--
is
function to_Renderer return Renderer.lean.item;
function new_Renderer return Renderer.lean.view;
end openGL.Renderer.lean.forge;

File diff suppressed because it is too large Load Diff

View File

@@ -0,0 +1,310 @@
with
openGL.Context,
openGL.Surface,
openGL.Geometry,
openGL.Model,
openGL.Visual,
openGL.Impostor,
openGL.Texture,
openGL.Font,
openGL.Light;
limited
with
openGL.Camera;
private
with
ada.Containers.hashed_Maps,
ada.unchecked_Conversion;
package openGL.Renderer.lean
--
-- Provides a rendering engine for the 'lean' GL profile.
--
is
type Item is limited new Renderer.item with private;
type View is access all Item'Class;
---------
--- Forge
--
procedure define (Self : access Item);
procedure destroy (Self : in out Item);
procedure free (Self : in out View);
--------------
--- Attributes
--
function new_Light (Self : in out Item) return Light.item;
procedure set (Self : in out Item; the_Light : in Light.item);
procedure rid (Self : in out Item; the_Light : in Light.item);
function Light (Self : in out Item; Id : in light.Id_t) return openGL.Light.item;
function fetch (Self : in out Item) return openGL.Light.items;
type context_Setter is access procedure;
type Swapper is access procedure;
procedure Context_is (Self : in out Item; Now : in Context.view);
procedure Context_Setter_is (Self : in out Item; Now : in context_Setter);
procedure Swapper_is (Self : in out Item; Now : in Swapper);
--------------
-- Operations
--
type impostor_Update
is
record
Impostor : openGL.Impostor.view;
current_Width_pixels : gl.GLsizei;
current_Height_pixels : gl.GLsizei;
current_copy_x_Offset : gl.GLsizei;
current_copy_y_Offset : gl.GLsizei;
current_copy_X : gl.GLsizei;
current_copy_Y : gl.GLsizei;
current_copy_Width : gl.GLsizei;
current_copy_Height : gl.GLsizei;
current_Camera_look_at_Rotation : Matrix_3x3;
end record;
type impostor_Updates is array (Positive range <>) of impostor_Update;
procedure queue_Impostor_updates (Self : in out Item; the_Updates : in impostor_Updates;
the_Camera : access Camera.item'Class);
procedure queue_Visuals (Self : in out Item; the_Visuals : in Visual.views;
the_Camera : access Camera.item'Class);
procedure start_Engine (Self : in out Item);
procedure stop_Engine (Self : in out Item);
procedure render (Self : in out Item; to_Surface : in Surface.view := null);
procedure add_Font (Self : in out Item; font_Id : in Font.font_Id);
procedure Screenshot (Self : in out Item; Filename : in String;
with_Alpha : in Boolean := False);
function is_Busy (Self : in Item) return Boolean;
procedure draw (Self : in out Item; the_Visuals : in Visual.views;
camera_world_Transform : in Matrix_4x4;
view_Transform : in Matrix_4x4;
perspective_Transform : in Matrix_4x4;
clear_Frame : in Boolean;
to_Surface : in Surface.view := null);
--
-- Raises buffer_Overflow if the renderer is unable to cope with the new 'draw'.
procedure free (Self : in out Item; the_Model : in Model .view);
procedure free (Self : in out Item; the_Impostor : in Impostor.view);
buffer_Overflow : exception;
Texture_not_found : exception;
private
type Camera_view is access all openGL.Camera.item'Class;
max_Visuals : constant := 20_000;
----------
-- Updates
--
type updates_for_Camera is
record
impostor_Updates : lean.impostor_Updates (1 .. max_Visuals);
impostor_updates_Last : Natural := 0;
Visuals : Visual.views (1 .. max_Visuals);
visuals_Last : Natural := 0;
end record;
type Updates_for_Camera_view is access Updates_for_Camera;
function Hash is new ada.unchecked_Conversion (Camera_view, ada.Containers.Hash_type);
package camera_Maps_of_updates is new ada.Containers.Hashed_Maps (Camera_view,
updates_for_Camera_view,
Hash,
"=");
type camera_updates_Couple is
record
Camera : Camera_view;
Updates : Updates_for_Camera_view;
end record;
type camera_updates_Couples is array (Positive range <>) of camera_updates_Couple;
protected
type safe_camera_Map_of_updates
is
procedure define;
procedure destruct;
procedure add (the_Updates : in impostor_Updates;
the_Camera : in Camera_view);
procedure add (the_Visuals : in Visual.views;
the_Camera : in Camera_view);
procedure fetch_all_Updates (the_Updates : out camera_updates_Couples;
Length : out Natural);
private
Map_1 : aliased camera_Maps_of_updates.Map;
Map_2 : aliased camera_Maps_of_updates.Map;
current_Map : access camera_Maps_of_updates.Map;
end safe_camera_Map_of_updates;
-- visual_geometry_Couple
--
type visual_geometry_Couple is
record
Visual : openGL.Visual .view;
Geometry : openGL.Geometry.view;
end record;
type visual_geometry_Couples is array (math.Index range <>) of visual_geometry_Couple;
type visual_geometry_Couples_view is access all visual_geometry_Couples;
-- graphics_Models
--
type graphics_Models is array (1 .. max_Visuals) of Model.view;
protected
type safe_Models
is
procedure add (the_Model : in Model.view);
procedure fetch (the_Models : out graphics_Models;
Count : out Natural);
private
my_Models : graphics_Models;
my_Count : Natural := 0;
end safe_Models;
-- Impostors
--
type Impostor_Set is array (1 .. max_Visuals) of Impostor.view;
protected
type safe_Impostors
is
procedure add (the_Impostor : in Impostor.view);
procedure fetch (Impostors : out Impostor_Set;
Count : out Natural);
private
the_Impostors : Impostor_Set;
the_Count : Natural := 0;
end safe_Impostors;
----------
--- Lights
--
function Hash (Id : in openGL.light.Id_t) return ada.Containers.Hash_type;
use type openGL.Light.Id_t,
openGL.Light.item;
package id_Maps_of_light is new ada.Containers.hashed_Maps (Key_type => openGL.light.Id_t,
Element_type => openGL.Light.item,
Hash => Hash,
equivalent_Keys => "=");
subtype id_Map_of_light is id_Maps_of_light.Map;
protected
type safe_Lights
is
procedure add (Light : in openGL.Light.item);
procedure set (Light : in openGL.Light.item);
procedure rid (Light : in openGL.Light.item);
function get (Id : in openGL.light.Id_t) return openGL.Light.item;
function fetch return openGL.Light.items;
private
the_Lights : id_Map_of_light;
end safe_Lights;
-- Engine
--
task type Engine (Self : access Item'Class)
is
entry start (Context : in openGL.Context.view);
entry Stop;
entry render;
entry add_Font (font_Id : in Font.font_Id);
entry Screenshot (Filename : in String;
with_Alpha : in Boolean := False);
pragma Storage_Size (100_000_000);
end Engine;
-- Renderer
--
type Item is limited new Renderer.item with
record
Lights : safe_Lights;
prior_Light_Id : openGL.Light.Id_t := 0;
Textures : aliased Texture.name_Map_of_texture;
Fonts : Font.font_id_Map_of_font;
all_opaque_Couples : visual_geometry_Couples_view := new visual_geometry_Couples (1 .. max_Visuals);
all_lucid_Couples : visual_geometry_Couples_view := new visual_geometry_Couples (1 .. max_Visuals);
obsolete_Models : safe_Models;
obsolete_Impostors : safe_Impostors;
texture_Pool : aliased Texture.Pool;
safe_Camera_updates_Map
: aliased safe_camera_Map_of_updates;
Engine : lean.Engine (Self => Item'Access);
Context : openGL.Context.view;
context_Setter : lean.context_Setter;
Swapper : lean.Swapper;
swap_Required : Boolean;
is_Busy : Boolean := False;
end record;
procedure update_Impostors_and_draw_Visuals
(Self : in out Item; all_Updates : in camera_updates_Couples);
procedure update_Impostors (Self : in out Item; the_Updates : in impostor_Updates;
camera_world_Transform : in Matrix_4x4;
view_Transform : in Matrix_4x4;
perspective_Transform : in Matrix_4x4);
procedure free_old_Models (Self : in out Item);
procedure free_old_Impostors (Self : in out Item);
end openGL.Renderer.lean;