module cubedag_history_types
  use gkernel_interfaces
  use cubelist_types
  use cubedag_parameters
  use cubedag_messaging
  use cubedag_link_type
  use cubedag_links_type
  use cubedag_dag_buffer
  !---------------------------------------------------------------------
  ! Support module for the history type
  !---------------------------------------------------------------------
  !
  public :: cubedag_history_t,cubedag_history_ptr
  public :: cubedag_history_list_t
  private
  !
  integer(kind=4), parameter :: command_length=16  ! ZZZ Duplicated from SIC
  !
  ! DAG data format
  character(len=*), parameter :: form_i8='(A,T13,I20)'
  character(len=*), parameter :: form_a='(A,T13,A)'  ! Scalar string
  !
  type, extends(list_object_t) :: cubedag_history_t
    integer(kind=iden_l)              :: id = 0
    character(len=command_length)     :: command = strg_unk
    character(len=commandline_length) :: line = strg_unk
    type(cubedag_hlinks_t)            :: links
  contains
    procedure, public  :: init       => cubedag_history_init
    procedure, public  :: read       => cubedag_history_read
    procedure, private :: read_head  => cubedag_history_read_head
    procedure, public  :: write      => cubedag_history_write
    procedure, private :: write_head => cubedag_history_write_head
    procedure, public  :: final      => cubedag_history_final
  end type cubedag_history_t
  !
  type, extends(list_t) :: cubedag_history_list_t
    integer(kind=4), private :: lun
  contains
    procedure, public  :: entrynum => cubedag_history_entrynum
    procedure, public  :: add      => cubedag_history_add_fromargs
    procedure, public  :: liste    => cubedag_history_list
    procedure, public  :: init     => cubedag_history_list_init
    procedure, private :: open     => cubedag_history_list_open
    procedure, public  :: read     => cubedag_history_list_read
    procedure, public  :: write    => cubedag_history_list_write
    procedure, private :: close    => cubedag_history_list_close
  end type cubedag_history_list_t
contains

  function cubedag_history_ptr(lot,error)
    !-------------------------------------------------------------------
    ! Check if the input type is a 'cubedag_history_t', and return a
    ! pointer to it if relevant.
    !-------------------------------------------------------------------
    type(cubedag_history_t), pointer :: cubedag_history_ptr  ! Function value on return
    class(list_object_t), pointer       :: lot
    logical,              intent(inout) :: error
    !
    character(len=*), parameter :: rname='OPENED>PTR'
    !
    select type(lot)
    type is (cubedag_history_t)
      cubedag_history_ptr => lot
    class default
      cubedag_history_ptr => null()
      call cubedag_message(seve%e,rname,'Internal error: object is not a cubedag_history_t')
      error = .true.
      return
    end select
  end function cubedag_history_ptr

  subroutine cubedag_history_init(hist,error)
    !-------------------------------------------------------------------
    ! Initialize the i-th component in the index
    !-------------------------------------------------------------------
    class(cubedag_history_t), intent(out)   :: hist
    logical,                  intent(inout) :: error
    !
    ! Done with intent(out)
  end subroutine cubedag_history_init
  !
  subroutine cubedag_history_read(hobj,lun,nshift,hshift,nomore,error)
    !-------------------------------------------------------------------
    ! Read the next history object from the DAG file (if any)
    !-------------------------------------------------------------------
    class(cubedag_history_t), intent(inout) :: hobj
    integer(kind=4),          intent(in)    :: lun
    integer(kind=iden_l),     intent(in)    :: nshift  ! Node ID shift
    integer(kind=iden_l),     intent(in)    :: hshift  ! History ID shift
    logical,                  intent(inout) :: nomore
    logical,                  intent(inout) :: error
    !
    call hobj%read_head(lun,hshift,nomore,error)
    if (error)  return
    if (nomore)  return
    call hobj%links%read(lun,nshift,error)
    if (error)  return
  end subroutine cubedag_history_read
  !
  subroutine cubedag_history_read_head(hobj,lun,hshift,nomore,error)
    class(cubedag_history_t), intent(inout) :: hobj
    integer(kind=4),          intent(in)    :: lun
    integer(kind=iden_l),     intent(in)    :: hshift  ! History ID shift
    logical,                  intent(inout) :: nomore
    logical,                  intent(inout) :: error
    !
    character(len=*), parameter :: rname='HREPOSITORY>READ'
    character(len=12) :: key
    integer(kind=iden_l) :: hid
    integer(kind=4) :: ier
    !
    read(lun,form_i8,iostat=ier) key,hid
    if (ier.lt.0) then
      ! EOF
      nomore = .true.
      return
    endif
    if (ier.gt.0) then
      call putios('E-HREPOSITORY,  ',ier)
      error = .true.
      return
    endif
    if (key.ne.'ID') then
      call cubedag_message(seve%e,rname,'Malformatted file: got '//trim(key))
      error = .true.
      return
    endif
    !
    hobj%id = hid+hshift
    read(lun,form_a) key,hobj%command
    read(lun,form_a) key,hobj%line
  end subroutine cubedag_history_read_head
  !
  subroutine cubedag_history_write(hobj,lun,error)
    !-------------------------------------------------------------------
    ! Write the next history object to the DAG file
    !-------------------------------------------------------------------
    class(cubedag_history_t), intent(in)    :: hobj
    integer(kind=4),          intent(in)    :: lun
    logical,                  intent(inout) :: error
    !
    call hobj%write_head(lun,error)
    if (error)  return
    call hobj%links%write(lun,error)
    if (error)  return
  end subroutine cubedag_history_write
  !
  subroutine cubedag_history_write_head(hobj,lun,error)
    class(cubedag_history_t), intent(in)    :: hobj
    integer(kind=4),          intent(in)    :: lun
    logical,                  intent(inout) :: error
    !
    write(lun,form_i8) 'ID',hobj%id
    write(lun,form_a)  'COMMAND',trim(hobj%command)
    write(lun,form_a)  'LINE',trim(hobj%line)
  end subroutine cubedag_history_write_head
  !
  subroutine cubedag_history_final(obj,error)
    !-------------------------------------------------------------------
    ! No implicit final because of
    ! https://gcc.gnu.org/bugzilla/show_bug.cgi?id=112459
    !-------------------------------------------------------------------
    class(cubedag_history_t), intent(inout) :: obj
    logical,                  intent(inout) :: error
    !
    ! Clean
    call obj%links%final(error)
    if (error)  continue
    !
    ! Reinitialize (after cleaning)
    call obj%init(error)
    if (error)  continue
  end subroutine cubedag_history_final

  function cubedag_history_entrynum(hx,id,error)
    !-------------------------------------------------------------------
    ! Resolve the entry number corresponding to the given ID.
    ! - If ID>0, the entry is resolved by searching in all the history
    ! index. This resolution is based on two strong assumptions:
    !  1) the identifier is UNIQUE,
    !  2) the identifier list is SORTED
    ! - If ID<=0, the ID is assumed to be a position from the end
    ! (0=last, same as CubeID).
    !-------------------------------------------------------------------
    integer(kind=entr_k) :: cubedag_history_entrynum
    class(cubedag_history_list_t), intent(in)    :: hx
    integer(kind=iden_l),          intent(in)    :: id
    logical,                       intent(inout) :: error
    !
    integer(kind=entr_k) :: inf,mid,sup
    character(len=mess_l) :: mess
    type(cubedag_history_t), pointer :: hist
    character(len=*), parameter :: rname='HISTORY>ENTRYNUM'
    !
    if (id.le.0) then
      ! Search by position from the end
      if (-id.gt.hx%n-1) then
        write(mess,'(A,I0,A)')  'No such identifier ',id,' in command history index'
        call cubedag_message(seve%e,rname,mess)
        cubedag_history_entrynum = 0
        error = .true.
        return
      endif
      cubedag_history_entrynum = hx%n+id
      return
    endif
    !
    ! Dichotomic search
    hist => cubedag_history_ptr(hx%list(1)%p,error)
    if (error)  return
    if (hist%id.eq.id) then
      cubedag_history_entrynum = 1
      return
    endif
    !
    inf = 1
    sup = hx%n
    do while (sup.gt.inf+1)
      mid = (inf+sup)/2  ! Integer division
      hist => cubedag_history_ptr(hx%list(mid)%p,error)
      if (error)  return
      if (hist%id.lt.id) then
        inf = mid
      else
        sup = mid
      endif
    enddo
    !
    hist => cubedag_history_ptr(hx%list(sup)%p,error)
    if (error)  return
    if (hist%id.eq.id) then
      cubedag_history_entrynum = sup
    else
      write(mess,'(A,I0,A)')  'No such identifier ',id,' in command history index'
      call cubedag_message(seve%e,rname,mess)
      cubedag_history_entrynum = 0
      error = .true.
      return
    endif
  end function cubedag_history_entrynum
  !
  subroutine cubedag_history_add_fromargs(hoptx,command,line,inputs,outputs,&
    hid,error)
    !-------------------------------------------------------------------
    ! Add a new command in the HISTORY index
    !-------------------------------------------------------------------
    class(cubedag_history_list_t), intent(inout) :: hoptx
    character(len=*),              intent(in)    :: command
    character(len=*),              intent(in)    :: line
    type(cubedag_link_t),          intent(in)    :: inputs
    type(cubedag_link_t),          intent(in)    :: outputs
    integer(kind=list_k),          intent(out)   :: hid
    logical,                       intent(inout) :: error
    !
    type(cubedag_history_t) :: model
    class(list_object_t), pointer :: lot
    type(cubedag_history_t), pointer :: hobj
    !
    ! Add
    call hoptx%allocate(model,lot,error)
    if (error)  return
    hobj => cubedag_history_ptr(lot,error)
    if (error)  return
    !
    ! Fill the object
    hid = hoptx%n
    hobj%id = hid
    hobj%command = command
    hobj%line = line
    call inputs%copy(hobj%links%inputs,error)
    if (error)  return
    call outputs%copy(hobj%links%outputs,error)
    if (error)  return
  end subroutine cubedag_history_add_fromargs

  subroutine cubedag_history_list(hoptx,error)
    !-------------------------------------------------------------------
    ! List the history index
    !-------------------------------------------------------------------
    class(cubedag_history_list_t), intent(in)    :: hoptx
    logical,                       intent(inout) :: error
    !
    character(len=*), parameter :: rname='HISTORY>LIST'
    type(cubedag_history_t), pointer :: obj
    integer(kind=entr_k) :: ient
    character(len=10) :: tmpi,tmpo
    integer(kind=4) :: nd
    character(len=16) :: forma
    integer(kind=iden_l) :: maxid
    !
    if (hoptx%n.le.0) then
      call cubedag_message(seve%w,rname,'History index is empty')
      return
    endif
    !
    maxid = 0
    do ient=1,hoptx%n
      obj => cubedag_history_ptr(hoptx%list(ient)%p,error)
      if (error)  return
      maxid = max(maxid,obj%id)
    enddo
    nd = ceiling(log10(real(maxid+1,kind=8)))
    write(forma,'(A,I0,A)') '(I',nd,',4(2X,A))'
    !
    do ient=1,hoptx%n
      obj => cubedag_history_ptr(hoptx%list(ient)%p,error)
      if (error)  return
      call obj%links%inputs%repr('i=',tmpi)
      call obj%links%outputs%repr('o=',tmpo)
      write(*,forma)  obj%id,obj%command,tmpi,tmpo,trim(obj%line)
    enddo
  end subroutine cubedag_history_list
  !
  subroutine cubedag_history_list_init(hoptx,path,error)
    !-------------------------------------------------------------------
    ! Initialize a new repository
    !-------------------------------------------------------------------
    class(cubedag_history_list_t), intent(inout) :: hoptx
    character(len=*),              intent(in)    :: path
    logical,                       intent(inout) :: error
    !
    character(len=*), parameter :: rname='HISTORY>LIST>INIT'
    !
    ! Create and init new one on disk
    ! ZZZ Not yet implemented
    !
  end subroutine cubedag_history_list_init
  !
  subroutine cubedag_history_list_open(hoptx,name,read,error)
    use cubetools_system_tool
    !-------------------------------------------------------------------
    ! Open the repository file for reading or writing.
    !-------------------------------------------------------------------
    class(cubedag_history_list_t), intent(inout) :: hoptx
    character(len=*),              intent(in)    :: name
    logical,                       intent(in)    :: read
    logical,                       intent(inout) :: error
    !
    character(len=3) :: mode
    integer(kind=4) :: ier
    logical :: readonly
    character(len=*), parameter :: rname='HISTORY>LIST>OPEN'
    !
    if (read) then
      mode = 'OLD'
      readonly = .true.
    else
      call cubedag_message(seve%i,rname,'Creating history repository in file '//name)
      readonly = .false.
      mode = 'NEW'
      call cubetools_directory_create_for_file(name,error)
      if (error) return
    endif
    !
    ier = sic_getlun(hoptx%lun)
    if (mod(ier,2).eq.0) then
      error = .true.
      return
    endif
    ier = sic_open(hoptx%lun,name,mode,readonly)
    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_history_list_open
  !
  subroutine cubedag_history_list_close(hoptx,error)
    class(cubedag_history_list_t), intent(inout) :: hoptx
    logical,                       intent(inout) :: error
    !
    integer(kind=4) :: ier
    !
    ier = sic_close(hoptx%lun)
    call sic_frelun(hoptx%lun)
  end subroutine cubedag_history_list_close
  !
  subroutine cubedag_history_list_write(hoptx,reponame,error)
    class(cubedag_history_list_t), intent(inout) :: hoptx
    character(len=*),              intent(in)    :: reponame
    logical,                       intent(inout) :: error
    !
    integer(kind=entr_k) :: ient
    character(len=mess_l) :: mess
    type(cubedag_history_t), pointer :: hobj
    character(len=*), parameter :: rname='HISTORY>LIST>WRITE'
    !
    call hoptx%open(reponame,.false.,error)
    if (error)  return
    !
    do ient=1,hoptx%n
      hobj => cubedag_history_ptr(hoptx%list(ient)%p,error)
      if (error)  return
      call hobj%write(hoptx%lun,error)
      if (error) then
        write(mess,'(2(A,I0))')  'Error writing history entry #',ient,'/',hoptx%n
        call cubedag_message(seve%e,rname,mess)
        return
      endif
    enddo
    !
    call hoptx%close(error)
    if (error)  return
  end subroutine cubedag_history_list_write

  subroutine cubedag_history_list_read(hoptx,reponame,nshift,hshift,error)
    class(cubedag_history_list_t), intent(inout) :: hoptx
    character(len=*),              intent(in)    :: reponame
    integer(kind=iden_l),          intent(in)    :: nshift  ! Node ID shift
    integer(kind=iden_l),          intent(in)    :: hshift  ! History ID shift
    logical,                       intent(inout) :: error
    !
    character(len=mess_l) :: mess
    logical :: nomore
    integer(kind=entr_k) :: ient
    type(cubedag_history_t) :: model
    type(cubedag_history_t), pointer :: hobj
    class(list_object_t), pointer :: lot
    character(len=*), parameter :: rname='HISTORY>LIST>READ'
    !
    call hoptx%open(reponame,.true.,error)
    if (error)  return
    !
    nomore = .false.
    do
      ! Allocate a new object
      call hoptx%allocate(model,lot,error)
      if (error)  return
      hobj => cubedag_history_ptr(lot,error)
      if (error)  return
      call hobj%read(hoptx%lun,nshift,hshift,nomore,error)
      if (error)  return
      if (nomore) then
        ! The last allocated object was useless: remove
        call hoptx%pop(hoptx%n,error)
        if (error)  return
        exit
      endif
    enddo
    !
    ! Post-read: resolve all the links (from IDs to pointers) AFTER the
    ! whole DAG (IX) is reconstructed
    do ient=1,hoptx%n
      hobj => cubedag_history_ptr(hoptx%list(ient)%p,error)
      if (error)  return
      call hobj%links%resolve(ix,error)
      if (error)  return
    enddo
    !
    ! Feedback
    write(mess,'(A,I0,A)')  'Loaded an history index of ',hoptx%n,' commands'
    call cubedag_message(seve%i,rname,mess)
    !
    call hoptx%close(error)
    if (error)  return
  end subroutine cubedag_history_list_read

end module cubedag_history_types
