Ada 95 :: x56_tree.ada

with Ada.Strings.Bounded; use Ada.Strings.Bounded;
  package B_String is
    new Generic_Bounded_Length( 80 );

-- Note I/O errors on finalize initialize passed to user
with B_string, Ada.Finalization; 
use  B_string, Ada.Finalization;
generic
  type Index is private;                  -- Index for record
  type Data  is private;                  -- Data for record
  with function  ">"( f:in Index; s:in Index ) return Boolean;
package Class_pic is
  Not_there, Exists, Per_error : exception; -- Raised Exceptions
  type PIC  is new Limited_controlled with private;
  procedure initialize( the:in out PIC );
  procedure initialize( the:in out PIC; id:in String );
  procedure finalize( the:in out PIC );
  procedure discard( the:in out PIC );
  procedure set_name( the:in out PIC; id:in String );
  function  get_name( the:in PIC ) return String;

  procedure add( the:in out PIC; i:in Index; d:in Data );
  procedure extract( the:in out PIC; i:in Index; d:in out Data );
  procedure update( the:in out PIC; i:in Index; d:in out Data );
private
  type Leaf;                     -- Index + Data
  type Subtree is access Leaf;   --
  type PIC is new Limited_controlled with record
    tree   : Subtree := null;    --  Storage
    obj_id : Bounded_string;     --  Name of object
  end record;

  function  find( the:in Subtree; i:in Index) return Subtree;
  procedure release_storage( the:in out Subtree );

end Class_pic;

with unchecked_deallocation, sequential_io;
package body Class_pic is

  type Element is record    --
    s_index: Index;         -- The Index
    s_data : Data;          -- The Data
  end record;

  type Leaf is record       --
    left   : Subtree;       -- Possible left node
    rec    : Element;       -- Index + data
    right  : Subtree;       -- Possible right node;
  end record;

  package io is new Sequential_io( Element );

  procedure initialize( the:in out PIC ) is
  begin
    the.tree := null;    -- No storage
  end initialize;

  procedure initialize( the:in out PIC; id:in String ) is
    per : io.File_type;    -- File descriptor
    cur : Element;         -- Persistent data record element
  begin
    set_name( the, id );                  -- Name object
    io.open( per, io.IN_FILE, id );       -- Open saved state
    while not io.end_of_file( per ) loop  -- Restore saved state
      io.read( per, cur );
      add( the, cur.s_index, cur.s_data );
    end loop;
    io.close( per );
  exception                               -- Return real exception
     when others => raise Per_error;      --  as sub code
  end initialize;

  procedure finalize( the:in out PIC ) is
    per : io.File_type;    -- File descriptor
    procedure rec_finalize( the:in Subtree ) is -- Save state
    begin
      if the /= null then                   -- Subtree save as
        io.write( per, the.rec );           --  Item
        rec_finalize( the.left );           --  LHS
        rec_finalize( the.right );          --  RHS
      end if;
    end rec_finalize;
  begin
    if to_string(the.obj_id) /= "" then     -- If save state
      io.create( per, io.out_FILE,
                 to_string( the.obj_id ) );
      rec_finalize( the.tree );
      io.close( per );
    end if;
    release_storage( the.tree );
  exception                              -- Return real exception
     when others => raise Per_error;     --  as sub code
  end finalize;

  procedure discard( the:in out PIC ) is
  begin
    set_name( the, "" );                 -- No name
    release_storage( the.tree );         -- Release storage
  end discard;

  procedure set_name( the:in out PIC; id:in String ) is
  begin
    the.obj_id := to_bounded_string(id); -- Set object name
  end set_name;

  function  get_name( the:in PIC ) return String is
  begin
      return to_string( the.obj_id );     -- Name of object
  end get_name;

  procedure add( the:in out PIC; i:in Index; d:in Data ) is
    procedure add_s(the:in out Subtree; i:in Index; d:in Data) is
    begin
      if the = null then
        the := new Leaf'( null, Element'(i,d), null );
      else
        if i = the.rec.s_index then     -- Index all ready exists
          raise Exists;
        elsif i > the.rec.s_index then  -- Try on RHS
          add_s( the.right, i, d );
        else                            -- LHS
          add_s( the.left, i, d );
        end if;
      end if;
    end add_s;
  begin
    add_s( the.tree, i, d );
  end add;

  procedure extract(the:in out PIC; i:in Index; d:in out Data) is
    node_is : Subtree;
  begin
    node_is := find( the.tree, i );     -- Find node with iey
    d := node_is.rec.s_data;            -- return data
  end extract;

  procedure update(the:in out PIC; i:in Index; d:in out Data) is
    node_is : Subtree;
  begin
    node_is := find( the.tree, i );     -- Find node with iey
    node_is.rec.s_data := d;            -- Update data
  end update;


  function find( the:in Subtree; i:in Index) return Subtree is
  begin
    if the = null then raise Not_there; end if;
    if i = the.rec.s_index then
      return the;                           -- Found
    else
      if i > the.rec.s_index
        then return find( the.right, i );   -- Try RHS
        else return find( the.left,  i );   -- Try LHS
      end if;
    end if;
  end find;

  procedure dispose is
    new unchecked_deallocation( Leaf, Subtree );

  procedure release_storage( the:in out Subtree ) is
  begin
    if the /= null then             -- Not empty
      release_storage( the.left );  -- Free LHS
      release_storage( the.right ); -- Free RHS
      dispose( the );               -- Dispose of item
    end if;
    the := null;                    -- Subtree root null
  end release_storage;

end Class_pic;

-- Subtype as get demands a String
package Pack_types is
  subtype  Country is String( 1 .. 12 );
  subtype  IDC     is String( 1 .. 6 );
end Pack_types;

----[gt.adb] Procedure
--with Pack_types;
--use  Pack_types;
--function gt(f:in Country; s:in Country ) return Boolean is
--begin
--  return f > s;
--end gt;

with Class_pic, Pack_types;
use  Pack_types;
  pragma ELABorATE_all( Class_pic );
  package Class_tel_list is new
    Class_pic( Country, IDC, ">" );

package Pack_procedures is
  procedure ex1;
  procedure ex2;
  procedure ex3;
  procedure ex4;
end Pack_procedures;

with Simple_io, Pack_types, Class_tel_list;
use  Simple_io, Pack_types, Class_tel_list;
package body Pack_procedures is

procedure ex1 is
  tel_list : PIC;
begin
  put("Creating Telephone list"); new_line;
  set_name( tel_list, "tel_list.per" );
  add( tel_list, "Canada      ", "+1    " );
  add( tel_list, "USA         ", "+1    " );
  add( tel_list, "Netherlands ", "+31   " );
  add( tel_list, "Belgium     ", "+32   " );
  add( tel_list, "France      ", "+33   " );
  add( tel_list, "Gibraltar   ", "+350  " );
  add( tel_list, "Ireland     ", "+353  " );
  add( tel_list, "Switzerland ", "+41   " );
  add( tel_list, "UK          ", "+44   " );
  add( tel_list, "Denmark     ", "+45   " );
  add( tel_list, "Norway      ", "+47   " );
  add( tel_list, "Germany     ", "+49   " );
  add( tel_list, "Australia   ", "+61   " );
  add( tel_list, "Japan       ", "+81   " );
end ex1;

procedure ex2 is
  tel_list : PIC;
  action   : Character;
  name     : Country;
  tel      : IDC;
begin
  initialize( tel_list, "tel_list.per" );
  while not end_of_file loop
    begin
      get( action );                       -- Action to perform
      case action is
        when '+' =>                        -- Add
          get( name ); get( tel );
          add( tel_list, name, tel );
        when '=' =>                        -- Extract
          get( name );
          extract( tel_list, name, tel );
          put( "IDC for " ); put( name );
          put( " is "); put( tel ); new_line;
        when '*' =>                        -- Update
          get( name ); get( tel );
          update( tel_list, name, tel );
        when others =>                     -- Invalid action
          null;
      end case;
    exception
      when Not_there =>                    -- Not there
        put("Name not in directory"); new_line;
      when Exists =>                       -- Exists
        put("Name already in directory"); new_line;
    end;
    skip_line;
  end loop;
end ex2;

procedure ex3 is
  tel_list : PIC;
  name     : Country;
  tel      : IDC;
begin
  add( tel_list, "Canada      ", "+1    " );
  add( tel_list, "USA         ", "+1    " );
  add( tel_list, "Netherlands ", "+31   " );
  add( tel_list, "Belgium     ", "+32   " );
  add( tel_list, "France      ", "+33   " );
  add( tel_list, "Gibraltar   ", "+350  " );
  name := "France      ";
  extract( tel_list, name, tel );
  put( "IDC for " ); put( name ); put( " is "); put( tel ); new_line;
  name := "USA         ";
  extract( tel_list, name, tel );
  put( "IDC for " ); put( name ); put( " is "); put( tel ); new_line;
end ex3;

procedure ex4 is
  tel_list : PIC;
  name     : Country;
  tel      : IDC;
begin
  add( tel_list, "Canada      ", "+1    " );
  put("Object identity is ["); put( get_name(tel_list) ); put("]"); new_line;
  set_name( tel_list, "tel_list.per" );
  put("Object identity is ["); put( get_name(tel_list) ); put("]"); new_line;
  discard( tel_list );
end ex4;

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