!>
!! Provides array-based, self-extending reference vectors of arbitrary type.
!!
module self_vector_ref
use self_object
implicit none
private
type :: vector_item
class(*), pointer :: stuff => null()
end type vector_item
integer, parameter :: vector_initial_size = 20
!>
!! Array-based, self-extending vector containing references to arbitrary data.
!!
!! Vectors may be initialized by passing an array to the constructor,
!! or by creating an empty vector and subsequently adding items.
!! In any case, only references to these elements are stored,
!! i.e. the original data must have the 'target' attribute.
!! Changing the base data will also change the vector items.
!!
type, extends(object), public :: vector_ref
private
integer :: current_size = 0
integer :: maximum_size = 0
logical :: verbose = .false.
type(vector_item), allocatable :: items(:)
contains
procedure :: clone
final :: destroy
procedure :: clear
procedure :: extend
procedure :: at
procedure :: find
procedure :: add_item
generic :: add => add_item
procedure :: add_array
procedure :: add_vector
procedure :: add_iter
generic :: add_list => add_array
generic :: add_list => add_vector
generic :: add_list => add_iter
procedure :: set_verbose
procedure :: get_verbose
procedure :: length
procedure :: capacity
procedure :: includes
procedure :: iter
procedure :: is_equal
procedure :: to_string
! first, last, pop, push, shift, unshift, uniq
end type vector_ref
interface vector_ref
module procedure new_empty
module procedure new_from_array
end interface vector_ref
type, public :: vector_iterator
private
class(vector_ref), pointer, public :: my_vector => null()
integer :: current = 0
contains
procedure :: set_vector
procedure :: more
procedure :: next
procedure :: pos
end type vector_iterator
contains
!
! type(vector_ref)
!
! constructors {{{
function new_empty(verbose, initial_size) result(this)
logical, optional, intent(in) :: verbose
integer, optional, intent(in) :: initial_size
type(vector_ref) :: this
this%maximum_size = vector_initial_size
if(present(initial_size)) this%maximum_size = initial_size
if(present(verbose)) then
this%verbose = verbose
end if
allocate(this%items(this%maximum_size))
if(this%verbose) then
print *, 'created vector_ref (', this%current_size, '/', &
this%maximum_size, ' elements)'
end if
end function new_empty
!>
!! Create a vector from a pre-existing array
!!
!! @note gfortran handles array literals incorrectly, use a variable instead
!!
function new_from_array(items, verbose, initial_size) result(this)
class(*), target, intent(in) :: items(:)
logical, optional, intent(in) :: verbose
integer, optional, intent(in) :: initial_size
type(vector_ref) :: this
integer :: i
this%maximum_size = 2*size(items)
if(present(initial_size)) this%maximum_size = initial_size
if(present(verbose)) then
this%verbose = verbose
end if
allocate(this%items(this%maximum_size))
do i = lbound(items, 1), ubound(items, 1)
call this%add_item(items(i))
end do
if(this%verbose) then
print *, 'created vector_ref (', this%current_size, '/', &
this%maximum_size, ' elements)'
end if
end function new_from_array
! }}}
! copy {{{
subroutine clone(this, copy)
class(vector_ref), intent(in) :: this
class(vector_ref), intent(inout) :: copy
copy%verbose = this%verbose
! Following Fortran 2003, the allocation is done automatically.
! Some compilers (intel) need a flag to do this correctly
copy%items = this%items
copy%maximum_size = this%maximum_size
copy%current_size = this%current_size
if(this%verbose) then
print *, 'cloned vector (', copy%current_size, ' elements)'
end if
end subroutine clone
! }}}
! destructors {{{
recursive subroutine destroy(this)
type(vector_ref),intent(inout) :: this
if(allocated(this%items)) then
deallocate(this%items)
end if
if(this%verbose) then
print *, 'destroyed vector_ref (', this%current_size, ' elements)'
end if
this%current_size = 0
this%maximum_size = 0
end subroutine destroy
subroutine clear(this)
class(vector_ref), intent(inout) :: this
integer :: i
do i = 1, this%current_size
this%items(i)%stuff => null()
end do
this%current_size = 0
end subroutine
! }}}
! internal extension {{{
subroutine extend(this)
class(vector_ref), intent(inout) :: this
type(vector_item), allocatable :: items(:)
integer :: new_maximum_size
new_maximum_size = 2*this%maximum_size
allocate(items(new_maximum_size))
items(:this%maximum_size) = this%items
call move_alloc(items, this%items)
this%maximum_size = new_maximum_size
if(this%verbose) then
print *, 'extended vector_ref storage (max. ', this%maximum_size, &
' elements)'
end if
end subroutine
! }}}
! getter/setter {{{
function at(this, idx)
class(vector_ref), intent(in) :: this
integer, intent(in) :: idx
class(*), pointer :: at
at => null()
if(1 <= idx .and. idx <= this%current_size) then
at => this%items(idx)%stuff
end if
end function at
function find(this, my_stuff, offset)
class(vector_ref), intent(in) :: this
class(*), intent(in) :: my_stuff
integer, intent(in), optional :: offset
integer :: find
integer :: i, offset_
offset_ = 1
if(present(offset)) offset_ = offset
find = 0
do i = offset_, this%current_size
if(object_equal(this%items(i)%stuff, my_stuff)) then
find = i
exit
end if
end do
end function find
recursive subroutine add_item(this, new_stuff)
class(vector_ref),intent(inout) :: this
class(*), target, intent(in) :: new_stuff
if(this%get_verbose()) print *, 'vector_ref%add_item begin'
if(this%current_size == this%maximum_size) then
call this%extend()
end if
this%current_size = this%current_size + 1
this%items(this%current_size)%stuff => new_stuff
if(this%verbose) then
print *, 'added to vector_ref (', this%current_size, '/', &
this%maximum_size, ' elements)'
end if
if(this%get_verbose()) print *, 'vector_ref%add_item end'
end subroutine add_item
subroutine add_array(this, items)
class(vector_ref),intent(inout) :: this
class(*), target, intent(in) :: items(:)
integer :: i
do i = lbound(items,1), ubound(items,1)
call this%add(items(i))
end do
end subroutine add_array
subroutine add_vector(this, that)
class(vector_ref),intent(inout) :: this
class(vector_ref),intent(in) :: that
integer :: i
do i = 1, that%current_size
call this%add(that%items(i)%stuff)
end do
end subroutine add_vector
subroutine add_iter(this, iter)
class(vector_ref),intent(inout) :: this
class(vector_iterator) :: iter
class(*), pointer :: stuff
do while(iter%next(stuff))
call this%add(stuff)
end do
end subroutine add_iter
subroutine set(this, idx, my_stuff)
class(vector_ref), intent(inout) :: this
integer, intent(in) :: idx
class(*), target, intent(in) :: my_stuff
if(idx > this%current_size) then
do while(idx > this%maximum_size)
call this%extend()
end do
end if
if (1 <= idx .and. idx <= this%current_size) then
this%items(idx)%stuff => my_stuff
end if
end subroutine set
! }}}
! getter/setter for private attribute: verbose {{{
subroutine set_verbose(this, value)
class(vector_ref), intent(inout) :: this
logical, optional :: value
if(present(value)) then
this%verbose = value
else
this%verbose = .true.
end if
end subroutine set_verbose
logical function get_verbose(this)
class(vector_ref), intent(in) :: this
get_verbose = this%verbose
end function get_verbose
! }}}
! information about the vector {{{
integer function length(this)
class(vector_ref), intent(in) :: this
length = this%current_size
end function length
integer function capacity(this)
class(vector_ref), intent(in) :: this
capacity = this%maximum_size
end function capacity
logical function includes(this, my_stuff)
class(vector_ref), intent(in) :: this
class(*), intent(in) :: my_stuff
includes = this%find(my_stuff) /= 0
end function includes
! }}}
type(vector_iterator) function iter(this)
class(vector_ref), intent(in) :: this
call iter%set_vector(this)
end function iter
! Object interface implementations
recursive logical function is_equal(this, that) result(equal)
class(vector_ref), intent(in) :: this
class(*), intent(in) :: that
integer :: i
equal = .true.
select type(that)
class is (vector_ref)
if(this%current_size /= that%current_size) then
equal = .false.
return
end if
do i = 1, this%current_size
if(.not. object_equal(this%items(i)%stuff, &
that%items(i)%stuff)) then
equal = .false.
return
end if
end do
class default
equal = .false.
end select
end function is_equal
recursive function to_string(this)
class(vector_ref), intent(in) :: this
character(:), allocatable :: to_string
integer :: i
to_string = "["
if(this%current_size > 0) then
to_string = to_string // object_pointer_string(this%items(1)%stuff)
end if
do i = 2, this%current_size
to_string = to_string // "," // &
object_pointer_string(this%items(i)%stuff)
end do
to_string = to_string // "]"
end function to_string
! iterator implementations {{{
!
! type(vector_iterator)
!
subroutine set_vector(this, my_vector)
class(vector_iterator), intent(inout) :: this
type(vector_ref), target, intent(in) :: my_vector
this%my_vector => my_vector
this%current = 0
end subroutine set_vector
logical function more(this)
class(vector_iterator), intent(in) :: this
more = this%current < this%my_vector%current_size
end function more
logical function next(this, item)
class(vector_iterator), intent(inout) :: this
class(*), pointer, intent(out) :: item
next = this%more()
if(next) then
this%current = this%current + 1
item => this%my_vector%items(this%current)%stuff
else
item => null()
end if
end function next
integer function pos(this)
class(vector_iterator), intent(in) :: this
pos = this%current
end function pos
! }}}
end module self_vector_ref
! vim: sw=4 foldmethod=marker