442 lines
12 KiB
Ada
442 lines
12 KiB
Ada
with
|
|
ada.Text_IO,
|
|
ada.Exceptions;
|
|
|
|
package body openGL.Camera
|
|
is
|
|
use math.Algebra.linear,
|
|
math.Algebra.linear.d3,
|
|
ada.Text_IO;
|
|
|
|
---------
|
|
-- Forge
|
|
--
|
|
|
|
procedure define (Self : in out Item)
|
|
is
|
|
begin
|
|
Self.Culler .define;
|
|
Self.Impostorer.define;
|
|
|
|
Self.world_Transform := Identity_4x4;
|
|
Self. view_Transform := Identity_4x4;
|
|
Self.Viewport := (Min => [0, 0],
|
|
Max => [0, 0]);
|
|
end define;
|
|
|
|
|
|
procedure destroy (Self : in out Item)
|
|
is
|
|
begin
|
|
Self.cull_Engine.stop;
|
|
end destroy;
|
|
|
|
|
|
--------------
|
|
-- Attributes
|
|
--
|
|
|
|
function to_World_Site (Self : in Item; Window_Site : in math.Vector_3) return math.Vector_3
|
|
is
|
|
perspective_Transform : constant math.Matrix_4x4 := to_Perspective (FoVy => Self.FoVy,
|
|
Aspect => Self.Aspect,
|
|
zNear => Self.near_Plane_Distance,
|
|
zFar => Self. far_Plane_Distance);
|
|
Viewport : constant Rectangle := Self.Viewport;
|
|
Position_window_space : constant Vector_3 := [Window_Site (1),
|
|
Real (Viewport.Max (2)) - Window_Site (2),
|
|
Window_Site (3)];
|
|
Site_world_space : constant Vector_3 := unProject (Position_window_space,
|
|
Model => Self.view_Transform,
|
|
Projection => perspective_Transform,
|
|
Viewport => Viewport);
|
|
begin
|
|
return Site_world_space;
|
|
end to_World_Site;
|
|
|
|
|
|
|
|
procedure Site_is (Self : in out Item; now : in math.Vector_3)
|
|
is
|
|
begin
|
|
Self.world_Transform := to_transform_Matrix ((Self.Spin,
|
|
now));
|
|
Self.update_View_Transform;
|
|
end Site_is;
|
|
|
|
|
|
function Site (Self : in Item) return math.Vector_3
|
|
is
|
|
begin
|
|
return get_Translation (Self.world_Transform);
|
|
end Site;
|
|
|
|
|
|
|
|
procedure Position_is (Self : in out Item'Class; Site : in math.Vector_3;
|
|
Spin : in math.Matrix_3x3)
|
|
is
|
|
begin
|
|
Self.world_Transform := to_transform_Matrix ((Spin,
|
|
Site));
|
|
Self.update_View_Transform;
|
|
end Position_is;
|
|
|
|
|
|
|
|
procedure Spin_is (Self : in out Item'Class; now : in math.Matrix_3x3)
|
|
is
|
|
begin
|
|
set_Rotation (Self.world_Transform, to => now);
|
|
Self.update_View_Transform;
|
|
end Spin_is;
|
|
|
|
|
|
function Spin (Self : in Item'Class) return math.Matrix_3x3
|
|
is
|
|
begin
|
|
return get_Rotation (Self.world_Transform);
|
|
end Spin;
|
|
|
|
|
|
|
|
function World_Transform (Self : in Item) return math.Matrix_4x4
|
|
is
|
|
begin
|
|
return Self.world_Transform;
|
|
end World_Transform;
|
|
|
|
|
|
function FoVy (Self : in Item'Class) return math.Degrees
|
|
is
|
|
begin
|
|
return Self.FoVy;
|
|
end FOVy;
|
|
|
|
|
|
procedure FoVy_is (Self : in out Item'Class; Now : in math.Degrees)
|
|
is
|
|
begin
|
|
Self.FoVy := Now;
|
|
end FoVy_is;
|
|
|
|
|
|
|
|
function Aspect (Self : in Item'Class) return math.Real
|
|
is
|
|
begin
|
|
return Self.Aspect;
|
|
end Aspect;
|
|
|
|
|
|
procedure Aspect_is (Self : in out Item'Class; now : in math.Real)
|
|
is
|
|
begin
|
|
Self.Aspect := now;
|
|
end Aspect_is;
|
|
|
|
|
|
|
|
function near_Plane_Distance (Self : in Item'Class) return math.Real
|
|
is
|
|
begin
|
|
return Self.near_Plane_Distance;
|
|
end near_Plane_Distance;
|
|
|
|
|
|
procedure near_Plane_Distance_is (Self : in out Item'Class; now : in math.Real)
|
|
is
|
|
begin
|
|
Self.near_Plane_Distance := now;
|
|
end near_Plane_Distance_is;
|
|
|
|
|
|
|
|
function far_Plane_Distance (Self : in Item'Class) return math.Real
|
|
is
|
|
begin
|
|
return Self.far_Plane_Distance;
|
|
end far_Plane_Distance;
|
|
|
|
|
|
procedure far_Plane_Distance_is (Self : in out Item'Class; now : in math.Real)
|
|
is
|
|
begin
|
|
Self.far_Plane_Distance := now;
|
|
end far_Plane_Distance_is;
|
|
|
|
|
|
|
|
function view_Transform (Self : in Item'Class) return math.Matrix_4x4
|
|
is
|
|
begin
|
|
return Self.view_Transform;
|
|
end view_Transform;
|
|
|
|
|
|
function projection_Transform (Self : in Item'Class) return math.Matrix_4x4
|
|
is
|
|
begin
|
|
return Self.projection_Transform;
|
|
end projection_Transform;
|
|
|
|
|
|
|
|
procedure Viewport_is (Self : in out Item'Class; Width, Height : in Positive)
|
|
is
|
|
use real_Functions;
|
|
|
|
half_FoV_max : Radians := to_Radians (0.5 * Self.FoVy);
|
|
Tan_of_half_FoV_max : constant Real := Tan (half_FoV_max);
|
|
|
|
begin
|
|
Self.Viewport.Min (1) := 0;
|
|
Self.Viewport.Min (2) := 0;
|
|
|
|
Self.Viewport.Max (1) := Width - 1;
|
|
Self.Viewport.Max (2) := Height - 1;
|
|
|
|
Self.Aspect := Real (Width) / Real (Height);
|
|
|
|
Self.near_plane_Height := Self.near_plane_Distance * Tan_of_half_FoV_max;
|
|
Self.near_plane_Width := Self.near_plane_Height * Self.Aspect;
|
|
|
|
Self.far_plane_Height := Self.far_plane_Distance * Tan_of_half_FoV_max;
|
|
Self.far_plane_Width := Self.far_plane_Height * Self.Aspect;
|
|
|
|
if Self.Aspect > 1.0
|
|
then -- X side angle broader than y side angle.
|
|
half_FoV_max := arcTan (Self.aspect * Tan_of_half_FoV_max); -- TODO: 'half_FoV_max' is not used after here. Why is it set ?
|
|
end if;
|
|
|
|
Self.projection_Transform := to_Perspective (FoVy => Self.FoVy,
|
|
Aspect => Self.Aspect,
|
|
zNear => Self.near_Plane_Distance,
|
|
zFar => Self. far_Plane_Distance);
|
|
end Viewport_is;
|
|
|
|
|
|
|
|
function Viewport (Self : in Item) return linear_Algebra_3d.Rectangle
|
|
is
|
|
begin
|
|
return Self.Viewport;
|
|
end Viewport;
|
|
|
|
|
|
procedure Renderer_is (Self : in out Item; now : in Renderer.lean.view)
|
|
is
|
|
begin
|
|
Self.Renderer := now;
|
|
end Renderer_is;
|
|
|
|
|
|
function cull_completed (Self : in Item) return Boolean
|
|
is
|
|
begin
|
|
return Boolean (Self.cull_Completed);
|
|
end cull_completed;
|
|
|
|
|
|
procedure disable_cull (Self : in out Item)
|
|
is
|
|
begin
|
|
Self.is_Culling := False;
|
|
end disable_cull;
|
|
|
|
|
|
|
|
function vanish_Point_Size_min (Self : in Item'Class) return Real
|
|
is
|
|
begin
|
|
return Self.Culler.vanish_Point_Size_min;
|
|
end vanish_Point_Size_min;
|
|
|
|
|
|
procedure vanish_Point_Size_min_is (Self : in out Item'Class; now : in Real)
|
|
is
|
|
begin
|
|
Self.Culler.vanish_Point_Size_min_is (now);
|
|
end vanish_Point_Size_min_is;
|
|
|
|
|
|
|
|
-- Impostors
|
|
--
|
|
|
|
function Impostor_Size_min (Self : in Item) return Real
|
|
is
|
|
begin
|
|
return Self.Impostorer.Impostor_Size_min;
|
|
end Impostor_Size_min;
|
|
|
|
|
|
procedure Impostor_Size_min_is (Self : in out Item; now : in Real)
|
|
is
|
|
begin
|
|
Self.Impostorer.Impostor_Size_min_is (now);
|
|
end Impostor_Size_min_is;
|
|
|
|
|
|
procedure allow_Impostors (Self : in out Item; now : in Boolean := True)
|
|
is
|
|
begin
|
|
Self.Impostors_allowed := now;
|
|
end allow_Impostors;
|
|
|
|
|
|
|
|
----------
|
|
-- Engine
|
|
--
|
|
task body cull_Engine
|
|
is
|
|
Done : Boolean := False;
|
|
culling : Boolean;
|
|
|
|
all_Visuals : openGL.Visual.views (1 .. 20_000);
|
|
all_Visuals_last : Natural;
|
|
|
|
begin
|
|
loop
|
|
select
|
|
accept stop
|
|
do
|
|
Done := True;
|
|
end stop;
|
|
or
|
|
accept cull (the_Visuals : in Visual.views; do_cull : in Boolean)
|
|
do
|
|
all_Visuals (the_Visuals'Range) := the_Visuals;
|
|
all_visuals_Last := the_Visuals'Last;
|
|
|
|
culling := do_cull;
|
|
Self.Cull_completed := False;
|
|
end cull;
|
|
end select;
|
|
|
|
exit when Done;
|
|
|
|
declare
|
|
function get_Visuals return Visual.views
|
|
is
|
|
begin
|
|
if culling
|
|
then
|
|
return Self.Culler.cull (the_Visuals => all_Visuals (1 .. all_Visuals_last),
|
|
Camera_Frustum => Self.current_Planes,
|
|
Camera_Site => Self.Site);
|
|
else
|
|
return all_Visuals (1 .. all_visuals_Last);
|
|
end if;
|
|
end get_Visuals;
|
|
|
|
the_Visuals : Visual.views := get_Visuals;
|
|
|
|
begin
|
|
if Self.Impostors_allowed
|
|
then
|
|
Self.Impostorer.Renderer_is (Self.Renderer);
|
|
Self.Impostorer.substitute (the_Visuals,
|
|
Camera => Self);
|
|
end if;
|
|
|
|
Self.Renderer.queue_Visuals (the_Visuals, Self);
|
|
|
|
Self.Cull_completed := True;
|
|
end;
|
|
end loop;
|
|
|
|
Self.Impostorer.destruct;
|
|
|
|
exception
|
|
when E : others =>
|
|
new_Line;
|
|
put_Line ("Unhandled exception in openGL camera Cull engine.");
|
|
put_Line (ada.Exceptions.Exception_Information (E));
|
|
end cull_Engine;
|
|
|
|
|
|
|
|
--------------
|
|
-- Operations
|
|
--
|
|
|
|
procedure render (Self : in out Item; Visuals : in Visual.views;
|
|
to : in Surface.view := null)
|
|
is
|
|
pragma Unreferenced (To); -- TODO: Finish using surfaces.
|
|
begin
|
|
Self.cull_Engine.cull (Visuals, do_cull => Self.is_Culling);
|
|
end render;
|
|
|
|
|
|
|
|
function current_Planes (Self : in Item) return openGL.Frustum.Plane_array
|
|
is
|
|
use openGL.Frustum;
|
|
|
|
the_Planes : Frustum.Plane_array;
|
|
|
|
Projection : constant Matrix_4x4 := Self.projection_Transform;
|
|
Model : constant Matrix_4x4 := Self.view_Transform;
|
|
Clip : constant Matrix_4x4 := Model * Projection;
|
|
|
|
begin
|
|
-- Extract the Right plane.
|
|
--
|
|
the_Planes (Right)(1) := clip (1,4) - clip (1,1);
|
|
the_Planes (Right)(2) := clip (2,4) - clip (2,1);
|
|
the_Planes (Right)(3) := clip (3,4) - clip (3,1);
|
|
the_Planes (Right)(4) := clip (4,4) - clip (4,1);
|
|
|
|
-- Extract the Left plane.
|
|
--
|
|
the_Planes (Left)(1) := clip (1,4) + clip (1,1);
|
|
the_Planes (Left)(2) := clip (2,4) + clip (2,1);
|
|
the_Planes (Left)(3) := clip (3,4) + clip (3,1);
|
|
the_Planes (Left)(4) := clip (4,4) + clip (4,1);
|
|
|
|
-- Extract the Low plane.
|
|
--
|
|
the_Planes (Low)(1) := clip (1,4) + clip (1,2);
|
|
the_Planes (Low)(2) := clip (2,4) + clip (2,2);
|
|
the_Planes (Low)(3) := clip (3,4) + clip (3,2);
|
|
the_Planes (Low)(4) := clip (4,4) + clip (4,2);
|
|
|
|
-- Extract the High plane.
|
|
--
|
|
the_Planes (High)(1) := clip (1,4) - clip (1,2);
|
|
the_Planes (High)(2) := clip (2,4) - clip (2,2);
|
|
the_Planes (High)(3) := clip (3,4) - clip (3,2);
|
|
the_Planes (High)(4) := clip (4,4) - clip (4,2);
|
|
|
|
-- Extract the Far plane.
|
|
--
|
|
the_Planes (Far)(1) := clip (1,4) - clip (1,3);
|
|
the_Planes (Far)(2) := clip (2,4) - clip (2,3);
|
|
the_Planes (Far)(3) := clip (3,4) - clip (3,3);
|
|
the_Planes (Far)(4) := clip (4,4) - clip (4,3);
|
|
|
|
-- Extract the Near plane.
|
|
--
|
|
the_Planes (Near)(1) := clip (1,4) + clip (1,3);
|
|
the_Planes (Near)(2) := clip (2,4) + clip (2,3);
|
|
the_Planes (Near)(3) := clip (3,4) + clip (3,3);
|
|
the_Planes (Near)(4) := clip (4,4) + clip (4,3);
|
|
|
|
normalise (the_Planes);
|
|
return the_Planes;
|
|
end current_Planes;
|
|
|
|
|
|
|
|
procedure update_View_Transform (Self : in out Item)
|
|
is
|
|
begin
|
|
Self.view_Transform := inverse_Transform (Self.world_Transform);
|
|
end update_View_Transform;
|
|
|
|
|
|
end openGL.Camera;
|