! 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
    implicit none

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

    public:: stoi, stod, get_array, toString

    interface stoi
        module procedure atoi_scalar
        module procedure stoi_scalar
    end interface

    interface stod
        module procedure atod_scalar
        module procedure stod_scalar
    end interface

    interface get_array
        module procedure str2ip
        module procedure str2rp
        module procedure str2dp
    end interface

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

    interface toString
        module procedure itos_scalar
        module procedure itos_array
        module procedure rtos_scalar
        module procedure rtos_array
        module procedure dtos_scalar
        module procedure dtos_array
    end interface

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

    public:: ToUpper, strieq, StrHead

    interface ToUpper
        ! that of DCL
        subroutine CUPPER(ch)
            character(len = *), intent(inout):: ch
        end subroutine
    end interface

    interface strieq
        module procedure strieq_sc
        module procedure strieq_cc
    end interface

    interface StrHead
        module procedure StrHead_sc
    end interface

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

    public:: GTStringQuoteForDcl
    interface
        type(VSTRING) function GTStringQuoteForDcl(string)
            use dcstring_base, only: VSTRING
            type(VSTRING), intent(in):: string
        end function
    end interface

    public:: sprintf
    interface sprintf
        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
    end interface

    public:: printf
    interface printf
        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(string_a, string_b) result(result)
        type(VSTRING), intent(in):: string_a
        character(len = *), intent(in):: string_b
        result = (extract(string_a, 1, len(string_b)) == string_b)
    end function

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

    logical function strieq_cc(string_a, string_b) result(result)
        character(len = *), intent(in):: string_a
        character(len = *), intent(in):: string_b
        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

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

    integer function atoi_scalar(string) result(result)
        character(len = *), intent(in):: string
        integer:: ios
    continue
        read(unit=string, fmt="(i80)", iostat=ios) result
        if (ios /= 0) result = 0
    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)
        use dcstring_list
        integer, pointer:: int_ptr(:)
        character(len = *), 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)
        use dcstring_list
        real, pointer:: real_ptr(:)
        character(len = *), 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(dble_ptr, string)
        use dcstring_list
        double precision, pointer:: dble_ptr(:)
        character(len = *), 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

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

    type(VSTRING) function itos_scalar(i) result(result)
        integer, intent(in):: i
        character(len = 30):: buffer
    continue
        write(unit=buffer, fmt="(i30)") i
        result = trim(adjustl(buffer))
    end function

    type(VSTRING) function itos_array(ibuf) result(result)
        integer, intent(in):: ibuf(:)
        integer:: i
    continue
        if (size(ibuf) <= 0) then
            result = ""
            return
        endif
        result = toString(ibuf(1))
        do, i = 2, size(ibuf)
            result = result // ", " // toString(ibuf(i))
        enddo
    end function

    type(VSTRING) function rtos_scalar(x) result(result)
        real, intent(in):: x
        character(len = 40):: buffer
    continue
        write(unit=buffer, fmt="(g40.30)") x
        result = trim(adjustl(buffer))
    end function

    type(VSTRING) function rtos_array(rbuf) result(result)
        real, intent(in):: rbuf(:)
        integer:: i
    continue
        if (size(rbuf) <= 0) then
            result = ""
            return
        endif
        result = toString(rbuf(1))
        do, i = 2, size(rbuf)
            result = result // ", " // toString(rbuf(i))
        enddo
    end function

    type(VSTRING) function dtos_scalar(d) result(result)
        double precision, intent(in):: d
        character(len = 40):: buffer
    continue
        write(unit=buffer, fmt="(g40.30)") d
        result = trim(adjustl(buffer))
    end function

    type(VSTRING) function dtos_array(dbuf) result(result)
        double precision, intent(in):: dbuf(:)
        integer:: i
    continue
        if (size(dbuf) <= 0) then
            result = ""
            return
        endif
        result = toString(dbuf(1))
        do, i = 2, size(dbuf)
            result = result // ", " // toString(dbuf(i))
        enddo
    end function

end module
