module cubedag_repository
  use gkernel_interfaces
  use cubetools_parameters
  use cubedag_parameters
  use cubedag_flag
  use cubedag_types
  use cubedag_tuple
  use cubedag_dag
  use cubedag_node
  use cubedag_messaging
  use cubedag_index
  use cubedag_type
  !
  integer(kind=4), parameter :: dag_version_current(2) = (/ 0,2 /)
  !
  integer(kind=4), parameter :: key_l=24  ! Note the T26 tab below
  character(len=*), parameter :: form_i4 ='(A,T26,I11,20(I11))'       ! Scalar or array I*4
  character(len=*), parameter :: form_i4c='(A,T26,I11,A)'             ! I*4 array (decoding)
  character(len=*), parameter :: form_i8 ='(A,T26,I20)'
  character(len=*), parameter :: form_r8 ='(A,T26,1PG25.16)'
  character(len=*), parameter :: form_a  ='(A,T26,A)'                 ! Scalar string
  character(len=*), parameter :: form_na ='(A,T26,I11,(20(1X,A12)))'  ! String array
  character(len=*), parameter :: form_nac='(A,T26,I11,A)'             ! String array (decoding)

  public :: cubedag_repository_init,cubedag_repository_write,cubedag_repository_read
  private

contains

  subroutine cubedag_repository_init(path,error)
    !-------------------------------------------------------------------
    ! Initialize a new repository
    !-------------------------------------------------------------------
    character(len=*), intent(in)    :: path
    logical,          intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='REPOSITORY>INIT'
    !
    ! Create and init new one on disk
    ! ZZZ Not yet implemented
    !
    call cubedag_dag_resetcounter(error)
    if (error)  return
    !
    ! Create the root node in IX
    call cubedag_dag_root(error)
    if (error)  return
  end subroutine cubedag_repository_init

  !---------------------------------------------------------------------

  subroutine cubedag_repository_open(name,read,lun,error)
    character(len=*), intent(in)    :: name
    logical,          intent(in)    :: read
    integer(kind=4),  intent(out)   :: lun
    logical,          intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='REPOSITORY>OPEN'
    character(len=3) :: mode
    integer(kind=4) :: ier
    !
    if (read) then
      mode = 'OLD'
    else
      call cubedag_message(seve%i,rname,'Creating DAG repository in file '//name)
      mode = 'NEW'
    endif
    !
    ier = sic_getlun(lun)
    if (mod(ier,2).eq.0) then
      error = .true.
      return
    endif
    ier = sic_open(lun,name,mode,.false.)
    if (ier.ne.0) then
      call cubedag_message(seve%e,rname,'Error opening file '//name)
      call putios('E-SIC, ',ier)
      error = .true.
      return
    endif
  end subroutine cubedag_repository_open

  subroutine cubedag_repository_close(lun,error)
    integer(kind=4),  intent(in)   :: lun
    logical,          intent(inout) :: error
    ! Local
    integer(kind=4) :: ier
    !
    ier = sic_close(lun)
    call sic_frelun(lun)
  end subroutine cubedag_repository_close

  subroutine cubedag_repository_write(reponame,error)
    character(len=*), intent(in)    :: reponame
    logical,          intent(inout) :: error
    ! Local
    integer(kind=entr_k) :: ient
    integer(kind=4) :: lun
    !
    call cubedag_repository_open(reponame,.false.,lun,error)
    if (error)  return
    !
    call cubedag_write_version(lun,dag_version_current,error)
    if (error)  return
    !
    do ient=2,ix%next-1  ! Skip root on purpose
      call cubedag_write_entry(lun,ient,error)
      if (error)  return
    enddo
    !
    call cubedag_repository_close(lun,error)
    if (error)  return
  end subroutine cubedag_repository_write

  subroutine cubedag_write_version(lun,version,error)
    integer(kind=4), intent(in)    :: lun
    integer(kind=4), intent(in)    :: version(2)  ! Major + minor
    logical,         intent(inout) :: error
    !
    write(lun,form_i4) 'VERSION_MAJOR',version(1)
    write(lun,form_i4) 'VERSION_MINOR',version(2)
  end subroutine cubedag_write_version

  subroutine cubedag_write_entry(lun,ient,error)
    integer(kind=4),      intent(in)    :: lun
    integer(kind=entr_k), intent(in)    :: ient
    logical,              intent(inout) :: error
    !
    call cubedag_write_entry_node(lun,ix%object(ient)%p,error)
    if (error)  return
    call cubedag_tuple_write(lun,ix%object(ient)%p%node%tuple,error)
    if (error)  return
    call cubedag_write_entry_history(lun,ix%object(ient)%p,error)
    if (error)  return
    call cubedag_write_entry_links(lun,ix%object(ient)%p,error)
    if (error)  return
    call cubedag_write_entry_head(lun,ient,error)
    if (error)  return
  end subroutine cubedag_write_entry

  subroutine cubedag_write_entry_node(lun,object,error)
    integer(kind=4),             intent(in)    :: lun
    type(cubedag_node_object_t), intent(in)    :: object
    logical,                     intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='WRITE>ENTRY>NODE'
    integer(kind=4) :: iflag,ier
    character(len=dag_flagl), allocatable :: lflags(:)
    type(flag_t), pointer :: flag
    !
    write(lun,form_a)  'TYPE',trim(cubedag_type_tokey(object%node%type))
    write(lun,form_i8) 'ID',object%node%id
    write(lun,form_i4) 'ORIGIN',object%node%origin
    write(lun,form_a)  'FAMILY',trim(object%node%family)
    !
    ! Flags
    allocate(lflags(object%node%flag%n),stat=ier)
    if (failed_allocate(rname,'flags',ier,error)) return
    do iflag=1,object%node%flag%n
      flag => cubedag_flag_ptr(object%node%flag%list(iflag)%p,error)
      if (error)  return
      lflags(iflag) = flag%get_name()
    enddo
    ! ZZZ flag names elements have length < 12: they are right justified
    !     in their 12-char space... See patch at read time
    write(lun,form_na) 'FLAG',object%node%flag%n,(/ (lflags(iflag),iflag=1,object%node%flag%n) /)
  end subroutine cubedag_write_entry_node

  subroutine cubedag_write_entry_history(lun,object,error)
    integer(kind=4),             intent(in)    :: lun
    type(cubedag_node_object_t), intent(in)    :: object
    logical,                     intent(inout) :: error
    !
    write(lun,form_i8) 'HISTORY',object%node%history
  end subroutine cubedag_write_entry_history

  subroutine cubedag_write_entry_links(lun,object,error)
    integer(kind=4),             intent(in)    :: lun
    type(cubedag_node_object_t), intent(inout) :: object
    logical,                     intent(inout) :: error
    !
    call object%node%parents%write(lun,'PARENTS',error)
    if (error)  return
    call object%node%children%write(lun,'CHILDREN',error)
    if (error)  return
    call object%node%twins%write(lun,'TWINS',error)
    if (error)  return
  end subroutine cubedag_write_entry_links

  subroutine cubedag_write_entry_head(lun,ient,error)
    integer(kind=4),      intent(in)    :: lun
    integer(kind=entr_k), intent(in)    :: ient
    logical,              intent(inout) :: error
    ! Local
    class(cubedag_node_object_t), pointer :: obj
    !
    obj => ix%object(ient)%p
    call obj%node%head%write(lun,error)
    if (error)  return
  end subroutine cubedag_write_entry_head

  !---------------------------------------------------------------------

  subroutine cubedag_repository_read(reponame,error)
    character(len=*), intent(in)    :: reponame
    logical,          intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='REPOSITORY>READ'
    character(len=mess_l) :: mess
    integer(kind=4) :: lun,version(2)
    logical :: nomore
    integer(kind=entr_k) :: ient
    !
    ! Sanity
    if (ix%next.ge.3) then
      ! This would be possible, but this implies renumbering the identifiers
      ! Might be easy by adding a shift (e.g. highest current id) to all
      ! ids/parents/children of the DAG to be imported. But what about overlaps
      ! (i.e. cubes appearing in 2 DAGs at the same time?)
      call cubedag_message(seve%e,rname,'Can not import '//trim(reponame)//  &
        ' in a non-empty DAG')
      error = .true.
      return
    endif
    !
    call cubedag_repository_open(reponame,.true.,lun,error)
    if (error)  return
    !
    call cubedag_read_version(reponame,lun,version,error)
    if (error)  return
    !
    nomore = .false.
    do
      call cubedag_read_entry(reponame,lun,nomore,error)
      if (error)  return
      if (nomore)  exit
    enddo
    !
    ! Post-read: resolve all the links (from IDs to pointers)
    do ient=1,ix%next-1
      call cubedag_repo_resolve(ix%object(ient)%p,error)
      if (error)  return
    enddo
    !
    ! Feedback
    write(mess,'(A,I0,A)')  'Loaded a repository of ',ix%next-1,' objects'
    call cubedag_message(seve%i,rname,mess)
    !
    call cubedag_repository_close(lun,error)
    if (error)  return
    !
    call cubedag_dag_updatecounter(error)
    if (error)  return
  end subroutine cubedag_repository_read

  subroutine cubedag_read_version(reponame,lun,version,error)
    character(len=*), intent(in)    :: reponame
    integer(kind=4),  intent(in)    :: lun
    integer(kind=4),  intent(out)   :: version(2)  ! Major + minor
    logical,          intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='REPOSITORY>READ'
    character(len=key_l) :: key
    integer(kind=4) :: ier
    !
    read(lun,form_i4,iostat=ier) key,version(1)
    if (ier.gt.0) then
      call putios('E-REPOSITORY,  ',ier)
      error = .true.
      return
    endif
    if (key.ne.'VERSION_MAJOR') then
      call cubedag_message(seve%e,rname,'File '//trim(reponame)//' is malformatted')
      error = .true.
      return
    endif
    read(lun,form_i4,iostat=ier) key,version(2)
  end subroutine cubedag_read_version

  subroutine cubedag_read_entry(reponame,lun,nomore,error)
    character(len=*), intent(in)    :: reponame
    integer(kind=4),  intent(in)    :: lun
    logical,          intent(inout) :: nomore
    logical,          intent(inout) :: error
    ! Local
    class(cubedag_node_object_t), pointer :: object
    !
    call cubedag_read_entry_node(reponame,lun,object,nomore,error)
    if (error)  return
    if (nomore)  return
    call cubedag_tuple_read(lun,object%node%tuple,error)
    if (error)  return
    call cubedag_read_entry_history(lun,object,error)
    if (error)  return
    call cubedag_read_entry_links(lun,object,error)
    if (error)  return
    call cubedag_read_entry_head(lun,object,error)
    if (error)  return
    ! Insert in DAG
    call cubedag_dag_attach(object,error)
    if (error)  return
  end subroutine cubedag_read_entry

  subroutine cubedag_read_entry_node(reponame,lun,object,nomore,error)
    character(len=*),             intent(in)    :: reponame
    integer(kind=4),              intent(in)    :: lun
    class(cubedag_node_object_t), pointer       :: object
    logical,                      intent(inout) :: nomore
    logical,                      intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='REPOSITORY>READ'
    character(len=key_l) :: key
    character(len=12) :: ktype,chflags(dag_mflags)
    integer(kind=4) :: ier,nflag,iflag
    integer(kind=code_k) :: type
    type(flag_t), pointer :: flag
    logical :: found
    !
    read(lun,form_a,iostat=ier) key,ktype
    if (ier.lt.0) then
      ! EOF
      nomore = .true.
      return
    endif
    if (ier.gt.0) then
      call putios('E-REPOSITORY,  ',ier)
      error = .true.
      return
    endif
    if (key.ne.'TYPE') then
      call cubedag_message(seve%e,rname,'File '//trim(reponame)//' is malformatted')
      error = .true.
      return
    endif
    !
    call cubedag_type_tocode(ktype,type,error)
    if (error)  return
    call cubedag_dag_newnode(object,type,error)
    if (error)  return
    !
    read(lun,form_i8) key,object%node%id
    read(lun,form_i4) key,object%node%origin
    read(lun,form_a)  key,object%node%family
    call cubedag_read_nch(lun,nflag,chflags,error)
    if (error)  return
    call cubetools_list_reallocate(object%node%flag,int(nflag,kind=8),error)
    if (error)  return
    ! Resolving codes from names below is unefficient. Solutions:
    !  1) Sort the main list, and use dichotomic search, OR
    !  2) Get rid of the integer codes (as we want flexibility
    !     e.g. user-defined flags)
    do iflag=1,nflag
#if defined(IFORT)
      if (object%node%flag%list(iflag)%code_pointer.eq.code_pointer_allocated)  &
        deallocate(object%node%flag%list(iflag)%p)
      allocate(flag_t::object%node%flag%list(iflag)%p,stat=ier)
      if (failed_allocate(rname,'flag',ier,error)) return
      object%node%flag%list(iflag)%code_pointer = code_pointer_allocated
      flag => cubedag_flag_ptr(object%node%flag%list(iflag)%p,error)
      if (error)  return
      call cubedag_flag_name2flag(chflags(iflag),found,flag)
      ! if (.not.found) => was replaced with flag_unknown
#else
      allocate(flag,stat=ier)
      if (failed_allocate(rname,'flag',ier,error)) return
      call cubedag_flag_name2flag(chflags(iflag),found,flag)
      ! if (.not.found) => was replaced with flag_unknown
      call cubetools_list_setelem(object%node%flag%list(iflag),flag,  &
        code_pointer_allocated,error)
      if (error)  return
#endif
    enddo
    object%node%flag%n = nflag
  end subroutine cubedag_read_entry_node

  subroutine cubedag_read_entry_history(lun,object,error)
    integer(kind=4),              intent(in)    :: lun
    class(cubedag_node_object_t), pointer       :: object
    logical,                      intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='REPOSITORY>READ'
    character(len=key_l) :: key
    !
    read(lun,form_i8) key,object%node%history
  end subroutine cubedag_read_entry_history

  subroutine cubedag_read_entry_links(lun,object,error)
    integer(kind=4),              intent(in)    :: lun
    class(cubedag_node_object_t), intent(inout) :: object
    logical,                      intent(inout) :: error
    !
    call object%node%parents%read(lun,error)
    if (error)  return
    call object%node%children%read(lun,error)
    if (error)  return
    call object%node%twins%read(lun,error)
    if (error)  return

  end subroutine cubedag_read_entry_links

  subroutine cubedag_read_entry_head(lun,object,error)
    integer(kind=4),              intent(in)    :: lun
    class(cubedag_node_object_t), intent(inout) :: object
    logical,                      intent(inout) :: error
    ! Local
    integer(kind=4) :: ier
    character(len=*), parameter :: rname='READ>ENTRY>HEAD'
    !
    if (associated(object%node%head))  deallocate(object%node%head)
    allocate(object%node%head,stat=ier)
    if (failed_allocate(rname,'object%node%head',ier,error)) return
    !
    call object%node%head%read(lun,error)
    if (error)  return
  end subroutine cubedag_read_entry_head

  !---------------------------------------------------------------------

  subroutine cubedag_read_ni4(lun,ni4,i4,error)
    !-------------------------------------------------------------------
    !-------------------------------------------------------------------
    integer(kind=4),      intent(in)    :: lun
    integer(kind=4),      intent(out)   :: ni4
    integer(kind=code_k), intent(out)   :: i4(:)
    logical,              intent(inout) :: error
    ! Local
    character(len=key_l) :: key
    character(len=128) :: tmp
    !
    read(lun,form_i4c) key,ni4,tmp
    if (ni4.gt.0)  &
      read(tmp,'(20(I11))')  i4(1:ni4)
  end subroutine cubedag_read_ni4

  subroutine cubedag_read_nch(lun,nch,ch,error)
    !-------------------------------------------------------------------
    !-------------------------------------------------------------------
    integer(kind=4),  intent(in)    :: lun
    integer(kind=4),  intent(out)   :: nch
    character(len=*), intent(out)   :: ch(:)
    logical,          intent(inout) :: error
    ! Local
    character(len=key_l) :: key
    character(len=128) :: tmp
    integer(kind=4) :: ich
    !
    read(lun,form_nac) key,nch,tmp
    if (nch.gt.0) then
      read(tmp,'(20(1X,A12))')  ch(1:nch)
      do ich=1,nch
        ! ZZZ Elements might have been right-justified in their 12-char
        !     space: force left-justification
        ch(ich) = adjustl(ch(ich))
      enddo
    endif
  end subroutine cubedag_read_nch

  !---------------------------------------------------------------------

  subroutine cubedag_repo_resolve(obj,error)
    !-------------------------------------------------------------------
    ! Resolve all the cross-links (from IDs to pointer) for the given
    ! object.
    !-------------------------------------------------------------------
    type(cubedag_node_object_t), intent(inout) :: obj
    logical,                     intent(inout) :: error
    !
    call cubedag_link_resolve(obj%node%parents,error)
    if (error)  return
    call cubedag_link_resolve(obj%node%children,error)
    if (error)  return
    call cubedag_link_resolve(obj%node%twins,error)
    if (error)  return
    !
  end subroutine cubedag_repo_resolve

end module cubedag_repository
