Ada 95 :: x60_set.ada

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, Class_list.Iterator;
pragma ELABorATE_all( Class_List, Class_List.Iterator );
generic
  type T is private;
  with procedure put( item:in T ) is <>;
  with function  ">" (first,second:in T ) return Boolean is <>;
  with function  "<" (first,second:in T ) return Boolean is <>;
package Class_set is
  type Set is private;
  procedure put( the:in Set );
  function "+"( f:in Set; s:in Set ) return Set;
  function set_const( item: in T )   return Set;
  function members( the:in Set )     return Positive;
private
  package Class_list_t          is new Class_list(T);
  package Class_list_t_iterator is new Class_list_t.Iterator;
  type Set is new Class_list_t.List with record
    elements : Natural := 0;             -- Elements in set
  end record;
end Class_set;

with Simple_io; use Simple_io;
package body Class_set is
  use Class_list_t, Class_list_t_iterator;

  procedure put( the:in Set ) is
    it    : List_iter;
    c_the : List := List(the);
  begin
    put("("); first( it, c_the );
    for i in 1 .. the.elements loop
      put( deliver(it) ); next( it );
      if i /= the.elements then put(","); end if;
    end loop;
    put(")");
  end put;

  function "+"  ( f:in Set; s:in Set ) return Set is
    res_it    : List_iter;
    f_it,s_it : List_iter;
    res       : Set;
    f_list, s_list: List;
  begin
    f_list := List(f); s_list := List(s);
    first( f_it, List(f_list) );
    first( s_it, List(s_list) );
    first( res_it, List(res) );

    while (not is_end(f_it)) or (not is_end(s_it)) loop
      if is_end(f_it) then
        next(res_it); insert(res_it, deliver(s_it));
        next(s_it);
      elsif is_end(s_it) then
        next(res_it); insert(res_it, deliver(f_it));
        next(f_it);
      elsif deliver(f_it) < deliver(s_it) then
        next(res_it); insert(res_it, deliver(f_it));
        next(f_it);
      elsif deliver(f_it) > deliver(s_it) then
        next(res_it); insert(res_it, deliver(s_it));
        next(s_it);
      elsif deliver(f_it) = deliver(s_it) then
        next(res_it); insert(res_it, deliver(f_it) );
        next(f_it); next(s_it);
      end if;
      res.elements := res.elements + 1;
    end loop;
    return res;
  end "+";


  function set_const( item: in T ) return Set is
    res : Set;
  begin
    initialize( res, item ); res.elements := 1;
    return res;
  end set_const;

  function members( the:in Set ) return Positive is
  begin
    return the.elements;
  end members;

end Class_set;

-- ---- --- --- --- --- --- --- --- --- --- --- --- --- ---

-- ---- --- --- --- --- --- --- --- --- --- --- --- --- ---

package Pack_types is
  type Filling is ( CHEESE, ONION, HAM, TOMATO );
end Pack_types;

with Simple_io, Pack_types; 
use  Simple_io, Pack_types;
procedure put_filling( c:in Filling ) is
begin
  put( Filling'Image( c ) );
end put_filling;

with Pack_types, Class_set, put_filling;
use  Pack_types;                          -- **** Object Ada
pragma ELABorATE_all( Class_set );
package Class_set_sandwich is 
  new Class_set( T => Pack_types.Filling, put => put_filling );

 with Pack_types, Simple_io, Class_set_sandwich;
 use  Pack_types, Simple_io, Class_set_sandwich;
procedure main1 is
  sandwich : Class_set_sandwich.Set;
begin
  sandwich := sandwich + set_const(CHEESE);
  sandwich := sandwich + set_const(ONION) ;
  put("Contents of sandwich are : ");
  put( sandwich ); new_line;
  put("Number of ingredients is : ");
  put( members(sandwich) ); new_line;
  null;
end main1;

-- ---- --- --- --- --- --- --- --- --- --- --- --- --- ---

with Simple_io;
procedure put_natural( n:in Natural ) is
begin
  Simple_io.put( n, width=>2 );
end put_natural;

with Class_set, put_natural;
pragma ELABorATE_all( Class_set );
package Class_set_naturals is 
  new Class_set( T => Natural, put => put_natural );

with Simple_io, Class_set_naturals;
use  Simple_io, Class_set_naturals;
procedure main2 is
  set1 : Class_set_naturals.Set;
  set2 : Class_set_naturals.Set;
  set3 : Class_set_naturals.Set;
begin
  for i in 1 .. 5 loop
    set1 := set1 + set_const(i*2);
  end loop;
  put( "Set 1 =       "); put( set1 ); new_line;
  for i in 1 .. 5 loop
    set2 := set2 + set_const(i*2+1);
  end loop;
  put( "Set 2 =       "); put( set2 ); new_line;
  put( "Set 1 + Set 2 ");
  put( set1+set2 ); new_line;
  for i in 4 .. 15 loop
    set3 := set3 + set_const(i);
  end loop;
  put( "Set 3 =       "); put( set3 ); new_line;
  put( "Set 2 + Set 3 ");
  put( set2+set3 ); new_line;
end main2;


with Simple_io;
use  Simple_io;
procedure main3 is
begin
  null;
end main3;

with Simple_io;
use  Simple_io;
procedure main4 is
begin
  null;
end main4;

with Simple_io, main1, main2, main3, main4;
use  Simple_io;
procedure main is
begin
  put("Example 1 "); new_line; main1;
  put("Example 2 "); new_line; main2;
  put("Example 3 "); new_line; main3;
  put("Example 4 "); new_line; main4;
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]