module cubelist_list_types
  use cubetools_parameters
  use cubelist_messaging
  use cubelist_object_class
  use cubelist_object_pointer_types
  !---------------------------------------------------------------------
  ! 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.
  !---------------------------------------------------------------------
  !
  private
  public :: list_k
  public :: list_t
  !
  integer(kind=4), parameter :: list_k=8
  !
  type :: list_t
    integer(kind=list_k), private :: first = 1  ! Array index starting point (as allocated)
    integer(kind=list_k), private :: last  = 0  ! Array index end point (as allocated)
    integer(kind=list_k), public  :: n = 0      ! Useful part of the array (upper bound)
    type(list_object_p_t), allocatable, public :: list(:)
  contains
    ! Actions on the whole list
    procedure, public  :: lbound     => cubelist_set_lbound
    procedure, private :: reallocate_byubound4 => cubelist_reallocate_byubound4
    procedure, private :: reallocate_byubound8 => cubelist_reallocate_byubound8
    generic,   public  :: reallocate => reallocate_byubound4,reallocate_byubound8
    procedure, public  :: copy       => cubelist_copy
    procedure, public  :: enlarge    => cubelist_enlarge
    procedure, public  :: final      => cubelist_final  ! NB: no implicit FINAL: Fortran requires
                                                        ! the exact type as argument (does not work for extended types)
    ! Actions on 1 object in list
    procedure, public  :: allocate   => cubelist_allocate
    procedure, public  :: associate  => cubelist_associate
    procedure, public  :: pop        => cubelist_pop
    procedure, public  :: dissociate => cubelist_dissociate
  end type list_t
  !
contains
  !
  subroutine cubelist_set_lbound(arr,first,error)
    !-------------------------------------------------------------------
    ! Modify the lower-bound index of the array. Future allocations will
    ! use this value as lower-bound.
    !-------------------------------------------------------------------
    class(list_t),        intent(inout) :: arr
    integer(kind=list_k), intent(in)    :: first
    logical,              intent(inout) :: error
    !
    character(len=*), parameter :: rname='SET>LBOUND'
    !
    if (allocated(arr%list)) then
      call cubelist_message(seve%e,rname,  &
        'Can not modify list lower-bound as list is already allocated')
      error = .true.
      return
    endif
    arr%first = first
  end subroutine cubelist_set_lbound
  !
  recursive subroutine cubelist_reallocate_byubound4(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(list_t),   intent(inout) :: arr
    integer(kind=4), intent(in)    :: n
    logical,         intent(inout) :: error
    !
    call cubelist_reallocate_byrange8(arr,arr%first,int(n,kind=8),error)
    if (error) return
  end subroutine cubelist_reallocate_byubound4
  !
  recursive subroutine cubelist_reallocate_byubound8(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(list_t),   intent(inout) :: arr
    integer(kind=8), intent(in)    :: n
    logical,         intent(inout) :: error
    !
    call cubelist_reallocate_byrange8(arr,arr%first,n,error)
    if (error) return
  end subroutine cubelist_reallocate_byubound8
  !
  recursive subroutine cubelist_reallocate_byrange8(arr,first,last,error)
    use gkernel_interfaces
    !-------------------------------------------------------------------
    ! (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(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(list_t) :: tmp
    character(len=*), parameter :: rname='LIST>REALLOCATE'
    !
    if (allocated(arr%list)) then
      ofirst = lbound(arr%list,1)
      olast  = ubound(arr%list,1)
      if (ofirst.eq.first .and. olast.ge.last) then
        arr%first = ofirst  ! Should not be needed
        arr%last  = olast   ! Should not be needed
        return
      else
        call cubelist_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%first = nfirst
    arr%last = nlast
    arr%n = nfirst-1
    !
    if (tmp%n.gt.0) then
      call cubelist_transfer(tmp,arr,error)
      if (error) return
    endif
  end subroutine cubelist_reallocate_byrange8
  !
  subroutine cubelist_enlarge(arr,nnew,start,error)
    !-------------------------------------------------------------------
    ! Enlarge a list_t by inserting 'nnew' elements at the
    ! desired position. Old elements are moved consistently if needed,
    ! new elements are left unallocated.
    !-------------------------------------------------------------------
    class(list_t),        intent(inout) :: arr
    integer(kind=list_k), intent(in)    :: nnew
    integer(kind=list_k), intent(in)    :: start
    logical,              intent(inout) :: error
    !
    integer(kind=list_k) :: ntot,ielem,jelem
    !
    ! First enlarge to its full size
    ntot = arr%n+nnew
    call cubelist_reallocate_byrange8(arr,arr%first,ntot,error)
    if (error)  return
    !
    ! Move the old elements to the right, if any
    do ielem=arr%n,start,-1  ! Old position
      jelem = ielem+nnew  ! New position
      arr%list(jelem)%p            => arr%list(ielem)%p
      arr%list(jelem)%code_pointer =  arr%list(ielem)%code_pointer
      ! Keep old element as a pointer. Probably not much sense but this
      ! leaves the array in proper shape (the caller will probably do
      ! other things with this element).
      arr%list(ielem)%code_pointer = code_pointer_associated
    enddo
    !
    ! arr%n is not updated, as sometimes we kept valid pointers, but
    ! sometimes (when enlarging to the right) the pointers are just null
    ! (thus unusable). It is the reponsibility of the caller to update
    ! arr%n when relevant.
  end subroutine cubelist_enlarge
  !
  subroutine cubelist_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.
    !-------------------------------------------------------------------
    class(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%first,arr%last
        call arr%list(iobj)%final(error)
        if (error)  return
      enddo
    endif
    !
    ! Free the list
    if (allocated(arr%list))  deallocate(arr%list)
    arr%first = 1
    arr%last = 0
    arr%n = 0
  end subroutine cubelist_final
  !
  subroutine cubelist_copy(arr1,arr2,error)
    !-------------------------------------------------------------------
    ! Copy one list to another, including implicit reallocation of the
    ! output instance.
    ! The target objects are saved under the association status, i.e.
    ! they do not own the allocation.
    !-------------------------------------------------------------------
    class(list_t), intent(in)    :: arr1
    class(list_t), intent(inout) :: arr2
    logical,       intent(inout) :: error
    !
    integer(kind=list_k) :: i,last
    !
    if (.not.allocated(arr1%list)) then
      call arr2%final(error)
      return
    endif
    !
    last = arr1%n  ! Transfer only the useful part
    call cubelist_reallocate_byrange8(arr2,arr1%first,last,error)
    if (error) return
    !
    do i=arr1%first,last
      arr2%list(i)%p => arr1%list(i)%p
      arr2%list(i)%code_pointer = code_pointer_associated
    enddo
    arr2%n = arr1%n
  end subroutine cubelist_copy
  !
  subroutine cubelist_transfer(arr1,arr2,error)
    !-------------------------------------------------------------------
    ! Transfer one list to another, including allocation property if
    ! relevant. Includes implicit reallocation of the output instance.
    ! The input object is freed in return.
    !-------------------------------------------------------------------
    type(list_t), intent(inout) :: arr1
    type(list_t), intent(inout) :: arr2
    logical,      intent(inout) :: error
    !
    integer(kind=list_k) :: i,last
    !
    last = arr1%n  ! Transfer only the useful part
    call cubelist_reallocate_byrange8(arr2,arr1%first,last,error)
    if (error) return
    !
    do i=arr1%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%final(error)
    if (error) return
  end subroutine cubelist_transfer
  !
  !---------------------------------------------------------------------
  !
  subroutine cubelist_allocate(arr,template,lot,error)
    !----------------------------------------------------------------------
    ! Allocate an extended 'list_object_t' in memory, appended at last
    ! position in the list, of type taken from the given template. Return
    ! a pointer to this object in return.
    !----------------------------------------------------------------------
    class(list_t),        intent(inout) :: arr
    class(list_object_t), intent(in)    :: template
    class(list_object_t), pointer       :: lot
    logical,              intent(inout) :: error
    !
    call arr%reallocate(arr%n+1,error)
    if (error) return
    call arr%list(arr%n+1)%allocate(template,error)
    if (error) return
    ! Success
    arr%n = arr%n+1
    lot => arr%list(arr%n)%p
  end subroutine cubelist_allocate
  !
  subroutine cubelist_associate(arr,lot,error)
    !----------------------------------------------------------------------
    ! Associate an extended 'list_object_t' in memory, appended at last
    ! position in the list.
    !----------------------------------------------------------------------
    class(list_t),        intent(inout)      :: arr
    class(list_object_t), intent(in), target :: lot
    logical,              intent(inout)      :: error
    !
    call arr%reallocate(arr%n+1,error)
    if (error) return
    call arr%list(arr%n+1)%associate(lot,error)
    if (error) return
    ! Success
    arr%n = arr%n+1
  end subroutine cubelist_associate
  !
  subroutine cubelist_pop(full,ipop,error)
    !-------------------------------------------------------------------
    ! Free the ith element and pop it out from the list (list compressed
    ! in return)
    !-------------------------------------------------------------------
    class(list_t),        intent(inout) :: full
    integer(kind=list_k), intent(in)    :: ipop
    logical,              intent(inout) :: error
    !
    integer(kind=list_k) :: iobj
    !
    call full%list(ipop)%final(error)
    if (error)  return
    !
    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%first) then
      call full%final(error)
      if (error) return
    endif
  end subroutine cubelist_pop
  !
  subroutine cubelist_dissociate(full,object,error)
    !-------------------------------------------------------------------
    ! Dissociate (dereference) the given 'object' from the list (assume
    ! there can be one or more occurrences). The object itself is freed
    ! or not according to its code_pointer status.
    !
    ! The list is compressed in return.
    !-------------------------------------------------------------------
    class(list_t),        intent(inout) :: full
    class(list_object_t), pointer       :: object
    logical,              intent(inout) :: error
    !
    integer(kind=entr_k) :: ient,shift
    logical :: found
    !
    found = .false.
    shift = 0
    do ient=full%first,full%n
      if (associated(full%list(ient)%p,object)) then
        found = .true.
        shift = shift+1
        call full%list(ient)%final(error)
        if (error)  return
        cycle
      endif
      if (found) then
        full%list(ient-shift)%p => full%list(ient)%p
        full%list(ient-shift)%code_pointer = full%list(ient)%code_pointer
      endif
    enddo
    full%n = full%n-shift
    !
    if (full%n.lt.full%first) then
      call full%final(error)
      if (error) return
    endif
  end subroutine cubelist_dissociate
  !
end module cubelist_list_types
