------------------------------------------------------------------------------
------------------------------------------------------------------------------
-- Cheddar is a GNU GPL real-time scheduling analysis tool.
-- This program provides services to automatically check schedulability and
-- other performance criteria of real-time architecture models.
--
-- Copyright (C) 2002-2020, Frank Singhoff, Alain Plantec, Jerome Legrand,
--                          Hai Nam Tran, Stephane Rubini
--
-- The Cheddar project was started in 2002 by 
-- Frank Singhoff, Lab-STICC UMR 6285, Université de Bretagne Occidentale
-- 
-- Cheddar has been published in the "Agence de Protection des Programmes/France" in 2008. 
-- Since 2008, Ellidiss technologies also contributes to the development of 
-- Cheddar and provides industrial support.
--
-- The full list of contributors and sponsors can be found in AUTHORS.txt and SPONSORS.txt
--
-- This program is free software; you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation; either version 2 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program; if not, write to the Free Software
-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
--
--
-- Contact : cheddar@listes.univ-brest.fr
--           
------------------------------------------------------------------------------
-- Last update : 
--    $Rev$
--    $Date$
--    $Author: singhoff $
------------------------------------------------------------------------------
------------------------------------------------------------------------------

with Text_IO;                      use Text_IO;
with Unchecked_Deallocation;
with Ada.Numerics;
with Ada.Numerics.Discrete_Random;

package body sets is

   procedure reset (my_set : in out set; free_object : in Boolean := False) is
   begin
      if free_object then
         free (my_set);
      end if;
      my_set.number_of_elements := 0;
   end reset;

   procedure free (my_set : in out set) is

   begin
      for I in 0 .. my_set.number_of_elements - 1 loop
         free (my_set.container (I));
      end loop;
   end free;

   procedure free
     (my_set      : in out set_ptr;
      free_object : in Boolean := True)
   is

      procedure Free_Pointer is new Unchecked_Deallocation (
                                                            set'Class,
                                                            set_ptr);

   begin
      if free_object then
         for I in 0 .. my_set.number_of_elements - 1 loop
            free (my_set.container (I));
         end loop;
      end if;
      Free_Pointer (my_set);
   end free;

   procedure Free_Container
     (My_Set : in out Set) is
      procedure Free is new Unchecked_Deallocation (Element_table, Element_Table_Ptr);
   begin
      Free(My_Set.Container);
   end Free_Container;

   procedure initialize (my_set : in out set) is
   begin
      my_set.container := new element_table;
      reset (my_set);
   end initialize;

   procedure add (my_set : in out set; a_element : in element) is
   begin

      if (my_set.number_of_elements = element_range (max_element)) then
         raise full_set;
      end if;

      my_set.container (my_set.number_of_elements) := a_element;
      my_set.number_of_elements                    :=
        my_set.number_of_elements + 1;
   end add;

   procedure delete
     (my_set      : in out set;
      elements    : in set;
      free_object : in Boolean := False)
   is

   begin

      if (my_set.number_of_elements = 0) then
         raise empty_set;
      end if;

      for I in 0 .. elements.number_of_elements - 1 loop
         delete (my_set, elements.container (I), free_object);
      end loop;

   end delete;

   procedure delete
     (my_set      : in out set;
      a_element   : in element;
      free_object : in Boolean := False)
   is

      Found : Boolean := False;
   begin

      if (my_set.number_of_elements = 0) then
         raise empty_set;
      end if;

      for I in 0 .. (my_set.number_of_elements - 1) loop
         if (a_element = my_set.container (I)) then
            if free_object then
               free (my_set.container (I));
            end if;
            my_set.container (I)      :=
              my_set.container (my_set.number_of_elements - 1);
            my_set.number_of_elements := my_set.number_of_elements - 1;
            Found                     := True;
            exit;
         end if;
      end loop;
      if not Found then
         raise element_not_found;
      end if;
   end delete;

   procedure next_element (my_set : in set; my_iterator : in out iterator) is
   begin
      if (my_set.number_of_elements = 0) then
         raise empty_set;
      end if;

      my_iterator.current := my_iterator.current + 1;

   end next_element;

   procedure Previous_Element (My_Set : in Set; My_Iterator : in out Iterator) is
   begin
      if (My_Set.Number_Of_Elements = 0) then
         raise Empty_Set;
      end if;

      My_Iterator.Current := My_Iterator.Current - 1;

   end Previous_Element;

   procedure current_element
     (my_set         : in set;
      return_element : out element;
      my_iterator    : in iterator)
   is
   begin
      if (my_set.number_of_elements = 0) then
         raise empty_set;
      end if;

      return_element := my_set.container (my_iterator.current);
   end current_element;

   procedure get_element_number
     (my_set         : in set;
      return_element : out element;
      position       : in element_range)
   is
   begin
      if (my_set.number_of_elements <= position or position < 0) then
         raise invalid_argument;
      end if;

      return_element := my_set.container (position);

   end get_element_number;

   function get_number_of_elements (my_set : in set) return element_range is
   begin
      return (my_set.number_of_elements);
   end get_number_of_elements;

   function is_empty (my_set : in set) return Boolean is
   begin
      return (my_set.number_of_elements = 0);
   end is_empty;

   function is_last_element
     (my_set      : in set;
      my_iterator : in iterator)
      return        Boolean
   is
   begin
      return (my_iterator.current = (my_set.number_of_elements - 1));
   end is_last_element;

   function is_first_element
     (my_set      : in set;
      my_iterator : in iterator)
      return        Boolean
   is
   begin
      return (my_iterator.current = 0);
   end is_first_element;

   procedure reset_iterator
     (my_set      : in set;
      my_iterator : in out iterator)
   is
   begin
      my_iterator.current := 0;
   end reset_iterator;

   procedure Reset_Tail_Iterator
     (My_Set      : in Set;
      My_Iterator : in out Iterator)
   is
   begin
      My_Iterator.Current := My_Set.number_of_elements-1;
   end Reset_Tail_Iterator;

   procedure sort (my_set : in out set; order : order_function) is

      Temp : element;

   begin
      for I in 0 .. my_set.number_of_elements - 1 loop
         for J in 0 .. (my_set.number_of_elements - 2) loop
            if not order
              (my_set.container (J),
               my_set.container (J + 1))
            then
               Temp                     := my_set.container (J);
               my_set.container (J)     := my_set.container (J + 1);
               my_set.container (J + 1) := Temp;
            end if;
         end loop;
      end loop;
   end sort;

   procedure select_and_copy
     (src         : in set;
      dest        : in out set;
      must_select : select_function)
   is

      Tmp : element;
   begin
      for I in 0 .. src.number_of_elements - 1 loop
         if must_select (src.container (I)) then
            Tmp := copy (src.container (I));
            add (dest, Tmp);
         end if;
      end loop;
   end select_and_copy;

   function select_and_copy
     (src         : in set;
      must_select : in select_function)
      return        set
   is
      Dest : set;
      Tmp  : element;
   begin
      for I in 0 .. src.number_of_elements - 1 loop
         if must_select (src.container (I)) then
            Tmp := copy (src.container (I));
            add (Dest, Tmp);
         end if;
      end loop;
      return Dest;
   end select_and_copy;

   procedure select_and_copy
     (src         : in set;
      dest        : in out set;
      must_select : select_function_parameterizable;
      parameter   : element)
   is

      Tmp : element;
   begin
      for I in 0 .. src.number_of_elements - 1 loop
         if must_select (src.container (I), parameter) then
            Tmp := copy (src.container (I));
            add (dest, Tmp);
         end if;
      end loop;
   end select_and_copy;

   function select_and_copy
     (src         : in set;
      must_select : select_function_parameterizable;
      parameter   : element)
      return        set
   is
      Dest : set;
      Tmp  : element;
   begin
      for I in 0 .. src.number_of_elements - 1 loop
         if must_select (src.container (I), parameter) then
            Tmp := copy (src.container (I));
            add (Dest, Tmp);
         end if;
      end loop;
      return Dest;
   end select_and_copy;

   procedure duplicate (src : in set; dest : in out set) is

      Tmp : element;
   begin
      dest.number_of_elements := src.number_of_elements;
      for I in 0 .. src.number_of_elements - 1 loop
         Tmp                := copy (src.container (I));
         dest.container (I) := Tmp;
      end loop;
   end duplicate;

   function xml_string (my_set : in set_ptr) return Unbounded_String is
   begin
      return xml_string (my_set.all);
   end xml_string;

   function xml_root_string (My_Set : in set_ptr) return Unbounded_String is
   begin
      return xml_root_string (My_Set.all);
   end xml_root_string;

   function xml_root_string (My_Set : in set) return Unbounded_String is
      str : Unbounded_String := To_Unbounded_String ("");
   begin
      for I in 0 .. My_Set.number_of_elements - 1 loop
         str := str & xml_string (My_Set.container (I));
      end loop;
      return str;
   end xml_root_string;

   function xml_string (my_set : in set) return Unbounded_String is
      str : Unbounded_String := To_Unbounded_String ("");
   begin
      for I in 0 .. my_set.number_of_elements - 1 loop
         str := str & xml_ref_string (my_set.container (I));
      end loop;
      return str;
   end xml_string;

   procedure put (my_set : in set_ptr) is
   begin
      put (my_set.all);
   end put;

   procedure put (my_set : in set) is
   begin
      Put_Line ("Number of elements : " & my_set.number_of_elements'Img);
      New_Line;
      for I in 0 .. my_set.number_of_elements - 1 loop
         put (my_set.container (I));
         New_Line;
      end loop;
   end put;

   function get_random_element (my_set : in set) return element is
      P : element_range;
   begin
      P := Random (G) mod my_set.number_of_elements;
      return my_set.container (P);
   end get_random_element;

   procedure swap
     (my_set : in out set;
      i : in Iterator;
      j : in Iterator)
   is
      Temp : element;
   begin
      Temp                         := my_set.container (j.current);
      my_set.container (j.current) := my_set.container (i.current);
      my_set.container (i.current) := Temp;
   end swap;

begin
   Reset (G);
end sets;