1. ------------------------------------------------------------------------- 
  2.  --  GL.Geometry - GL geometry primitives 
  3.  -- 
  4.  --  Copyright (c) Rod Kay 2007 
  5.  --  AUSTRALIA 
  6.  --  Permission granted to use this software, without any warranty, 
  7.  --  for any purpose, provided this copyright note remains attached 
  8.  --  and unmodified if sources are distributed further. 
  9.  ------------------------------------------------------------------------- 
  10.  
  11. with GL.Math; use GL.Math; 
  12.  
  13. with Ada.Numerics.Generic_Elementary_Functions; 
  14. with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; 
  15. --  with Ada.Text_IO;           use Ada.Text_IO; 
  16. with Ada.Characters.Latin_1; 
  17.  
  18. package body GL.Geometry is 
  19.  
  20.    package GL_Double_EF is new Ada.Numerics.Generic_Elementary_Functions (GL.Double);  -- tbd : make this public ? 
  21.  
  22.    -- Plane 
  23.    -- 
  24.  
  25.    procedure Normalise (the_Plane : in out Plane) is 
  26.  
  27.       use GL_Double_EF; 
  28.       inv_Magnitude  : constant GL.Double := 1.0 / Sqrt (the_Plane (0) * the_Plane (0) 
  29.                                                        + the_Plane (1) * the_Plane (1) 
  30.                                                        + the_Plane (2) * the_Plane (2)); 
  31.    begin 
  32.       the_Plane := (0 => the_Plane (0) * inv_Magnitude, 
  33.                     1 => the_Plane (1) * inv_Magnitude, 
  34.                     2 => the_Plane (2) * inv_Magnitude, 
  35.                     3 => the_Plane (3) * inv_Magnitude); 
  36.    end Normalise; 
  37.  
  38.    -- Bounds 
  39.    -- 
  40.  
  41.    function Max (L, R : Extent) return Extent is 
  42.      (Min => GL.Double'Max (L.Min,  R.Min), 
  43.       Max => GL.Double'Max (L.Max,  R.Max)); 
  44.  
  45.    function Max (L, R : Axis_Aligned_Bounding_Box) return Axis_Aligned_Bounding_Box is 
  46.      (X_Extent => Max (L.X_Extent,  R.X_Extent), 
  47.       Y_Extent => Max (L.Y_Extent,  R.Y_Extent), 
  48.       Z_Extent => Max (L.Z_Extent,  R.Z_Extent)); 
  49.  
  50.    function Max (L, R : Bounds_record) return Bounds_record is 
  51.      (Sphere_Radius => GL.Double'Max (L.Sphere_Radius, R.Sphere_Radius), 
  52.       Box           => Max (L.Box, R.Box)); 
  53.  
  54.    -- vertex_Id's 
  55.    -- 
  56.  
  57.    procedure Increment (Self  : in out vertex_Id_array) is 
  58.  
  59.    begin 
  60.       for Each in Self'Range loop 
  61.          Self (Each) := Self (Each) + 1; 
  62.       end loop; 
  63.    end Increment; 
  64.  
  65.    procedure Decrement (Self  : in out vertex_Id_array) is 
  66.  
  67.    begin 
  68.       for Each in Self'Range loop 
  69.          Self (Each) := Self (Each) - 1; 
  70.       end loop; 
  71.    end Decrement; 
  72.  
  73.    -- vertices 
  74.    -- 
  75.  
  76.    function Image (Self : GL_Vertex) return String is 
  77.      (" (" & Double'Image (Self (0)) & Double'Image (Self (1)) & Double'Image (Self (2)) & ")"); 
  78.  
  79.    function Bounds (Self : GL_Vertex_array) return GL.Geometry.Bounds_record is 
  80.  
  81.       use GL_Double_EF; 
  82.       the_Bounds      : Bounds_record := null_Bounds; 
  83.       max_Distance_2  : GL.Double     := 0.0;      -- current maximum distance squared. 
  84.  
  85.    begin 
  86.       for p in Self'Range loop 
  87.          max_Distance_2 := GL.Double'Max (Self (p) (0) * Self (p) (0) 
  88.                                         + Self (p) (1) * Self (p) (1) 
  89.                                         + Self (p) (2) * Self (p) (2), 
  90.                                           max_Distance_2); 
  91.  
  92.          the_Bounds.Box := (X_Extent => (Min => GL.Double'Min (the_Bounds.Box.X_Extent.Min,  Self (p) (0)), 
  93.                                          Max => GL.Double'Max (the_Bounds.Box.X_Extent.Max,  Self (p) (0))), 
  94.                             Y_Extent => (Min => GL.Double'Min (the_Bounds.Box.Y_Extent.Min,  Self (p) (1)), 
  95.                                          Max => GL.Double'Max (the_Bounds.Box.Y_Extent.Max,  Self (p) (1))), 
  96.                             Z_Extent => (Min => GL.Double'Min (the_Bounds.Box.Z_Extent.Min,  Self (p) (2)), 
  97.                                          Max => GL.Double'Max (the_Bounds.Box.Z_Extent.Max,  Self (p) (2)))); 
  98.       end loop; 
  99.  
  100.       the_Bounds.Sphere_Radius := Sqrt (max_Distance_2); 
  101.  
  102.       return the_Bounds; 
  103.    end Bounds; 
  104.  
  105.    function Bounds (Given_Vertices : GL_Vertex_array; Given_Indices : vertex_Id_array) return GL.Geometry.Bounds_record is 
  106.  
  107.       use GL_Double_EF; 
  108.       the_Bounds      : Bounds_record := null_Bounds; 
  109.       max_Distance_2  : GL.Double     := 0.0;      -- current maximum distance squared. 
  110.  
  111.    begin 
  112.       for Each in Given_Indices'Range loop 
  113.          declare 
  114.             the_Point  : GL_Vertex renames Given_Vertices (Given_Indices (Each)); 
  115.          begin 
  116.             max_Distance_2 := GL.Double'Max (the_Point (0) * the_Point (0) 
  117.                                            + the_Point (1) * the_Point (1) 
  118.                                            + the_Point (2) * the_Point (2), 
  119.                                              max_Distance_2); 
  120.  
  121.             the_Bounds.Box := (X_Extent => (Min => GL.Double'Min (the_Bounds.Box.X_Extent.Min,  the_Point (0)), 
  122.                                             Max => GL.Double'Max (the_Bounds.Box.X_Extent.Max,  the_Point (0))), 
  123.                                Y_Extent => (Min => GL.Double'Min (the_Bounds.Box.Y_Extent.Min,  the_Point (1)), 
  124.                                             Max => GL.Double'Max (the_Bounds.Box.Y_Extent.Max,  the_Point (1))), 
  125.                                Z_Extent => (Min => GL.Double'Min (the_Bounds.Box.Z_Extent.Min,  the_Point (2)), 
  126.                                             Max => GL.Double'Max (the_Bounds.Box.Z_Extent.Max,  the_Point (2)))); 
  127.          end; 
  128.       end loop; 
  129.  
  130.       the_Bounds.Sphere_Radius := Sqrt (max_Distance_2); 
  131.  
  132.       return the_Bounds; 
  133.    end Bounds; 
  134.  
  135.    function Face_Count (Self : Geometry_t'Class) return Natural is 
  136.  
  137.       the_Count  : Natural; 
  138.  
  139.    begin 
  140.       case primitive_Id (Self) is 
  141.          when POINTS => 
  142.             the_Count := Natural (indices_Count (Self)); 
  143.  
  144.          when LINES => 
  145.             the_Count := Natural (indices_Count (Self) / 2); 
  146.  
  147.          when LINE_LOOP => 
  148.             the_Count := Natural (indices_Count (Self)); 
  149.  
  150.          when LINE_STRIP => 
  151.             the_Count := Natural'Max (Natural (indices_Count (Self) - 1),  0); 
  152.  
  153.          when TRIANGLES => 
  154.             the_Count := Natural (indices_Count (Self) / 3); 
  155.  
  156.          when TRIANGLE_STRIP => 
  157.             the_Count := Natural'Max (Natural (indices_Count (Self) - 2),  0); 
  158.  
  159.          when TRIANGLE_FAN => 
  160.             the_Count := Natural'Max (Natural (indices_Count (Self) - 2),  0); 
  161.  
  162.          when QUADS => 
  163.             the_Count := Natural (indices_Count (Self) / 4); 
  164.  
  165.          when QUAD_STRIP => 
  166.             the_Count := Natural (indices_Count (Self) / 2  -  1); 
  167.  
  168.          when POLYGON => 
  169.             the_Count := 1; 
  170.       end case; 
  171.  
  172.       return the_Count; 
  173.    end Face_Count; 
  174.  
  175.    function Image (Self : GL_Vertex_array) return String is 
  176.  
  177.       the_Image  : Unbounded_String; 
  178.       NL         : constant String := (1 => Ada.Characters.Latin_1.LF);   -- NL : New Line 
  179.  
  180.    begin 
  181.       Append (the_Image, " (" & NL); 
  182.       for Each in Self'Range loop 
  183.          Append (the_Image, " " & vertex_Id'Image (Each) & " => " & Image (Self (Each)) & NL); 
  184.       end loop; 
  185.       Append (the_Image, ")" & NL); 
  186.  
  187.       return To_String (the_Image); 
  188.    end Image; 
  189.  
  190.    -- abstract base geometry class 
  191.    -- 
  192.  
  193.    procedure Free (Self  : in out p_Geometry) is 
  194.  
  195.       procedure deallocate is new Ada.Unchecked_Deallocation (Geometry_t'Class, p_Geometry); 
  196.  
  197.    begin 
  198.       destroy    (Self.all); 
  199.       deallocate (Self); 
  200.    end Free; 
  201.  
  202.    function Vertex_Normals (Self : Geometry_t'Class) return GL_Normals_Vertex_Id is 
  203.  
  204.    begin 
  205.       case primitive_Id (Self) is 
  206.          when TRIANGLES => 
  207.             declare 
  208.                the_Vertices        :          GL_Vertex_array    renames Vertices (Self); 
  209.                the_Indices         :          vertex_Id_array renames Indices (Self); 
  210.                the_Normals         :          GL_Normals_Vertex_Id (the_Vertices'Range); 
  211.  
  212.                Triangle_Face_Count : constant Positive := the_Indices'Length / 3; 
  213.                face_Normals        :          GL_Normals  (1 .. Triangle_Face_Count); 
  214.  
  215.                N                   :          GL.Double_Vector_3D; 
  216.                length_N            :          GL.Double; 
  217.  
  218.                function vertex_Id_for (Face : Positive; point_Id : Positive) return vertex_Id is 
  219.                  (the_Indices (positive_uInt (3 * (Face - 1) + point_Id))); 
  220.  
  221.             begin 
  222.                -- Geometry (Normal of unrotated face) 
  223.                -- 
  224.                for each_Face in 1 .. Triangle_Face_Count loop 
  225.                   N := (the_Vertices (vertex_Id_for (each_Face, 2)) - the_Vertices (vertex_Id_for (each_Face, 1))) 
  226.                      * (the_Vertices (vertex_Id_for (each_Face, 3)) - the_Vertices (vertex_Id_for (each_Face, 1))); 
  227.                   length_N := Norm (N); 
  228.  
  229.                   case Almost_zero (length_N) is 
  230.                      when True  => face_Normals (each_Face) := N; -- 0 vector ! 
  231.                      when False => face_Normals (each_Face) := (1.0 / length_N) * N; 
  232.                   end case; 
  233.                end loop; 
  234.  
  235.                -- Calculate normal at each vertex. 
  236.                -- 
  237.                declare 
  238.                   vertex_adjacent_faces_Count  : array (the_Vertices'Range) of Natural := (others => 0); 
  239.                   the_Vertex                   : vertex_Id; 
  240.                   Vertex_Length                : Double; 
  241.                begin 
  242.  
  243.                   for p in the_Vertices'Range loop 
  244.                      the_Normals (p) := (0.0, 0.0, 0.0); 
  245.                   end loop; 
  246.  
  247.                   for f in 1 .. Triangle_Face_Count loop 
  248.                      for p in 1 .. 3 loop 
  249.                         the_Vertex := vertex_Id_for (f, p); 
  250.  
  251.                         vertex_adjacent_faces_Count (the_Vertex) := vertex_adjacent_faces_Count (the_Vertex) + 1; 
  252.                         the_Normals (the_Vertex)                 := the_Normals (the_Vertex) + face_Normals (f); 
  253.                      end loop; 
  254.                   end loop; 
  255.  
  256.                   for p in the_Vertices'Range loop 
  257.  
  258.                      Vertex_Length := Norm (the_Normals (p)); 
  259.  
  260.                      if not Almost_zero (Vertex_Length) then 
  261.                         the_Normals (p) := (1.0 / Vertex_Length) * the_Normals (p); 
  262.                      else 
  263.                         null; -- raise Constraint_Error;  -- tbd : proper exception as usual. 
  264.                      end if; 
  265.                   end loop; 
  266.  
  267.                end; 
  268.  
  269.                return the_Normals; 
  270.             end; 
  271.  
  272.          when others => 
  273.             raise Constraint_Error; -- tbd : finish these 
  274.       end case; 
  275.  
  276. --        return Normal_array' (1 .. 0 => (others => 0.0)); 
  277.    end Vertex_Normals; 
  278.  
  279. end GL.Geometry;