------------------------------------------------------------------------------
------------------------------------------------------------------------------
-- 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-2023, 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 README.md
--
-- 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;