Add initial prototype.
This commit is contained in:
Rod Kay
441
3-mid/opengl/source/lean/opengl-camera.adb
Normal file
441
3-mid/opengl/source/lean/opengl-camera.adb
Normal file
@@ -0,0 +1,441 @@
|
||||
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;
|
||||
Reference in New Issue
Block a user