module cubedag_types
  use cubetools_header_interface
  use cubedag_parameters
  use cubedag_flag
  use cubedag_tuple
  !---------------------------------------------------------------------
  ! Support module for the cubedag_node_object_t, i.e. the generic
  ! object type which is able to store any kind of object without
  ! knowing it (cubes, UV tables, etc).
  !
  ! A word on the dependencies:
  !    node -> desc -> link -> node-pointer -> node
  ! i.e. a circular dependency. These objects can not be split in
  ! several modules.
  !---------------------------------------------------------------------

  public :: cubedag_link_t,cubedag_node_object_t,cubedag_node_pobject_t
  public :: cubedag_flag_tostr,cubedag_sicvar_tostr
  private

  character(len=*), parameter :: form_lk='(A,T26,I20,1X,A)'  ! Link_t
  !
  type :: cubedag_link_t
    integer(kind=entr_k)                  :: n=0
    type(cubedag_node_pobject_t), pointer :: list(:)=>null()
    integer(kind=8),              pointer :: flag(:)=>null()  ! 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

  type :: cubedag_node_desc_t
    integer(kind=iden_l)  :: id=0                        ! Identifier
    integer(kind=entr_k)  :: ient                        ! Entry number (backpointer to IX)
    integer(kind=code_k)  :: type=code_null              ! Fortran type identifier
    integer(kind=code_k)  :: origin=code_origin_unknown  ! Imported, created, etc
    type(tools_list_t)    :: flag                        ! Signal, noise, etc
    type(cubedag_tuple_t) :: tuple                       !
    integer(kind=iden_l)  :: history=0                   ! History identifier
    type(cubedag_link_t)  :: parents                     ! List of parents
    type(cubedag_link_t)  :: children                    ! List of children
    type(cubedag_link_t)  :: twins                       ! List of twins
    integer(kind=4)       :: nsicvar=0                   !
    character(len=varn_l) :: sicvar(dag_msicvar)=''      ! List of SIC variables pointing to the node
    ! Header components
    character(len=base_l) :: family=''                   ! Family name
    type(cube_header_interface_t), pointer :: head=>null()
  end type cubedag_node_desc_t

  ! Placeholder for a 'node object' reference, i.e. for files indexed here. This
  ! type is extended by the external libraries using the DAG, to support their
  ! own object kinds (with their own Fortran types)
  type :: cubedag_node_object_t
    type(cubedag_node_desc_t) :: node
    procedure(ltype_interface),   pointer :: ltype=>null()     ! Return string describing the polymorphic type (used e.g. in LIST)
    procedure(memsize_interface), pointer :: memsize=>null()   ! Return the memory footprint
    procedure(memsize_interface), pointer :: disksize=>null()  ! Return the disk footprint
    procedure(memsize_interface), pointer :: datasize=>null()  ! Return the data size
  ! procedure(), pointer :: free=>null()     !
  ! procedure(), pointer :: getsize=>null()  ! Useful for garbage collecting?
  end type cubedag_node_object_t

  ! Fortran traditional trick to support list of pointers. List of
  ! pointers are more easily extensible without copying/transfering
  ! any data from the old list to the new one
  type :: cubedag_node_pobject_t
    class(cubedag_node_object_t), pointer :: p=>null()
  end type cubedag_node_pobject_t

contains

  function ltype_interface(obj)
    !-------------------------------------------------------------------
    ! Dummy procedure providing its interface for the ltype method
    !-------------------------------------------------------------------
    character(len=2) :: ltype_interface
    class(cubedag_node_object_t), intent(in) :: obj
    ltype_interface = '??'
  end function ltype_interface

  function memsize_interface(obj)
    !-------------------------------------------------------------------
    ! Dummy procedure providing its interface for the memsize method
    !-------------------------------------------------------------------
    integer(kind=size_length) :: memsize_interface
    class(cubedag_node_object_t), intent(in) :: obj
    memsize_interface = 0
  end function memsize_interface

  subroutine cubedag_flag_tostr(node,strflag,lstrflag,error)
    !-------------------------------------------------------------------
    ! Return the flag(s) of the input node into a string
    !-------------------------------------------------------------------
    type(cubedag_node_desc_t),  intent(in)    :: node
    character(len=*), optional, intent(out)   :: strflag
    integer(kind=4),  optional, intent(out)   :: lstrflag
    logical,          optional, intent(inout) :: error
    !
    call cubedag_flaglist_tostr(node%flag,strflag,lstrflag,error)
    if (error)  return
  end subroutine cubedag_flag_tostr

  subroutine cubedag_sicvar_tostr(nsicvar,sicvar,strsicvar,error)
    use cubetools_string
    !-------------------------------------------------------------------
    ! Return the SIC variable(s) of the input list into a string
    !-------------------------------------------------------------------
    integer(kind=4),  intent(in)    :: nsicvar
    character(len=*), intent(in)    :: sicvar(:)
    character(len=*), intent(out)   :: strsicvar
    logical,          intent(inout) :: error
    !
    call cubetools_string_concat(nsicvar,sicvar,',',strsicvar,error)
    if (error)  return
  end subroutine cubedag_sicvar_tostr

  ! === cubedag_link_t methods =========================================

  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 (associated(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
        tmp%list  => link%list
        tmp%flag  => link%flag
        link%list => null()
        link%flag => null()
      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 (associated(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
  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
    integer(kind=entr_k) :: jent
    integer(kind=4) :: nc,mlen
    character(len=10) :: tmp
    !
    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
        write(tmp,'(I0,A1)')  link%list(jent)%p%node%id,','
        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(inout) :: 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
    !
    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
        write(buf(ic+1:ic+20),'(I0,A1)')  link%list(il)%p%node%id,' '
        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(cubedag_node_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(link,error)
    !-------------------------------------------------------------------
    !-------------------------------------------------------------------
    class(cubedag_link_t), intent(inout) :: link
    logical,               intent(inout) :: error
    !
    if (associated(link%list))  deallocate(link%list,link%flag)
    link%n = 0
  end subroutine cubedag_link_final

end module cubedag_types
