module cubedag_link_type
  use cubetools_list
  use cubedag_parameters
  use cubedag_messaging

  ! The cubedag_link_t is a collection of tools_object_t, but an extended
  ! version which provides a get_id() method.
  type, abstract, extends(tools_object_t) :: dag_object_t
  contains
    procedure(get_id_interface), deferred :: get_id
  end type dag_object_t

  type, extends(tools_list_t) :: cubedag_link_t
    integer(kind=8), allocatable :: flag(:)  ! Some flag, context-dependent
  contains
    generic,   public  :: reallocate  => reallocate4,reallocate8
    procedure, private :: reallocate4 => cubedag_link_reallocate_i4
    procedure, private :: reallocate8 => cubedag_link_reallocate_i8
    procedure, public  :: copy        => cubedag_link_copy
    procedure, public  :: repr        => cubedag_link_repr
    procedure, public  :: write       => cubedag_link_write
    procedure, public  :: read        => cubedag_link_read
    procedure, public  :: unlink      => cubedag_link_unlink
    procedure, public  :: final       => cubedag_link_final  ! Explicit, make it implicit?
  end type cubedag_link_t

  character(len=*), parameter :: form_lk='(A,T26,I20,1X,A)'  ! Link_t

  public :: cubedag_link_t,dag_object_t
  private

contains

  subroutine cubedag_link_reallocate_i4(link,n,error)
    !-------------------------------------------------------------------
    !-------------------------------------------------------------------
    class(cubedag_link_t), intent(inout) :: link
    integer(kind=4),       intent(in)    :: n
    logical,               intent(inout) :: error
    call cubedag_link_reallocate_i8(link,int(n,kind=8),error)
    if (error)  return
  end subroutine cubedag_link_reallocate_i4

  subroutine cubedag_link_reallocate_i8(link,n,error)
    use gkernel_interfaces
    !-------------------------------------------------------------------
    !-------------------------------------------------------------------
    class(cubedag_link_t), intent(inout) :: link
    integer(kind=8),       intent(in)    :: n
    logical,               intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='LINK>REALLOCATE'
    integer(kind=entr_k), parameter :: cubedag_link_minalloc=10
    type(cubedag_link_t) :: tmp
    integer(kind=entr_k) :: osize,nsize,iobj
    integer(kind=4) :: ier
    !
    if (allocated(link%list)) then
      osize = size(link%list)
      if (osize.gt.n) then
        ! Nothing to do
        return
      else
        ! Steal allocation from original object
        tmp%n     =  link%n
        call move_alloc(from=link%list,to=tmp%list)
        call move_alloc(from=link%flag,to=tmp%flag)
      endif
      nsize = max(2*osize,n)
      ! link%n unchanged
    else
      nsize = max(cubedag_link_minalloc,n)
      link%n = 0
    endif
    !
    allocate(link%list(nsize),link%flag(nsize),stat=ier)
    if (failed_allocate(rname,'Link buffers',ier,error)) return
    !
    if (allocated(tmp%list)) then
      do iobj=1,link%n
        link%list(iobj)%p => tmp%list(iobj)%p
        link%flag(iobj)   =  tmp%flag(iobj)
      enddo
      call tmp%final(error)
    endif
    !
    ! Initialize the new components
    do iobj=link%n+1,nsize
      link%list(iobj)%p => null()
      link%flag(iobj)   =  0
    enddo
  end subroutine cubedag_link_reallocate_i8

  subroutine cubedag_link_copy(in,out,error)
    !-------------------------------------------------------------------
    !-------------------------------------------------------------------
    class(cubedag_link_t), intent(in)    :: in
    class(cubedag_link_t), intent(inout) :: out
    logical,               intent(inout) :: error
    ! Local
    integer(kind=entr_k) :: iobj
    !
    call out%reallocate(in%n,error)
    if (error)  return
    !
    do iobj=1,in%n
      out%list(iobj)%p => in%list(iobj)%p
      out%flag(iobj)   =  in%flag(iobj)
    enddo
    out%n = in%n
  end subroutine cubedag_link_copy

  subroutine cubedag_link_repr(link,prefix,str)
    !-------------------------------------------------------------------
    ! Create a one-line representation of the list
    !-------------------------------------------------------------------
    class(cubedag_link_t), intent(in)    :: link
    character(len=*),      intent(in)    :: prefix
    character(len=*),      intent(inout) :: str
    ! Local
    character(len=*), parameter :: rname='LINK>REPR'
    integer(kind=entr_k) :: jent
    integer(kind=4) :: nc,mlen
    character(len=10) :: tmp
    class(tools_object_t), pointer :: tot
    !
    str = prefix
    nc = len_trim(prefix)
    mlen= len(str)
    if (link%n.le.0) then
      write(str(nc+1:),'(A6)')  '<none>'
    else
      do jent=1,link%n
        tot => link%list(jent)%p
        select type (tot)
        class is (dag_object_t)
          write(tmp,'(I0,A1)')  tot%get_id(),','
        class default
          call cubedag_message(seve%e,rname,'Internal error: object has wrong class')
        end select
        str = str(1:nc)//tmp
        nc = len_trim(str)
        if (nc.eq.mlen) then  ! List too long, string exhausted
          str(nc-1:nc) = '..'
          exit
        elseif (jent.eq.link%n) then  ! Last element, strip off trailing coma
          str(nc:nc) = ' '
        endif
      enddo
    endif
  end subroutine cubedag_link_repr

  subroutine cubedag_link_write(link,lun,name,error)
    use gkernel_interfaces
    !-------------------------------------------------------------------
    ! Write the cubedag_link_t to output file
    !-------------------------------------------------------------------
    class(cubedag_link_t), intent(in)    :: link
    integer(kind=4),       intent(in)    :: lun
    character(len=*),      intent(in)    :: name
    logical,               intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='LINK>WRITE'
    integer(kind=entr_k) :: il
    integer(kind=4) :: ic,nc,ier
    character(len=:), allocatable :: buf,tmp
    character(len=mess_l) :: mess
    class(tools_object_t), pointer :: tot
    !
    if (link%n.le.0) then
      write(lun,form_lk) name,link%n
    else
      ic = 0
      allocate(character(100)::buf,stat=ier)
      if (failed_allocate(rname,'char buffer',ier,error)) return
      do il=1,link%n
        if (len(buf).lt.ic+21) then
          tmp = buf(1:ic)  ! Implicit (re)allocation
          deallocate(buf)
          allocate(character(2*ic)::buf,stat=ier)
          if (failed_allocate(rname,'char buffer',ier,error)) return
          buf(1:ic) = tmp
        endif
        if (.not.associated(link%list(il)%p)) then  ! Sanity check
          write(mess,'(3(A,I0))')  &
            'Internal error: pointer to node #',il,'/',link%n,' is not associated'
          call cubedag_message(seve%e,rname,mess)
          error = .true.
          return
        endif
        tot => link%list(il)%p
        select type (tot)
        class is (dag_object_t)
          write(buf(ic+1:ic+20),'(I0,A1)')  tot%get_id(),' '
        class default
          call cubedag_message(seve%e,rname,'Internal error: object has wrong class')
        end select
        nc = len_trim(buf(ic+1:ic+20))+1
        ic = ic+nc
      enddo
      write(lun,form_lk) name,link%n,buf(1:ic)
    endif
    !
  end subroutine cubedag_link_write

  subroutine cubedag_link_read(link,lun,error)
    use gkernel_interfaces
    !-------------------------------------------------------------------
    ! Read the cubedag_link_t from input file
    !-------------------------------------------------------------------
    class(cubedag_link_t), intent(inout) :: link
    integer(kind=4),       intent(in)    :: lun
    logical,               intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='LINK>READ'
    character(len=12) :: key
    character(len=:), allocatable :: buf
    integer(kind=entr_k) :: nl,il
    integer(kind=4) :: i1,i2,nc,ier
    !
    read(lun,form_lk) key,nl
    if (nl.gt.0) then
      ! Try to read in a long-enough buffer
      nc = 32
      do
        allocate(character(nc)::buf,stat=ier)
        if (failed_allocate(rname,'char buffer',ier,error)) return
        backspace(lun)   ! Backspace in formatted file is not standard!
        read(lun,form_lk) key,nl,buf
        if (buf(nc-1:nc).eq.' ')  then
          ! 2 last chars are blank => ok, no number missed
          exit
        endif
        deallocate(buf)
        nc = 2*nc
      enddo
      call link%reallocate(nl,error)
      if (error)  return
      il = 0
      i1 = 1
      i2 = 1
      do while (il.lt.nl)
        if (buf(i2+1:i2+1).eq.' ') then
          il = il+1
          read(buf(i1:i2),*)  link%flag(il)
          i1 = i2+2
          i2 = i1
        else
          i2 = i2+1
        endif
      enddo
    endif
    link%n = nl
  end subroutine cubedag_link_read

  subroutine cubedag_link_unlink(link,object,error)
    !-------------------------------------------------------------------
    ! Remove the named 'object' from the link list
    !-------------------------------------------------------------------
    class(cubedag_link_t), intent(inout) :: link
    class(tools_object_t), pointer       :: object
    logical,               intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='LINK>UNLINK'
    integer(kind=entr_k) :: ient,shift
    logical :: found
    !
    found = .false.
    shift = 0
    do ient=1,link%n
      if (associated(link%list(ient)%p,object)) then
        found = .true.
        shift = shift+1
        cycle
      endif
      if (found) then
        link%list(ient-shift)%p => link%list(ient)%p
        link%flag(ient-shift)   =  link%flag(ient)    ! Probably useless
      endif
    enddo
    link%n = link%n-shift
    !
    ! This is too much verbose, and can happen under legitimate
    ! conditions.
    ! if (.not.found)  &
    !   call cubedag_message(seve%w,rname,'Object not found in list')
    !
  end subroutine cubedag_link_unlink

  subroutine cubedag_link_final(arr,error)
    !-------------------------------------------------------------------
    ! Free the list but NOT its targets, assuming they are still
    ! referenced (accessible) by someone else.
    !-------------------------------------------------------------------
    class(cubedag_link_t), intent(inout) :: arr
    logical,               intent(inout) :: error
    !
    call arr%tools_list_t%final(error)
    if (allocated(arr%flag))  deallocate(arr%flag)
  end subroutine cubedag_link_final

  function get_id_interface(obj)
    !-------------------------------------------------------------------
    ! Dummy procedure providing its interface for the get_id method
    !-------------------------------------------------------------------
    integer(kind=iden_l) :: get_id_interface
    class(dag_object_t), intent(in) :: obj
    get_id_interface = 0
  end function get_id_interface

end module cubedag_link_type
