! varying_strings.f90 - 任意個の文字列を収納するスタック
! Copyright (C) TOYODA Eizi, 2000.  All rights reserved.
! vi: set sw=4:

module varying_strings

    use iso_varying_string
    implicit none
    private
    public:: STRINGS, init, clear, dispose, assignment(=)
    public:: push, pop, shift, unshift
    public:: len, extract, element

    type STRINGS
	private
	integer:: length
	type(VARYING_STRING), pointer:: body(:)
    end type

    interface init;  module procedure init_vs;  end interface
    interface clear;  module procedure clear_vs;  end interface
    interface dispose;  module procedure dispose_vs;  end interface
    interface len;  module procedure len_vs;  end interface
    interface push;  module procedure push_vs, push_vc;  end interface
    interface pop;  module procedure pop_vs;  end interface
    interface shift;  module procedure shift_vs;  end interface
    interface unshift;  module procedure unshift_vs;  end interface
    interface extract;  module procedure extract_vs;  end interface
    interface element;  module procedure element_vs;  end interface
    interface assignment(=);  module procedure copy_vs;  end interface

    integer, parameter:: ALLOC_INITIAL = 1
    integer, parameter:: ALLOC_BIG = 16

contains

    subroutine init_vs(vs)
	type(STRINGS), intent(out):: vs
	integer:: i
    continue
	vs%length = 0
	allocate(vs%body(ALLOC_INITIAL))
	do, i = 1, ALLOC_INITIAL
	    vs%body(i) = ""
	enddo
    end subroutine

    subroutine copy_vs(lhs, rhs)
	type(STRINGS), intent(inout):: lhs
	type(STRINGS), intent(in):: rhs
	integer:: i
    continue
	call clear_vs(lhs)
	allocate(lhs%body(size(rhs%body)))
    	do, i = 1, size(rhs%body)
	    lhs%body(i) = rhs%body(i)
	enddo
	lhs%length = rhs%length
    end subroutine

    subroutine clear_vs(vs)
	type(STRINGS), intent(inout):: vs
	integer:: i
    continue
    	do, i = 1, size(vs%body)
	    vs%body(i) = ""
	enddo
	vs%length = 0
	if (size(vs%body) > ALLOC_BIG) then
	    deallocate(vs%body)
	    call init_vs(vs)
	endif
    end subroutine

    subroutine dispose_vs(vs)
	type(STRINGS), intent(inout):: vs
	integer:: i
    continue
    	do, i = 1, size(vs%body)
	    vs%body(i) = ""
	enddo
	vs%length = 0
	deallocate(vs%body)
	nullify(vs%body)
    end subroutine

    integer function len_vs(vs) result(result)
	type(STRINGS), intent(in):: vs
    continue
	result = vs%length
    end function

    type(VARYING_STRING) function element_vs(vs, pos) result(result)
	type(STRINGS), intent(in):: vs
	integer, intent(in):: pos
    continue
	if (pos < 1 .or. pos > vs%length) then
	    result = ""
	    return
	endif
	result = vs%body(pos)
    end function

    function extract_vs(vs, start, finish) result(result)
	type(STRINGS):: result
	type(STRINGS), intent(in):: vs
	integer, intent(in), optional:: start, finish
	integer:: first, last
    continue
	first = 1
	last = vs%length
	if (present(start)) first = max(start, first)
	if (present(finish)) last = min(finish, last)
	result%length = last - first + 1
	allocate(result%body(result%length))
	result%body(:) = vs%body(first: last)
    end function

    subroutine push_vs(vs, string)
	type(STRINGS), intent(inout):: vs
	type(VARYING_STRING), intent(in):: string
    continue
	call internal_resize(vs, vs%length + 1)
	vs%body(vs%length) = string
    end subroutine

    subroutine push_vc(vs, string)
	type(STRINGS), intent(inout):: vs
	character(len = *), intent(in):: string
    continue
	call internal_resize(vs, vs%length + 1)
	vs%body(vs%length) = string
    end subroutine

    type(VARYING_STRING) function pop_vs(vs) result(result)
	type(STRINGS), intent(inout):: vs
    continue
	if (vs%length <= 0) then
	    result = ""
	    return
	endif
	result = vs%body(vs%length)
	call internal_resize(vs, vs%length - 1)
    end function

    type(VARYING_STRING) function shift_vs(vs) result(result)
	type(STRINGS), intent(inout):: vs
	integer:: i
    continue
	if (vs%length <= 0) then
	    result = ""
	    return
	endif
	result = vs%body(1)
	do, i = 1, vs%length - 1
	    vs%body(i) = vs%body(i + 1)
	enddo
	call internal_resize(vs, vs%length - 1)
    end function

    subroutine unshift_vs(vs, string)
	type(STRINGS), intent(inout):: vs
	type(VARYING_STRING), intent(in):: string
	integer:: i
    continue
	call internal_resize(vs, vs%length + 1)
	do, i = vs%length - 1, 1, -1
	    vs%body(i + 1) = vs%body(i)
	enddo
	vs%body(1) = string
    end subroutine

    subroutine internal_resize(vs, newlen)
	type(STRINGS), intent(inout):: vs
	integer, intent(in):: newlen
	type(VARYING_STRING), pointer:: oldbody(:)
	integer:: new_body_length, oldlen
    continue
	if (.not. associated(vs%body)) call init_vs(vs)
	if (newlen > size(vs%body)) then
	    new_body_length = max(newlen, size(vs%body) * 2)
	    goto 999
	else if (newlen < vs%length .and. size(vs%body) > ALLOC_BIG) then
	    new_body_length = size(vs%body) / 2
	    if (new_body_length > newlen + 1) goto 999
	endif
	vs%length = newlen
	return

	! resizer
    999 continue
	oldbody => vs%body(:)
	oldlen = size(oldbody(:))
	nullify(vs%body)
	allocate(vs%body(new_body_length))
	vs%body(1: oldlen) = oldbody(1: oldlen)
	deallocate(oldbody)
	vs%length = newlen
	return
    end subroutine

end module