::
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]