!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
module cubedag_flag
  use cubetools_parameters
  use cubetools_list
  use cubedag_messaging
  !---------------------------------------------------------------------
  ! Support module for flags and list of flags
  !---------------------------------------------------------------------
  !
  private :: kinds,flagsep_strg
  private :: cubedag_flag_eq,cubedag_flag_ne
  private :: flag_list,flag_list_sort
  private :: flag_list_sort_gt,flag_list_sort_ge
  private :: flag_name_gt,flag_name_lt,flag_name_ge,isnumeric
  public
  !
  ! Kinds
  integer(kind=code_k), parameter :: nkinds = 3
  character(len=*), parameter :: kinds(nkinds) = ['any    ','action ','product']
  integer(kind=code_k), parameter :: code_kind_any     = 1
  integer(kind=code_k), parameter :: code_kind_action  = 2
  integer(kind=code_k), parameter :: code_kind_product = 3
  !
  integer(kind=4), parameter :: dag_flagl=11
  character(len=1), parameter :: flagsep_strg=','
  !
  type, extends(tools_object_t) :: flag_t
     character(len=dag_flagl), private :: name
     character(len=dag_flagl), private :: key
     integer(kind=code_k), private     :: kind
     integer(kind=list_k), private     :: id
   contains
     procedure, public :: register   => cubedag_flag_register
     procedure, public :: list       => cubedag_flag_list
     procedure, public :: get_id     => cubedag_flag_get_id
     procedure, public :: get_name   => cubedag_flag_get_name
     procedure, public :: get_key    => cubedag_flag_get_key
     procedure, public :: get_kind   => cubedag_flag_get_kind
     procedure, public :: get_suffix => cubedag_flag_get_suffix
  end type flag_t
  !
  interface operator(.eq.)  ! Offers syntax e.g. "myflag.eq.flag_any" to programmers
    module procedure cubedag_flag_eq
  end interface
  !
  interface operator(.ne.)  ! Offers syntax e.g. "myflag.ne.flag_any" to programmers
    module procedure cubedag_flag_ne
  end interface
  !
  interface cubedag_flaglist_tostr
    module procedure cubedag_flaglist_tostr_from_array
    module procedure cubedag_flaglist_tostr_from_list
  end interface cubedag_flaglist_tostr
  !
  ! Some technical flags
  type(flag_t), target :: flag_unknown
  type(flag_t), target :: flag_any
  !
  ! The global list of flags
  type(tools_list_t) :: flag_list
  integer(kind=list_k), allocatable :: flag_list_sort(:)
  !
contains
  !
  !---------------------------------------------------------------------
  ! Support for scalar flags
  !---------------------------------------------------------------------
  !
  subroutine cubedag_flag_init(error)
    !-------------------------------------------------------------------
    ! Register the technical flags
    !-------------------------------------------------------------------
    logical, intent(inout) :: error
    !
    call flag_unknown%register('unknown',code_kind_any,error)
    call flag_any%register    ('*',      code_kind_any,error)
    if (error) return
    !
    ! Compute the sorting array
    call cubedag_flaglist_sort(error)
    if (error)  return
  end subroutine cubedag_flag_init
  !
  subroutine cubedag_flag_list(flag,error)
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(flag_t), target, intent(inout) :: flag
    logical,               intent(inout) :: error
    !
    character(mess_l) :: mess
    !
    write(mess,'(3x,a,i4,x,3(2a,x))') 'Id=',flag%id,'name=',flag%name,'key=',flag%key,'kind=',kinds(flag%kind)
    call cubedag_message(seve%r,'FLAG>LIST',mess)
  end subroutine cubedag_flag_list
  !
  function cubedag_flag_get_id(flag) result(id)
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(flag_t), intent(in) :: flag
    integer(kind=list_k)      :: id
    !
    id = flag%id
  end function cubedag_flag_get_id
  !
  function cubedag_flag_get_name(flag) result(name)
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(flag_t), intent(in) :: flag
    character(len=dag_flagl)  :: name
    !
    name = flag%name
  end function cubedag_flag_get_name
  !
  function cubedag_flag_get_key(flag) result(key)
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(flag_t), intent(in) :: flag
    character(len=dag_flagl)  :: key
    !
    key = flag%key
  end function cubedag_flag_get_key
  !
  function cubedag_flag_get_kind(flag) result(kind)
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(flag_t), intent(in) :: flag
    integer(kind=code_k)      :: kind
    !
    kind = flag%kind
  end function cubedag_flag_get_kind
  !
  function cubedag_flag_get_suffix(flag) result(suffix)
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    class(flag_t), intent(in)  :: flag
    character(len=dag_flagl+1) :: suffix
    !
    suffix = '-'//flag%name
  end function cubedag_flag_get_suffix
  !
  function cubedag_flag_eq(flag1,flag2)
    logical :: cubedag_flag_eq
    type(flag_t), intent(in) :: flag1,flag2
    cubedag_flag_eq = flag1%id.eq.flag2%id
  end function cubedag_flag_eq
  !
  function cubedag_flag_ne(flag1,flag2)
    logical :: cubedag_flag_ne
    type(flag_t), intent(in) :: flag1,flag2
    cubedag_flag_ne = flag1%id.ne.flag2%id
  end function cubedag_flag_ne
  !
  function cubedag_flag_ptr(tot,error)
    !-------------------------------------------------------------------
    ! Check if the input class is of type(flag_t), and return a
    ! pointer to it if relevant.
    !-------------------------------------------------------------------
    type(flag_t), pointer :: cubedag_flag_ptr
    class(tools_object_t), pointer       :: tot
    logical,               intent(inout) :: error
    !
    character(len=*), parameter :: rname='FLAG>PTR'
    !
    select type(tot)
    type is (flag_t)
      cubedag_flag_ptr => tot
    class default
      cubedag_flag_ptr => null()
      call cubedag_message(seve%e,rname,  &
        'Internal error: object is not a flag_t type')
      error = .true.
      return
    end select
  end function cubedag_flag_ptr
  !
  subroutine cubedag_flag_name2flag(name,found,flag)
    use gkernel_interfaces
    !-------------------------------------------------------------------
    ! Resolve the flag given its name. Raising an error or not is the
    ! responsibility of the caller.
    !-------------------------------------------------------------------
    character(len=*), intent(in)  :: name
    logical,          intent(out) :: found
    type(flag_t),     intent(out) :: flag
    ! Local
    integer(kind=list_k) :: iflag
    type(flag_t), pointer :: lflag
    logical :: error
    !
    found = .false.
    flag = flag_unknown
    error = .false.
    !
    call gi0_dicho_with_user_ltgt(flag_list%n,.true.,iflag,  &
      flag_list_lt,flag_list_gt,error)
    if (error)  return
    ! In return jflag is the flag lower or equal to the request
    ! in the sorted array (flag_list_sort)
    !
    lflag => cubedag_flag_ptr(flag_list%list(flag_list_sort(iflag))%p,error)
    if (error)  return
    if (lflag%name.eq.name) then
      found = .true.
      flag = lflag
    endif
    !
  contains
    function flag_list_lt(m)
      logical :: flag_list_lt
      integer(kind=list_k), intent(in) :: m
      ! 'name', 'flag', and 'error' shared with main routine
      lflag => cubedag_flag_ptr(flag_list%list(flag_list_sort(m))%p,error)
      if (error)  return
      flag_list_lt = flag_name_lt(lflag%name,name)
    end function flag_list_lt
    function flag_list_gt(m)
      logical :: flag_list_gt
      integer(kind=list_k), intent(in) :: m
      ! 'name', 'flag', and 'error' shared with main routine
      lflag => cubedag_flag_ptr(flag_list%list(flag_list_sort(m))%p,error)
      if (error)  return
      flag_list_gt = flag_name_gt(lflag%name,name)
    end function flag_list_gt
  end subroutine cubedag_flag_name2flag
  !
  function flag_name_gt(name1,name2)
    !-------------------------------------------------------------------
    ! Compare 2 flag names, i.e. if name1 > name2
    ! Typically used for lexicographical sorting
    !-------------------------------------------------------------------
    logical :: flag_name_gt
    character(len=*), intent(in) :: name1
    character(len=*), intent(in) :: name2
    ! Local
    integer(kind=4) :: len1,len2
    !
    if (isnumeric(name1(1:1)) .and. isnumeric(name2(1:1))) then
      ! Compare numerics as character strings, ensuring "2" < "10".
      ! NB: this won't work if mixing numerics and letters e.g. "123ABC",
      ! but what do we want in this case?
      len1 = len_trim(name1)
      len2 = len_trim(name2)
      if (len1.gt.len2) then
        flag_name_gt = .true.
      elseif (len1.lt.len2) then
        flag_name_gt = .false.
      else
        flag_name_gt = lgt(name1,name2)
      endif
    else
      flag_name_gt = lgt(name1,name2)
    endif
  end function flag_name_gt
  !
  function flag_name_lt(name1,name2)
    !-------------------------------------------------------------------
    ! Compare 2 flag names, i.e. if name1 < name2
    ! Typically used for lexicographical sorting
    !-------------------------------------------------------------------
    logical :: flag_name_lt
    character(len=*), intent(in) :: name1
    character(len=*), intent(in) :: name2
    ! Local
    integer(kind=4) :: len1,len2
    !
    if (isnumeric(name1(1:1)) .and. isnumeric(name2(1:1))) then
      ! Compare numerics as character strings, ensuring "2" < "10".
      ! NB: this won't work if mixing numerics and letters e.g. "123ABC",
      ! but what do we want in this case?
      len1 = len_trim(name1)
      len2 = len_trim(name2)
      if (len1.gt.len2) then
        flag_name_lt = .false.
      elseif (len1.lt.len2) then
        flag_name_lt = .true.
      else
        flag_name_lt = llt(name1,name2)
      endif
    else
      flag_name_lt = llt(name1,name2)
    endif
  end function flag_name_lt
  !
  function flag_name_ge(name1,name2)
    !-------------------------------------------------------------------
    ! Compare 2 flag names, i.e. if name1 >= name2
    ! Typically used for lexicographical sorting
    !-------------------------------------------------------------------
    logical :: flag_name_ge
    character(len=*), intent(in) :: name1
    character(len=*), intent(in) :: name2
    !
    flag_name_ge = .not.flag_name_lt(name1,name2)
  end function flag_name_ge
  !
  function isnumeric(c1)
    !-------------------------------------------------------------------
    ! Return .true. if the given character is an ASCII character in the
    ! range [0-9]
    !-------------------------------------------------------------------
    logical :: isnumeric
    character(len=1), intent(in) :: c1
    ! Local
    integer(kind=4) :: ichara
    !
    ichara = ichar(c1)-ichar('0')
    isnumeric = ichara.ge.0 .and. ichara.le.9
  end function isnumeric
  !
  !---------------------------------------------------------------------
  ! Support for list of flags
  !---------------------------------------------------------------------
  !
  subroutine cubedag_flag_register(flag,name,kind,error)
    use gkernel_interfaces
    !----------------------------------------------------------------------
    ! Register a flag in the flag list
    !----------------------------------------------------------------------
    class(flag_t), target, intent(inout) :: flag
    character(len=*),      intent(in)    :: name
    integer(kind=code_k),  intent(in)    :: kind
    logical,               intent(inout) :: error
    !
    flag%name = name
    flag%key  = name
    call sic_upper(flag%key)
    flag%kind = kind
    !
    flag%id = flag_list%n+1
    call cubetools_list_reallocate(flag_list,flag%id,error)
    if (error)  return
    call cubetools_list_setelem(flag_list%list(flag%id),flag,  &
      code_pointer_associated,error)
    if (error)  return
    flag_list%n = flag%id
  end subroutine cubedag_flag_register
  !
  subroutine cubedag_flaglist_create(flags,list,error)
    use gkernel_interfaces
    !-------------------------------------------------------------------
    ! Create a tools_list_t of flag_t from an array of flag_t
    ! This creates copies of the flags. The list MUST be cleaned with
    ! cubetools_list_final.
    !-------------------------------------------------------------------
    type(flag_t), target, intent(in)    :: flags(:)
    type(tools_list_t),   intent(inout) :: list
    logical,              intent(inout) :: error
    !
    character(len=*), parameter :: rname='FLAGLIST>CREATE'
    integer(kind=list_k) :: iflag,nflag
    type(flag_t), pointer :: flag
    integer(kind=4) :: ier
    !
    nflag = size(flags)
    call cubetools_list_reallocate(list,nflag,error)
    if (error)  return
    !
    do iflag=1,nflag
#if defined(IFORT)
      if (list%list(iflag)%code_pointer.eq.code_pointer_allocated)  &
        deallocate(list%list(iflag)%p)
      allocate(flag_t::list%list(iflag)%p,stat=ier)
      if (failed_allocate(rname,'flag',ier,error)) return
      list%list(iflag)%code_pointer = code_pointer_allocated
      flag => cubedag_flag_ptr(list%list(iflag)%p,error)
      if (error)  return
      flag = flags(iflag)
#else
      allocate(flag,stat=ier)
      if (failed_allocate(rname,'flag',ier,error)) return
      flag = flags(iflag)
      call cubetools_list_setelem(list%list(iflag),flag,  &
        code_pointer_allocated,error)
      if (error)  return
#endif
    enddo
    list%n = nflag
    !
  end subroutine cubedag_flaglist_create
  !
  subroutine cubedag_flaglist_tostr_from_array(flags,nflag,strflag,lstrflag,error)
    !-------------------------------------------------------------------
    ! Concatenate the flags list into a string.
    ! ---
    ! This version with a flat 'flag_t' array as argument
    !-------------------------------------------------------------------
    type(flag_t),               intent(in)    :: flags(:)
    integer(kind=4),            intent(in)    :: nflag
    character(len=*), optional, intent(out)   :: strflag
    integer(kind=4),  optional, intent(out)   :: lstrflag
    logical,                    intent(inout) :: error
    ! Local
    type(tools_list_t) :: tmp
    !
    call cubedag_flaglist_create(flags(1:nflag),tmp,error)
    if (error)  return
    call cubedag_flaglist_tostr_from_list(tmp,strflag=strflag,lstrflag=lstrflag,error=error)
    if (error)  return
    call cubetools_list_final(tmp,error)
    if (error)  return
  end subroutine cubedag_flaglist_tostr_from_array
  !
  subroutine cubedag_flaglist_tostr_from_list(list,strflag,lstrflag,error)
    !-------------------------------------------------------------------
    ! Concatenate the flags list into a string. This subroutine can be
    ! used to:
    !   1) concatenate the flags into an output list
    ! AND/OR
    !   2) return the length of the concatenatation
    ! ---
    ! This version with a tools_list_t as argument
    !-------------------------------------------------------------------
    type(tools_list_t),         intent(in)    :: list
    character(len=*), optional, intent(out)   :: strflag
    integer(kind=4),  optional, intent(out)   :: lstrflag
    logical,          optional, intent(inout) :: error
    ! Local
    integer(kind=4) :: iflag,nc,mc
    type(flag_t), pointer :: flag
    !
    if (list%n.le.0) then
      if (present(strflag))   strflag = ''
      if (present(lstrflag))  lstrflag = 0
      return
    endif
    !
    nc = 0
    if (present(strflag)) then
      mc = len(strflag)
    else
      mc = huge(mc)
    endif
    do iflag=1,list%n
      if (nc.gt.0) then
        nc = nc+1
        if (present(strflag)) strflag(nc:nc) = flagsep_strg
      endif
      flag => cubedag_flag_ptr(list%list(iflag)%p,error)
      if (error)  return
      ! ZZZ There used to be a specific support for flag_any
      if (present(strflag)) strflag(nc+1:mc) = flag%name
      nc = nc+len_trim(flag%name)
      if (nc.gt.mc) then
        if (present(strflag)) strflag(mc-1:mc) = '..'
        nc = mc
        exit
      endif
    enddo
    !
    if (present(lstrflag))  lstrflag = nc
    !
  end subroutine cubedag_flaglist_tostr_from_list
  !
  subroutine cubedag_string_toflaglist(string,flags,error)
    use gkernel_interfaces
    !----------------------------------------------------------------------
    ! Parse a string into a list of flags
    !----------------------------------------------------------------------
    character(len=*),          intent(in)    :: string
    type(flag_t), allocatable, intent(out)   :: flags(:)
    logical,                   intent(inout) :: error
    !
    integer(kind=list_k) :: nflag,iflag
    integer(kind=4) :: ichar,seppos(20),ierr
    character(len=argu_l) :: oneflag
    character(len=mess_l) :: mess
    logical :: found
    character(len=*), parameter :: rname='CUBEID>STRING2FLAGS'
    !
    ! call cubedag_message(dagseve%trace,rname,'Welcome')
    !
    if (len_trim(string).eq.0) then ! No flags given return
      return
    else
      nflag = 0
      seppos(:) = -1
      seppos(1) = 0
      do ichar=1,len_trim(string)
        if (string(ichar:ichar).eq.flagsep_strg) then
          nflag = nflag+1
          seppos(nflag+1) = ichar
        endif
      end do
      nflag = nflag+1
      seppos(nflag+1) = len_trim(string)+1
      !
      ierr = 0
      mess = ''
      allocate(flags(nflag),stat=ierr)
      if (failed_allocate(rname,'flags',ierr,error)) return
      do iflag=1,nflag
        oneflag = string(seppos(iflag)+1:seppos(iflag+1)-1)
        call cubedag_flag_name2flag(oneflag,found,flags(iflag))
        if (.not.found) then
          ierr = ierr +1
          if (ierr.ne.1) mess = trim(mess)//', '
          mess = trim(mess)//trim(oneflag)
          error = .true.
        endif
      end do
      if (error) then
        call cubedag_message(seve%e,rname,'Unrecognized flags: '//mess)
        return
      endif
    endif
  end subroutine cubedag_string_toflaglist
  !
  subroutine cubedag_flag_debug(error)
    !-------------------------------------------------------------------
    ! Display the full list of flags registered
    !-------------------------------------------------------------------
    logical, intent(inout) :: error
    ! Local
    integer(kind=list_k) :: iflag
    type(flag_t), pointer :: flag
    !
    do iflag=1,flag_list%n
      flag => cubedag_flag_ptr(flag_list%list(iflag)%p,error)
      if (error) return
      call flag%list(error)
      if (error) return
    enddo
  end subroutine cubedag_flag_debug
  !
  subroutine cubedag_flaglist_sort(error)
    use gkernel_interfaces
    !-------------------------------------------------------------------
    ! Compute the sorting array of the flag list (by alphabetical order
    ! of names)
    !-------------------------------------------------------------------
    logical, intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='FLAGLIST>SORT'
    integer(kind=list_k) :: iflag
    integer(kind=4) :: ier
    !
    if (allocated(flag_list_sort))  deallocate(flag_list_sort)
    allocate(flag_list_sort(flag_list%n),stat=ier)
    if (failed_allocate(rname,'flag_list_sort',ier,error)) return
    do iflag=1,flag_list%n
      flag_list_sort(iflag) = iflag
    enddo
    !
    call gi0_quicksort_index_with_user_gtge(flag_list_sort,flag_list%n,  &
      flag_list_sort_gt,flag_list_sort_ge,error)
    if (error)  return
  end subroutine cubedag_flaglist_sort
  !
  function flag_list_sort_gt(m,l)
    logical :: flag_list_sort_gt
    integer(kind=list_k), intent(in) :: m,l
    ! Local
    logical :: error
    type(flag_t), pointer :: flagm,flagl
    !
    error = .false.
    flagm => cubedag_flag_ptr(flag_list%list(m)%p,error)
    if (error)  return
    flagl => cubedag_flag_ptr(flag_list%list(l)%p,error)
    if (error)  return
    flag_list_sort_gt = flag_name_gt(flagm%name,flagl%name)
  end function flag_list_sort_gt
  !
  function flag_list_sort_ge(m,l)
    logical :: flag_list_sort_ge
    integer(kind=list_k), intent(in) :: m,l
    ! Local
    logical :: error
    type(flag_t), pointer :: flagm,flagl
    !
    error = .false.
    flagm => cubedag_flag_ptr(flag_list%list(m)%p,error)
    if (error)  return
    flagl => cubedag_flag_ptr(flag_list%list(l)%p,error)
    if (error)  return
    flag_list_sort_ge = flag_name_ge(flagm%name,flagl%name)
  end function flag_list_sort_ge
  !
  subroutine cubedag_flaglist_list_all(error)
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    logical, intent(inout) :: error
    !
    integer(kind=list_k) :: iflag
    integer(kind=4) :: nlp,nla
    type(flag_t), pointer :: pflag
    character(len=2048) :: products,actions
    !
    character(len=*), parameter :: rname = 'FLAGLIST>LIST>ALL'
    !
    ! call cubedag_message(dagseve%trace,rname,'Welcome')
    !
    products = ''
    actions  = ''
    nlp = 0
    nla = 0
    do iflag=1,flag_list%n
       pflag => cubedag_flag_ptr(flag_list%list(flag_list_sort(iflag))%p,error)
       if (error) return
       select case(pflag%kind)
       case(code_kind_product)
          call format_line_break(pflag%key,products,nlp)
       case(code_kind_action)
          call format_line_break(pflag%key,actions,nla)
       case default
          ! Do nothing
       end select
    enddo
    call cubedag_message(seve%r,rname,'Product flags:')
    call cubedag_message(seve%r,rname,products(1:len_trim(products)-1))
    call cubedag_message(seve%r,rname,blankstr)
    call cubedag_message(seve%r,rname,'Action flags:')    
    call cubedag_message(seve%r,rname,actions(1:len_trim(actions)-1))
  contains
    subroutine format_line_break(key,line,nl)
      use cubetools_help
      !----------------------------------------------------------------------
      !
      !----------------------------------------------------------------------
      character(len=*), intent(in)    :: key
      character(len=*), intent(inout) :: line
      integer(kind=4),  intent(inout) :: nl
      !
      integer(kind=4) :: nc
      character(len=*), parameter :: sep = ','
      !
      nc = len_trim(key)
      if (nl+nc+2.gt.help_width()) then
         write(line,'(2a)') trim(line),strg_cr
         nl = 0
      endif
      write(line,'(a,x,2a)') trim(line),trim(key),sep
      nl = nl+nc+2
    end subroutine format_line_break
  end subroutine cubedag_flaglist_list_all
  !
end module cubedag_flag
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
