! Appendix D
module directory
!
! Strong typing imposed
!
! Only subroutine interfaces, the length of the character
! component, and the I/O unit number are public
   public  :: start, add_node, remove_node, retrieve,               &
              dump_tree, restore_tree, finish
   private :: tree_out, find, look, remove
!
! Module constants
   character(len=*), private, parameter:: eot = "End-of-Tree....."
   integer, parameter, public :: unit = 4,   & ! I/O unit number
                                 max_char = 16 ! length of character 
                                               ! component
!
! Define the basic tree type
   type, private :: node
       character(len=max_char)     :: name    ! name of node
       real, pointer, dimension(:) :: y    ! stored real data
       type(node), pointer         :: parent  ! parent node
       type(node), pointer         :: sibling ! next sibling node
       type(node), pointer         :: child   ! first child node
   end type node
!
! Module variables
   type(node), pointer, private   :: current     ! current node
   type(node), pointer, private   :: forest_root ! the root of the forest
   integer,private                :: max_data    ! max size of data array
   character(len=max_char), private, allocatable, target, dimension(:)  &
                                                               :: names
                                           ! for returning list of names
! The module procedures
 
contains
 
   subroutine start ()
! Initialize the tree.
      allocate (forest_root)
      current => forest_root
      forest_root%name = "forest_root"
      nullify(forest_root%parent, forest_root%sibling, forest_root%child)
      allocate(forest_root%y(0))
      max_data = 0
      allocate (names(0))
   end subroutine start

   subroutine find(name)
      character(len=*), intent(in) :: name
! Make the module variable current point to the node with given name,
! or be null if the name is not there.
      type(node), pointer    :: root
! For efficiency, we search the tree rooted at current, and if this
! fails try its parent and so on until the forest root is reached.
      if (associated(current)) then
         root => current
         nullify (current)
      else
         root => forest_root
      end if
      do
         call look(root ,name)
         if (associated(current)) then
            return
         end if
         root => root%parent
         if (.not.associated(root)) then
            exit
         end if
      end do
end subroutine find
 
      recursive subroutine look(root, name)
         type(node), pointer :: root
         character(len=*), intent(in)   :: name
! Look for name in the tree rooted at root. If found, make the
! module variable current point to the node
         type(node), pointer    :: child
!
         if (root%name == name) then
            current => root
         else
            child => root%child
            do
               if (.not.associated(child)) then
                 exit
               end if
               call look(child, name)
               if (associated(current)) then
                 return
               end if
               child => child%sibling
            end do
         end if
      end subroutine look
 
   subroutine add_node(name, name_of_parent, data)
      character(len=*), intent(in)             :: name, name_of_parent
! For a root, name_of_parent = ""
      real, intent(in), optional, dimension(:) :: data
! Allocate a new tree node of type node, store the given name and
! data there, set pointers to the parent and to its next sibling
! (if any). If the parent is not found, the new node is treated as
! a root. It is assumed that the node is not already present in the
! forest.
      type(node), pointer :: new_node
!
      allocate (new_node)
      new_node%name = name
      if (present(data)) then
         allocate(new_node%y(size(data)))
         new_node%y = data
         max_data = max(max_data, size(data))
      else
         allocate(new_node%y(0))
      end if
!
! If name of parent is not null, search for it. 
! If not found, print message.
      if (name_of_parent == "") then
         current => forest_root
      else
         call find (name_of_parent)
         if (.not.associated(current)) then
            print *, "no parent ", name_of_parent, " found for ", name
            current => forest_root
         end if
      end if
      new_node%parent => current
      new_node%sibling => current%child
      current%child => new_node
      nullify(new_node%child)
   end subroutine add_node
 
   subroutine remove_node(name)
      character(len=*), intent(in) :: name
! Remove node and the subtree rooted on it (if any),
! deallocating associated pointer targets.
      type(node), pointer :: parent, child, sibling
!
      call find (name)
      if (associated(current)) then
         parent =>  current%parent
         child => parent%child
         if (.not.associated(child, current)) then
! Make it the first child, looping through the siblings to find it
! and resetting the links
            parent%child => current
            sibling => child
            do
              if (associated (sibling%sibling, current)) then
                exit
              end if
              sibling => sibling%sibling
            end do
            sibling%sibling => current%sibling
            current%sibling => child
         end if
         call remove(current)
      end if
   end subroutine remove_node

   recursive subroutine remove (old_node)
! Remove a first child node and the subtree rooted on it (if any),
! deallocating associated pointer targets.
      type(node), pointer :: old_node
      type(node), pointer :: child, sibling
!
      child => old_node%child
      do
         if (.not.associated(child)) then
           exit
         end if
         sibling => child%sibling
         call remove(child)
         child => sibling
      end do
! remove leaf node
      if (associated(old_node%parent)) then
         old_node%parent%child => old_node%sibling
      end if
      deallocate (old_node%y)
      deallocate (old_node)
   end subroutine remove
 
   subroutine retrieve(name, data, parent, children)
      character(len=*), intent(in)            :: name
      real, pointer, dimension(:)             :: data
      character(len=*), intent(out)           :: parent
      character(len=*), pointer, dimension(:) :: children
! Returns a pointer to the data at the node, the name of the
! parent, and a pointer to the names of the children.
      integer :: counter, i
      type(node), pointer :: child
!
      call find (name)
      if (associated(current)) then
         data => current%y
         parent = current%parent%name
! Count the number of children
         counter = 0
         child => current%child
         do
           if (.not.associated(child)) then
             exit
           end if
           counter = counter + 1
           child => child%sibling
         end do
         deallocate (names)
         allocate (names(counter))
! and store their names
         children => names
         child => current%child
         do i = 1, counter
            children(i) = child%name
            child => child%sibling
         end do
      else
         nullify(data)
         parent = ""
         nullify(children)
      end if
   end subroutine retrieve

   subroutine dump_tree(root)
      character(len=*), intent(in) :: root
! Write out a complete tree followed by an end-of-tree record
! unformatted on the file unit.
      call find (root)
      if (associated(current)) then
         call tree_out(current)
      end if
      write(unit = unit) eot, 0, eot
   end subroutine dump_tree
 
      recursive subroutine tree_out (root)
! Traverse a complete tree or subtree, writing out its contents
         type(node), intent(in) :: root     ! root node of tree
! Local variable
         type(node), pointer    :: child
!
         write(unit = unit) root%name, size(root%y), root%y, &
                            root%parent%name
         child => root%child
         do
            if (.not.associated(child)) then
              exit
            end if
            call tree_out (child)
            child => child%sibling
         end do
      end subroutine tree_out
 
   subroutine restore_tree ()
! Reads a subtree unformatted from the file unit.
      character(len=max_char)         :: name
      integer :: length_y
      real, allocatable, dimension(:) :: y
      character(len=max_char)         :: name_of_parent
!
      allocate(y(max_data))
      do
         read (unit= unit) name, length_y, y(:length_y), name_of_parent
         if (name == eot) then
           exit
         end if
         call add_node( name, name_of_parent, y(:length_y) )
      end do
      deallocate(y)
   end subroutine restore_tree
 
   subroutine finish ()
! Deallocate all allocated targets.
      call remove (forest_root)
      deallocate(names)
   end subroutine finish
 
end module directory
 
module tree_print
 
  use  directory
  private
  public :: print_tree
 
  contains
 
   recursive subroutine print_tree(name)
! To print the data contained in a subtree
      character(len=*), intent(in)                       :: name
      integer                                            :: i
      real, pointer, dimension(:)                        :: data
      character(len=max_char)                            :: parent, self
      character(len=max_char), pointer, dimension(:)     :: children
      character(len=max_char), allocatable, dimension(:) :: siblings
!
      call retrieve(name, data, parent, children)
      if (.not.associated(data)) then
        return
      end if
      self = name
      write(unit=*,fmt=*) self, data
      write(unit=*,fmt=*) "   parent:   ", parent
      if (size(children) > 0 ) then
         write(unit=*,fmt=*)  "   children: ", children
      end if
      allocate(siblings(size(children)))
      siblings = children
      do i = 1, size(children)
         call print_tree(siblings(i))
      end do
         deallocate(siblings)
   end subroutine print_tree
end module tree_print
 
program test
   use directory
   use tree_print
!
! Initialize a tree
   call start ()
! Fill it with some data
   call add_node("ernest","",(/1.0,2.0/))
   call add_node("helen","ernest",(/3.0,4.0,5.0/))
   call add_node("douglas","ernest",(/6.0,7.0/))
   call add_node("john","helen",(/8.0/))
   call add_node("betty","helen",(/9.0,10.0/))
   call add_node("nigel","betty",(/11.0/))
   call add_node("peter","betty",(/12.0/))
   call add_node("ruth","betty")
! Manipulate subtrees
   open(unit=unit, form="unformatted", status="scratch",    &
        action="readwrite", position="rewind")
   call dump_tree("betty")
   call remove_node("betty")
   write(unit=*,fmt=*)
   call print_tree("ernest")
   rewind (unit=unit)
   call restore_tree ()
   rewind (unit=unit)
   write(unit=*,fmt=*)
   call print_tree("ernest")
   call dump_tree("john")
   call remove_node("john")
   write(unit=*,fmt=*)
   call print_tree("ernest")
   rewind (unit=unit)
   call restore_tree ()
   write(unit=*,fmt=*)
   call print_tree("ernest")
! Return storage
   call finish ()
 
end program test
