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
  contains
    procedure, public :: allocate  => cubetools_object_allocate
    procedure, public :: associate => cubetools_object_associate
    procedure, public :: nullify   => cubetools_object_nullify
  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 :: reallocate_bysize4  => cubetools_list_reallocate_bysize4
    procedure, private :: reallocate_bysize8  => cubetools_list_reallocate_bysize8
    procedure, private :: reallocate_byrange4 => cubetools_list_reallocate_byrange4
    procedure, private :: reallocate_byrange8 => cubetools_list_reallocate_byrange8
    generic,   public  :: realloc => reallocate_bysize4,reallocate_bysize8,  &
                                     reallocate_byrange4,reallocate_byrange8
    procedure, private :: lbound => cubetools_list_lbound
    procedure, private :: ubound => cubetools_list_ubound
    procedure, public  :: pop    => cubetools_list_pop
    ! NB: no implicit FINAL as there are 2 use-cases + Fortran requires
    !     the exact type as argument (does not work for extended types)
    procedure, public  :: free   => cubetools_list_free
    procedure, public  :: final  => cubetools_list_final
  end type tools_list_t
  !
  private
  public :: list_k
  public :: tools_object_t
  public :: tools_list_t
  !
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
    !----------------------------------------------------------------------
    class(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)  ! Implicit call of the FINAL method
    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
  !
  subroutine cubetools_object_associate(topt,tot,error)
    !-------------------------------------------------------------------
    ! Set or replace the tools_object_t, taking care of the previous
    ! allocation status
    !-------------------------------------------------------------------
    class(tools_object_p_t), intent(inout) :: topt   !
    class(tools_object_t),   target        :: tot    ! New target
    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_pointer_associated
  end subroutine cubetools_object_associate
  !
  subroutine cubetools_object_nullify(topt,error)
    !-------------------------------------------------------------------
    ! Nullify the tools_object_t, taking care of the previous
    ! allocation status
    !-------------------------------------------------------------------
    class(tools_object_p_t), intent(inout) :: topt
    logical,                 intent(inout) :: error
    !
    if (topt%code_pointer.eq.code_pointer_allocated)  &
      deallocate(topt%p)  ! Implicit call of the FINAL method
    topt%p => null()
    topt%code_pointer = code_pointer_null
  end subroutine cubetools_object_nullify
  !
  !---------------------------------------------------------------------
  !
  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
  !
  recursive subroutine cubetools_list_reallocate_bysize4(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).
    !-------------------------------------------------------------------
    class(tools_list_t), intent(inout) :: arr
    integer(kind=4),     intent(in)    :: n
    logical,             intent(inout) :: error
    !
    call cubetools_list_reallocate_byrange8(arr,int(1,kind=8),int(n,kind=8),error)
    if (error) return
  end subroutine cubetools_list_reallocate_bysize4
  !
  recursive subroutine cubetools_list_reallocate_bysize8(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).
    !-------------------------------------------------------------------
    class(tools_list_t), intent(inout) :: arr
    integer(kind=8),     intent(in)    :: n
    logical,             intent(inout) :: error
    !
    call cubetools_list_reallocate_byrange8(arr,int(1,kind=8),n,error)
    if (error) return
  end subroutine cubetools_list_reallocate_bysize8
  !
  recursive subroutine cubetools_list_reallocate_byrange4(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.
    !-------------------------------------------------------------------
    class(tools_list_t), intent(inout) :: arr
    integer(kind=4),     intent(in)    :: first,last
    logical,             intent(inout) :: error
    !
    call cubetools_list_reallocate_byrange8(arr,int(first,kind=8),int(last,kind=8),error)
    if (error) return
  end subroutine cubetools_list_reallocate_byrange4
  !
  recursive subroutine cubetools_list_reallocate_byrange8(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.
    !-------------------------------------------------------------------
    class(tools_list_t), intent(inout) :: arr
    integer(kind=8),     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_byrange8
  !
  subroutine cubetools_list_free(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.
    !-------------------------------------------------------------------
    class(tools_list_t), intent(inout) :: arr
    logical,             intent(inout) :: error
    !
    integer(kind=list_k) :: iobj
    !
    ! Free the targets
    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
    endif
    ! Free the list
    call arr%final(error)
  end subroutine cubetools_list_free
  !
  subroutine cubetools_list_final(arr,error)
    !-------------------------------------------------------------------
    ! Free the list but NOT its targets, assuming they are still
    ! referenced (accessible) by someone else.
    !-------------------------------------------------------------------
    class(tools_list_t), intent(inout) :: arr
    logical,             intent(inout) :: error
    !
    if (allocated(arr%list))  deallocate(arr%list)
    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 arr2%realloc(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 arr1%free(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)
    !-------------------------------------------------------------------
    class(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 full%free(error)
      if (error) return
    endif
  end subroutine cubetools_list_pop
  !
end module cubetools_list
