Programmer's ROM - The Computer Language Library/programmersrom.iso/ada/misc/slist.src

Text File | 1988-05-03 | 23.3 KB | 595 lines

::::::::::
slist.pro
::::::::::
-------- SIMTEL20 Ada Software Repository Prologue ------------
--                                                           -*
-- Unit name    : SINGLY_LINKED_LIST
-- Version      : 1.0
-- Author       : Tim Harrison
--              : Texas Instruments
--              :
--              :
-- DDN Address  : THarrison@ECLB
-- Copyright    : (c) 1985
-- Date created :  1-Mar-85
-- Release date : 15-Jul-85
-- Last update  :
-- Machine/System Compiled/Run on : VAX/VMS 4.1/VMS 4.1
--                                                           -*
---------------------------------------------------------------
--                                                           -*
-- Keywords     : Singly Linked List
----------------:
--
-- Abstract     : This package provides an abstract singly linked list
----------------: with a single point of reference.
--                                                           -*
------------------ Revision history ---------------------------
--                                                           -*
-- DATE         VERSION    AUTHOR                  HISTORY
-- 15-May-85    1.0     Tim Harrison        Original
--                                                           -*
------------------ Distribution and Copyright -----------------
--                                                           -*
-- This prologue must be included in all copies of this software.
--
-- This software is copyright by the author.
--
-- This software is released to the Ada community.
-- This software is released to the Public Domain (note:
--   software released to the Public Domain is not subject
--   to copyright protection).
-- Restrictions on use or distribution:  NONE
--                                                           -*
------------------ Disclaimer ---------------------------------
--                                                           -*
-- This software and its documentation are provided "AS IS" and
-- without any expressed or implied warranties whatsoever.
-- No warranties as to performance, merchantability, or fitness
-- for a particular purpose exist.
--
-- Because of the diversity of conditions and hardware under
-- which this software may be used, no warranty of fitness for
-- a particular purpose is offered.  The user is advised to
-- test the software thoroughly before relying on it.  The user
-- must assume the entire risk and liability of using this
-- software.
--
-- In no event shall any person or organization of people be
-- held responsible for any direct, indirect, consequential
-- or inconsequential damages or lost profits.
--                                                           -*
-------------------END-PROLOGUE--------------------------------
::::::::::
slist.ada
::::::::::
-------- SIMTEL20 Ada Software Repository Prologue ------------
--                                                           -*
-- Unit name    : SINGLY_LINKED_LIST
-- Version      : 1.0
-- Author       : Tim Harrison
--              : Texas Instruments
--              :
--              :
-- DDN Address  : THarrison@ECLB
-- Copyright    : (c) 1985
-- Date created :  1-Mar-85
-- Release date : 15-Jul-85
-- Last update  :
-- Machine/System Compiled/Run on : VAX/VMS 4.1/VMS 4.1
--                                                           -*
---------------------------------------------------------------
--                                                           -*
-- Keywords     : Singly Linked List
----------------:
--
-- Abstract     : This package provides an abstract singly linked list
----------------: with a single point of reference.
--                                                           -*
------------------ Revision history ---------------------------
--                                                           -*
-- DATE         VERSION    AUTHOR                  HISTORY
-- 15-May-85    1.0     Tim Harrison        Original
--                                                           -*
------------------ Distribution and Copyright -----------------
--                                                           -*
-- This prologue must be included in all copies of this software.
--
-- This software is copyright by the author.
--
-- This software is released to the Ada community.
-- This software is released to the Public Domain (note:
--   software released to the Public Domain is not subject
--   to copyright protection).
-- Restrictions on use or distribution:  NONE
--                                                           -*
------------------ Disclaimer ---------------------------------
--                                                           -*
-- This software and its documentation are provided "AS IS" and
-- without any expressed or implied warranties whatsoever.
-- No warranties as to performance, merchantability, or fitness
-- for a particular purpose exist.
--
-- Because of the diversity of conditions and hardware under
-- which this software may be used, no warranty of fitness for
-- a particular purpose is offered.  The user is advised to
-- test the software thoroughly before relying on it.  The user
-- must assume the entire risk and liability of using this
-- software.
--
-- In no event shall any person or organization of people be
-- held responsible for any direct, indirect, consequential
-- or inconsequential damages or lost profits.
--                                                           -*
-------------------END-PROLOGUE--------------------------------

generic
  type List_Element is private;
package Singly_Linked_List is
-------------------------------------------------------------------------------
-- Abstract   : This package provides an abstraction for a singly linked list.
-------------------------------------------------------------------------------
  type List_Type is limited private;

  function Empty (List : List_Type) return Boolean;
-- Indicates whether the list contains any elements.

  function Null_Node (List : List_Type) return Boolean;
-- Indicates whether the "current pointer" references an element in the list.

  function Head_Node (List : List_Type) return Boolean;
-- Indicates whether the "current pointer" references the head of the list.

  function Tail_Node (List : List_Type) return Boolean;
-- Indicates whether the "current pointer" references the tail of the list.

  function Current_Element (List : List_Type) return List_Element;
-- Returns the value of the element referenced by the "current pointer".
-- Raises End_Error if Null_Node(List) = True.

  procedure First (List : in out List_Type);
-- Positions the "current pointer" at the head of the list
-- (even if the list is empty).

  procedure Next (List : in out List_Type);
-- Positions the "current pointer" at the next element in the list.
-- After the last element in the list Null_Node(List) becomes True.
-- Raises End_Error if Null_Node(List) = True.

  procedure Insert_After (List : in out List_Type; Element : List_Element);
-- Inserts an element after the "current pointer".
-- If Null_Node(List) = True the element is appended after the tail element.

  procedure Insert_Before (List : in out List_Type; Element : List_Element);
-- Inserts an element before the "current pointer".
-- If Null_Node(List) = True the element is prepended before the head element.

  procedure Delete_Element (List : in out List_Type);
-- Deletes the element referenced by the "current pointer" from the list.
-- Upon deletion, the "current pointer" references the element after the
-- deleted element.
-- Raises End_Error if Null_Node(List) = True.

  generic
    with procedure Transformation (Element : in out List_Element);
  procedure Modify (List : List_Type);
-- Permits modification of the element referenced by the "current pointer"
-- where the modification doesn't require external values (e.g. incrementing
-- a field of the element).
-- Raises End_Error if Null_Node(List) = True.

  generic
    type Update_Information is private;
    with procedure Transformation (Element     : in out List_Element;
                                   Information : Update_Information);
  procedure Update (List : List_Type; Information : Update_Information);
-- Permits modification of the element referenced by the "current pointer"
-- where the modification requires external values (e.g. assigning a value
-- to a field of the element).
-- Raises End_Error if Null_Node(List) = True.

  pragma Inline (Empty, Null_Node, Head_Node, Tail_Node, Current_Element);

  pragma Inline (Modify, Update);

  End_Error : exception;

private

  type Node;
  type Node_Access is access Node;
  type Node is
    record
      Element : List_Element;
      Next    : Node_Access;
    end record;

  type List_Type is
    record
      Head     : Node_Access;
      Tail     : Node_Access;
      Previous : Node_Access;
      Current  : Node_Access;
    end record;

end Singly_Linked_List;


with Unchecked_Deallocation;
package body Singly_Linked_List is
--------------------------------------------------------------------------
-- Abstract   : This package provides an abstraction for a singly linked
--              list.
--------------------------------------------------------------------------
-- Assumptions:
--      The lists being manipulated must be in one of the following states
--      both before and after execution of any subprogram in the package:
--              (1) empty-list          -- Head = null, Tail = null,
--                                         Previous = null, Current = null
--              (2) beginning-of-list   -- Head /= null, Tail /= null
--                                         Previous = null, Current = Head
--              (3) inside-of-list      -- Head /= null, Tail /= null
--                                         Previous.Next = Current
--              (4) outside-of-list     -- Head /= null, Tail /= null
--                                         Previous = null, Current = null
----------------------------------------------------------------------

  function Empty (List : List_Type) return Boolean is
--------------------------------------------------------------------------
-- Abstract   : Indicates whether the list contains any elements.
--------------------------------------------------------------------------
-- Parameters : LIST - is the list to be queried.
--------------------------------------------------------------------------
  begin
    return (List.Head = null);
  end Empty;

  function Null_Node (List : List_Type) return Boolean is
--------------------------------------------------------------------------
-- Abstract   : Indicates whether the "current pointer" references an
--              element in the list.
--------------------------------------------------------------------------
-- Parameters : LIST - is the list to be queried.
--------------------------------------------------------------------------
  begin
    return (List.Current = null);
  end Null_Node;

  function Head_Node (List : List_Type) return Boolean is
--------------------------------------------------------------------------
-- Abstract   : Indicates whether the "current pointer" references the
--              head of the list.
--------------------------------------------------------------------------
-- Parameters : LIST - is the list to be queried.
--------------------------------------------------------------------------
  begin
    return (List.Current = List.Head);
  end Head_Node;

  function Tail_Node (List : List_Type) return Boolean is
--------------------------------------------------------------------------
-- Abstract   : Indicates whether the "current pointer" references the
--              tail of the list.
--------------------------------------------------------------------------
-- Parameters : LIST - is the list to be queried.
--------------------------------------------------------------------------
  begin
    return (List.Current = List.Tail);
  end Tail_Node;

  function Current_Element (List : List_Type) return List_Element is
--------------------------------------------------------------------------
-- Abstract   : Returns the value of the element referenced by the
--              "current pointer".
--              Raises END_ERROR if NULL_NODE(LIST) = TRUE.
--------------------------------------------------------------------------
-- Parameters : LIST - is the list to be queried.
--------------------------------------------------------------------------
  begin
    if List.Current = null then
      raise End_Error;
    else
      return List.Current.Element;
    end if;
  end Current_Element;

  procedure First (List : in out List_Type) is
--------------------------------------------------------------------------
-- Abstract   : Positions the "current pointer" at the head of the list
--              (even if the list is empty).
--------------------------------------------------------------------------
-- Parameters : LIST - is the list to be modified.
--------------------------------------------------------------------------
  begin
    List.Previous := null;
    List.Current := List.Head;
  end First;

  procedure Next (List : in out List_Type) is
--------------------------------------------------------------------------
-- Abstract   : Positions the "current pointer" at the next element in the
--              list.  After the last element in the list NULL_NODE(LIST)
--              becomes true.
--              Raises END_ERROR if NULL_NODE(LIST) = TRUE.
--------------------------------------------------------------------------
-- Parameters : LIST - is the list to be modified.
--------------------------------------------------------------------------
  begin
    if List.Current = null then
      raise End_Error;
    else
      if List.Current = List.Tail then
        List.Previous := null;
      else
        List.Previous := List.Current;
      end if;
      List.Current := List.Current.Next;
    end if;
  end Next;

  procedure Insert_After (List : in out List_Type; Element : List_Element) is
--------------------------------------------------------------------------
-- Abstract   : Inserts an element after the "current pointer".
--              If NULL_NODE(LIST) = TRUE the element is appended after
--              the tail element of the list.
--------------------------------------------------------------------------
-- Parameters : LIST    - is the list to be modified.
--              ELEMENT - is the element to be inserted.
--------------------------------------------------------------------------
  begin
    if List.Current = null then
      List.Current := List.Tail;
    end if;
    if Empty (List) then
      List.Head := new Node'(Element, null);
      List.Tail := List.Head;
      List.Previous := null;
      List.Current := List.Head;
    else
      declare
        New_Node : Node_Access := new Node'(Element, List.Current.Next);
      begin
        if List.Current = List.Tail then
          List.Tail := New_Node;
        end if;
        List.Previous := List.Current;
        List.Previous.Next := New_Node;
        List.Current := New_Node;
      end;
    end if;
  end Insert_After;

  procedure Insert_Before (List    : in out List_Type;
                           Element : List_Element) is
--------------------------------------------------------------------------
-- Abstract   : Inserts an element before the "current pointer".
--              If NULL_NODE(LIST) = TRUE the element is prepended before
--              the head element of the list.
--------------------------------------------------------------------------
-- Parameters : LIST    - is the list to be modified.
--              ELEMENT - is the element to be inserted.
--------------------------------------------------------------------------
  begin
    if List.Current = null then
      List.Current := List.Head;
    end if;
    if Empty (List) then
      List.Head := new Node'(Element, null);
      List.Tail := List.Head;
      List.Previous := null;
      List.Current := List.Head;
    elsif List.Current = List.Head then
      List.Head := new Node'(Element, List.Head);
      List.Previous := null;
      List.Current := List.Head;
    else
      List.Previous.Next := new Node'(Element, List.Current);
      List.Current := List.Previous.Next;
    end if;
  end Insert_Before;

  procedure Delete_Element (List : in out List_Type) is
--------------------------------------------------------------------------
-- Abstract   : Deletes the element referenced by the "current pointer"
--              from the list.  Upon deletion the "current pointer"
--              references the element after the deleted element.
--              Raises END_ERROR if NULL_NODE(LIST) = TRUE.
--------------------------------------------------------------------------
-- Parameters : LIST - is the list to be modified.
--------------------------------------------------------------------------

    procedure Free is new Unchecked_Deallocation (Node, Node_Access);

  begin
    if List.Current = null then
      raise End_Error;
    elsif List.Current = List.Head then
      declare
        Next_Node : Node_Access := List.Head.Next;
      begin
        Free (List.Head);
        List.Head := Next_Node;
        if List.Head = null then
          List.Tail := null;
        end if;
        List.Current := List.Head;
      end;
    else
      if List.Current = List.Tail then
        List.Tail := List.Previous;
      end if;
      List.Previous.Next := List.Current.Next;
      Free (List.Current);
      List.Current := List.Previous.Next;
      if List.Current = null then
        List.Previous := null;
      end if;
    end if;
  end Delete_Element;

  procedure Modify (List : List_Type) is
--------------------------------------------------------------------------
-- Abstract   : Permits modification of the element referenced by the
--              "current pointer" where the modification doesn't require
--              external values (e.g. incrementing a field of the element).
--              Raises END_ERROR if NULL_NODE(LIST) = TRUE.
--------------------------------------------------------------------------
-- Parameters : LIST - is the list to be modified.
--------------------------------------------------------------------------
  begin
    if List.Current = null then
      raise End_Error;
    else
      Transformation (List.Current.Element);
    end if;
  end Modify;

  procedure Update (List : List_Type; Information : Update_Information) is
--------------------------------------------------------------------------
-- Abstract   : Permits modification of the element referenced by the
--              "current pointer" where the modification requires
--              external values (e.g. assigning a value to a field of
--              the element).
--              Raises END_ERROR if NULL_NODE(LIST) = TRUE.
--------------------------------------------------------------------------
-- Parameters : LIST        - is the list to be modified.
--              INFORMATION - is the data necessary for the modification.
--------------------------------------------------------------------------
  begin
    if List.Current = null then
      raise End_Error;
    else
      Transformation (List.Current.Element, Information);
    end if;
  end Update;

end Singly_Linked_List;
::::::::::
slist_test.ada
::::::::::
with Text_IO,
     Singly_Linked_List;
use Text_IO;
procedure Singly_Linked_List_Test is

  package Boolean_IO is new Enumeration_IO(Boolean);
  use Boolean_IO;

  package Int_IO is new Integer_IO(Integer);
  use Int_IO;

  package Integer_List is new Singly_Linked_List(Integer);
  use Integer_List;

  procedure Increment(Element : in out Integer);

  procedure Increment_Element is new Integer_List.Modify(Increment);

  procedure Replace(Element : in out Integer;
                    Data    : in     Integer);

  procedure Replace_Element is new Integer_List.Update(Integer, Replace);

  Command       : Character;
  Done          : Boolean := False;
  Element       : Integer := 0;
  List          : Integer_List.List_Type;

  procedure Increment(Element : in out Integer) is
  begin
    Element := Element + 1;
  end Increment;

  procedure Replace(Element : in out Integer;
                    Data    : in     Integer) is
  begin
    Element := Data;
  end Replace;

  procedure Print_List is
  begin
    if not Empty(List) then
      Put_Line("The list currently contains:");
    else
      Put_Line("The list is empty.");
    end if;
    First(List);
    while not Null_Node(List) loop
      Put(Current_Element(List)); New_Line;
      Next(List);
    end loop;
  end Print_List;

begin
  Put_Line("Singly_Linked_List test program (Version 0.1)");
  while not Done loop
    New_Line;
    Put_Line("Enter command (S F/N I/D M/U P/Q):");
    Get(Command); Skip_Line;
    begin
      case Command is
        when 'S' | 's' =>
          if Empty(List) then
            Put("-- Empty List ");
          end if;
          if Head_Node(List) then
            Put("-- Current is at Head ");
          end if;
          if Tail_Node(List) then
            Put("-- Current is at Tail ");
          end if;
          if Null_Node(List) then
            Put("-- Current is Null");
          else
            Put("-- Current Element is" & Integer'Image(Current_Element(List)));
          end if;
          New_Line;
        when 'F' | 'f' => First(List);
        when 'N' | 'n' => Next(List);
        when 'I' | 'i' =>
          Put_Line("Enter position (B/efore A/fter):");
          Get(Command); Skip_Line;
          case Command is
            when 'A' | 'a' => Insert_After(List, Element);
                                Put_Line(Integer'Image(Element) &
                                        " inserted AFTER current element.");
                                Element := Integer'Succ(Element);
            when 'B' | 'b' => Insert_Before(List, Element);
                                Put_Line(Integer'Image(Element) &
                                        " inserted BEFORE current element.");
                                Element := Integer'Succ(Element);
            when others  => null;
          end case;
        when 'D' | 'd' => Delete_Element(List);
        when 'M' | 'm' => Increment_Element(List);
        when 'U' | 'u' =>
          declare
            Data : Integer;
          begin
            loop
              begin
                Put_Line("Enter replacement number:");
                Get(Data); Skip_Line;
                exit;
              exception
                when others => null;
              end;
            end loop;
            Replace_Element(List, Data);
          end;
        when 'P' | 'p' => Print_List;
        when 'Q' | 'q' => Done := True;
        when others =>
          New_Line;
          Put_Line("S/tatus");
          Put_Line("F/irst    N/ext");
          Put_Line("I/nsert   D/elete");
          Put_Line("M/odify   U/pdate");
          Put_Line("P/rint    Q/uit");
      end case;
    exception
      when others => Put_Line("Exception raised.");
    end;
  end loop;
end Singly_Linked_List_Test;