Ada 95 :: x60_ll5.ada

-- list  -> ( first_node, last_node ) ( prev,item,next)
-- Iter  -> ( cur_list_first, cur_list_last, cur_node )

with Ada.Finalization, Unchecked_deallocation;
use  Ada.Finalization;
generic
  type T is private;                  -- Any type
package Class_list is
  type List is new Controlled with private;

  procedure initialize( the:in out List );
  procedure initialize( the:in out List; data:in T );
  procedure finalize( the:in out List );
  procedure adjust( the:in out List );
  function "="  ( f:in List; s:in List ) return Boolean;
private
  procedure release_storage( the:in out List );

  type Node;                       -- Tentative declaration
  type P_Node is access all Node;  -- Pointer to Node

  type Node is record
    prev    : P_Node;              -- Previous Node
    item    : T;                   -- The physical item
    next    : P_Node;              -- Next Node
  end record;

  procedure dispose_node is
    new unchecked_deallocation( Node, P_Node );
  type List is new Controlled with record
    first_node : aliased P_Node := null;   -- First item in list
    last_node  : aliased P_Node := null;   -- First item in list
  end record;

end Class_list;

--with Simple_io; use  Simple_io;
package body Class_list is

  procedure initialize( the:in out List ) is
  begin
    the.first_node := null;   -- Empty list
    the.last_node  := null;   -- Empty list
  end initialize;

  procedure initialize( the:in out List; data:in T ) is
  begin
    the.first_node := new Node'(null, data, null);
    the.last_node  := the.first_node;
  end initialize;

  procedure finalize( the:in out List ) is
  begin
    if the.first_node /= null then
      release_storage( the );
      the.first_node := null;
    end if;
    --xyz( the ); -- Can not do this here DEBUG TRACE
  end finalize;

  procedure adjust( the:in out List ) is
    cur : P_Node := the.first_node;  -- Original list
    lst : P_Node := null;            -- Last created node
    prv : P_Node := null;            -- Previously created node
    fst : P_Node := null;            -- The first node

  begin
    while cur /= null loop
      lst := new Node'( prv, cur.item, null );
      if fst =  null then fst := lst; end if;
      if prv /= null then prv.next := lst; end if;
      prv := lst;
      cur := cur.next;               -- Next node
    end loop;
    the.first_node := fst;           -- Update
    the.last_node  := lst;
  end adjust;

  function "="  ( f:in List; s:in List ) return Boolean is
    f_node : P_Node := f.first_node;  -- First list
    s_node : P_Node := s.first_node;  -- Second list
  begin
    while f_node /= null and s_node /= null loop
      if f_node.item /= s_node.item then
        return FALSE;                 -- Different items
      end if;
      f_node := f_node.next; s_node := s_node.next;
    end loop;
    return f_node = s_node;           -- Both null if equal
  end "=";

  procedure release_storage( the:in out List ) is
    cur : P_Node := the.first_node; -- Pointer to curr node
    tmp : P_Node;                   -- Node to dispose
  begin
    while cur /= null loop          -- For each item in list
      tmp := cur;                   -- Item to dispose
      cur := cur.next;              -- Next node
      dispose_node( tmp );          -- Dispose of item
    end loop;
  end release_storage;

end Class_list;

--with Ada.Finalization; use  Ada.Finalization;
generic
package Class_list.Iterator is

  type List_iter is limited private;

  procedure initialize( the:in out List_iter );
  procedure finalize( the:in out List_iter );
  procedure first( the:in out List_iter; l:in out List );
  procedure last( the:in out List_iter; l:in out List );

  function  deliver( the:in List_iter) return T;
  procedure insert( the:in out List_iter; data:in T );
  procedure delete( the:in out List_iter );
  function  is_end( the:in List_iter ) return Boolean;
  procedure next( the:in out List_iter );
  procedure prev( the:in out List_iter );
private
  type P_P_Node is access all P_Node;
  type List_iter is record
    cur_list_first: P_P_Node := null;    -- First in chain
    cur_list_last : P_P_Node := null;    -- Last in chain
    cur_node      : P_Node   := null;    -- Current item
  end record;
end Class_list.Iterator;

--with Simple_io; use Simple_io;
package body Class_list.Iterator is

  procedure initialize( the:in out List_iter ) is
  begin
    the.cur_node       := null;   -- Iterator not setup
    the.cur_list_first := null;
    the.cur_list_last  := null;
  end initialize;

  procedure finalize( the:in out List_iter ) is
  begin
    null;
  end finalize;

  procedure first( the:in out List_iter; l:in out List ) is
  begin
    the.cur_node      := l.first_node;       -- Set to first
    the.cur_list_first:= l.first_node'Unchecked_Access;
    the.cur_list_last := l.last_node'Unchecked_Access;
  end first;

  procedure last( the:in out List_iter; l:in out List ) is
  begin
    the.cur_node      := l.last_node;        -- Set to last
    the.cur_list_first:= l.first_node'Unchecked_Access;
    the.cur_list_last := l.last_node'Unchecked_Access;
  end last;

  function deliver( the:in List_iter ) return T is
  begin
    return the.cur_node.item;  -- The current item
  end deliver;

  procedure insert( the:in out List_iter; data:in T ) is
    tmp   : P_Node;
    cur   : P_Node   := the.cur_node;   -- Current element
    first : P_P_Node := the.cur_list_first;
    last  : P_P_Node := the.cur_list_last;
  begin
    if cur = null then            -- Empty or last item
      if first.all = null then    --  Empty list
        tmp := new Node'( null, data, null );
        first.all := tmp;
        last.all  := tmp;
        the.cur_node := tmp;
      else                        --  Last
        tmp := new Node'( last.all, data, null );
        last.all.next := tmp;
        last.all      := tmp;
        the.cur_node := tmp;
       end if;
    else
      tmp := new Node'( cur.prev, data, cur );
      if cur.prev = null then      -- First item
        first.all := tmp;
      else
        cur.prev.next := tmp;
      end if;
      cur.prev := tmp;
    end if;
  end insert;

  procedure delete( the:in out List_iter) is
    cur   : P_Node   := the.cur_node;   -- Current element
    first : P_P_Node := the.cur_list_first;
    last  : P_P_Node := the.cur_list_last;
  begin
    if cur /= null then             -- Something to delete
      if cur.prev /= null then      -- Fix forward pointer;
        cur.prev.next := cur.next;  --  Not first in chain
      else
        first.all := cur.next;      --  First in chain
        if first.all = null then
          last.all := null;         --   Empty list
        end if;
      end if;
      if cur.next /= null then      -- Fix backward pointer;
        cur.next.prev := cur.prev;  --  Not last in chain
      else
        last.all := cur.prev;       --  Last in chain
        if last.all = null then
          first.all := null;        --   Empty list
        end if;
      end if;
      if cur.next /= null then      -- Fix current pointer
        the.cur_node := cur.next;   --  next
      elsif cur.prev /= null then
        the.cur_node := cur.prev;   --  previous
      else
        the.cur_node := null;       --  none empty list
      end if;
      dispose_node( cur );          -- Release storage
    end if;
  end delete;

  function  is_end( the:in List_iter ) return Boolean is
  begin
    return the.cur_node = null;               -- True if end
  end is_end;

  procedure next( the:in out List_iter ) is
  begin
    if the.cur_node /= null then               --
      the.cur_node  := the.cur_node.next;      -- Next
    end if;
  end next;

  procedure prev( the:in out List_iter ) is
  begin
    if the.cur_node /= null then               --
      the.cur_node  := the.cur_node.prev;      -- Previous
    end if;
  end prev;

end Class_list.Iterator;

with Class_list;
pragma ELABorATE_all( Class_List );
  package Class_list_nat is new Class_list(Natural);

with Class_list_nat, Class_list.Iterator;
  pragma ELABorATE_all( Class_List_nat, Class_List.Iterator );
  package Class_list_nat_iterator is new Class_list_nat.Iterator;


with Simple_io, Class_list_nat, Class_list_nat_iterator;
use  Simple_io, Class_list_nat, Class_list_nat_iterator;
package Pack_procedures is
  procedure ex1;
  procedure ex2;
  procedure ex3;
  procedure ex4;
  procedure ex5;
  procedure ex6;
end Pack_procedures;

with Simple_io; use Simple_io;
package body Pack_procedures is

procedure ex1 is
  numbers    : List;            -- List of Natural numbers
  numbers_it : List_iter;       -- Iterator for list
begin
  first( numbers_it, numbers );
  insert( numbers_it, 50 );
  insert( numbers_it, 5 );
  insert( numbers_it, 40 );
  last( numbers_it, numbers );
  next( numbers_it );
  insert( numbers_it, 100 );
  prev( numbers_it );
  prev( numbers_it );
  insert( numbers_it, 30 );
  first( numbers_it, numbers );
  while not is_end( numbers_it ) loop
    put( deliver( numbers_it ) );
    next( numbers_it );
  end loop;
  new_line;
end ex1;

procedure ex2 is
  numbers    : List;            -- List of Natural numbers
  numbers_it : List_iter;       -- Iterator for list

procedure insert( pos:in Integer; num:in Integer ) is
  count : Integer := pos;
begin
  first( numbers_it, numbers );
  while count >= 1 loop
    next( numbers_it ); count := count-1;
  end loop;
  insert( numbers_it, num );
end insert;

procedure delete( pos:in Integer ) is
  count : Integer := pos;
begin
  first( numbers_it, numbers );
  while count >= 1 loop
    next( numbers_it ); count := count-1;
  end loop;
  delete( numbers_it );
end delete;

procedure print is
begin
  first( numbers_it, numbers );
  while not is_end(numbers_it) loop
    put( deliver(numbers_it), width=>3 );
    next( numbers_it );
  end loop;
  new_line;
end print;

begin
  insert( 0, 50 ); print;
  put(" 50 <Should be>"); new_line;
  insert( 0, 30 ); print;
  put(" 30 50 <Should be>"); new_line;
  insert( 1, 40 ); print;
  put(" 30 40 50 <Should be>"); new_line;
  insert( 2, 45 ); print;
  put(" 30 40 45 50 <Should be>"); new_line;
  insert( 2, 42 ); print;
  put(" 30 40 42 45 50 <Should be>"); new_line;
  insert( 5, 99 ); print;
  put(" 30 40 42 45 50 99<Should be>"); new_line;

  delete( 5 ); print;
  put(" 30 40 42 45 50 <Should be>"); new_line;
  delete( 0 ); print;
  put(" 40 42 45 50 <Should be>"); new_line;
  delete( 1 ); print;
  put(" 40 45 50 <Should be>"); new_line;
  delete( 2 ); print;
  put(" 40 45 <Should be>"); new_line;
  delete( 1 ); print;
  put(" 40 <Should be>"); new_line;
  delete( 0 ); print;
  put(" <Should be>"); new_line;
end ex2;

procedure ex3 is
  numbers    : List;            -- List of Natural numbers
  numbers_it : List_iter;       -- Iterator for list
begin
  first( numbers_it, numbers );
  insert( numbers_it, 100 );
  insert( numbers_it, 50 );

  first( numbers_it, numbers );
  while not is_end(numbers_it) loop
    put( deliver(numbers_it) ); next( numbers_it );
  end loop;
  new_line;
end ex3;

procedure ex4 is
  numbers    : List;               -- List of Natural numbers
  numbers_it : List_iter;          -- Iterator for list
begin
  first( numbers_it, numbers );    -- Initialize
  for number in 1 .. 10 loop
    insert( numbers_it, number );  -- Insert before
    next( numbers_it );            -- Next item
  end loop;

  first(numbers_it,numbers);                -- Set to start
  while not is_end( numbers_it ) loop       -- Not end of list
    put( deliver(numbers_it) ); put(" ");   --  Print
    next( numbers_it );                     -- Next item
  end loop;
  new_line;
end ex4;

procedure ex5 is
  original: List;                      -- List of numbers
  copy    : List;                      -- List of numbers
  num_it  : List_iter;                 -- Iterator
begin
  for number in 1 .. 10 loop
    last( num_it, original );          -- Set iterator last
    next( num_it );                    -- So can insert
    insert( num_it, number );          --   after last item
  end loop;

  put("copy := original "); new_line;
  copy := original;

  put("copy = original ");
  if copy = original then put("True"); else put("False"); end if;
  new_line;

  put("Append 99 to copy "); new_line;
  last( num_it, copy ); next( num_it );
  insert( num_it, 99 );

  put("copy = original ");
  if copy = original then put("True"); else put("False"); end if;
  new_line;

  first(num_it,original);               -- Set to start
  while not is_end( num_it ) loop       -- Not end of list
    put( deliver(num_it), width=>4 );   --  Print
    next( num_it );                     -- Next item
  end loop;

  new_line;
  first(num_it,copy);                   -- Set to start
  while not is_end( num_it ) loop       -- Not end of list
    put( deliver(num_it), width=>4 );   --  Print
    next( num_it );                     -- Next item
  end loop;
  new_line;
end ex5;

procedure ex6 is
  numbers: List;                       -- List of numbers
  num_it : List_iter;                  --  Iterator
  num,in_list: Natural;
begin
  first( num_it, numbers );

  while not end_of_file loop           -- Data available
    while not end_of_line loop
      get(num); first(num_it,numbers); -- Read number
      while not is_end( num_it ) loop  -- Scan through list
          in_list := deliver(num_it);
          exit when in_list > num;     -- Exit when larger no.
          next( num_it );              -- Next item
      end loop;
      insert( num_it, num );           -- Before larger no.
    end loop;
    skip_line;                         -- Next line
  end loop;

  put("Numbers sorted are: ");
  first(num_it,numbers);               -- Set at start
  while not is_end( num_it ) loop
    in_list := deliver( num_it );      -- Current number
    put( in_list,width=>1 ); put(" "); --  Print
    next( num_it );                    -- Next number
  end loop;
  new_line;
end ex6;


end Pack_procedures;

with Simple_io, Pack_procedures;
use  Simple_io, Pack_procedures;
procedure main is
begin
  put("Example 1"); new_line; ex1;
  put("Example 2"); new_line; ex2;
  put("Example 3"); new_line; ex3;
  put("Example 4"); new_line; ex4;
  put("Example 5"); new_line; ex5;
  put("Example 6"); new_line; ex6;
end main;


© M.A.Smith University of Brighton. Created September 1995 last modified May 1997.
Comments, suggestions, etc. M.A.Smith@brighton.ac.uk * [Home page]