1. with GLOBE_3D.Options, 
  2.      GLOBE_3D.Textures, 
  3.      GLOBE_3D.Math, 
  4.      GLOBE_3D.Portals; 
  5.  
  6. with GL.Errors, 
  7.      GL.Skins; 
  8.  
  9. with Ada.Characters.Handling;           use Ada.Characters.Handling; 
  10. with Ada.Exceptions;                    use Ada.Exceptions; 
  11. with Ada.Strings.Fixed;                 use Ada.Strings, Ada.Strings.Fixed; 
  12. with Ada.Text_IO;                       use Ada.Text_IO; 
  13.  
  14. with System.Storage_Elements; 
  15. with Ada.Containers.Generic_Array_Sort; 
  16.  
  17. package body GLOBE_3D is 
  18.  
  19.    use GLOBE_3D.Options; 
  20.  
  21.    package G3DT renames GLOBE_3D.Textures; 
  22.    package G3DM renames GLOBE_3D.Math; 
  23.  
  24.    function Image (r : Real) return String is 
  25.  
  26.       s : String (1 .. 10); 
  27.  
  28.    begin 
  29.       RIO.Put (s, r, 4, 0); 
  30.       return s; 
  31.  
  32.    exception 
  33.       when Ada.Text_IO.Layout_Error => return Real'Image (r); 
  34.    end Image; 
  35.  
  36.    function Coords (p : Point_3D) return String is 
  37.      ('(' & Image (p (0)) & 
  38.       ',' & Image (p (1)) & 
  39.       ',' & Image (p (2)) & 
  40.      ')'); 
  41.  
  42.    -- normal support 
  43.    -- 
  44.  
  45.    procedure Add_Normal_of_3p (o             :        Object_3D'Class; 
  46.                                Pn0, Pn1, Pn2 :        Integer; 
  47.                                N             : in out Vector_3D) is 
  48.       use G3DM; 
  49.  
  50.       function Params return String is 
  51.         (" Object : " & Trim (o.ID, Right) & 
  52.            " Pn0 =" & Integer'Image (Pn0) & 
  53.            " Pn1 =" & Integer'Image (Pn1) & 
  54.            " Pn2 =" & Integer'Image (Pn2)); 
  55.  
  56.       N_contrib : Vector_3D; 
  57.  
  58.    begin 
  59.       if Pn0 /= 0 and then Pn1 /= 0 and then Pn2 /= 0 then 
  60.          N_contrib := (o.Point (Pn1) - o.Point (Pn0)) * (o.Point (Pn2) - o.Point (Pn0)); 
  61.          if strict_geometry and then Almost_zero (Norm2 (N_contrib)) then 
  62.             pragma Warnings (Off, "this code can never be executed and has been deleted"); 
  63.             Raise_Exception (zero_normal'Identity, 
  64.                              Params & 
  65.                                " P0 =" & Coords (o.Point (Pn0)) & 
  66.                                " P1 =" & Coords (o.Point (Pn1)) & 
  67.                                " P2 =" & Coords (o.Point (Pn2)) & 
  68.                                " Nc =" & Coords (N_contrib)); 
  69.             pragma Warnings (On,  "this code can never be executed and has been deleted"); 
  70.          end if; 
  71.          N := N + N_contrib; 
  72.       end if; 
  73.  
  74.    exception 
  75.       when e : others => Raise_Exception (Exception_Identity (e), 
  76.                                           Exception_Message (e) & Params); 
  77.    end Add_Normal_of_3p; 
  78.  
  79.    -- blending support 
  80.    -- 
  81.  
  82.    function Is_to_blend (m : GL.Double)  return Boolean is (not G3DM.Almost_zero (m - 1.0)); 
  83.  
  84.    function Is_to_blend (m : GL.C_Float) return Boolean is (not G3DM.Almost_zero (m - 1.0)); 
  85.  
  86.    function Is_to_blend (m : GL.Material_Float_vector) return Boolean is (Is_to_blend (m (3))); 
  87.  
  88.    function Is_to_blend (m : GL.Materials.Material_type) return Boolean  is 
  89.      (Is_to_blend (m.ambient) or else 
  90.       Is_to_blend (m.diffuse) or else 
  91.       Is_to_blend (m.specular)); 
  92.    -- m.emission, m.shininess not relevant 
  93.  
  94.    -- material support 
  95.    -- 
  96.  
  97.    procedure Set_Material (m : GL.Materials.Material_type) is 
  98.  
  99.    begin 
  100.       Material (FRONT_AND_BACK, AMBIENT,   m.ambient); 
  101.       Material (FRONT_AND_BACK, DIFFUSE,   m.diffuse); 
  102.       Material (FRONT_AND_BACK, SPECULAR,  m.specular); 
  103.       Material (FRONT_AND_BACK, EMISSION,  m.emission); 
  104.       Material (FRONT_AND_BACK, SHININESS, m.shininess); 
  105.    end Set_Material; 
  106.  
  107.    -- 'Visual' 
  108.    -- 
  109.  
  110.    procedure Free (o : in out p_Visual) is 
  111.  
  112.       procedure Deallocate is new Ada.Unchecked_Deallocation (Visual'Class, p_Visual); 
  113.  
  114.    begin 
  115.       Destroy (o.all); 
  116.       Deallocate (o); 
  117.    end Free; 
  118.  
  119.    function skinned_Geometrys (o : Visual) return GL.Skinned_Geometry.skinned_Geometrys is 
  120.      (GL.Skinned_Geometry.null_skinned_Geometrys); 
  121.  
  122.    function Width  (o : Visual'class) return Real is 
  123.         (Bounds (o).Box.X_Extent.Max - Bounds (o).Box.X_Extent.Min); 
  124.  
  125.    function Height  (o : Visual'class) return Real is 
  126.         (Bounds (o).Box.Y_Extent.Max - Bounds (o).Box.Y_Extent.Min); 
  127.  
  128.    function Depth  (o : Visual'class) return Real is 
  129.         (Bounds (o).Box.Z_Extent.Max - Bounds (o).Box.Z_Extent.Min); 
  130.  
  131.    -- 'Object_3D' 
  132.    -- 
  133.  
  134.    -- object validation 
  135.    -- 
  136.  
  137.    procedure Check_object (o : Object_3D) is 
  138.  
  139.       use G3DM; 
  140.  
  141.       procedure Check_faces is 
  142.  
  143.          procedure Check (f, v : Integer) is 
  144.             pragma Inline (Check); 
  145.          begin 
  146.             if v < 0 or else v > o.Max_points then 
  147.                Raise_Exception (bad_vertex_number'Identity, 
  148.                                 o.ID & " face ="   & Integer'Image (f) & 
  149.                                   " vertex =" & Integer'Image (v)); 
  150.             end if; 
  151.          end Check; 
  152.  
  153.          procedure Check_duplicate (f, Pn1, Pn2 : Integer) is 
  154.             pragma Inline (Check_duplicate); 
  155.          begin 
  156.             -- Skip "dead" edge (triangle), 30 - Dec - 2001 
  157.             if Pn1 = 0 or else Pn2 = 0 then 
  158.                return; 
  159.             end if; 
  160.             -- Detect same point number 
  161.             if Pn1 = Pn2 then 
  162.                Raise_Exception (duplicated_vertex'Identity, 
  163.                                 o.ID & " in face "   & Integer'Image (f)); 
  164.             end if; 
  165.             -- Detect same point coordinates (tolerated in an object, 
  166.             -- although inefficient, but harms as vertex of the same face!) 
  167.  
  168.             if Almost_zero (Norm2 (o.Point (Pn1) - o.Point (Pn2))) then 
  169.                Raise_Exception (duplicated_vertex_location'Identity, 
  170.                                 o.ID & " in face "   & Integer'Image (f)); 
  171.             end if; 
  172.          end Check_duplicate; 
  173.  
  174.       begin 
  175.          for fa in o.face'Range loop 
  176.             for edge_num in 1 .. 4 loop 
  177.                Check (fa, o.face (fa).P (edge_num)); 
  178.                for other_edge in edge_num + 1 .. 4 loop 
  179.                   Check_duplicate (fa, o.face (fa).P (edge_num), 
  180.                                    o.face (fa).P (other_edge)); 
  181.                end loop; 
  182.             end loop; 
  183.          end loop; -- fa 
  184.       end Check_faces; 
  185.  
  186.    begin 
  187.       Check_faces; 
  188.    end Check_object; 
  189.  
  190.    -------------------------------------------- 
  191.    -- Object initialization (1x in its life) -- 
  192.    -------------------------------------------- 
  193.  
  194.    overriding procedure Pre_calculate (o : in out Object_3D) is 
  195.  
  196.       use G3DM; 
  197.  
  198.       N        : Vector_3D; 
  199.       length_N : Real; 
  200.  
  201.       procedure Calculate_face_invariants ( 
  202.                                            fa :     Face_type; 
  203.                                            fi : out Face_invariant_type 
  204.                                           ) is 
  205.          l : Natural := 0; 
  206.          quadri_edge :  array (fa.P'Range) of Natural; 
  207.          ex_U, ex_V : Real; 
  208.       begin 
  209.          l := 0; 
  210.          for qe in fa.P'Range loop 
  211.             if fa.P (qe) /= 0 then 
  212.                l := l + 1; 
  213.                quadri_edge (l) := qe; -- if triangle, "map" edge on a quadri 
  214.                fi.P_compact (l) := fa.P (qe); 
  215.             end if; 
  216.          end loop; 
  217.          if l in Edge_count then 
  218.             fi.last_edge := l; 
  219.          else 
  220.             Raise_Exception (bad_edge_number'Identity, o.ID); 
  221.          end if; 
  222.          -- * Face invariant : Textured face : extremities 
  223.          for e in 1 .. l loop 
  224.             if fa.whole_texture then 
  225.                ex_U := Real (fa.repeat_U); 
  226.                ex_V := Real (fa.repeat_V); 
  227.                case quadri_edge (e) is 
  228.                when 1 => fi.UV_extrema (e) := (0.0, 0.0); -- bottom, left  4 --< --3 
  229.                when 2 => fi.UV_extrema (e) := (ex_U, 0.0); -- bottom, right |     | 
  230.                when 3 => fi.UV_extrema (e) := (ex_U, ex_V); -- top, right    1 --> --2 
  231.                when 4 => fi.UV_extrema (e) := (0.0, ex_V); -- top, left 
  232.                when others => null; 
  233.                end case; 
  234.             else 
  235.                -- Just copy the mapping, but in compact form for triangles : 
  236.                fi.UV_extrema (e) := fa.texture_edge_map (quadri_edge (e)); 
  237.             end if; 
  238.          end loop; 
  239.          -- * Face invariant : Normal of unrotated face 
  240.          N := (0.0, 0.0, 0.0); 
  241.          case fi.last_edge is 
  242.          when 3 => 
  243.             Add_Normal_of_3p (o, 
  244.                               fi.P_compact (1), 
  245.                               fi.P_compact (2), 
  246.                               fi.P_compact (3), 
  247.                               N 
  248.                              ); 
  249.          when 4 => 
  250.             Add_Normal_of_3p (o, fa.P (1), fa.P (2), fa.P (4), N); 
  251.             -- We sum other normals for not perfectly flat faces, 
  252.             -- in order to have a convenient average .. . 
  253.             Add_Normal_of_3p (o, fa.P (2), fa.P (3), fa.P (1), N); 
  254.             Add_Normal_of_3p (o, fa.P (3), fa.P (4), fa.P (2), N); 
  255.             Add_Normal_of_3p (o, fa.P (4), fa.P (1), fa.P (3), N); 
  256.          end case; 
  257.          length_N := Norm (N); 
  258.          if Almost_zero (length_N) then 
  259.             if strict_geometry then 
  260.                pragma Warnings (Off, "this code can never be executed and has been deleted"); 
  261.                raise zero_summed_normal; 
  262.                pragma Warnings (On,  "this code can never be executed and has been deleted"); 
  263.             else 
  264.                fi.normal := N; -- 0 vector ! 
  265.             end if; 
  266.          else 
  267.             fi.normal := (1.0 / length_N) * N; 
  268.          end if; 
  269.       end Calculate_face_invariants; 
  270.  
  271.       adjacent_faces : array (o.Point'Range) of Natural := (others => 0); 
  272.       pf : Natural; 
  273.       length : Real; 
  274.  
  275.    begin -- Pre_calculate 
  276.       if full_check_objects then 
  277.          pragma Warnings (Off, "this code can never be executed and has been deleted"); 
  278.          Check_object (o); 
  279.          pragma Warnings (On,  "this code can never be executed and has been deleted"); 
  280.       end if; 
  281.  
  282.       for i in o.face'Range loop 
  283.          begin 
  284.             -- Geometry 
  285.             Calculate_face_invariants (o.face (i), o.Face_Invariant (i)); 
  286.             -- Disable blending when alphas are = 1 
  287.             case o.face (i).skin is 
  288.             when material_only | material_texture => 
  289.                o.Face_Invariant (i).blending := Is_to_blend (o.face (i).material); 
  290.             when colour_only | coloured_texture | texture_only => 
  291.                o.Face_Invariant (i).blending := Is_to_blend (o.face (i).alpha); 
  292.             when invisible => 
  293.                o.Face_Invariant (i).blending := False; 
  294.             end case; 
  295.             o.transparent := o.transparent or else o.Face_Invariant (i).blending; 
  296.          exception 
  297.             when zero_summed_normal => 
  298.                Raise_Exception (zero_summed_normal'Identity, 
  299.                                 o.ID & " face =" & Integer'Image (i)); 
  300.          end; 
  301.       end loop; 
  302.  
  303.       declare 
  304.          use GLOBE_3D.REF; 
  305.          max_Norm2 : Real := 0.0; 
  306.       begin 
  307.          o.Bounds.Box.X_Extent.Min := Real'Last;   o.Bounds.Box.X_Extent.Max := Real'First; 
  308.          o.Bounds.Box.Y_Extent.Min := Real'Last;   o.Bounds.Box.Y_Extent.Max := Real'First; 
  309.          o.Bounds.Box.Z_Extent.Min := Real'Last;   o.Bounds.Box.Z_Extent.Max := Real'First; 
  310.  
  311.          for p in o.Point'Range loop 
  312.             o.edge_vector (p)          := (0.0, 0.0, 0.0); 
  313.             max_Norm2                 := Real'Max (Norm2 (o.Point (p)),  max_Norm2); 
  314.  
  315.             o.Bounds.Box.X_Extent.Min := Real'Min (o.Bounds.Box.X_Extent.Min,  o.Point (p) (0));  -- tbd : set extents and bounding sphere radius in 
  316.             o.Bounds.Box.X_Extent.Max := Real'Max (o.Bounds.Box.X_Extent.Max,  o.Point (p) (0));  --      common procedure for 'object_base' class. 
  317.             o.Bounds.Box.Y_Extent.Min := Real'Min (o.Bounds.Box.Y_Extent.Min,  o.Point (p) (1)); 
  318.             o.Bounds.Box.Y_Extent.Max := Real'Max (o.Bounds.Box.Y_Extent.Max,  o.Point (p) (1)); 
  319.             o.Bounds.Box.Z_Extent.Min := Real'Min (o.Bounds.Box.Z_Extent.Min,  o.Point (p) (2)); 
  320.             o.Bounds.Box.Z_Extent.Max := Real'Max (o.Bounds.Box.Z_Extent.Max,  o.Point (p) (2)); 
  321.          end loop; 
  322.  
  323.          o.Bounds.Sphere_Radius := Sqrt (max_Norm2); 
  324.       end; 
  325.  
  326.       -- Calculate edge vectors. 
  327.       --   Naive algorithm : for each point, scan all faces to see 
  328.       --   if they are adjacent. It took #points * #faces steps. 
  329.       --   - > better algorithm here : 2 * #points + 4 * #faces. (22 - Jan - 2006) 
  330.       for f in o.face'Range loop 
  331.          for p in o.face (f).P'Range loop 
  332.             pf := o.face (f).P (p); 
  333.             if pf /= 0 then 
  334.                adjacent_faces (pf) := adjacent_faces (pf) + 1; 
  335.                o.edge_vector (pf) := o.edge_vector (pf) + o.Face_Invariant (f).normal; 
  336.             end if; 
  337.          end loop; 
  338.          if is_textured (o.face (f).skin) and then 
  339.            not Textures.Valid_texture_ID (o.face (f).texture) 
  340.          then 
  341.             Raise_Exception (Textures.Undefined_texture_ID'Identity, 
  342.                              Trim (o.ID, Right) & 
  343.                                " face ="   & Integer'Image (f) & 
  344.                                " skin ="   & Skin_Type'Image (o.face (f).skin) & 
  345.                                " texture_id =" & Image_ID'Image (o.face (f).texture)); 
  346.          end if; 
  347.       end loop; 
  348.       for p in o.Point'Range loop 
  349.          if adjacent_faces (p) = 0 then 
  350.             if strict_geometry then 
  351.                pragma Warnings (Off, "this code can never be executed and has been deleted"); 
  352.                -- Strict approach : detect any unmatched point : 
  353.                Raise_Exception (point_unmatched'Identity, 
  354.                                 Trim (o.ID, Right) & 
  355.                                   " point " & Integer'Image (p) & 
  356.                                   " belongs to none of the object's face"); 
  357.                pragma Warnings (On,  "this code can never be executed and has been deleted"); 
  358.             end if; 
  359.          else 
  360.             length := Norm (o.edge_vector (p)); 
  361.             if not Almost_zero (length) then 
  362.                o.edge_vector (p) := (1.0 / length) * o.edge_vector (p); 
  363.             end if; 
  364.          end if; 
  365.       end loop; 
  366.  
  367.       -- Ooof. Now we can certify : 
  368.       o.pre_calculated := True; 
  369.    end Pre_calculate; 
  370.  
  371.    procedure Arrow (P : Point_3D; D : Vector_3D) is 
  372.  
  373.       use G3DM; 
  374.  
  375.       V, V1, V2 : Vector_3D; 
  376.  
  377.    begin 
  378.       if Almost_zero (Norm2 (D)) then 
  379.          return; 
  380.       end if; 
  381.       V := (D (1), -D (0), 0.0);         -- an orthogonal, or zero 
  382.       if Almost_zero (Norm2 (V)) then -- bad luck, it is zero 
  383.          V := (0.0, -D (2), D (1));       -- 2nd try 
  384.       end if; 
  385.       V := (0.2 / Norm (V)) * V; 
  386.       V1 := 0.7 * D + V; 
  387.       V2 := 0.7 * D - V; 
  388.       GL_Begin (GL.LINES); 
  389.       Vertex (P + D);    Vertex (P); 
  390.       Vertex (P + D);    Vertex (P + V1); 
  391.       Vertex (P + D);    Vertex (P + V2); 
  392.       GL_End; 
  393.    end Arrow; 
  394.  
  395.    --     neutral_material_already_set : Boolean := False; 
  396.  
  397.    ------------- 
  398.    -- Display -- 
  399.    ------------- 
  400.  
  401.    procedure Display_one (o : in out Object_3D) is 
  402.       -- Display only this object and not connected objects 
  403.       -- out : object will be initialized if not yet 
  404.  
  405.       -- 
  406.  
  407.       -- 
  408.       -- Display face routine which is optimized to produce a shorter list 
  409.       -- of GL commands. Runs slower then the original Display face routine 
  410.       -- yet needs to be executed only once. 
  411.       -- 
  412.       -- Uwe R. Zimmer, July 2011 
  413.       -- 
  414.       package Display_face_optimized is 
  415.          procedure Display_face (First_Face : Boolean; fa : Face_type; fi : in out Face_invariant_type); 
  416.       private 
  417.          Previous_face           : Face_type; 
  418.          Previous_face_Invariant : Face_invariant_type; 
  419.       end Display_face_optimized; 
  420.  
  421.       package body Display_face_optimized is 
  422.  
  423.          use GL.Materials; 
  424.  
  425.          procedure Display_face (First_Face : Boolean; fa : Face_type; fi : in out Face_invariant_type) is 
  426.  
  427.             blending_hint : Boolean; 
  428.  
  429.          begin -- Display_face 
  430.  
  431.             if fa.skin = invisible then 
  432.                Previous_face           := fa; 
  433.                Previous_face_Invariant := fi; 
  434.                return; 
  435.             end if; 
  436.  
  437.             -------------- 
  438.             -- Material -- 
  439.             -------------- 
  440.  
  441.             if First_Face 
  442.               or else Previous_face.skin = invisible 
  443.               or else fa.skin /= Previous_face.skin 
  444.               or else (fa.skin = Previous_face.skin 
  445.                        and then fa.material /= Previous_face.material) 
  446.             then 
  447.                case fa.skin is 
  448.                when material_only | material_texture => 
  449.                   Disable (COLOR_MATERIAL); 
  450.                   Set_Material (fa.material); 
  451.                when others => 
  452.                   Set_Material (GL.Materials.neutral_material); 
  453.                end case; 
  454.             end if; 
  455.  
  456.             ------------ 
  457.             -- Colour -- 
  458.             ------------ 
  459.  
  460.             if First_Face 
  461.               or else Previous_face.skin = invisible 
  462.               or else fa.skin /= Previous_face.skin 
  463.               or else (fa.skin = Previous_face.skin 
  464.                        and then (fa.colour /= Previous_face.colour 
  465.                                  or else fa.alpha /= Previous_face.alpha)) 
  466.             then 
  467.                case fa.skin is 
  468.                when material_only | material_texture => 
  469.                   null; -- done above 
  470.                when colour_only | coloured_texture => 
  471.                   Enable (COLOR_MATERIAL); 
  472.                   ColorMaterial (FRONT_AND_BACK, AMBIENT_AND_DIFFUSE); 
  473.                   Color ( 
  474.                          red   => fa.colour.Red, 
  475.                          green => fa.colour.Green, 
  476.                          blue  => fa.colour.Blue, 
  477.                          alpha => fa.alpha 
  478.                         ); 
  479.                when texture_only => 
  480.                   Disable (COLOR_MATERIAL); 
  481.                when invisible => 
  482.                   null; 
  483.                end case; 
  484.             end if; 
  485.  
  486.             ------------- 
  487.             -- Texture -- 
  488.             ------------- 
  489.  
  490.             if is_textured (fa.skin) then 
  491.                G3DT.Check_2D_texture (fa.texture, blending_hint); 
  492.                if blending_hint then 
  493.                   fi.blending := True; 
  494.                   -- 13 - Oct - 2006 : override the decision made at Pre_calculate. 
  495.                   -- If texture data contains an alpha layer, we switch 
  496.                   -- on transparency. 
  497.                end if; 
  498.             end if; 
  499.  
  500.             if First_Face 
  501.               or else Previous_face.skin = invisible 
  502.               or else fa.skin /= Previous_face.skin 
  503.               or else (fa.skin = Previous_face.skin 
  504.                        and then fa.texture /= Previous_face.texture) 
  505.             then 
  506.                case fa.skin is 
  507.                when texture_only | coloured_texture | material_texture => 
  508.                   Enable (TEXTURE_2D); 
  509.                   GL.BindTexture (GL.TEXTURE_2D, GL.Uint (Image_ID'Pos (fa.texture) + 1)); 
  510.                   -- ^ superfluous ?!! 
  511.                when colour_only | material_only => 
  512.                   Disable (TEXTURE_2D); 
  513.                when invisible => 
  514.                   null; 
  515.                end case; 
  516.             end if; 
  517.  
  518.             ----------------------------- 
  519.             -- Blending / transparency -- 
  520.             ----------------------------- 
  521.  
  522.             if First_Face 
  523.               or else Previous_face.skin = invisible 
  524.               or else fi.blending /= Previous_face_Invariant.blending 
  525.             then 
  526.                if fi.blending then 
  527.                   Enable (BLEND); -- See 4.1.7 Blending 
  528.                   BlendFunc (sfactor => SRC_ALPHA, 
  529.                              dfactor => ONE_MINUS_SRC_ALPHA); 
  530.                   -- Disable (DEPTH_TEST); 
  531.                   -- Disable (CULL_FACE); 
  532.                else 
  533.                   Disable (BLEND); 
  534.                   -- Enable (DEPTH_TEST); 
  535.                   -- Enable (CULL_FACE); 
  536.                   -- CullFace (BACK); 
  537.                end if; 
  538.             end if; 
  539.  
  540.             ------------- 
  541.             -- Drawing -- 
  542.             ------------- 
  543.  
  544.             case fi.last_edge is 
  545.             when 3 => GL_Begin (TRIANGLES); 
  546.             when 4 => GL_Begin (QUADS); 
  547.             end case; 
  548.  
  549.             for i in 1 .. fi.last_edge loop 
  550.                if is_textured (fa.skin) then 
  551.                   TexCoord (fi.UV_extrema (i).U, fi.UV_extrema (i).V); 
  552.                end if; 
  553.                Normal (o.edge_vector (fi.P_compact (i))); 
  554.                Vertex (o.Point (fi.P_compact (i))); 
  555.             end loop; 
  556.  
  557.             GL_End; 
  558.  
  559.             Previous_face           := fa; 
  560.             Previous_face_Invariant := fi; 
  561.          end Display_face; 
  562.  
  563.       end Display_face_optimized; 
  564.  
  565.       procedure Display_normals is 
  566.  
  567.          use G3DM; 
  568.  
  569.          C : Vector_3D; 
  570.  
  571.       begin 
  572.          GL.Color (0.5, 0.5, 1.0, 1.0); 
  573.          -- show pseudo (average) normals at edges : 
  574.          for e in o.Point'Range loop 
  575.             Arrow (o.Point (e), arrow_inflator * o.edge_vector (e)); 
  576.          end loop; 
  577.          GL.Color (1.0, 1.0, 0.5, 1.0); 
  578.          -- show normals of faces : 
  579.          for f in o.face'Range loop 
  580.             C := (0.0, 0.0, 0.0); 
  581.             for i in 1 .. o.Face_Invariant (f).last_edge loop 
  582.                C := C + o.Point (o.Face_Invariant (f).P_compact (i)); 
  583.             end loop; 
  584.             C := (1.0 / Real (o.Face_Invariant (f).last_edge)) * C; 
  585.             Arrow (C, arrow_inflator * o.Face_Invariant (f).normal); 
  586.          end loop; 
  587.       end Display_normals; 
  588.  
  589.       use G3DM; 
  590.  
  591.    begin -- Display_one 
  592.  
  593.       if not o.pre_calculated then 
  594.          Pre_calculate (o); 
  595.       end if; 
  596.  
  597.       GL.BindBuffer    (GL.ARRAY_BUFFER, 0);             -- disable 'vertex buffer objects' 
  598.       GL.BindBuffer    (GL.ELEMENT_ARRAY_BUFFER, 0);     -- disable 'vertex buffer objects' indices 
  599.  
  600.       --      gl.disableClientState (gl.TEXTURE_COORD_ARRAY); 
  601.       --      gl.disable    (ALPHA_TEST); 
  602.       GL.Enable (LIGHTING); 
  603.  
  604.       GL.PushMatrix; -- 26 - May - 2006 : instead of rotating/translating back 
  605.       GL.Translate (o.Centre); 
  606.       Multiply_GL_Matrix (o.rotation); 
  607.  
  608.       -- List preparation phase 
  609.       case o.List_Status is 
  610.       when No_List | Is_List => 
  611.          null; 
  612.  
  613.       when Generate_List => 
  614.          o.List_Id := Integer (GL.GenLists (1)); 
  615.          GL.NewList (GL.Uint (o.List_Id), COMPILE_AND_EXECUTE); 
  616.       end case; 
  617.  
  618.       -- Execution phase 
  619.       case o.List_Status is 
  620.       when No_List => 
  621.          for f in o.face'Range loop 
  622.             Display_face_optimized.Display_face (True, o.face (f), o.Face_Invariant (f)); 
  623.             -- We mimic the old Display_face with redundant color, material, etc. 
  624.             -- instructions by passing True for First_Face. 
  625.          end loop; 
  626.       when Generate_List => 
  627.          for f in o.face'Range loop 
  628.             Display_face_optimized.Display_face (f = o.face'First, o.face (f), o.Face_Invariant (f)); 
  629.          end loop; 
  630.  
  631.       when Is_List => GL.CallList (GL.Uint (o.List_Id)); 
  632.       end case; 
  633.  
  634.       -- Close list 
  635.       case o.List_Status is 
  636.       when No_List | Is_List => null; 
  637.  
  638.       when Generate_List  => 
  639.          GL.EndList; 
  640.          if GL.Get_Error = OUT_OF_MEMORY then 
  641.             o.List_Status := No_List; 
  642.          else 
  643.             o.List_Status := Is_List; 
  644.          end if; 
  645.       end case; 
  646.  
  647.       if show_normals then 
  648.          pragma  Warnings (Off, "this code can never be executed and has been deleted"); 
  649.          GL.Disable (GL.LIGHTING); 
  650.          GL.Disable (GL.TEXTURE_2D); 
  651.          Display_normals; 
  652.          GL.Enable (GL.LIGHTING); -- mmmh .. . 
  653.          pragma  Warnings (On,  "this code can never be executed and has been deleted"); 
  654.       end if; 
  655.  
  656.       GL.PopMatrix; -- 26 - May - 2006 : instead of rotating/translating back 
  657.       --  GL.Rotate (o.auto_rotation (2),  0.0,  0.0, - 1.0); 
  658.       --  GL.Rotate (o.auto_rotation (1),  0.0, - 1.0,  0.0); 
  659.       --  GL.Rotate (o.auto_rotation (0), - 1.0,  0.0,  0.0); 
  660.  
  661.       --  GL.Translate ( - o.centre); 
  662.    end Display_one; 
  663.  
  664.    overriding procedure Display (o    : in out Object_3D; 
  665.                                  clip :        Clipping_data) is 
  666.  
  667.       use GLOBE_3D.Portals; 
  668.  
  669.       procedure Display_clipped (o            : in out Object_3D'Class; 
  670.                                  clip_area    :        Clipping_area; 
  671.                                  portal_depth :        Natural) is 
  672.  
  673.          procedure Try_portal (f : Positive) is 
  674.  
  675.             use G3DM; 
  676.  
  677.             dp : Real; 
  678.             plane_to_eye : Vector_3D; -- vector from any point in plane to the eye 
  679.             bounding_of_face, intersection_clip_and_face : Clipping_area; 
  680.             success, non_empty_intersection : Boolean; 
  681.  
  682.          begin 
  683.             -- Culling #1 : check if portal is in vield of view's "dead angle" 
  684.             dp := o.Face_Invariant (f).normal * clip.view_direction; 
  685.             if dp < clip.max_dot_product then 
  686.                -- Culling #2 : check if we are on the right side of the portal 
  687.                -- NB : ignores o.auto_rotation ! 
  688.                plane_to_eye := 
  689.                  clip.Eye_Position - 
  690.                    (o.Point (o.Face_Invariant (f).P_compact (1)) + o.Centre) 
  691.           ; 
  692.                dp := plane_to_eye * o.Face_Invariant (f).normal; 
  693.                -- dp = signed distance to the plane 
  694.                if dp > 0.0 then 
  695.                   -- Culling #3 : clipping rectangle 
  696.                   Find_bounding_box (o, f, bounding_of_face, success); 
  697.                   if success then 
  698.                      Intersect (clip_area, bounding_of_face, 
  699.                                 intersection_clip_and_face, non_empty_intersection); 
  700.                   else 
  701.                      -- in doubt, draw with the present clipping 
  702.                      intersection_clip_and_face := clip_area; 
  703.                      non_empty_intersection := True; 
  704.                   end if; 
  705.                   if non_empty_intersection then 
  706.                      -- Recursion here : 
  707.                      Display_clipped ( 
  708.                                       o            => o.face (f).connecting.all, 
  709.                                       clip_area    => intersection_clip_and_face, 
  710.                                       portal_depth => portal_depth + 1 
  711.                                      ); 
  712.                   end if; 
  713.                end if; 
  714.             end if; 
  715.          end Try_portal; 
  716.  
  717.       begin -- Display_clipped 
  718.          if not o.pre_calculated then 
  719.             Pre_calculate (o); 
  720.          end if; 
  721.          -- 
  722.          -- a/ Display connected objects which are visible through o's faces 
  723.          --    This is where recursion happens 
  724.          if (not filter_portal_depth) or else -- filter_portal_depth : test/debug 
  725.            portal_depth <= 6 
  726.          then 
  727.             for f in o.face'Range loop 
  728.                if o.face (f).connecting /= null and then 
  729.                  not o.Face_Invariant (f).portal_seen 
  730.                -- ^ prevents infinite recursion on rare cases where 
  731.                -- object A or B is not convex, and A and B see each other 
  732.                -- and the culling by clipping cannot stop the recursion 
  733.                -- (e.g. origin2.proc, tomb.proc) 
  734.                -- 
  735.                -- NB : drawing [different parts of] the same object several times 
  736.                -- is right, since portions can be seen through different portals, 
  737.                -- but going more than once through the same portal is wrong 
  738.                then 
  739.                   o.Face_Invariant (f).portal_seen := True; 
  740.                   Try_portal (f); 
  741.                   -- ^ recursively calls Display_clipped for 
  742.                   --   objects visible through face f. 
  743.                end if; 
  744.             end loop; 
  745.          end if; 
  746.          -- b/ Display the object itself 
  747.          if (not filter_portal_depth) or else -- filter_portal_depth : test/debug 
  748.            (portal_depth = 1 or else portal_depth = 5) 
  749.          then 
  750.             -- The graphical clipping (Scissor) gives various effects 
  751.             -- - almost no speedup on the ATI Radeon 9600 Pro (hardware) 
  752.             -- - factor : ~ Sqrt (clipped surface ratio) with software GL 
  753.             if portal_depth > 0 then 
  754.                GL.Enable (GL.SCISSOR_TEST); 
  755.                GL.Scissor (x      => GL.Int (clip_area.X1), 
  756.                            y      => GL.Int (clip_area.Y1), 
  757.                            width  => GL.Sizei (clip_area.X2 - clip_area.X1 + 1), 
  758.                            height => GL.Sizei (clip_area.Y2 - clip_area.Y1 + 1)); 
  759.             else 
  760.                GL.Disable (GL.SCISSOR_TEST); 
  761.             end if; 
  762.             info_b_ntl2 := info_b_ntl2 + 1; 
  763.             info_b_ntl3 := Natural'Max (portal_depth, info_b_ntl3); 
  764.             Display_one (o); 
  765.          end if; 
  766.          if show_portals and then portal_depth > 0 then 
  767.             pragma Warnings (Off, "this code can never be executed and has been deleted"); 
  768.             Draw_boundary (clip.main_clipping, clip_area); 
  769.             pragma Warnings (On,  "this code can never be executed and has been deleted"); 
  770.          end if; 
  771.       end Display_clipped; 
  772.  
  773.       procedure Reset_portal_seen (o : in out Object_3D'Class) is 
  774.       begin 
  775.          for f in o.face'Range loop 
  776.             if o.Face_Invariant (f).portal_seen then 
  777.                o.Face_Invariant (f).portal_seen := False; 
  778.                Reset_portal_seen (o.face (f).connecting.all); 
  779.             end if; 
  780.          end loop; 
  781.       end Reset_portal_seen; 
  782.  
  783.    begin 
  784.       info_b_ntl2 := 0; -- count amount of objects displayed, not distinct 
  785.       info_b_ntl3 := 0; -- records max depth 
  786.       Display_clipped (o, clip_area => clip.main_clipping, portal_depth => 0); 
  787.       Reset_portal_seen (o); 
  788.    end Display; 
  789.  
  790.    overriding procedure Destroy (o : in out Object_3D) is 
  791.  
  792.       ol : p_Object_3D_list := o.sub_objects; 
  793.  
  794.    begin 
  795.       while ol /= null loop 
  796.          Free (p_Visual (ol.all.objc)); 
  797.          ol := ol.all.next; 
  798.       end loop; 
  799.    end Destroy; 
  800.  
  801.    overriding procedure set_Alpha (o : in out Object_3D; Alpha : GL.Double) is 
  802.  
  803.    begin 
  804.       for f in o.face'Range loop 
  805.          o.face (f).alpha := Alpha; 
  806.       end loop; 
  807.    end set_Alpha; 
  808.  
  809.    overriding function is_Transparent (o : Object_3D) return Boolean is 
  810.  
  811.    begin 
  812.       return o.transparent; 
  813.    end is_Transparent; 
  814.  
  815.    overriding function face_Count (o : Object_3D) return Natural is 
  816.  
  817.    begin 
  818.       return o.Max_faces; 
  819.    end face_Count; 
  820.  
  821.    overriding function Bounds (o : Object_3D) return GL.Geometry.Bounds_record is 
  822.  
  823.    begin 
  824.       return o.Bounds; 
  825.    end Bounds; 
  826.  
  827.    -- Lighting support. 
  828.    -- 
  829.  
  830.    -- lights : array (Light_ident) of Light_definition; 
  831.    light_defined : array (Light_ident) of Boolean := (others => False); 
  832.  
  833.    procedure Define (which : Light_ident; as : Light_definition) is 
  834.  
  835.       id : constant GL.LightIDEnm := GL.LightIDEnm'Val (which - 1); 
  836.  
  837.    begin 
  838.       -- lights (which) := as; 
  839.       Light (id, POSITION, as.position); 
  840.       Light (id, AMBIENT,  as.ambient); 
  841.       Light (id, DIFFUSE,  as.diffuse); 
  842.       Light (id, SPECULAR, as.specular); 
  843.       light_defined (which) := True; 
  844.    end Define; 
  845.  
  846.    procedure Switch_lights (on : Boolean) is 
  847.  
  848.    begin 
  849.       for l in Light_ident loop 
  850.          Switch_light (l, on); 
  851.       end loop; 
  852.    end Switch_lights; 
  853.  
  854.    function Server_id (which : Light_ident) return GL.ServerCapabilityEnm is 
  855.  
  856.    begin 
  857.       return GL.ServerCapabilityEnm'Val (GL.ServerCapabilityEnm'Pos (GL.LIGHT0) + which - 1); 
  858.    end Server_id; 
  859.  
  860.    procedure Switch_light (which : Light_ident; on : Boolean) is 
  861.  
  862.    begin 
  863.       if light_defined (which) then 
  864.          if on then 
  865.             GL.Enable (Server_id (which)); 
  866.          else 
  867.             GL.Disable (Server_id (which)); 
  868.          end if; 
  869.       end if; 
  870.    end Switch_light; 
  871.  
  872.    function Is_light_switched (which : Light_ident) return Boolean is 
  873.  
  874.    begin 
  875.       return Boolean'Val (GL.IsEnabled (Server_id (which))); 
  876.    end Is_light_switched; 
  877.  
  878.    procedure Reverse_light_switch (which : Light_ident) is 
  879.  
  880.    begin 
  881.       Switch_light (which, not Is_light_switched (which)); 
  882.    end Reverse_light_switch; 
  883.  
  884.    prec_a360    : constant := 10000; 
  885.    r_prec_a360  : constant := 10000.0; 
  886.    i_r_prec_a360 : constant := 1.0 / r_prec_a360; 
  887.  
  888.    procedure Angles_modulo_360 (v : in out Vector_3D) is 
  889.  
  890.    begin 
  891.       for i in v'Range loop 
  892.          v (i) := 
  893.            GL.Double (Integer (r_prec_a360 * v (i)) mod (360 * prec_a360)) 
  894.            * i_r_prec_a360; 
  895.       end loop; 
  896.    end Angles_modulo_360; 
  897.  
  898.    ------------------ 
  899.    -- Resource I/O -- 
  900.    ------------------ 
  901.  
  902.    procedure Load_if_needed (zif : in out Zip.Zip_info; name : String) is 
  903.  
  904.    begin 
  905.       if not Zip.Is_loaded (zif) then 
  906.          begin 
  907.             Zip.Load (zif, name); 
  908.          exception 
  909.             when Zip.Zip_file_open_Error => -- Try with lower case : 
  910.                Zip.Load (zif, To_Lower (name)); 
  911.          end; 
  912.       end if; 
  913.    end Load_if_needed; 
  914.  
  915.    procedure Set_local_data_name (s : String) is 
  916.  
  917.    begin 
  918.       if Zip.Is_loaded (zif_level) then 
  919.          Zip.Delete (zif_level); 
  920.       end if; 
  921.       -- ^ Possible resource name change - > need this, will be reloaded on next use 
  922.       level_data_name := Ada.Strings.Unbounded.To_Unbounded_String (s); 
  923.       if not Zip.Exists (s) then 
  924.          raise data_file_not_found with s; 
  925.       end if; 
  926.    end Set_local_data_name; 
  927.  
  928.    procedure Set_global_data_name (s : String) is 
  929.  
  930.    begin 
  931.       if Zip.Is_loaded (zif_global) then 
  932.          Zip.Delete (zif_global); 
  933.       end if; 
  934.       -- ^ Possible resource name change - > need this, will be reloaded on next use 
  935.       global_data_name := Ada.Strings.Unbounded.To_Unbounded_String (s); 
  936.       if not Zip.Exists (s) then 
  937.          raise data_file_not_found with s; 
  938.       end if; 
  939.    end Set_global_data_name; 
  940.  
  941.    procedure Set_name (o : in out Visual'class; new_name : String) is 
  942.  
  943.    begin 
  944.       if new_name'Length > Ident'Length then 
  945.          raise Constraint_Error; 
  946.       end if; 
  947.       o.ID := empty; 
  948.       o.ID (1 .. new_name'Length) := new_name; 
  949.    end Set_name; 
  950.  
  951.    function Get_name (o : Visual'class) return String is 
  952.  
  953.    begin 
  954.       return Trim (o.ID, Right); 
  955.    end Get_name; 
  956.  
  957.    procedure Rebuild_links (o            : in out Object_3D'Class; -- object to be relinked 
  958.                             neighbouring :        Map_of_Visuals;  -- neighbourhood 
  959.                             tolerant_obj :        Boolean;         -- tolerant on missing objects 
  960.                             tolerant_tex :        Boolean          -- tolerant on missing textures 
  961.                            ) is 
  962.  
  963.       found : Boolean; 
  964.  
  965.    begin 
  966.       for f in o.face'Range loop 
  967.          -- 1/ Find texture IDs : 
  968.          if is_textured (o.face (f).skin) and then 
  969.            o.Face_Invariant (f).texture_name /= empty 
  970.          then 
  971.             begin 
  972.                o.face (f).texture := 
  973.                  Textures.Texture_ID (o.Face_Invariant (f).texture_name); 
  974.             exception 
  975.                when Textures.Texture_name_not_found => 
  976.                   if tolerant_tex then 
  977.                      o.face (f).texture := null_image; 
  978.                      o.face (f).skin := material_only; 
  979.                   else 
  980.                      raise; 
  981.                   end if; 
  982.             end; 
  983.          end if; 
  984.          -- 2/ Connections through portals : 
  985.          if o.Face_Invariant (f).connect_name /= empty then 
  986.             found := False; 
  987.             -- XX old linear search : 
  988.             --  for i in neighbouring'Range loop 
  989.             --    if neighbouring (i).ID = o.face_invariant (f).connect_name then 
  990.             --      o.face (f).connecting := neighbouring (i); 
  991.             --      found := True; 
  992.             --      exit; 
  993.             --    end if; 
  994.             --  end loop; 
  995.             begin 
  996.                o.face (f).connecting := p_Object_3D (Visuals_Mapping.Element ( 
  997.                                                      Visuals_Mapping.Map (neighbouring), 
  998.                                                      Ada.Strings.Unbounded.To_Unbounded_String (o.Face_Invariant (f).connect_name)) 
  999.                                                     ); 
  1000.  
  1001.                found := True; 
  1002.             exception 
  1003.                when Constraint_Error => 
  1004.                   -- GNAT gives also the message : 
  1005.                   -- no element available because key not in map 
  1006.                   null; 
  1007.             end; 
  1008.             if not found then 
  1009.                if tolerant_obj then 
  1010.                   o.face (f).connecting := null; 
  1011.                else 
  1012.                   Raise_Exception ( 
  1013.                                    Portal_connection_failed'Identity, 
  1014.                                    "For object name [" & Trim (o.ID, Right) & 
  1015.                                      "], looking for [" & 
  1016.                                      Trim (o.Face_Invariant (f).connect_name, Right) 
  1017.                                    & ']' 
  1018.                                   ); 
  1019.                end if; 
  1020.             end if; 
  1021.          end if; 
  1022.       end loop; 
  1023.    end Rebuild_links; 
  1024.  
  1025.    procedure Texture_name_hint (o    : in out Object_3D; 
  1026.                                 face :        Positive; 
  1027.                                 name :        String 
  1028.                                ) is 
  1029.  
  1030.    begin 
  1031.       if name'Length > Ident'Length then 
  1032.          raise Constraint_Error; 
  1033.       end if; 
  1034.       o.Face_Invariant (face).texture_name := empty; 
  1035.       o.Face_Invariant (face).texture_name (1 .. name'Length) := name; 
  1036.    end Texture_name_hint; 
  1037.  
  1038.    procedure Portal_name_hint (o   : in out Object_3D; 
  1039.                                face :        Positive; 
  1040.                                name :        String 
  1041.                               ) is 
  1042.  
  1043.    begin 
  1044.       if name'Length > Ident'Length then 
  1045.          raise Constraint_Error; 
  1046.       end if; 
  1047.       o.Face_Invariant (face).connect_name := empty; 
  1048.       o.Face_Invariant (face).connect_name (1 .. name'Length) := name; 
  1049.    end Portal_name_hint; 
  1050.  
  1051.    ---------------------------------------- 
  1052.    -- tbd : has been moved (for the moment) external to 'render' for performance, but this makes package task unsafe ! 
  1053.    -- 
  1054.    -- 
  1055.    type Visual_Geometry is 
  1056.       record 
  1057.          Visual   : p_Visual; 
  1058.          Geometry : GL.Skinned_Geometry.Skinned_Geometry_t; 
  1059.       end record; 
  1060.    pragma Convention (C, Visual_Geometry);  -- using convention pragma to disable default initialization (for performance) 
  1061.  
  1062.    type Visual_Geometries is array (Positive range <>) of Visual_Geometry; 
  1063.    pragma Convention (C, Visual_Geometries);  -- using convention pragma to disable default initialization (for performance) 
  1064.  
  1065.    All_Geometries : Visual_Geometries (1 .. 80_000);   pragma Convention (C, All_Geometries);  -- tbd : this is slow ! 
  1066.    -- 
  1067.    -------------------------------------- 
  1068.  
  1069.    procedure render (the_Visuals : Visual_array; the_Camera : Camera) is 
  1070.  
  1071.       use REF, G3DM; 
  1072.  
  1073.       all_Transparents  : GLOBE_3D.Visual_array (1 .. 10_000); 
  1074.       transparent_Count : Natural   := 0; 
  1075.  
  1076.       geometry_Count    : Natural   := 0;   -- for 'all_Geometrys' array. 
  1077.  
  1078.       current_Skin      : GL.Skins.p_Skin; 
  1079.  
  1080.    begin 
  1081.       -- prepare openGL to display visuals. 
  1082.       -- 
  1083.       Clear    (COLOR_BUFFER_BIT or DEPTH_BUFFER_BIT); 
  1084.       Enable   (DEPTH_TEST); 
  1085.  
  1086.       Enable   (LIGHTING);                               -- enable lighting for G3D.Display in 'separate Visuals' (obsolete). 
  1087.       Enable   (CULL_FACE); 
  1088.       CullFace (BACK); 
  1089.  
  1090.       MatrixMode    (MODELVIEW); 
  1091.       Set_GL_Matrix (the_Camera.World_Rotation); 
  1092.       Translate     (-the_Camera.Clipper.Eye_Position (0),  -the_Camera.Clipper.Eye_Position (1),  -the_Camera.Clipper.Eye_Position (2)); 
  1093.  
  1094.       PushMatrix; 
  1095.  
  1096.       -- separate Visuals 
  1097.       -- 
  1098.       for Each_Visual in the_Visuals'Range loop 
  1099.          declare 
  1100.             the_Visual       : Visual'Class                          renames the_Visuals (Each_Visual).all; 
  1101.             visual_Geometrys : GL.Skinned_Geometry.skinned_Geometrys renames skinned_Geometrys (the_Visual); 
  1102.          begin 
  1103.             if is_Transparent (the_Visual) then 
  1104.                transparent_Count                    := transparent_Count + 1; 
  1105.                all_Transparents (transparent_Count) := the_Visual'Access; 
  1106.             else 
  1107.                for Each_Geometry in visual_Geometrys'Range loop 
  1108.                   geometry_Count                          := geometry_Count + 1; 
  1109.                   All_Geometries (geometry_Count).Visual   := the_Visual'Access; 
  1110.                   All_Geometries (geometry_Count).Geometry := visual_Geometrys (Each_Geometry); 
  1111.                end loop; 
  1112.  
  1113.                Display (the_Visuals (Each_Visual).all,  the_Camera.Clipper); 
  1114.             end if; 
  1115.          end; 
  1116.       end loop; 
  1117.  
  1118.       GL.Errors.log; 
  1119.  
  1120.       -- display all opaque geometries, sorted by gl geometry primitive kind and skin. 
  1121.       -- 
  1122.       declare 
  1123.  
  1124. --           pragma Warnings (Off, "declaration of ""<"" hides predefined operator"); 
  1125.          function "<" (L, R : Visual_Geometry) return Boolean is 
  1126. --              pragma Warnings (On, "declaration of ""<"" hides predefined operator"); 
  1127.  
  1128.             use GL.Geometry, System.Storage_Elements; 
  1129.  
  1130.          begin 
  1131.             if primitive_Id (L.Geometry.Geometry.all)  =  primitive_Id (R.Geometry.Geometry.all) then   -- tbd : find better naming scheme to avoid '.Geometry.Geometry.' 
  1132.                return To_Integer (L.Geometry.Skin.all'Address) < To_Integer (R.Geometry.Skin.all'Address); -- tbd : check this is safe/portable 
  1133.                -- GdM : aaargh! remove that !! 
  1134.             else 
  1135.                return primitive_Id (L.Geometry.Geometry.all) < primitive_Id (R.Geometry.Geometry.all); 
  1136.             end if; 
  1137.          end "<"; 
  1138.  
  1139.          procedure sort is new Ada.Containers.Generic_Array_Sort (Positive, 
  1140.                                                                   Visual_Geometry, 
  1141.                                                                   Visual_Geometries); 
  1142.          use GL.Skins, GL.Geometry, GL.Skinned_Geometry; 
  1143.  
  1144.          current_Visual : p_Visual; 
  1145.  
  1146.       begin 
  1147.          if geometry_Count > 1 then 
  1148.             sort (All_Geometries (1 .. geometry_Count)); 
  1149.          end if; 
  1150.  
  1151.          GL.PushMatrix; 
  1152.  
  1153.          for Each in 1 .. geometry_Count loop 
  1154.  
  1155.             if All_Geometries (Each).Geometry.Skin /= current_Skin then 
  1156.                current_Skin := All_Geometries (Each).Geometry.Skin; 
  1157.                Enable (current_Skin.all); 
  1158.                GL.Errors.log; 
  1159.             end if; 
  1160.  
  1161.             if All_Geometries (Each).Geometry.Veneer /= null then 
  1162.                Enable (All_Geometries (Each).Geometry.Veneer.all); 
  1163.                GL.Errors.log; 
  1164.             end if; 
  1165.  
  1166.             if All_Geometries (Each).Visual = current_Visual then 
  1167.                Draw (All_Geometries (Each).Geometry.Geometry.all); 
  1168.                GL.Errors.log; 
  1169.             else 
  1170.                GL.PopMatrix; 
  1171.                GL.PushMatrix; 
  1172.                GL.Translate       (All_Geometries (Each).Visual.all.Centre); 
  1173.                Multiply_GL_Matrix (All_Geometries (Each).Visual.all.rotation); 
  1174.  
  1175.                Draw (All_Geometries (Each).Geometry.Geometry.all); 
  1176.                GL.Errors.log; 
  1177.  
  1178.                current_Visual := All_Geometries (Each).Visual; 
  1179.             end if; 
  1180.  
  1181.          end loop; 
  1182.  
  1183.          GL.PopMatrix; 
  1184.       end; 
  1185.  
  1186.       GL.Errors.log; 
  1187.  
  1188.       -- display all transparent visuals, sorted from far to near. 
  1189.       -- 
  1190.       declare 
  1191.  
  1192. --           pragma Warnings (Off, "declaration of ""<"" hides predefined operator"); 
  1193.          function "<" (L, R : GLOBE_3D.p_Visual) return Boolean is -- tbd : ugh move expensive calcs outside 
  1194. --              pragma Warnings (On, "declaration of ""<"" hides predefined operator"); 
  1195.  
  1196.          begin 
  1197.             return L.all.Centre_Camera_Space (2) < R.all.Centre_Camera_Space (2);  -- nb : in camera space, negative Z is forward, so use '<'. 
  1198.          end "<"; 
  1199.  
  1200.          -- procedure sort is new Ada.Containers.Generic_Array_Sort (Positive, 
  1201.          procedure sort is new Ada.Containers.Generic_Array_Sort (Positive, 
  1202.                                                                   GLOBE_3D.p_Visual, 
  1203.                                                                   GLOBE_3D.Visual_array); 
  1204.       begin 
  1205.          for Each in 1 .. transparent_Count loop  -- pre - calculate each visuals Centre in camera space. 
  1206.             all_Transparents (Each).all.Centre_Camera_Space :=   the_Camera.World_Rotation 
  1207.               * (all_Transparents (Each).all.Centre - the_Camera.Clipper.Eye_Position); 
  1208.          end loop; 
  1209.  
  1210.          if transparent_Count > 1 then 
  1211.             sort (all_Transparents (1 .. transparent_Count)); 
  1212.          end if; 
  1213.  
  1214.          GL.Depth_Mask (GL_False);  -- make depth buffer read - only, for correct transparency 
  1215.  
  1216.          Enable    (LIGHTING);   -- ensure lighting is enabled for G3D.Display of transparents (obsolete). 
  1217.          Enable    (BLEND); 
  1218.          BlendFunc (sfactor => ONE, 
  1219.                     dfactor => ONE_MINUS_SRC_ALPHA); 
  1220.  
  1221.          for Each_Transparency in 1 .. transparent_Count loop 
  1222.             declare 
  1223.                the_Visual       : Visual'Class                          renames all_Transparents (Each_Transparency).all; 
  1224.                visual_Geometrys : constant GL.Skinned_Geometry.skinned_Geometrys      := skinned_Geometrys (the_Visual); -- tbd : apply ogl state sorting here ? 
  1225.             begin 
  1226.                Display (the_Visual,  the_Camera.Clipper); 
  1227.                GL.Errors.log; 
  1228.  
  1229.                for Each_Geometry in visual_Geometrys'Range loop 
  1230.                   declare 
  1231.                      use GL.Skins, GL.Geometry; 
  1232.                      the_Geometry : GL.Skinned_Geometry.Skinned_Geometry_t renames visual_Geometrys (Each_Geometry); 
  1233.                   begin 
  1234.  
  1235.                      if the_Geometry.Skin /= current_Skin then 
  1236.                         current_Skin := the_Geometry.Skin; 
  1237.                         Enable (current_Skin.all); 
  1238.                         GL.Errors.log; 
  1239.                      end if; 
  1240.  
  1241.                      if the_Geometry.Veneer /= null then 
  1242.                         Enable (the_Geometry.Veneer.all); 
  1243.                         GL.Errors.log; 
  1244.                      end if; 
  1245.  
  1246.                      GL.PushMatrix; 
  1247.  
  1248.                      GL.Translate       (the_Visual.Centre); 
  1249.                      Multiply_GL_Matrix (the_Visual.rotation); 
  1250.  
  1251.                      Draw (the_Geometry.Geometry.all); 
  1252.                      GL.Errors.log; 
  1253.  
  1254.                      GL.PopMatrix; 
  1255.                   end; 
  1256.                end loop; 
  1257.  
  1258.             end; 
  1259.          end loop; 
  1260.  
  1261.          GL.Depth_Mask (GL_True); 
  1262.       end; 
  1263.  
  1264.       PopMatrix; 
  1265.  
  1266.       GL.Errors.log;      -- tbd : for debug only 
  1267.    end render; 
  1268.  
  1269.    function empty_map return Map_of_Visuals is 
  1270.       thing : Map_of_Visuals; 
  1271.    begin 
  1272.       Visuals_Mapping.Map (thing) := Visuals_Mapping.Empty_Map; 
  1273.       return thing; 
  1274.    end empty_map; 
  1275.  
  1276.    procedure Add (to_map : in out Map_of_Visuals; what : p_Visual) is 
  1277.       pos : Visuals_Mapping.Cursor; 
  1278.       success : Boolean; 
  1279.    begin 
  1280.       Visuals_Mapping.Insert ( 
  1281.                               Visuals_Mapping.Map (to_map), 
  1282.                               Ada.Strings.Unbounded.To_Unbounded_String (what.all.ID), 
  1283.                               what, 
  1284.                               pos, 
  1285.                               success 
  1286.                              ); 
  1287.       if not success then -- A.18.4. 45/2 
  1288.          raise Duplicate_name with what.all.ID; 
  1289.       end if; 
  1290.    end Add; 
  1291.  
  1292.    function Map_of (va : Visual_array) return Map_of_Visuals is 
  1293.       res : Map_of_Visuals := empty_map; 
  1294.    begin 
  1295.       -- Perhaps Reserve_Capacity would be good here ?? 
  1296.       for i in va'Range loop 
  1297.          Add (res, va (i)); 
  1298.       end loop; 
  1299.       return res; 
  1300.    end Map_of; 
  1301.  
  1302. end GLOBE_3D;