!== Stack in which arbitrary number of strings are stored
!
! Authors::   Eizi TOYODA
! Version::   $Id: dcstring_list.f90,v 1.2 2005/12/22 03:17:20 morikawa Exp $
! Tag Name::  $Name: gt4f90io-20060627 $
! Copyright:: Copyright (C) GFD Dennou Club, 2000-2005. All rights reserved.
! License::   See COPYRIGHT[link:../../COPYRIGHT]
!
!--
! vi: set ts=8 sw=4:
!++


module dcstring_list !:nodoc: 4,3
  !
  ! 任意個の文字列を収納するスタック
  !
  use dcstring_base
  implicit none
  private
  public:: STRING_LIST, init, clear, dispose, assignment(=)
  public:: push, pop, shift, unshift
  public:: len, extract, element, split

  type STRING_NODE
    type(VSTRING):: body
    type(STRING_NODE), pointer:: next
  end type STRING_NODE

  type STRING_LIST
    private
    type(STRING_NODE), pointer:: head
  end type STRING_LIST

  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 copy;  module procedure copy_vs;  end interface


  interface split 10
    module procedure CharSplit
    module procedure VstSplit
  end interface

contains


  subroutine init_vs(vs)
    type(STRING_LIST), intent(out):: vs
  continue
    nullify(vs%head)
  end subroutine init_vs


  subroutine copy_vs(lhs, rhs, items) 1
    type(STRING_LIST), intent(inout):: lhs
    type(STRING_LIST), intent(in):: rhs
    integer, intent(in), optional:: items
    type(STRING_NODE), pointer:: rhs_cursor
    type(STRING_NODE), pointer:: lhs_cursor
    integer:: c, ncopy
  continue
    ncopy = huge(ncopy)
    if (present(items)) ncopy = items
    rhs_cursor => rhs%head
    if (.not. associated(rhs_cursor)) then
      nullify(lhs%head)
      return
    endif
    allocate(lhs%head)
    lhs_cursor => lhs%head
    c = 0
    do
      c = c + 1
      lhs_cursor%body = rhs_cursor%body
      if (c == ncopy .or. .not. associated(rhs_cursor%next)) then
        nullify(lhs_cursor%next)
        return
      endif
      rhs_cursor => rhs_cursor%next
      allocate(lhs_cursor%next)
      lhs_cursor => lhs_cursor%next
    enddo
  end subroutine copy_vs


  subroutine clear_vs(vs)
    type(STRING_LIST), intent(inout):: vs
  continue
    nullify(vs%head)
  end subroutine clear_vs


  subroutine dispose_vs(vs)
    type(STRING_LIST), intent(inout):: vs
    type(STRING_NODE), pointer:: cursor
    type(STRING_NODE), pointer:: nextp
  continue
    cursor => vs%head
    do
      if (.not. associated(cursor)) exit
      nextp => cursor%next
      cursor%body = ""
      deallocate(cursor)
      cursor => nextp
    enddo
  end subroutine dispose_vs


  integer function len_vs(vs) result(result)
    type(STRING_LIST), intent(in):: vs
    type(STRING_NODE), pointer:: cursor
  continue
    result = 0
    cursor => vs%head
    do
      if (.not. associated(cursor)) exit
      result = result + 1
      cursor => cursor%next
    enddo
  end function len_vs


  type(VSTRING) function element_vs(vs, pos) result(result)
    type(STRING_LIST), intent(in):: vs
    type(STRING_NODE), pointer:: cursor
    integer, intent(in):: pos
    integer:: c
  continue
    c = 0
    cursor => vs%head
    do
      if (.not. associated(cursor)) exit
      c = c + 1
      if (c == pos) then
        result = cursor%body
        return
      endif
      cursor => cursor%next
    enddo
    result = ""
  end function element_vs


  function extract_vs(vs, start, finish) result(result),1
    ! deep copy を作る
    !
    type(STRING_LIST):: result
    type(STRING_LIST), intent(in):: vs
    integer, intent(in), optional:: start, finish
    type(STRING_LIST):: shallow_copy
    type(STRING_NODE), pointer:: cursor
    integer:: c, first, items
  continue
    first = 1
    if (present(start)) first = max(start, first)
    c = 0
    cursor = vs%head
    do
      if (.not. associated(cursor)) then
        nullify(result%head)
        return
      endif
      c = c + 1
      if (c == first) then
        shallow_copy%head => cursor
        exit
      endif
      cursor => cursor%next
    enddo
    items = HUGE(1)
    if (present(finish)) items = finish - first
    call copy_vs(result, shallow_copy, items)
  end function extract_vs


  subroutine push_vs(vs, string)
    type(STRING_LIST), intent(inout):: vs
    type(VSTRING), intent(in):: string
    type(STRING_NODE), pointer:: cursor
  continue
    if (.not. associated(vs%head)) then
      allocate(vs%head)
      vs%head%body = string
      nullify(vs%head%next)
      return
    endif
    cursor => vs%head
    do
      if (.not. associated(cursor%next)) exit
      cursor => cursor%next
    enddo
    allocate(cursor%next)
    cursor%next%body = string
    nullify(cursor%next%next)
  end subroutine push_vs


  subroutine push_vc(vs, string)
    type(STRING_LIST), intent(inout):: vs
    character(len = *), intent(in):: string
    type(STRING_NODE), pointer:: cursor
  continue
    cursor => vs%head
    if (.not. associated(cursor)) then
      allocate(vs%head)
      nullify(vs%head%next)
      vs%head%body = string
      return
    endif
    do
      if (.not. associated(cursor%next)) exit
      cursor => cursor%next
    enddo
    allocate(cursor%next)
    cursor => cursor%next
    cursor%body = string
    nullify(cursor%next)
  end subroutine push_vc


  type(VSTRING) function pop_vs(vs) result(result)
    type(STRING_LIST), intent(inout):: vs
    type(STRING_NODE), pointer:: cursor
  continue
    cursor => vs%head
    if (.not. associated(cursor)) then
      result = ""
    else if (.not. associated(cursor%next)) then
      result = cursor%body
      deallocate(cursor)
      nullify(vs%head)
    else
      do
        if (.not. associated(cursor%next%next)) exit
        cursor => cursor%next
      enddo
      result = cursor%next%body
      deallocate(cursor%next)
    endif
  end function pop_vs


  type(VSTRING) function shift_vs(vs) result(result)
    type(STRING_LIST), intent(inout):: vs
    type(STRING_NODE), pointer:: cursor
  continue
    if (associated(vs%head)) then
      result = vs%head%body
    else
      result = ""
      return
    endif
    cursor => vs%head%next
    deallocate(vs%head)
    vs%head => cursor
  end function shift_vs


  subroutine unshift_vs(vs, string)
    type(STRING_LIST), intent(inout):: vs
    type(VSTRING), intent(in):: string
    type(STRING_NODE), pointer:: cursor
  continue
    cursor => vs%head
    allocate(vs%head)
    vs%head%body = string
    vs%head%next => cursor
  end subroutine unshift_vs

  !
  ! --- Split ---
  !


  subroutine VstSplit(LIST, string, fs) 1
    !
    ! fs で文字列を分解して STRING_LIST に格納する。
    ! このとき分解された語の先頭の空白は無視される。
    !
    type(STRING_LIST), intent(out):: LIST
    type(VSTRING), intent(in):: string
    character(len = *), intent(in):: FS
    integer:: ifind
    type(VSTRING):: watch
  continue
    call init(LIST)
    watch = string
    do
      ! watch に空白文字があるなら除去
      ifind = vverify(watch, " ")
      if (ifind == 0) exit
      watch = extract(watch, ifind)
      ! FS に含まれる最初の文字の直前か、それがなければ文末を取り出す
      ifind = vscan(watch, FS)
      if (ifind == 0) then
        call push(LIST, watch)
        exit
      endif
      call push(LIST, extract(watch, 1, ifind - 1))
      watch = extract(watch, ifind + 1)
    enddo
  end subroutine VstSplit


  subroutine CharSplit(list, string, fs) 1
    !
    ! fs で文字列を分解して STRING_LIST に格納する。
    ! このとき分解された語の先頭の空白は無視される。
    !
    type(STRING_LIST), intent(out):: list
    character(len = *), intent(in):: string
    character(len = *), intent(in):: FS
    integer:: istart, iend, ifind
  continue
    call init(list)
    istart = 1
    do
      ! istart 以降に空白でない文字があるか?
      ifind = verify(string(istart: ), " ")
      if (ifind == 0) exit
      istart = istart + ifind - 1
      ! FS に含まれる最初の文字の直前か、それがなければ文末を取り出す
      ifind = scan(string(istart: ), FS)
      if (ifind == 0) then
        iend = len(string)
      else
        iend = istart + ifind - 1
      endif
      call push(list, string(istart:iend))
      ! もし文字が残っていれば継続
      istart = iend + 2
      if (istart > len(string)) exit
    enddo
  end subroutine CharSplit

end module