1. pragma Warnings (Off); 
  2. pragma Style_Checks (Off); 
  3.  
  4. ------------------------------------------------------------------------- 
  5.  --  GL.Geometry - GL geometry primitives 
  6.  -- 
  7.  --  Copyright (c) Rod Kay 2007 
  8.  --  AUSTRALIA 
  9.  --  Permission granted to use this software, without any warranty, 
  10.  --  for any purpose, provided this copyright note remains attached 
  11.  --  and unmodified if sources are distributed further. 
  12.  ------------------------------------------------------------------------- 
  13.  
  14. with Ada.Numerics.Generic_Elementary_functions; 
  15. with Ada.Text_IO; use Ada.Text_IO; 
  16.  
  17. package body GL.geometry.Primitives is 
  18.  
  19.    procedure destroy (Self  : in out Primitive) 
  20.    is 
  21.    begin 
  22.       if self.owns_Vertices then 
  23.          free (self.Vertices); 
  24.       end if; 
  25.  
  26.       free (self.Indices); 
  27.    end; 
  28.  
  29.    procedure free (Self  : in out p_Primitive) 
  30.    is 
  31.       procedure deallocate is new ada.unchecked_Deallocation (Primitive'Class, p_Primitive); 
  32.    begin 
  33.       destroy    (Self.all); 
  34.       deallocate (Self); 
  35.    end; 
  36.  
  37.    procedure Draw (Self  : access Primitive'Class) 
  38.    is 
  39.    begin 
  40.       GL.bindBuffer    (gl.ARRAY_BUFFER, 0);                            -- disable 'vertex buffer objects' 
  41.       GL.bindBuffer    (gl.ELEMENT_ARRAY_BUFFER, 0);                    -- disable 'vertex buffer objects' indices 
  42.  
  43.       GL.Enable_Client_State (gl.VERTEX_ARRAY); 
  44.       GL.vertexPointer     (3, GL_DOUBLE,  0,  GL.to_Pointer (self.Vertices (1) (0)'Unchecked_Access)); 
  45.       GL.drawElements      (primitive_Id (Self.all), 
  46.                             self.Indices'Length, 
  47.                             GL.UNSIGNED_INT, 
  48.                             to_void_Pointer (self.Indices (1)'Unchecked_Access)); 
  49.    end; 
  50.  
  51.    procedure set_Vertices  (Self  : in out Primitive;   To  : access GL.geometry.GL_Vertex_array) 
  52.    is 
  53.    begin 
  54.       if self.Vertices = null then 
  55.          self.Vertices      := new GL_Vertex_array' (To.all); 
  56.          self.owns_Vertices := True; 
  57.  
  58.       elsif self.Vertices'Length = To'Length then 
  59.          self.Vertices.all := To.all; 
  60.       else 
  61.          free (self.Vertices); 
  62.          self.Vertices      := new GL_Vertex_array' (To.all); 
  63.          self.owns_Vertices := True; 
  64.       end if; 
  65.    end; 
  66.  
  67.    procedure set_Indices   (Self  : in out Primitive;   To  : access GL.geometry.vertex_Id_array) 
  68.    is 
  69.    begin 
  70.       if self.Indices = null then 
  71.          self.Indices := new vertex_Id_array' (To.all); 
  72.  
  73.       elsif self.Indices'Length = To'Length then 
  74.          self.Indices.all := To.all; 
  75.       else 
  76.          free (self.Indices); 
  77.          self.Indices := new vertex_Id_array' (To.all); 
  78.       end if; 
  79.    end; 
  80.  
  81.    -- 'Points' 
  82.  
  83.    function create_Points (point_Count  : in vertex_Id;   Vertices  : p_vertex_array := null) return Points 
  84.    is 
  85.    begin 
  86.       if Vertices = null then 
  87.          return (vertices         => new GL_Vertex_array    (1 .. point_Count), 
  88.                  owns_vertices    => True, 
  89.                  indices          => new vertex_Id_array (1 .. positive_uInt (point_Count))); 
  90.       else 
  91.          return (vertices         => Vertices, 
  92.                  owns_vertices    => False, 
  93.                  indices          => new vertex_Id_array (1 .. positive_uInt (point_Count))); 
  94.       end if; 
  95.    end; 
  96.  
  97.    function primitive_Id (Self  : in Points) return GL.ObjectTypeEnm 
  98.    is 
  99.    begin 
  100.       return GL.POINTS; 
  101.    end; 
  102.  
  103.    -- 'Lines' 
  104.    -- 
  105.  
  106.    function create_Lines (line_Count  : in Natural;   Vertices  : p_Vertex_array := null) return Lines 
  107.    is 
  108.       indices_Count  : positive_uInt := positive_uInt (2 * line_Count); 
  109.    begin 
  110.       if Vertices = null then 
  111.          return (vertices      => new GL_Vertex_array (1 .. 2 * vertex_Id (line_Count)), 
  112.                  owns_vertices => True, 
  113.                  indices       => new vertex_Id_array (1 .. indices_Count)); 
  114.       else 
  115.          return (vertices      => Vertices, 
  116.                  owns_vertices => False, 
  117.                  indices       => new vertex_Id_array (1 .. indices_Count)); 
  118.       end if; 
  119.    end; 
  120.  
  121.    function primitive_Id (Self  : in Lines) return GL.ObjectTypeEnm 
  122.    is 
  123.    begin 
  124.       return GL.LINES; 
  125.    end; 
  126.  
  127.    function get_vertex_Id (Self  : in Lines;   Line    : in Positive; 
  128.                                               Vertex  : in Positive) 
  129.                                                                       return vertex_Id 
  130.    is 
  131.    begin 
  132.       return self.Indices (positive_uInt (2 * (Line - 1)  +  Vertex)) + 1; 
  133.    end; 
  134.  
  135.    procedure set_vertex_Id (Self  : in out Lines;   Line    : in Positive; 
  136.                                                    Vertex  : in Positive; 
  137.                                                    To      : in vertex_Id) 
  138.    is 
  139.    begin 
  140.       self.Indices (positive_uInt (2 * (Line - 1)  +  Vertex)) := To - 1; 
  141.    end; 
  142.  
  143.    -- 'line Strip' 
  144.    -- 
  145.  
  146.    function create_line_Strip (line_Count  : in Natural;   Vertices  : p_Vertex_array := null) return line_Strip 
  147.    is 
  148.       indices_Count  : positive_uInt := positive_uInt (line_Count + 1); 
  149.    begin 
  150.       if Vertices = null then 
  151.          return (vertices      => new GL_Vertex_array (1 .. vertex_Id (line_Count) + 1), 
  152.                  owns_vertices => True, 
  153.                  indices       => new vertex_Id_array (1 .. indices_Count)); 
  154.       else 
  155.          return (vertices      => Vertices, 
  156.                  owns_vertices => False, 
  157.                  indices       => new vertex_Id_array (1 .. indices_Count)); 
  158.       end if; 
  159.    end; 
  160.  
  161.    function primitive_Id (Self  : in line_Strip) return GL.ObjectTypeEnm 
  162.    is 
  163.    begin 
  164.       return GL.LINE_STRIP; 
  165.    end; 
  166.  
  167.    function get_vertex_Id (Self  : in line_Strip;   Line    : in Positive; 
  168.                                                    Vertex  : in Positive) 
  169.                                                                          return vertex_Id 
  170.    is 
  171.    begin 
  172.       return self.Indices (positive_uInt (Line - 1  +  Vertex)) + 1; 
  173.    end; 
  174.  
  175.    procedure set_vertex_Id (Self  : in out line_Strip;   Line    : in Positive; 
  176.                                                         Vertex  : in Positive; 
  177.                                                         To      : in vertex_Id) 
  178.    is 
  179.    begin 
  180.       self.Indices (positive_uInt (Line - 1  +  Vertex)) := To - 1; 
  181.    end; 
  182.  
  183.    -- 'line Loop' 
  184.    -- 
  185.  
  186.    function create_line_Loop (line_Count  : in Natural;   Vertices : p_Vertex_array := null) return line_Loop 
  187.    is 
  188.       indices_Count  : positive_uInt :=  positive_uInt (line_Count) + 1; 
  189.    begin 
  190.       if Vertices = null then 
  191.          return (vertices => new GL_Vertex_array (1 .. vertex_Id (line_Count) + 1), 
  192.                  owns_vertices => True, 
  193.                  indices       => new vertex_Id_array (1 .. indices_Count)); 
  194.       else 
  195.          return (vertices      => Vertices, 
  196.                  owns_vertices => False, 
  197.                  indices       => new vertex_Id_array (1 .. indices_Count)); 
  198.       end if; 
  199.    end; 
  200.  
  201.    function primitive_Id (Self  : in line_Loop) return GL.ObjectTypeEnm 
  202.    is 
  203.    begin 
  204.       return GL.LINE_LOOP; 
  205.    end; 
  206.  
  207.    function get_vertex_Id (Self  : in line_Loop;   Line    : in Positive; 
  208.                                                   Vertex  : in Positive) 
  209.                                                                          return vertex_Id 
  210.    is 
  211.    begin 
  212.       return self.Indices (positive_uInt (Line - 1  +  Vertex)) + 1; 
  213.    end; 
  214.  
  215.    procedure set_vertex_Id (Self  : in out line_Loop;   Line    : in Positive; 
  216.                                                        Vertex  : in Positive; 
  217.                                                        To      : in vertex_Id) 
  218.    is 
  219.    begin 
  220.       self.Indices (positive_uInt (Line - 1  +  Vertex)) := To - 1; 
  221.    end; 
  222.  
  223.    -- 'Triangles' 
  224.    -- 
  225.  
  226.    function create_Triangles (triangle_Count  : in Natural;   Vertices  : p_Vertex_array) return Triangles 
  227.    is 
  228.    begin 
  229.        return (vertices      => Vertices, 
  230.                owns_vertices => False, 
  231.                indices       => new vertex_Id_array (1 .. 3 * positive_uInt (triangle_Count))); 
  232.    end; 
  233.  
  234.    function new_Triangles    (triangle_Count  : in Natural;   Vertices  : in     p_vertex_array) return p_Triangles 
  235.    is 
  236.    begin 
  237.       return new Triangles' (create_Triangles (triangle_Count, Vertices)); 
  238.    end; 
  239.  
  240.    function primitive_Id (Self  : in Triangles) return GL.ObjectTypeEnm 
  241.    is 
  242.    begin 
  243.       return GL.TRIANGLES; 
  244.    end; 
  245.  
  246.    function get_vertex_Id (Self  : in Triangles;   Triangle  : in Positive; 
  247.                                                   Vertex    : in Positive) 
  248.                                                                           return vertex_Id 
  249.    is 
  250.    begin 
  251.       return self.Indices (positive_uInt (3 * (Triangle - 1)  +  Vertex)) + 1; 
  252.    end; 
  253.  
  254.    procedure set_vertex_Id (Self  : in out Triangles;   Triangle  : in Positive; 
  255.                                                        Vertex    : in Positive; 
  256.                                                        To        : in vertex_Id) 
  257.    is 
  258.    begin 
  259.       self.Indices (positive_uInt (3 * (Triangle - 1)  +  Vertex)) := To - 1; 
  260.    end; 
  261.  
  262.    -- 'triangle Strip' 
  263.    -- 
  264.  
  265.    function create_triangle_Strip (triangle_Count  : in Natural;   Vertices  : p_Vertex_array) return triangle_Strip'Class 
  266.    is 
  267.       the_Strip  : triangle_Strip; -- (max_indices => positive_uInt (triangle_Count) + 2); 
  268.    begin 
  269.       the_Strip.Vertices      := Vertices; 
  270.       the_Strip.owns_Vertices := False; 
  271.       the_Strip.Indices       := new vertex_Id_array (1 .. positive_uInt (triangle_Count) + 2); 
  272.  
  273.       return the_Strip; 
  274.    end; 
  275.  
  276.    function new_triangle_Strip (triangle_Count  : in Natural;   Vertices : p_Vertex_array) return p_triangle_Strip 
  277.    is 
  278.    begin 
  279.       return new triangle_Strip'Class' (create_triangle_Strip (triangle_Count, Vertices)); 
  280.    end; 
  281.  
  282.    function primitive_Id (Self  : in triangle_Strip) return GL.ObjectTypeEnm 
  283.    is 
  284.    begin 
  285.       return GL.TRIANGLE_STRIP; 
  286.    end; 
  287.  
  288.    function get_vertex_Id (Self  : in triangle_Strip;   Triangle  : in Positive; 
  289.                                                        Vertex    : in Positive) 
  290.                                                                               return vertex_Id 
  291.    is 
  292.    begin 
  293.       return self.Indices (positive_uInt (Triangle + Vertex - 1)) + 1; 
  294.    end; 
  295.  
  296.    procedure set_vertex_Id (Self  : in out triangle_Strip;   Triangle  : in Positive; 
  297.                                                             Vertex    : in Positive; 
  298.                                                             To        : in vertex_Id) 
  299.    is 
  300.    begin 
  301.       self.Indices (positive_uInt (Triangle + Vertex - 1)) := To - 1; 
  302.    end; 
  303.  
  304.    -- 'triangle Fan' 
  305.    -- 
  306.  
  307.    function create_triangle_Fan (triangle_Count  : in Natural;   Vertices : p_Vertex_array) return triangle_Fan 
  308.    is 
  309.    begin 
  310.       return (vertices      => Vertices, 
  311.               owns_vertices => False, 
  312.               indices       => new vertex_Id_array (1 .. positive_uInt (triangle_Count) + 2)); 
  313.    end; 
  314.  
  315.    function primitive_Id (Self  : in triangle_Fan) return GL.ObjectTypeEnm 
  316.    is 
  317.    begin 
  318.       return GL.TRIANGLE_FAN; 
  319.    end; 
  320.  
  321.    function get_vertex_Id (Self  : in triangle_Fan;   Triangle  : in Positive; 
  322.                                                      Vertex    : in Positive) 
  323.                                                                               return vertex_Id 
  324.    is 
  325.    begin 
  326.       if Vertex = 1 then 
  327.          return self.Indices (1); 
  328.       else 
  329.          return self.Indices (positive_uInt (Triangle + Vertex - 1)) + 1; 
  330.       end if; 
  331.    end; 
  332.  
  333.    procedure set_vertex_Id (Self  : in out triangle_Fan;   Triangle  : in Positive; 
  334.                                                           Vertex    : in Positive; 
  335.                                                           To        : in vertex_Id) 
  336.    is 
  337.    begin 
  338.       if Vertex = 1 then 
  339.          self.Indices (1) := To; 
  340.       else 
  341.          self.Indices (positive_uInt (Triangle + Vertex - 1)) := To - 1; 
  342.       end if; 
  343.    end; 
  344.  
  345.    -- 'Quads' 
  346.    -- 
  347.  
  348.    function create_Quads (quad_Count  : in Natural;   Vertices : p_Vertex_array := null) return Quads 
  349.    is 
  350.       indices_Count  : positive_uInt := 4 * positive_uInt (quad_Count); 
  351.    begin 
  352.       if Vertices = null then 
  353.          return (vertices      => new GL_Vertex_array (1 .. vertex_Id (4 * quad_Count)), 
  354.                  owns_vertices => True, 
  355.                  indices       => new vertex_Id_array (1 .. indices_Count)); 
  356.       else 
  357.          return (vertices      => Vertices, 
  358.                  owns_vertices => False, 
  359.                  indices       => new vertex_Id_array (1 .. indices_Count)); 
  360.       end if; 
  361.  
  362.    end; 
  363.  
  364.    function new_Quads (quad_Count  : in Natural;   Vertices : p_Vertex_array := null) return p_Quads 
  365.    is 
  366.    begin 
  367.       return new Quads' (create_Quads (quad_Count, Vertices)); 
  368.    end; 
  369.  
  370.    function primitive_Id (Self  : in Quads) return GL.ObjectTypeEnm 
  371.    is 
  372.    begin 
  373.       return GL.QUADS; 
  374.    end; 
  375.  
  376.    function get_vertex_Id (Self  : in Quads;   Quad    : in Positive; 
  377.                                               Vertex  : in Positive) 
  378.                                                                           return vertex_Id 
  379.    is 
  380.    begin 
  381.       return self.Indices (positive_uInt (4 * (Quad - 1)  +  Vertex)) + 1; 
  382.    end; 
  383.  
  384.    procedure set_vertex_Id (Self  : in out Quads;   Quad      : in Positive; 
  385.                                                    Vertex    : in Positive; 
  386.                                                    To        : in vertex_Id) 
  387.    is 
  388.    begin 
  389.       self.Indices (positive_uInt (4 * (Quad - 1)  +  Vertex)) := To - 1; 
  390.    end; 
  391.  
  392.    -- 'quad Strip' 
  393.    -- 
  394.  
  395.    function create_quad_Strip (quad_Count  : in Natural;   Vertices : p_Vertex_array) return quad_Strip 
  396.    is 
  397.    begin 
  398.       return (vertices      => Vertices, 
  399.               owns_vertices => False, 
  400.               indices       => new vertex_Id_array (1 .. 2 * positive_uInt (quad_Count)  +  2)); 
  401.    end; 
  402.  
  403.    function primitive_Id (Self  : in quad_Strip) return GL.ObjectTypeEnm 
  404.    is 
  405.    begin 
  406.       return GL.QUAD_STRIP; 
  407.    end; 
  408.  
  409.    function get_vertex_Id (Self  : in quad_Strip;   Quad      : in Positive; 
  410.                                                    Vertex    : in Positive) 
  411.                                                                               return vertex_Id 
  412.    is 
  413.    begin 
  414.       return self.Indices (positive_uInt (2 * (Quad - 1) + Vertex)) + 1; 
  415.    end; 
  416.  
  417.    procedure set_vertex_Id (Self  : in out quad_Strip;   Quad      : in Positive; 
  418.                                                         Vertex    : in Positive; 
  419.                                                         To        : in vertex_Id) 
  420.    is 
  421.    begin 
  422.       self.Indices (positive_uInt (2 * (Quad - 1) + Vertex)) := To - 1; 
  423.    end; 
  424.  
  425.    -- 'Polygon' 
  426.  
  427.    function create_Polygon (vertex_Count  : in Natural;   Vertices : p_Vertex_array) return Polygon 
  428.    is 
  429.    begin 
  430.       return (vertices      => Vertices, 
  431.               owns_vertices => False, 
  432.               indices       => new vertex_Id_array (1 .. positive_uInt (vertex_Count))); 
  433.    end; 
  434.  
  435.    function primitive_Id (Self  : in Polygon) return GL.ObjectTypeEnm 
  436.    is 
  437.    begin 
  438.       return GL.POLYGON; 
  439.    end; 
  440.  
  441. end GL.geometry.Primitives;