! dc_string.f90 - character/string type support routines
! Copyright (C) by GFD Dennou Club, 2000.  All rights reserved.
! vi: set sw=4 ts=8:

module dc_string

    use dcstring_base
    use dcstring_list
    use dc_types, only: token, string
    implicit none

    ! === 文字から数値への変換 ===
    !
    ! INT, DBLE などの組み込み関数と同名にすべきか?

    public:: stoi
    interface stoi
        module procedure atoi_scalar
        module procedure stoi_scalar
    end interface

    public:: stod
    interface stod
        module procedure atod_scalar
        module procedure stod_scalar
    end interface

    public:: get_array
    interface get_array
        module procedure str2ip, strv2ip
        module procedure str2rp, strv2rp
        module procedure str2dp, strv2dp
    end interface

    public:: str_to_logical
    interface str_to_logical
        module procedure str2bool
    end interface

    ! === 数値から文字への変換 ===
    !
    ! VAR_STR と同名にすべきかもしれない

    public:: toChar
    interface toChar
        module procedure itoa_scalar
        module procedure itoa_array
        module procedure rtoa_scalar
        module procedure rtoa_array
        module procedure dtoa_scalar
        module procedure dtoa_array
    end interface

    ! === 文字配列の連結 ===

    public:: JoinChar

    ! === 文字列の解析 ===

    public:: index_ofs
    public:: replace

    ! === 大文字・小文字を無視した処理 ===

    public:: toUpper
    interface toUpper
       module procedure cupper
    end interface

    public:: toLower
    interface toLower
       module procedure clower
    end interface

    public:: UChar
    interface UChar
       module procedure UChar
    end interface

    public:: LChar
    interface LChar
       module procedure LChar
    end interface

    public:: strieq
    interface strieq
        module procedure strieq_sc
        module procedure strieq_cc
    end interface

    public:: strHead
    interface StrHead
!!$        module procedure StrHead_sc
        module procedure StrHead_cc
    end interface

    ! === 印字のための文字処理 ===

    public:: GTStringQuoteForDcl
    interface
        function GTStringQuoteForDcl(string) result(result)
            use dc_types, only: STRLEN => STRING
            character(*), intent(in):: string
            character(STRLEN):: result
        end function
    end interface

    public:: cprintf
    interface cprintf

        function &
        DCStringCPrintf(fmt, i, r, d, L, s, n, c1, c2, c3) result(result)
            use dc_types, only: string
            use dcstring_base, only: VSTRING
            character(len = string):: result
            character(*), intent(in):: fmt
            integer, intent(in), optional:: i(:), n(:)
            real, intent(in), optional:: r(:)
            double precision, intent(in), optional:: d(:)
            logical, intent(in), optional:: L(:)
            type(VSTRING), intent(in), optional:: s(:)
            character(*), intent(in), optional:: c1, c2, c3
        end function

    end interface

    public:: printf
    interface printf

        subroutine DCStringSPrintf(unit, fmt, i, r, d, L, s, n, c1, c2, c3)
            use dcstring_base, only: VSTRING
            character(*), intent(out):: unit
            character(*), intent(in):: fmt
            integer, intent(in), optional:: i(:), n(:)
            real, intent(in), optional:: r(:)
            double precision, intent(in), optional:: d(:)
            logical, intent(in), optional:: L(:)
            type(VSTRING), intent(in), optional:: s(:)
            character(*), intent(in), optional:: c1, c2, c3
        end subroutine

        subroutine DCStringPrintf(unit, fmt, i, r, d, L, s, n, c1, c2, c3)
            use dcstring_base, only: VSTRING
            type(VSTRING), intent(out):: unit
            character(*), intent(in):: fmt
            integer, intent(in), optional:: i(:), n(:)
            real, intent(in), optional:: r(:)
            double precision, intent(in), optional:: d(:)
            logical, intent(in), optional:: L(:)
            type(VSTRING), intent(in), optional:: s(:)
            character(*), intent(in), optional:: c1, c2, c3
        end subroutine

        subroutine DCStringFPrintf(unit, fmt, i, r, d, L, s, n, c1, c2, c3)
            use dcstring_base, only: VSTRING
            integer, intent(in), optional:: unit
            character(*), intent(in):: fmt
            integer, intent(in), optional:: i(:), n(:)
            real, intent(in), optional:: r(:)
            double precision, intent(in), optional:: d(:)
            logical, intent(in), optional:: L(:)
            type(VSTRING), intent(in), optional:: s(:)
            character(*), intent(in), optional:: c1, c2, c3
        end subroutine

    end interface

contains

    ! === 正規表現があれば.... ===

!!$    logical function StrHead_SC(whole, head) result(result)
!!$        type(VSTRING)     , intent(in) :: whole
!!$        character(len = *), intent(in) :: head
!!$    continue
!!$        result = (extract(whole, 1, len(head)) == head)
!!$    end function

    logical function StrHead_CC(whole, head) result(result)
        character(len = *), intent(in):: whole
        character(len = *), intent(in):: head
    continue
        result = (len(whole) >= len(head))
        if (.not. result) return
        result = (whole(1:len(head)) == head)
    end function

    ! === 大文字・小文字を無視した処理 (500文字まで) ===
    !
    ! コンパイラによっては character(len = len(string_a)):: abuf
    ! が通らないため, 文字数を string = 500 で制限

    logical function strieq_cc(string_a, string_b) result(result)
        character(len = *), intent(in):: string_a
        character(len = *), intent(in):: string_b
        character(len = string):: abuf
        character(len = string):: bbuf
!!$        character(len = len(string_a)):: abuf
!!$        character(len = len(string_b)):: bbuf
        abuf = string_a
        bbuf = string_b
        call toUpper(abuf)
        call toUpper(bbuf)
        result = (abuf == bbuf)
    end function


    logical function strieq_sc(string_a, string_b) result(result)
        type(VSTRING), intent(in):: string_a
        character(len = *), intent(in):: string_b
        result = strieq_cc(string_a%body(1:string_a%len), string_b)
    end function

    ! === 文字から数値への変換 ===

    logical function str2bool(string) result(result)
        character(len = *), intent(in):: string
    continue
        select case(string)
        case ("", "0", "0.0", "0.0D0", "0.0d0", ".false.", ".FALSE.", &
            & "f", "F", "false", "FALSE")
            result = .false.
        case default
            result = .true.
        end select
    end function

    integer function atoi_scalar(string, default) result(result)
        character(len = *), intent(in):: string
        integer, intent(in), optional:: default
        integer:: ios
    continue
        read(unit=string, fmt="(i80)", iostat=ios) result
        if (ios /= 0) then
            if (present(default)) then
                result = default
            else
                result = 0
            endif
        endif
    end function

    integer function stoi_scalar(string) result(result)
        type(VSTRING), intent(in):: string
        integer:: ios
        character(len = 80):: buffer
    continue
        buffer = string
        read(unit=buffer, fmt="(i80)", iostat=ios) result
        if (ios /= 0) result = 0
    end function

    double precision function atod_scalar(string) result(result)
        character(len = *), intent(in):: string
        integer:: ios
        character(len = 80):: buffer
        integer:: ipoint, iexp
        intrinsic scan
    continue
        buffer = string
        ! もし整定数をいれてしまった場合は小数点を附加
        if (index(buffer, '.') == 0) then
            iexp = scan(buffer, "eEdD")
            if (iexp /= 0) then
                buffer(iexp+1: len(buffer)) = buffer(iexp: len(buffer)-1)
                ipoint = iexp
            else
                ipoint = len_trim(buffer) + 1
            endif
            buffer(ipoint: ipoint) = '.'
        endif
        read(unit=buffer, fmt="(g80.10)", iostat=ios) result
        if (ios /= 0) result = 0.0
    end function

    double precision function stod_scalar(string) result(result)
        type(VSTRING), intent(in):: string
        character(len = 80):: buffer
    continue
        buffer = string
        result = atod_scalar(buffer)
    end function

    subroutine str2ip(int_ptr, string)
        integer, pointer:: int_ptr(:)
        character(len = *), intent(in):: string
        integer:: i, j, idx, nvalues
    continue
	nvalues = 1
        i = 1
	do
            idx = index(string(i: ), ',')
	    if (idx == 0) exit
	    i = i + idx - 1 + 1 
	    nvalues = nvalues + 1
	enddo
        allocate(int_ptr(nvalues))
	i = 1
	j = 1
        do
            idx = index(string(i: ), ',')
	    if (idx == 0) then
                int_ptr(j) = stoi(string(i: ))
		exit
	    endif
	    int_ptr(j) = stod(string(i: i+idx-2))
	    i = i + idx - 1 + 1 
	    j = j + 1
        enddo
    end subroutine

    subroutine strv2ip(int_ptr, string)
        use dcstring_list
        integer, pointer:: int_ptr(:)
        type(VSTRING), intent(in):: string
        type(STRING_LIST):: vslist
        integer:: nvalues, i
    continue
        call Split(vslist, string, ", ")
        nvalues = len(vslist)
        allocate(int_ptr(nvalues))
        do, i = 1, nvalues
            int_ptr(i) = stoi(shift(vslist))
        enddo
        call dispose(vslist)
    end subroutine

    subroutine str2rp(real_ptr, string)
        real, pointer:: real_ptr(:)
        character(len = *), intent(in):: string
        integer:: i, j, idx, nvalues
    continue
	nvalues = 1
        i = 1
	do
            idx = index(string(i: ), ',')
	    if (idx == 0) exit
	    i = i + idx - 1 + 1 
	    nvalues = nvalues + 1
	enddo
        allocate(real_ptr(nvalues))
	i = 1
	j = 1
        do
            idx = index(string(i: ), ',')
	    if (idx == 0) then
                real_ptr(j) = stod(string(i: ))
		exit
	    endif
	    real_ptr(j) = stod(string(i: i+idx-2))
	    i = i + idx - 1 + 1 
	    j = j + 1
        enddo
    end subroutine

    subroutine strv2rp(real_ptr, string)
        use dcstring_list
        real, pointer:: real_ptr(:)
        type(VSTRING), intent(in):: string
        type(STRING_LIST):: vslist
        integer:: i, nvalues
    continue
        call Split(vslist, string, ", ")
        nvalues = len(vslist)
        allocate(real_ptr(nvalues))
        do, i = 1, nvalues
            real_ptr(i) = stod(shift(vslist))
        enddo
        call dispose(vslist)
    end subroutine

    subroutine str2dp(real_ptr, string)
        double precision, pointer:: real_ptr(:)
        character(len = *), intent(in):: string
        integer:: i, j, idx, nvalues
    continue
	nvalues = 1
        i = 1
	do
            idx = index(string(i: ), ',')
	    if (idx == 0) exit
	    i = i + idx - 1 + 1 
	    nvalues = nvalues + 1
	enddo
        allocate(real_ptr(nvalues))
	i = 1
	j = 1
        do
            idx = index(string(i: ), ',')
	    if (idx == 0) then
                real_ptr(j) = stod(string(i: ))
		exit
	    endif
	    real_ptr(j) = stod(string(i: i+idx-2))
	    i = i + idx - 1 + 1 
	    j = j + 1
        enddo
    end subroutine

    subroutine strv2dp(dble_ptr, string)
        use dcstring_list
        double precision, pointer:: dble_ptr(:)
        type(VSTRING), intent(in):: string
        type(STRING_LIST):: vslist
        integer:: i, nvalues
    continue
        call Split(vslist, string, ", ")
        nvalues = len(vslist)
        allocate(dble_ptr(nvalues))
        do, i = 1, nvalues
            dble_ptr(i) = stod(shift(vslist))
        enddo
        call dispose(vslist)
    end subroutine

    !
    ! === 数値から文字への変換 ===
    !

    character(token) function itoa_scalar(i) result(result)
        integer, intent(in):: i
        character(len = 32):: buffer
    continue
        write(unit=buffer, fmt="(i20)") i
        result = adjustl(buffer)
    end function

    character(string) function itoa_array(ibuf) result(result)
        integer, intent(in):: ibuf(:)
        integer:: i
    continue
        if (size(ibuf) <= 0) then
            result = ""
            return
        endif
        result = toChar(ibuf(1))
        do, i = 2, size(ibuf)
            result = trim(result) // ", " // trim(toChar(ibuf(i)))
        enddo
    end function

    character(token) function rtoa_scalar(x) result(result)
        real, intent(in):: x
        character(len = 16):: buffer
    continue
        write(unit=buffer, fmt="(g16.8)") x
        result = adjustl(buffer)
    end function

    character(string) function rtoa_array(rbuf) result(result)
        real, intent(in):: rbuf(:)
        integer:: i
    continue
        if (size(rbuf) <= 0) then
            result = ""
            return
        endif
        result = toChar(rbuf(1))
        do, i = 2, size(rbuf)
            result = trim(result) // ", " // trim(toChar(rbuf(i)))
        enddo
    end function

    character(token) function dtoa_scalar(d) result(result)
        double precision, intent(in):: d
        character(len = 32):: buffer
    continue
        write(unit=buffer, fmt="(g32.24)") d
        result = adjustl(buffer)
    end function

    character(STRING) function dtoa_array(dbuf) result(result)
        double precision, intent(in):: dbuf(:)
        integer:: i
    continue
        if (size(dbuf) <= 0) then
            result = ""
            return
        endif
        result = toChar(dbuf(1))
        do, i = 2, size(dbuf)
            result = trim(result) // ", " // trim(toChar(dbuf(i)))
        enddo
    end function

    !
    ! === 文字配列の連結 ===
    !

    character(string) function JoinChar(carray, expr) result(result)
        character(*)     , intent(in)           :: carray(:)
        character(*)     , intent(in), optional :: expr

        character(2)     ,parameter :: default = ', '
        character(string)           :: delimiter
        integer                     :: dellen, i
    continue
        if ( present(expr) ) then
           delimiter = expr
           dellen = len(expr)
        else
           delimiter = default
           dellen = len(default)
        endif
        if (size(carray) <= 0) then
            result = ""
            return
        endif
        result = trim(carray(1))
        do, i = 2, size(carray)
            result = trim(result) // delimiter(1:dellen) // trim(carray(i))
        enddo
    end function

    ! === 文字列の解析 ===

    integer function index_ofs(string, start, substr) result(result)
        character(len = *), intent(in):: string
        integer, intent(in):: start
        character(len = *), intent(in):: substr
        intrinsic index
        if (start < 1) then
            result = 0
            return
        endif
        result = index(string(start: ), substr)
        if (result == 0) return
        result = start + result - 1
    end function

    function replace(string, from, to) result(result)
        use dc_types, only: strlen => string
    implicit none
        character(len = strlen):: result
        character(len = *), intent(in):: string, from, to
        integer:: i, isa, isb, iea, ieb
    continue
        result = string
        i = index(result, from)
        if (i == 0) return
        isa = i + len(from)
        isb = i + len(to)
        if (len(to) < len(from)) then
            iea = len(result)
            ieb = len(result) + len(to) - len(from)
        else
            iea = len(result) + len(from) - len(to)
            ieb = len(result)
        endif
        if (len(to) /= len(from)) result(isb:ieb) = result(isa:iea)
        result(i:i+len(to)-1) = to
    end function

    ! === 大文字・小文字を無視した処理 ===

    subroutine cupper(ch)
      character(len = *), intent(inout):: ch
      integer:: i, lch, idx
    continue
      lch = len(ch)
      do, i = 1, lch
         idx = ichar(ch(i:i))
         if (97 <= idx .and. idx <= 122) then
            ch(i:i)=char(idx - 32)
         end if
      end do
    end subroutine

    subroutine clower(ch)
      character(len = *), intent(inout):: ch
      integer:: i, lch, idx
    continue
      lch = len(ch)
      do, i = 1, lch
         idx = ichar(ch(i:i))
         if (65 <= idx .and. idx <= 90) then
            ch(i:i)=char(idx + 32)
         end if
      end do
    end subroutine

    character(string) function UChar(ch) result(result)
      character(len = *), intent(in):: ch
    continue
      result = ch
      call toUpper(result)
    end function UChar

    character(string) function LChar(ch) result(result)
      character(len = *), intent(in):: ch
    continue
      result = ch
      call toLower(result)
    end function LChar

end module