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) then 
  340.             Raise_Exception (Textures.Undefined_texture_ID'Identity, 
  341.                              Trim (o.ID, Right) & 
  342.                                " face ="   & Integer'Image (f) & 
  343.                                " skin ="   & Skin_Type'Image (o.face (f).skin) & 
  344.                                " texture_id =" & Image_ID'Image (o.face (f).texture)); 
  345.          end if; 
  346.       end loop; 
  347.       for p in o.Point'Range loop 
  348.          if adjacent_faces (p) = 0 then 
  349.             if strict_geometry then 
  350.                pragma Warnings (Off, "this code can never be executed and has been deleted"); 
  351.                -- Strict approach : detect any unmatched point : 
  352.                Raise_Exception (point_unmatched'Identity, 
  353.                                 Trim (o.ID, Right) & 
  354.                                   " point " & Integer'Image (p) & 
  355.                                   " belongs to none of the object's face"); 
  356.                pragma Warnings (On,  "this code can never be executed and has been deleted"); 
  357.             end if; 
  358.          else 
  359.             length := Norm (o.edge_vector (p)); 
  360.             if not Almost_zero (length) then 
  361.                o.edge_vector (p) := (1.0/length) * o.edge_vector (p); 
  362.             end if; 
  363.          end if; 
  364.       end loop; 
  365.  
  366.       -- Ooof. Now we can certify : 
  367.       o.pre_calculated := True; 
  368.    end Pre_calculate; 
  369.  
  370.    procedure Arrow (P : Point_3D; D : Vector_3D) is 
  371.        
  372.       use G3DM; 
  373.        
  374.       V, V1, V2 : Vector_3D; 
  375.     
  376.    begin 
  377.       if Almost_zero (Norm2 (D)) then 
  378.          return; 
  379.       end if; 
  380.       V := (D (1), -D (0), 0.0);         -- an orthogonal, or zero 
  381.       if Almost_zero (Norm2 (V)) then -- bad luck, it is zero 
  382.          V := (0.0, -D (2), D (1));       -- 2nd try 
  383.       end if; 
  384.       V := (0.2/Norm (V)) * V; 
  385.       V1 := 0.7 * D + V; 
  386.       V2 := 0.7 * D - V; 
  387.       GL_Begin (GL.LINES); 
  388.       Vertex (P + D);    Vertex (P); 
  389.       Vertex (P + D);    Vertex (P + V1); 
  390.       Vertex (P + D);    Vertex (P + V2); 
  391.       GL_End; 
  392.    end Arrow; 
  393.  
  394.    --     neutral_material_already_set : Boolean := False; 
  395.  
  396.    ------------- 
  397.    -- Display -- 
  398.    ------------- 
  399.  
  400.    procedure Display_one (o : in out Object_3D) is 
  401.       -- Display only this object and not connected objects 
  402.       -- out : object will be initialized if not yet 
  403.  
  404.       -- 
  405.  
  406.       -- 
  407.       -- Display face routine which is optimized to produce a shorter list 
  408.       -- of GL commands. Runs slower then the original Display face routine 
  409.       -- yet needs to be executed only once. 
  410.       -- 
  411.       -- Uwe R. Zimmer, July 2011 
  412.       -- 
  413.       package Display_face_optimized is 
  414.          procedure Display_face (First_Face : Boolean; fa : Face_type; fi : in out Face_invariant_type); 
  415.       private 
  416.          Previous_face           : Face_type; 
  417.          Previous_face_Invariant : Face_invariant_type; 
  418.       end Display_face_optimized; 
  419.  
  420.       package body Display_face_optimized is 
  421.  
  422.          use GL.Materials; 
  423.  
  424.          procedure Display_face (First_Face : Boolean; fa : Face_type; fi : in out Face_invariant_type) is 
  425.  
  426.             blending_hint : Boolean; 
  427.  
  428.          begin -- Display_face 
  429.  
  430.             if fa.skin = invisible then 
  431.                Previous_face           := fa; 
  432.                Previous_face_Invariant := fi; 
  433.                return; 
  434.             end if; 
  435.  
  436.             -------------- 
  437.             -- Material -- 
  438.             -------------- 
  439.  
  440.             if First_Face 
  441.               or else Previous_face.skin = invisible 
  442.               or else fa.skin /= Previous_face.skin 
  443.               or else (fa.skin = Previous_face.skin 
  444.                        and then fa.material /= Previous_face.material) then 
  445.                case fa.skin is 
  446.                when material_only | material_texture => 
  447.                   Disable (COLOR_MATERIAL); 
  448.                   Set_Material (fa.material); 
  449.                when others => 
  450.                   Set_Material (GL.Materials.neutral_material); 
  451.                end case; 
  452.             end if; 
  453.  
  454.             ------------ 
  455.             -- Colour -- 
  456.             ------------ 
  457.  
  458.             if First_Face 
  459.               or else Previous_face.skin = invisible 
  460.               or else fa.skin /= Previous_face.skin 
  461.               or else (fa.skin = Previous_face.skin 
  462.                        and then (fa.colour /= Previous_face.colour 
  463.                                  or else fa.alpha /= Previous_face.alpha)) then 
  464.                case fa.skin is 
  465.                when material_only | material_texture => 
  466.                   null; -- done above 
  467.                when colour_only | coloured_texture => 
  468.                   Enable (COLOR_MATERIAL); 
  469.                   ColorMaterial (FRONT_AND_BACK, AMBIENT_AND_DIFFUSE); 
  470.                   Color ( 
  471.                          red   => fa.colour.Red, 
  472.                          green => fa.colour.Green, 
  473.                          blue  => fa.colour.Blue, 
  474.                          alpha => fa.alpha 
  475.                         ); 
  476.                when texture_only => 
  477.                   Disable (COLOR_MATERIAL); 
  478.                when invisible => 
  479.                   null; 
  480.                end case; 
  481.             end if; 
  482.  
  483.             ------------- 
  484.             -- Texture -- 
  485.             ------------- 
  486.  
  487.             if is_textured (fa.skin) then 
  488.                G3DT.Check_2D_texture (fa.texture, blending_hint); 
  489.                if blending_hint then 
  490.                   fi.blending := True; 
  491.                   -- 13 - Oct - 2006 : override the decision made at Pre_calculate. 
  492.                   -- If texture data contains an alpha layer, we switch 
  493.                   -- on transparency. 
  494.                end if; 
  495.             end if; 
  496.  
  497.             if First_Face 
  498.               or else Previous_face.skin = invisible 
  499.               or else fa.skin /= Previous_face.skin 
  500.               or else (fa.skin = Previous_face.skin 
  501.                        and then fa.texture /= Previous_face.texture) then 
  502.                case fa.skin is 
  503.                when texture_only | coloured_texture | material_texture => 
  504.                   Enable (TEXTURE_2D); 
  505.                   GL.BindTexture (GL.TEXTURE_2D, GL.Uint (Image_ID'Pos (fa.texture) + 1)); 
  506.                   -- ^ superfluous ?!! 
  507.                when colour_only | material_only => 
  508.                   Disable (TEXTURE_2D); 
  509.                when invisible => 
  510.                   null; 
  511.                end case; 
  512.             end if; 
  513.  
  514.             ----------------------------- 
  515.             -- Blending / transparency -- 
  516.             ----------------------------- 
  517.  
  518.             if First_Face 
  519.               or else Previous_face.skin = invisible 
  520.               or else fi.blending /= Previous_face_Invariant.blending then 
  521.                if fi.blending then 
  522.                   Enable (BLEND); -- See 4.1.7 Blending 
  523.                   BlendFunc (sfactor => SRC_ALPHA, 
  524.                              dfactor => ONE_MINUS_SRC_ALPHA); 
  525.                   -- Disable (DEPTH_TEST); 
  526.                   -- Disable (CULL_FACE); 
  527.                else 
  528.                   Disable (BLEND); 
  529.                   -- Enable (DEPTH_TEST); 
  530.                   -- Enable (CULL_FACE); 
  531.                   -- CullFace (BACK); 
  532.                end if; 
  533.             end if; 
  534.  
  535.             ------------- 
  536.             -- Drawing -- 
  537.             ------------- 
  538.  
  539.             case fi.last_edge is 
  540.             when 3 => GL_Begin (TRIANGLES); 
  541.             when 4 => GL_Begin (QUADS); 
  542.             end case; 
  543.  
  544.             for i in 1 .. fi.last_edge loop 
  545.                if is_textured (fa.skin) then 
  546.                   TexCoord (fi.UV_extrema (i).U, fi.UV_extrema (i).V); 
  547.                end if; 
  548.                Normal (o.edge_vector (fi.P_compact (i))); 
  549.                Vertex (o.Point (fi.P_compact (i))); 
  550.             end loop; 
  551.  
  552.             GL_End; 
  553.  
  554.             Previous_face           := fa; 
  555.             Previous_face_Invariant := fi; 
  556.          end Display_face; 
  557.  
  558.       end Display_face_optimized; 
  559.  
  560.       procedure Display_normals is 
  561.          
  562.          use G3DM; 
  563.           
  564.          C : Vector_3D; 
  565.        
  566.       begin 
  567.          GL.Color (0.5, 0.5, 1.0, 1.0); 
  568.          -- show pseudo (average) normals at edges : 
  569.          for e in o.Point'Range loop 
  570.             Arrow (o.Point (e), arrow_inflator * o.edge_vector (e)); 
  571.          end loop; 
  572.          GL.Color (1.0, 1.0, 0.5, 1.0); 
  573.          -- show normals of faces : 
  574.          for f in o.face'Range loop 
  575.             C := (0.0, 0.0, 0.0); 
  576.             for i in 1 .. o.Face_Invariant (f).last_edge loop 
  577.                C := C + o.Point (o.Face_Invariant (f).P_compact (i)); 
  578.             end loop; 
  579.             C := (1.0/Real (o.Face_Invariant (f).last_edge)) * C; 
  580.             Arrow (C, arrow_inflator * o.Face_Invariant (f).normal); 
  581.          end loop; 
  582.       end Display_normals; 
  583.  
  584.       use G3DM; 
  585.  
  586.    begin -- Display_one 
  587.  
  588.       if not o.pre_calculated then 
  589.          Pre_calculate (o); 
  590.       end if; 
  591.  
  592.       GL.BindBuffer    (GL.ARRAY_BUFFER, 0);             -- disable 'vertex buffer objects' 
  593.       GL.BindBuffer    (GL.ELEMENT_ARRAY_BUFFER, 0);     -- disable 'vertex buffer objects' indices 
  594.  
  595.       --      gl.disableClientState (gl.TEXTURE_COORD_ARRAY); 
  596.       --      gl.disable    (ALPHA_TEST); 
  597.       GL.Enable (LIGHTING); 
  598.  
  599.       GL.PushMatrix; -- 26 - May - 2006 : instead of rotating/translating back 
  600.       GL.Translate (o.Centre); 
  601.       Multiply_GL_Matrix (o.rotation); 
  602.  
  603.       -- List preparation phase 
  604.       case o.List_Status is 
  605.       when No_List | Is_List => 
  606.          null; 
  607.  
  608.       when Generate_List => 
  609.          o.List_Id := Integer (GL.GenLists (1)); 
  610.          GL.NewList (GL.Uint (o.List_Id), COMPILE_AND_EXECUTE); 
  611.       end case; 
  612.  
  613.       -- Execution phase 
  614.       case o.List_Status is 
  615.       when No_List => 
  616.          for f in o.face'Range loop 
  617.             Display_face_optimized.Display_face (True, o.face (f), o.Face_Invariant (f)); 
  618.             -- We mimic the old Display_face with redundant color, material, etc. 
  619.             -- instructions by passing True for First_Face. 
  620.          end loop; 
  621.       when Generate_List => 
  622.          for f in o.face'Range loop 
  623.             Display_face_optimized.Display_face (f = o.face'First, o.face (f), o.Face_Invariant (f)); 
  624.          end loop; 
  625.  
  626.       when Is_List => GL.CallList (GL.Uint (o.List_Id)); 
  627.       end case; 
  628.  
  629.       -- Close list 
  630.       case o.List_Status is 
  631.       when No_List | Is_List => null; 
  632.  
  633.       when Generate_List  => 
  634.          GL.EndList; 
  635.          if GL.Get_Error = OUT_OF_MEMORY then 
  636.             o.List_Status := No_List; 
  637.          else 
  638.             o.List_Status := Is_List; 
  639.          end if; 
  640.       end case; 
  641.  
  642.       if show_normals then 
  643.          pragma  Warnings (Off, "this code can never be executed and has been deleted"); 
  644.          GL.Disable (GL.LIGHTING); 
  645.          GL.Disable (GL.TEXTURE_2D); 
  646.          Display_normals; 
  647.          GL.Enable (GL.LIGHTING); -- mmmh .. . 
  648.          pragma  Warnings (On,  "this code can never be executed and has been deleted"); 
  649.       end if; 
  650.  
  651.       GL.PopMatrix; -- 26 - May - 2006 : instead of rotating/translating back 
  652.       --  GL.Rotate (o.auto_rotation (2),  0.0,  0.0, - 1.0); 
  653.       --  GL.Rotate (o.auto_rotation (1),  0.0, - 1.0,  0.0); 
  654.       --  GL.Rotate (o.auto_rotation (0), - 1.0,  0.0,  0.0); 
  655.  
  656.       --  GL.Translate ( - o.centre); 
  657.    end Display_one; 
  658.  
  659.    overriding procedure Display (o    : in out Object_3D; 
  660.                                  clip :        Clipping_data) is 
  661.  
  662.       use GLOBE_3D.Portals; 
  663.  
  664.       procedure Display_clipped (o            : in out Object_3D'Class; 
  665.                                  clip_area    :        Clipping_area; 
  666.                                  portal_depth :        Natural) is 
  667.  
  668.          procedure Try_portal (f : Positive) is 
  669.  
  670.             use G3DM; 
  671.              
  672.             dp : Real; 
  673.             plane_to_eye : Vector_3D; -- vector from any point in plane to the eye 
  674.             bounding_of_face, intersection_clip_and_face : Clipping_area; 
  675.             success, non_empty_intersection : Boolean; 
  676.  
  677.          begin 
  678.             -- Culling #1 : check if portal is in vield of view's "dead angle" 
  679.             dp := o.Face_Invariant (f).normal * clip.view_direction; 
  680.             if dp < clip.max_dot_product then 
  681.                -- Culling #2 : check if we are on the right side of the portal 
  682.                -- NB : ignores o.auto_rotation ! 
  683.                plane_to_eye := 
  684.                  clip.Eye_Position - 
  685.                    (o.Point (o.Face_Invariant (f).P_compact (1)) + o.Centre) 
  686.           ; 
  687.                dp := plane_to_eye * o.Face_Invariant (f).normal; 
  688.                -- dp = signed distance to the plane 
  689.                if dp > 0.0 then 
  690.                   -- Culling #3 : clipping rectangle 
  691.                   Find_bounding_box (o, f, bounding_of_face, success); 
  692.                   if success then 
  693.                      Intersect (clip_area, bounding_of_face, 
  694.                                 intersection_clip_and_face, non_empty_intersection); 
  695.                   else 
  696.                      -- in doubt, draw with the present clipping 
  697.                      intersection_clip_and_face := clip_area; 
  698.                      non_empty_intersection := True; 
  699.                   end if; 
  700.                   if non_empty_intersection then 
  701.                      -- Recursion here : 
  702.                      Display_clipped ( 
  703.                                       o            => o.face (f).connecting.all, 
  704.                                       clip_area    => intersection_clip_and_face, 
  705.                                       portal_depth => portal_depth + 1 
  706.                                      ); 
  707.                   end if; 
  708.                end if; 
  709.             end if; 
  710.          end Try_portal; 
  711.  
  712.       begin -- Display_clipped 
  713.          if not o.pre_calculated then 
  714.             Pre_calculate (o); 
  715.          end if; 
  716.          -- 
  717.          -- a/ Display connected objects which are visible through o's faces 
  718.          --    This is where recursion happens 
  719.          if (not filter_portal_depth) or else -- filter_portal_depth : test/debug 
  720.            portal_depth <= 6 
  721.          then 
  722.             for f in o.face'Range loop 
  723.                if o.face (f).connecting /= null and then 
  724.                  not o.Face_Invariant (f).portal_seen 
  725.                -- ^ prevents infinite recursion on rare cases where 
  726.                -- object A or B is not convex, and A and B see each other 
  727.                -- and the culling by clipping cannot stop the recursion 
  728.                -- (e.g. origin2.proc, tomb.proc) 
  729.                -- 
  730.                -- NB : drawing [different parts of] the same object several times 
  731.                -- is right, since portions can be seen through different portals, 
  732.                -- but going more than once through the same portal is wrong 
  733.                then 
  734.                   o.Face_Invariant (f).portal_seen := True; 
  735.                   Try_portal (f); 
  736.                   -- ^ recursively calls Display_clipped for 
  737.                   --   objects visible through face f. 
  738.                end if; 
  739.             end loop; 
  740.          end if; 
  741.          -- b/ Display the object itself 
  742.          if (not filter_portal_depth) or else -- filter_portal_depth : test/debug 
  743.            (portal_depth = 1 or else portal_depth = 5) 
  744.          then 
  745.             -- The graphical clipping (Scissor) gives various effects 
  746.             -- - almost no speedup on the ATI Radeon 9600 Pro (hardware) 
  747.             -- - factor : ~ Sqrt (clipped surface ratio) with software GL 
  748.             if portal_depth > 0 then 
  749.                GL.Enable (GL.SCISSOR_TEST); 
  750.                GL.Scissor (x      => GL.Int (clip_area.X1), 
  751.                            y      => GL.Int (clip_area.Y1), 
  752.                            width  => GL.Sizei (clip_area.X2 - clip_area.X1 + 1), 
  753.                            height => GL.Sizei (clip_area.Y2 - clip_area.Y1 + 1)); 
  754.             else 
  755.                GL.Disable (GL.SCISSOR_TEST); 
  756.             end if; 
  757.             info_b_ntl2 := info_b_ntl2 + 1; 
  758.             info_b_ntl3 := Natural'Max (portal_depth, info_b_ntl3); 
  759.             Display_one (o); 
  760.          end if; 
  761.          if show_portals and then portal_depth > 0 then 
  762.             pragma Warnings (Off, "this code can never be executed and has been deleted"); 
  763.             Draw_boundary (clip.main_clipping, clip_area); 
  764.             pragma Warnings (On,  "this code can never be executed and has been deleted"); 
  765.          end if; 
  766.       end Display_clipped; 
  767.  
  768.       procedure Reset_portal_seen (o : in out Object_3D'Class) is 
  769.       begin 
  770.          for f in o.face'Range loop 
  771.             if o.Face_Invariant (f).portal_seen then 
  772.                o.Face_Invariant (f).portal_seen := False; 
  773.                Reset_portal_seen (o.face (f).connecting.all); 
  774.             end if; 
  775.          end loop; 
  776.       end Reset_portal_seen; 
  777.  
  778.    begin 
  779.       info_b_ntl2 := 0; -- count amount of objects displayed, not distinct 
  780.       info_b_ntl3 := 0; -- records max depth 
  781.       Display_clipped (o, clip_area => clip.main_clipping, portal_depth => 0); 
  782.       Reset_portal_seen (o); 
  783.    end Display; 
  784.  
  785.    overriding procedure Destroy (o : in out Object_3D) is 
  786.  
  787.       ol : p_Object_3D_list := o.sub_objects; 
  788.  
  789.    begin 
  790.       while ol /= null loop 
  791.          Free (p_Visual (ol.all.objc)); 
  792.          ol := ol.all.next; 
  793.       end loop; 
  794.    end Destroy; 
  795.  
  796.    overriding procedure set_Alpha (o : in out Object_3D; Alpha : GL.Double) is 
  797.  
  798.    begin 
  799.       for f in o.face'Range loop 
  800.          o.face (f).alpha := Alpha; 
  801.       end loop; 
  802.    end set_Alpha; 
  803.  
  804.    overriding function is_Transparent (o : Object_3D) return Boolean is 
  805.  
  806.    begin 
  807.       return o.transparent; 
  808.    end is_Transparent; 
  809.  
  810.    overriding function face_Count (o : Object_3D) return Natural is 
  811.  
  812.    begin 
  813.       return o.Max_faces; 
  814.    end face_Count; 
  815.  
  816.    overriding function Bounds (o : Object_3D) return GL.Geometry.Bounds_record is 
  817.  
  818.    begin 
  819.       return o.Bounds; 
  820.    end Bounds; 
  821.  
  822.    -- Lighting support. 
  823.    -- 
  824.  
  825.    -- lights : array (Light_ident) of Light_definition; 
  826.    light_defined : array (Light_ident) of Boolean := (others => False); 
  827.  
  828.    procedure Define (which : Light_ident; as : Light_definition) is 
  829.  
  830.       id : constant GL.LightIDEnm := GL.LightIDEnm'Val (which - 1); 
  831.  
  832.    begin 
  833.       -- lights (which) := as; 
  834.       Light (id, POSITION, as.position); 
  835.       Light (id, AMBIENT,  as.ambient); 
  836.       Light (id, DIFFUSE,  as.diffuse); 
  837.       Light (id, SPECULAR, as.specular); 
  838.       light_defined (which) := True; 
  839.    end Define; 
  840.  
  841.    procedure Switch_lights (on : Boolean) is 
  842.  
  843.    begin 
  844.       for l in Light_ident loop 
  845.          Switch_light (l, on); 
  846.       end loop; 
  847.    end Switch_lights; 
  848.  
  849.    function Server_id (which : Light_ident) return GL.ServerCapabilityEnm is 
  850.  
  851.    begin 
  852.       return GL.ServerCapabilityEnm'Val (GL.ServerCapabilityEnm'Pos (GL.LIGHT0) + which - 1); 
  853.    end Server_id; 
  854.  
  855.    procedure Switch_light (which : Light_ident; on : Boolean) is 
  856.  
  857.    begin 
  858.       if light_defined (which) then 
  859.          if on then 
  860.             GL.Enable (Server_id (which)); 
  861.          else 
  862.             GL.Disable (Server_id (which)); 
  863.          end if; 
  864.       end if; 
  865.    end Switch_light; 
  866.  
  867.    function Is_light_switched (which : Light_ident) return Boolean is 
  868.  
  869.    begin 
  870.       return Boolean'Val (GL.IsEnabled (Server_id (which))); 
  871.    end Is_light_switched; 
  872.  
  873.    procedure Reverse_light_switch (which : Light_ident) is 
  874.  
  875.    begin 
  876.       Switch_light (which, not Is_light_switched (which)); 
  877.    end Reverse_light_switch; 
  878.  
  879.    prec_a360    : constant := 10000; 
  880.    r_prec_a360  : constant := 10000.0; 
  881.    i_r_prec_a360 : constant := 1.0 / r_prec_a360; 
  882.  
  883.    procedure Angles_modulo_360 (v : in out Vector_3D) is 
  884.  
  885.    begin 
  886.       for i in v'Range loop 
  887.          v (i) := 
  888.            GL.Double (Integer (r_prec_a360 * v (i)) mod (360 *prec_a360)) 
  889.            * i_r_prec_a360; 
  890.       end loop; 
  891.    end Angles_modulo_360; 
  892.  
  893.    ------------------ 
  894.    -- Resource I/O -- 
  895.    ------------------ 
  896.  
  897.    procedure Load_if_needed (zif : in out Zip.Zip_info; name : String) is 
  898.  
  899.    begin 
  900.       if not Zip.Is_loaded (zif) then 
  901.          begin 
  902.             Zip.Load (zif, name); 
  903.          exception 
  904.             when Zip.Zip_file_open_Error => -- Try with lower case : 
  905.                Zip.Load (zif, To_Lower (name)); 
  906.          end; 
  907.       end if; 
  908.    end Load_if_needed; 
  909.  
  910.    procedure Set_local_data_name (s : String) is 
  911.  
  912.    begin 
  913.       if Zip.Is_loaded (zif_level) then 
  914.          Zip.Delete (zif_level); 
  915.       end if; 
  916.       -- ^ Possible resource name change - > need this, will be reloaded on next use 
  917.       level_data_name := Ada.Strings.Unbounded.To_Unbounded_String (s); 
  918.       if not Zip.Exists (s) then 
  919.          raise data_file_not_found with s; 
  920.       end if; 
  921.    end Set_local_data_name; 
  922.  
  923.    procedure Set_global_data_name (s : String) is 
  924.  
  925.    begin 
  926.       if Zip.Is_loaded (zif_global) then 
  927.          Zip.Delete (zif_global); 
  928.       end if; 
  929.       -- ^ Possible resource name change - > need this, will be reloaded on next use 
  930.       global_data_name := Ada.Strings.Unbounded.To_Unbounded_String (s); 
  931.       if not Zip.Exists (s) then 
  932.          raise data_file_not_found with s; 
  933.       end if; 
  934.    end Set_global_data_name; 
  935.  
  936.    procedure Set_name (o : in out Visual'class; new_name : String) is 
  937.  
  938.    begin 
  939.       if new_name'Length > Ident'Length then 
  940.          raise Constraint_Error; 
  941.       end if; 
  942.       o.ID := empty; 
  943.       o.ID (1 .. new_name'Length) := new_name; 
  944.    end Set_name; 
  945.  
  946.    function Get_name (o : Visual'class) return String is 
  947.  
  948.    begin 
  949.       return Trim (o.ID, Right); 
  950.    end Get_name; 
  951.  
  952.    procedure Rebuild_links (o            : in out Object_3D'Class; -- object to be relinked 
  953.                             neighbouring :        Map_of_Visuals;  -- neighbourhood 
  954.                             tolerant_obj :        Boolean;         -- tolerant on missing objects 
  955.                             tolerant_tex :        Boolean          -- tolerant on missing textures 
  956.                            ) is 
  957.  
  958.       found : Boolean; 
  959.  
  960.    begin 
  961.       for f in o.face'Range loop 
  962.          -- 1/ Find texture IDs : 
  963.          if is_textured (o.face (f).skin) and then 
  964.            o.Face_Invariant (f).texture_name /= empty 
  965.          then 
  966.             begin 
  967.                o.face (f).texture := 
  968.                  Textures.Texture_ID (o.Face_Invariant (f).texture_name); 
  969.             exception 
  970.                when Textures.Texture_name_not_found => 
  971.                   if tolerant_tex then 
  972.                      o.face (f).texture := null_image; 
  973.                      o.face (f).skin := material_only; 
  974.                   else 
  975.                      raise; 
  976.                   end if; 
  977.             end; 
  978.          end if; 
  979.          -- 2/ Connections through portals : 
  980.          if o.Face_Invariant (f).connect_name /= empty then 
  981.             found := False; 
  982.             -- XX old linear search : 
  983.             --  for i in neighbouring'Range loop 
  984.             --    if neighbouring (i).ID = o.face_invariant (f).connect_name then 
  985.             --      o.face (f).connecting := neighbouring (i); 
  986.             --      found := True; 
  987.             --      exit; 
  988.             --    end if; 
  989.             --  end loop; 
  990.             begin 
  991.                o.face (f).connecting := p_Object_3D (Visuals_Mapping.Element ( 
  992.                                                      Visuals_Mapping.Map (neighbouring), 
  993.                                                      Ada.Strings.Unbounded.To_Unbounded_String (o.Face_Invariant (f).connect_name)) 
  994.                                                     ); 
  995.  
  996.                found := True; 
  997.             exception 
  998.                when Constraint_Error => 
  999.                   -- GNAT gives also the message : 
  1000.                   -- no element available because key not in map 
  1001.                   null; 
  1002.             end; 
  1003.             if not found then 
  1004.                if tolerant_obj then 
  1005.                   o.face (f).connecting := null; 
  1006.                else 
  1007.                   Raise_Exception ( 
  1008.                                    Portal_connection_failed'Identity, 
  1009.                                    "For object name [" & Trim (o.ID, Right) & 
  1010.                                      "], looking for [" & 
  1011.                                      Trim (o.Face_Invariant (f).connect_name, Right) 
  1012.                                    & ']' 
  1013.                                   ); 
  1014.                end if; 
  1015.             end if; 
  1016.          end if; 
  1017.       end loop; 
  1018.    end Rebuild_links; 
  1019.  
  1020.    procedure Texture_name_hint (o    : in out Object_3D; 
  1021.                                 face :        Positive; 
  1022.                                 name :        String 
  1023.                                ) is 
  1024.  
  1025.    begin 
  1026.       if name'Length > Ident'Length then 
  1027.          raise Constraint_Error; 
  1028.       end if; 
  1029.       o.Face_Invariant (face).texture_name := empty; 
  1030.       o.Face_Invariant (face).texture_name (1 .. name'Length) := name; 
  1031.    end Texture_name_hint; 
  1032.  
  1033.    procedure Portal_name_hint (o   : in out Object_3D; 
  1034.                                face :        Positive; 
  1035.                                name :        String 
  1036.                               ) is 
  1037.  
  1038.    begin 
  1039.       if name'Length > Ident'Length then 
  1040.          raise Constraint_Error; 
  1041.       end if; 
  1042.       o.Face_Invariant (face).connect_name := empty; 
  1043.       o.Face_Invariant (face).connect_name (1 .. name'Length) := name; 
  1044.    end Portal_name_hint; 
  1045.  
  1046.    ---------------------------------------- 
  1047.    -- tbd : has been moved (for the moment) external to 'render' for performance, but this makes package task unsafe ! 
  1048.    -- 
  1049.    -- 
  1050.    type Visual_Geometry is 
  1051.       record 
  1052.          Visual   : p_Visual; 
  1053.          Geometry : GL.Skinned_Geometry.Skinned_Geometry_t; 
  1054.       end record; 
  1055.    pragma Convention (C, Visual_Geometry);  -- using convention pragma to disable default initialization (for performance) 
  1056.  
  1057.    type Visual_Geometries is array (Positive range <>) of Visual_Geometry; 
  1058.    pragma Convention (C, Visual_Geometries);  -- using convention pragma to disable default initialization (for performance) 
  1059.  
  1060.    All_Geometries : Visual_Geometries (1 .. 80_000);   pragma Convention (C, All_Geometries);  -- tbd : this is slow ! 
  1061.    -- 
  1062.    -------------------------------------- 
  1063.  
  1064.    procedure render (the_Visuals : Visual_array; the_Camera : Camera) is 
  1065.  
  1066.       use REF, G3DM; 
  1067.  
  1068.       all_Transparents  : GLOBE_3D.Visual_array (1 .. 10_000); 
  1069.       transparent_Count : Natural   := 0; 
  1070.  
  1071.       geometry_Count    : Natural   := 0;   -- for 'all_Geometrys' array. 
  1072.  
  1073.       current_Skin      : GL.Skins.p_Skin; 
  1074.  
  1075.    begin 
  1076.       -- prepare openGL to display visuals. 
  1077.       -- 
  1078.       Clear    (COLOR_BUFFER_BIT or DEPTH_BUFFER_BIT); 
  1079.       Enable   (DEPTH_TEST); 
  1080.  
  1081.       Enable   (LIGHTING);                               -- enable lighting for G3D.Display in 'separate Visuals' (obsolete). 
  1082.       Enable   (CULL_FACE); 
  1083.       CullFace (BACK); 
  1084.  
  1085.       MatrixMode    (MODELVIEW); 
  1086.       Set_GL_Matrix (the_Camera.World_Rotation); 
  1087.       Translate     (-the_Camera.Clipper.Eye_Position (0),  -the_Camera.Clipper.Eye_Position (1),  -the_Camera.Clipper.Eye_Position (2)); 
  1088.  
  1089.       PushMatrix; 
  1090.  
  1091.       -- separate Visuals 
  1092.       -- 
  1093.       for Each_Visual in the_Visuals'Range loop 
  1094.          declare 
  1095.             the_Visual       : Visual'Class                          renames the_Visuals (Each_Visual).all; 
  1096.             visual_Geometrys : GL.Skinned_Geometry.skinned_Geometrys renames skinned_Geometrys (the_Visual); 
  1097.          begin 
  1098.             if is_Transparent (the_Visual) then 
  1099.                transparent_Count                    := transparent_Count + 1; 
  1100.                all_Transparents (transparent_Count) := the_Visual'Access; 
  1101.             else 
  1102.                for Each_Geometry in visual_Geometrys'Range loop 
  1103.                   geometry_Count                          := geometry_Count + 1; 
  1104.                   All_Geometries (geometry_Count).Visual   := the_Visual'Access; 
  1105.                   All_Geometries (geometry_Count).Geometry := visual_Geometrys (Each_Geometry); 
  1106.                end loop; 
  1107.  
  1108.                Display (the_Visuals (Each_Visual).all,  the_Camera.Clipper); 
  1109.             end if; 
  1110.          end; 
  1111.       end loop; 
  1112.  
  1113.       GL.Errors.log; 
  1114.  
  1115.       -- display all opaque geometries, sorted by gl geometry primitive kind and skin. 
  1116.       -- 
  1117.       declare 
  1118.  
  1119.          pragma Warnings (Off, "declaration of ""<"" hides predefined operator"); 
  1120.          function "<" (L, R : Visual_Geometry) return Boolean is 
  1121.             pragma Warnings (On, "declaration of ""<"" hides predefined operator"); 
  1122.           
  1123.             use GL.Geometry, System.Storage_Elements; 
  1124.  
  1125.          begin 
  1126.             if primitive_Id (L.Geometry.Geometry.all)  =  primitive_Id (R.Geometry.Geometry.all) then   -- tbd : find better naming scheme to avoid '.Geometry.Geometry.' 
  1127.                return To_Integer (L.Geometry.Skin.all'Address) < To_Integer (R.Geometry.Skin.all'Address); -- tbd : check this is safe/portable 
  1128.                -- GdM : aaargh! remove that !! 
  1129.             else 
  1130.                return primitive_Id (L.Geometry.Geometry.all) < primitive_Id (R.Geometry.Geometry.all); 
  1131.             end if; 
  1132.          end "<"; 
  1133.  
  1134.          procedure sort is new Ada.Containers.Generic_Array_Sort (Positive, 
  1135.                                                                   Visual_Geometry, 
  1136.                                                                   Visual_Geometries); 
  1137.          use GL.Skins, GL.Geometry, GL.Skinned_Geometry; 
  1138.  
  1139.          current_Visual : p_Visual; 
  1140.  
  1141.       begin 
  1142.          if geometry_Count > 1 then 
  1143.             sort (All_Geometries (1 .. geometry_Count)); 
  1144.          end if; 
  1145.  
  1146.          GL.PushMatrix; 
  1147.  
  1148.          for Each in 1 .. geometry_Count loop 
  1149.  
  1150.             if All_Geometries (Each).Geometry.Skin /= current_Skin then 
  1151.                current_Skin := All_Geometries (Each).Geometry.Skin; 
  1152.                Enable (current_Skin.all); 
  1153.                GL.Errors.log; 
  1154.             end if; 
  1155.  
  1156.             if All_Geometries (Each).Geometry.Veneer /= null then 
  1157.                Enable (All_Geometries (Each).Geometry.Veneer.all); 
  1158.                GL.Errors.log; 
  1159.             end if; 
  1160.  
  1161.             if All_Geometries (Each).Visual = current_Visual then 
  1162.                Draw (All_Geometries (Each).Geometry.Geometry.all); 
  1163.                GL.Errors.log; 
  1164.             else 
  1165.                GL.PopMatrix; 
  1166.                GL.PushMatrix; 
  1167.                GL.Translate       (All_Geometries (Each).Visual.all.Centre); 
  1168.                Multiply_GL_Matrix (All_Geometries (Each).Visual.all.rotation); 
  1169.  
  1170.                Draw (All_Geometries (Each).Geometry.Geometry.all); 
  1171.                GL.Errors.log; 
  1172.  
  1173.                current_Visual := All_Geometries (Each).Visual; 
  1174.             end if; 
  1175.  
  1176.          end loop; 
  1177.  
  1178.          GL.PopMatrix; 
  1179.       end; 
  1180.  
  1181.       GL.Errors.log; 
  1182.  
  1183.       -- display all transparent visuals, sorted from far to near. 
  1184.       -- 
  1185.       declare 
  1186.           
  1187.          pragma Warnings (Off, "declaration of ""<"" hides predefined operator"); 
  1188.          function "<" (L, R : GLOBE_3D.p_Visual) return Boolean is -- tbd : ugh move expensive calcs outside 
  1189.             pragma Warnings (On, "declaration of ""<"" hides predefined operator"); 
  1190.          
  1191.          begin 
  1192.             return L.all.Centre_Camera_Space (2) < R.all.Centre_Camera_Space (2);  -- nb : in camera space, negative Z is forward, so use '<'. 
  1193.          end "<"; 
  1194.  
  1195.          -- procedure sort is new Ada.Containers.Generic_Array_Sort (Positive, 
  1196.          procedure sort is new Ada.Containers.Generic_Array_Sort (Positive, 
  1197.                                                                   GLOBE_3D.p_Visual, 
  1198.                                                                   GLOBE_3D.Visual_array); 
  1199.       begin 
  1200.          for Each in 1 .. transparent_Count loop  -- pre - calculate each visuals Centre in camera space. 
  1201.             all_Transparents (Each).all.Centre_Camera_Space :=   the_Camera.World_Rotation 
  1202.               * (all_Transparents (Each).all.Centre - the_Camera.Clipper.Eye_Position); 
  1203.          end loop; 
  1204.  
  1205.          if transparent_Count > 1 then 
  1206.             sort (all_Transparents (1 .. transparent_Count)); 
  1207.          end if; 
  1208.  
  1209.          GL.Depth_Mask (GL_False);  -- make depth buffer read - only, for correct transparency 
  1210.  
  1211.          Enable    (LIGHTING);   -- ensure lighting is enabled for G3D.Display of transparents (obsolete). 
  1212.          Enable    (BLEND); 
  1213.          BlendFunc (sfactor => ONE, 
  1214.                     dfactor => ONE_MINUS_SRC_ALPHA); 
  1215.  
  1216.          for Each_Transparency in 1 .. transparent_Count loop 
  1217.             declare 
  1218.                the_Visual       : Visual'Class                          renames all_Transparents (Each_Transparency).all; 
  1219.                visual_Geometrys : constant GL.Skinned_Geometry.skinned_Geometrys      := skinned_Geometrys (the_Visual); -- tbd : apply ogl state sorting here ? 
  1220.             begin 
  1221.                Display (the_Visual,  the_Camera.Clipper); 
  1222.                GL.Errors.log; 
  1223.  
  1224.                for Each_Geometry in visual_Geometrys'Range loop 
  1225.                   declare 
  1226.                      use GL.Skins, GL.Geometry; 
  1227.                      the_Geometry : GL.Skinned_Geometry.Skinned_Geometry_t renames visual_Geometrys (Each_Geometry); 
  1228.                   begin 
  1229.  
  1230.                      if the_Geometry.Skin /= current_Skin then 
  1231.                         current_Skin := the_Geometry.Skin; 
  1232.                         Enable (current_Skin.all); 
  1233.                         GL.Errors.log; 
  1234.                      end if; 
  1235.  
  1236.                      if the_Geometry.Veneer /= null then 
  1237.                         Enable (the_Geometry.Veneer.all); 
  1238.                         GL.Errors.log; 
  1239.                      end if; 
  1240.  
  1241.                      GL.PushMatrix; 
  1242.  
  1243.                      GL.Translate       (the_Visual.Centre); 
  1244.                      Multiply_GL_Matrix (the_Visual.rotation); 
  1245.  
  1246.                      Draw (the_Geometry.Geometry.all); 
  1247.                      GL.Errors.log; 
  1248.  
  1249.                      GL.PopMatrix; 
  1250.                   end; 
  1251.                end loop; 
  1252.  
  1253.             end; 
  1254.          end loop; 
  1255.  
  1256.          GL.Depth_Mask (GL_True); 
  1257.       end; 
  1258.  
  1259.       PopMatrix; 
  1260.  
  1261.       GL.Errors.log;      -- tbd : for debug only 
  1262.    end render; 
  1263.  
  1264.    function empty_map return Map_of_Visuals is 
  1265.       thing : Map_of_Visuals; 
  1266.    begin 
  1267.       Visuals_Mapping.Map (thing) := Visuals_Mapping.Empty_Map; 
  1268.       return thing; 
  1269.    end empty_map; 
  1270.  
  1271.    procedure Add (to_map : in out Map_of_Visuals; what : p_Visual) is 
  1272.       pos : Visuals_Mapping.Cursor; 
  1273.       success : Boolean; 
  1274.    begin 
  1275.       Visuals_Mapping.Insert ( 
  1276.                               Visuals_Mapping.Map (to_map), 
  1277.                               Ada.Strings.Unbounded.To_Unbounded_String (what.all.ID), 
  1278.                               what, 
  1279.                               pos, 
  1280.                               success 
  1281.                              ); 
  1282.       if not success then -- A.18.4. 45/2 
  1283.          raise Duplicate_name with what.all.ID; 
  1284.       end if; 
  1285.    end Add; 
  1286.  
  1287.    function Map_of (va : Visual_array) return Map_of_Visuals is 
  1288.       res : Map_of_Visuals := empty_map; 
  1289.    begin 
  1290.       -- Perhaps Reserve_Capacity would be good here ?? 
  1291.       for i in va'Range loop 
  1292.          Add (res, va (i)); 
  1293.       end loop; 
  1294.       return res; 
  1295.    end Map_of; 
  1296.  
  1297. end GLOBE_3D;