------------------------------------------------------------------------------
------------------------------------------------------------------------------
-- 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 Unchecked_Deallocation;

package body lists is

   procedure free is new Unchecked_Deallocation (cell, cell_ptr);

   procedure initialize (l : in out list) is

      current  : cell_ptr := l.head;
      previous : cell_ptr;

   begin
      while current /= null loop
         previous := current;
         current  := current.next;
         free (previous);
      end loop;

      l.head := null;
      l.tail := null;
   end initialize;

   procedure add (l : in out list; e : in element) is

      new_cell : cell_ptr;

   begin
      new_cell      := new cell;
      new_cell.info := e;

      new_cell.next := l.head;
      l.head        := new_cell;

      if (l.tail = null) then
         l.tail := new_cell;
      else
         new_cell.next.previous := new_cell;
      end if;

   end add;

   procedure add_head (l : in out list; e : in element) is

   begin

      add (l, e);

   end add_head;

   procedure add_tail (l : in out list; e : in element) is

      new_cell : cell_ptr;

   begin
      new_cell      := new cell;
      new_cell.info := e;

      new_cell.previous := l.tail;
      l.tail            := new_cell;

      if (l.head = null) then
         l.head := new_cell;
      else
         new_cell.previous.next := new_cell;
      end if;

   end add_tail;

   procedure put (l : in list) is

      current : cell_ptr := l.head;

   begin
      while current /= null loop
         put (current.info);
         current := current.next;
      end loop;
   end put;

   function get_number_of_elements (l : in list) return Natural is
      current : cell_ptr := l.head;
      size    : Natural  := 0;

   begin
      while current /= null loop
         size    := size + 1;
         current := current.next;
      end loop;

      return size;

   end get_number_of_elements;

   procedure delete (l : in out list; e : in list) is

      current : cell_ptr := e.head;

   begin
      while current /= null loop
         delete (l, current.info);
         current := current.next;
      end loop;
   end delete;

   procedure delete (l : in out list; e : in element) is

      current  : cell_ptr := l.head;
      is_found : Boolean  := False;

   begin
      while current /= null loop
         if current.info = e then
            is_found := True;

            -- Delete the last item
            --
            if (current.previous = null) and (current.next = null) then
               l.head := null;
               l.tail := null;
            else

               -- Delete the Head item
               --
               if (current.previous = null) then
                  l.head                := current.next;
                  current.next.previous := null;
               else
                  -- delete the Tail item
                  --
                  if (current.next = null) then
                     l.tail                := current.previous;
                     current.previous.next := null;
                  -- Middle item
                  --
                  else
                     current.previous.next := current.next;
                     current.next.previous := current.previous;
                  end if;
               end if;
            end if;

            free (current);
            exit;
         end if;

         current := current.next;
      end loop;

      if not is_found then
         raise element_not_found;
      end if;

   end delete;

   function element_in_list (e : in element; l : in list) return Boolean is
      current  : cell_ptr := l.head;
      is_found : Boolean  := False;

   begin
      while current /= null loop
         if current.info = e then
            is_found := True;
            exit;
         end if;
         current := current.next;
      end loop;

      return is_found;

   end element_in_list;

   procedure delete (l : in out list) is

      current  : cell_ptr := l.head;
      previous : cell_ptr;

   begin
      while current /= null loop
         previous := current;
         current  := current.next;
         free (previous);
      end loop;

   end delete;

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

      current : cell_ptr := src.tail;

   begin

      while current /= null loop

         add (dest, current.info);

         current := current.previous;
      end loop;

   end duplicate;

   function get_head (l : in list) return element is
   begin
      return (l.head.info);
   end get_head;

   function get_tail (l : in list) return element is
   begin
      return (l.tail.info);
   end get_tail;

   procedure get_element_number
     (my_list        : in     list;
      return_element :    out element;
      position       : in     Integer)
   is
      i : Integer;

      my_iterator : iterator;
      an_element  : element;
   begin
      if (get_number_of_elements (my_list) <= position or position < 0) then
         raise invalid_argument;
      end if;

      if not is_empty (my_list) then
         reset_head_iterator (my_list, my_iterator);

         i := 0;
         loop
            current_element (my_list, an_element, my_iterator);

            if (i = position) then
               return_element := an_element;
               exit;
            end if;

            exit when is_tail_element (my_list, my_iterator);
            next_element (my_list, my_iterator);
            i := i + 1;
         end loop;
      end if;
   end get_element_number;

   function is_empty (l : in list) return Boolean is
   begin
      return (l.head = null) or (l.tail = null);
   end is_empty;

   procedure previous_element (l : in list; my_iterator : in out iterator) is
   begin
      my_iterator.current := my_iterator.current.previous;
   end previous_element;

   procedure next_element (l : in list; my_iterator : in out iterator) is
   begin
      my_iterator.current := my_iterator.current.next;
   end next_element;

   function is_tail_element
     (l           : in list;
      my_iterator : in iterator) return Boolean
   is
   begin
      return (my_iterator.current = l.tail) or (l.tail = null);
   end is_tail_element;

   function is_head_element
     (l           : in list;
      my_iterator : in iterator) return Boolean
   is
   begin
      return (my_iterator.current = l.head) or (l.head = null);
   end is_head_element;

   procedure current_element
     (l              : in     list;
      return_element :    out element;
      my_iterator    : in     iterator)
   is
   begin
      return_element := my_iterator.current.info;
   end current_element;

   procedure reset_head_iterator
     (l           : in     list;
      my_iterator : in out iterator)
   is
   begin
      my_iterator.current := l.head;
   end reset_head_iterator;

   procedure reset_tail_iterator
     (l           : in     list;
      my_iterator : in out iterator)
   is
   begin
      my_iterator.current := l.tail;
   end reset_tail_iterator;

   function xml_string
     (obj   : in list;
      level : in Natural := 0) return Unbounded_String
   is
      result  : Unbounded_String := To_Unbounded_String ("");
      current : cell_ptr         := obj.head;
   begin
      while current /= null loop
         result  := result & xml_string (current.info);
         current := current.next;
      end loop;
      return result;
   end xml_string;

   function get_random_element (my_list : in list) return element is
      p : Integer;
      e : element;
   begin
      p := Random (g) mod get_number_of_elements (my_list);
      get_element_number (my_list, e, p);
      return e;
   end get_random_element;

   procedure sort (my_list : in out list; order : order_function) is
      temp         : element;
      cur_i, cur_j : cell_ptr;
   begin
      cur_i := my_list.head;

      while cur_i /= null loop
         cur_j := cur_i.next;

         while cur_j /= null loop
            if not order (cur_i.info, cur_j.info) then
               temp       := cur_i.info;
               cur_i.info := cur_j.info;
               cur_j.info := temp;
            end if;

            cur_j := cur_j.next;
         end loop;

         cur_i := cur_i.next;
      end loop;
   end sort;

begin
   Reset (g);
end lists;