module cubetools_list
  use gkernel_interfaces
  use cubetools_parameters
  !---------------------------------------------------------------------
  ! Support module to support generic list of objects, including methods
  ! to reallocate them, preserving previous values.
  ! The base type is an empty shell (class). Users have to create
  ! extended types from this class.
  !---------------------------------------------------------------------
  !
  integer, parameter :: list_k=8
  !
  ! Basic object type
  type tools_object_t
     ! Empty
  end type tools_object_t
  !
  type :: tools_object_p_t
    class(tools_object_t), pointer :: p=>null()
    integer(kind=code_k)           :: code_pointer=code_pointer_null
  end type tools_object_p_t
  !
  type :: tools_list_t
    integer(kind=list_k) :: n = 0  ! Useful part of the array (upper bound)
    type(tools_object_p_t), allocatable :: list(:)
  contains
    procedure, private :: lbound => cubetools_list_lbound
    procedure, private :: ubound => cubetools_list_ubound
  end type tools_list_t
  !
  interface cubetools_list_reallocate
    module procedure cubetools_list_reallocate_bysize
    module procedure cubetools_list_reallocate_byrange
  end interface cubetools_list_reallocate
  !
  private
  ! Parameters
  public :: list_k
  ! Object
  public :: tools_object_t
  public :: cubetools_object_allocate
  ! List
  public :: tools_list_t
  public :: cubetools_list_setelem
  public :: cubetools_list_reallocate,cubetools_list_pop
  public :: cubetools_list_final
  !
contains
  !
  subroutine cubetools_object_allocate(topt,template,error)
    use gkernel_interfaces
    !----------------------------------------------------------------------
    ! Allocate an extended 'tools_object_t' in memory, of type taken from
    ! the given template
    !----------------------------------------------------------------------
    type(tools_object_p_t), intent(inout) :: topt
    class(tools_object_t),  intent(in)    :: template
    logical,                intent(inout) :: error
    !
    integer(kind=4) :: ier
    character(len=*), parameter :: rname='OBJECT>ALLOCATE'
    !
    if (topt%code_pointer.eq.code_pointer_allocated)  deallocate(topt%p)
    allocate(topt%p,source=template,stat=ier)
    if (failed_allocate(rname,'Object',ier,error)) return
    topt%code_pointer = code_pointer_allocated
  end subroutine cubetools_object_allocate
  !
  !---------------------------------------------------------------------
  !
  function cubetools_list_lbound(tlt)
    integer(kind=list_k) :: cubetools_list_lbound
    class(tools_list_t), intent(in) :: tlt
    if (allocated(tlt%list)) then
      cubetools_list_lbound = lbound(tlt%list,1)
    else
      cubetools_list_lbound = 0
    endif
  end function cubetools_list_lbound
  !
  function cubetools_list_ubound(tlt)
    integer(kind=list_k) :: cubetools_list_ubound
    class(tools_list_t), intent(in) :: tlt
    if (allocated(tlt%list)) then
      cubetools_list_ubound = ubound(tlt%list,1)
    else
      cubetools_list_ubound = 0
    endif
  end function cubetools_list_ubound
  !
  subroutine cubetools_list_setelem(topt,tot,code_p,error)
    !-------------------------------------------------------------------
    ! Set or replace the tools_object_t, taking care of the previous
    ! allocation status
    !-------------------------------------------------------------------
    type(tools_object_p_t), intent(inout) :: topt    !
    class(tools_object_t),  target        :: tot     ! New target
    integer(kind=code_k),   intent(in)    :: code_p  ! New code_pointer
    logical,                intent(inout) :: error   !
    !
    if (topt%code_pointer.eq.code_pointer_allocated)  &
      deallocate(topt%p)  ! Implicit call of the FINAL method
    topt%p => tot
    topt%code_pointer = code_p
  end subroutine cubetools_list_setelem
  !
  recursive subroutine cubetools_list_reallocate_bysize(arr,n,error)
    !-------------------------------------------------------------------
    ! (Re)allocate to given size.
    ! Previous values are preserved if a reallocation is actually
    ! performed.
    ! ---
    ! This version without the index of the first component (i.e.
    ! indices run from 1 to n).
    !-------------------------------------------------------------------
    type(tools_list_t),   intent(inout) :: arr
    integer(kind=list_k), intent(in)    :: n
    logical,              intent(inout) :: error
    !
    call cubetools_list_reallocate_byrange(arr,int(1,kind=list_k),n,error)
    if (error)  return
  end subroutine cubetools_list_reallocate_bysize
  !
  recursive subroutine cubetools_list_reallocate_byrange(arr,first,last,error)
    !-------------------------------------------------------------------
    ! (Re)allocate to given size.
    ! Previous values are preserved if a reallocation is actually
    ! performed.
    ! ---
    ! This version with a range of indices to allocate.
    !-------------------------------------------------------------------
    type(tools_list_t),   intent(inout) :: arr
    integer(kind=list_k), intent(in)    :: first,last
    logical,              intent(inout) :: error
    !
    integer(kind=list_k), parameter :: array_minalloc=10
    integer(kind=list_k) :: ofirst,olast,nfirst,nlast
    integer(kind=4) :: ier
    type(tools_list_t) :: tmp
    character(len=*), parameter :: rname='LIST>REALLOCATE'
    !
    if (allocated(arr%list)) then
      ofirst = arr%lbound()
      olast  = arr%ubound()
      if (ofirst.eq.first .and. olast.ge.last) then
        return
      else
        call cubetools_list_transfer(arr,tmp,error)
        if (error)  return
      endif
    else
      olast = 0
    endif
    !
    nfirst = first
    nlast = max(last,2*olast)
    nlast = max(nlast,array_minalloc)
    !
    allocate(arr%list(nfirst:nlast),stat=ier)
    if (failed_allocate(rname,'list',ier,error)) return
    arr%n = 0
    !
    if (tmp%n.gt.0) then
      call cubetools_list_transfer(tmp,arr,error)
      if (error)  return
    endif
  end subroutine cubetools_list_reallocate_byrange
  !
  subroutine cubetools_list_final(arr,error)
    !-------------------------------------------------------------------
    ! Free the targets referenced by the list (if relevant) and free the
    ! list itself.
    ! This properly works if the targets have declared a FINAL method.
    !-------------------------------------------------------------------
    type(tools_list_t), intent(inout) :: arr
    logical,            intent(inout) :: error
    !
    integer(kind=list_k) :: iobj
    !
    if (allocated(arr%list)) then
      do iobj=arr%lbound(),arr%ubound()
        if (arr%list(iobj)%code_pointer.eq.code_pointer_allocated)  &
          deallocate(arr%list(iobj)%p)
      enddo
      deallocate(arr%list)
    endif
    arr%n = 0
  end subroutine cubetools_list_final
  !
  subroutine cubetools_list_transfer(arr1,arr2,error)
    !-------------------------------------------------------------------
    ! Transfer one list to another, including allocation property if
    ! relevant. Includes implicit reallocation of the target instance.
    ! The input object is freed in return.
    !-------------------------------------------------------------------
    type(tools_list_t), intent(inout) :: arr1
    type(tools_list_t), intent(inout) :: arr2
    logical,            intent(inout) :: error
    !
    integer(kind=list_k) :: i,first,last
    !
    first = arr1%lbound()
    last  = arr1%n  ! Transfer only the useful part
    call cubetools_list_reallocate(arr2,first,last,error)
    if (error)  return
    !
    do i=first,last
      ! Steal the object
      arr2%list(i)%p => arr1%list(i)%p
      arr2%list(i)%code_pointer = arr1%list(i)%code_pointer
      ! Just keep as a pointer
      arr1%list(i)%code_pointer = code_pointer_associated
    enddo
    arr2%n = arr1%n
    !
    call cubetools_list_final(arr1,error)
    if (error)  return
  end subroutine cubetools_list_transfer
  !
  subroutine cubetools_list_pop(full,ipop,error)
    !-------------------------------------------------------------------
    ! Free the ith element and pop it out from the list (list compressed
    ! in return)
    !-------------------------------------------------------------------
    type(tools_list_t),   intent(inout) :: full
    integer(kind=list_k), intent(in)    :: ipop
    logical,              intent(inout) :: error
    !
    integer(kind=list_k) :: iobj
    !
    if (full%list(ipop)%code_pointer.eq.code_pointer_allocated) then
      deallocate(full%list(ipop)%p)  ! Performs implicit FINAL of the dynamic type
    else
      full%list(ipop)%p => null()
    endif
    full%list(ipop)%code_pointer = code_pointer_null
    !
    do iobj=ipop+1,full%n
      full%list(iobj-1)%p            => full%list(iobj)%p
      full%list(iobj-1)%code_pointer =  full%list(iobj)%code_pointer
    enddo
    !
    ! Last element is now unused
    full%list(full%n)%p            => null()
    full%list(full%n)%code_pointer =  code_pointer_null
    !
    ! Update array size
    full%n = full%n-1
    !
    if (full%n.lt.full%lbound()) then
      call cubetools_list_final(full,error)
      if (error)  return
    endif
  end subroutine cubetools_list_pop
  !
end module cubetools_list
