動機

Fortran の配列は優秀で使い勝手が良いと (個人的には) 思います。しかしながら、 Fortran の配列は長さが固定であり、データのサイズがわからない状況では不便です。 Fortran にも可変長なデータ構造があれば便利だと思い linked list を実装しました。 Java の LinkedList に備わっているメソッドを参考にしました。

linked list とは

linked list はデータの要素同士が参照によって連結しているリストのことです。リストに要素を追加する、もしくはリストの要素を削除するのが高速 $O(1)$ なのが特徴です。しかしながら、リストの要素の検索には、要素を辿る必要があるため時間がかかる $O(N)$ のが欠点です。 linked list には要素同士の参照の仕方によりいくつか種類がありますが、この記事では双方向リストを実装します。

環境

macOS Sierra (10.12.6)
GNU Fortran (GCC) 6.3.0

プログラム

実際に実装したのが以下のものです。

linked_list.f08

module mod_linked_list

  type t_node
    integer :: item
    type(t_node), pointer :: prev => null()
    type(t_node), pointer :: next => null()
  end type t_node

  type t_linked_list
    integer :: num = 0
    type(t_node), pointer :: head => null()
    type(t_node), pointer :: tail => null()
  end type t_linked_list

contains

  function new_node(item) result(node)
    implicit none
    integer, intent(in) :: item
    type(t_node), pointer :: node

    allocate(node)
    node%item = item
    return
  end function new_node

  subroutine add_first(list,item)
    implicit none
    type(t_linked_list), intent(inout) :: list
    integer, intent(in) :: item
    type(t_node), pointer :: node

    node => new_node(item)
    if (associated(list%tail)) then
      node%next => list%head
      list%head%prev => node
    else
      list%tail => node
    end if
    list%head => node
    list%num = list%num+1
    return
  end subroutine add_first

  subroutine add_last(list,item)
    implicit none
    type(t_linked_list), intent(inout) :: list
    integer, intent(in) :: item
    type(t_node), pointer :: node

    node => new_node(item)
    if (associated(list%head)) then
      node%prev => list%tail
      list%tail%next => node
    else
      list%head => node
    end if
    list%tail => node
    list%num = list%num+1
    return
  end subroutine add_last

  function poll_first(list) result(item)
    implicit none
    type(t_linked_list), intent(inout) :: list
    integer :: item
    type(t_node), pointer :: node

    item = list%head%item
    node => list%head%next
    deallocate(list%head)
    list%head => node
    if (associated(node)) then
      node%prev => null()
    else
      list%tail => null()
    end if
    list%num = list%num-1
    return
  end function poll_first

  function poll_last(list) result(item)
    implicit none
    type(t_linked_list), intent(inout) :: list
    integer :: item
    type(t_node), pointer :: node

    item = list%tail%item
    node => list%tail%prev
    deallocate(list%tail)
    list%tail => node
    if (associated(node)) then
      node%next => null()
    else
      list%head => null()
    end if
    list%num = list%num-1
    return
  end function poll_last

  function peek_first(list) result(item)
    implicit none
    type(t_linked_list), intent(inout) :: list
    integer :: item

    item = list%head%item
    return
  end function peek_first

  function peek_last(list) result(item)
    implicit none
    type(t_linked_list), intent(inout) :: list
    integer :: item

    item = list%tail%item
    return
  end function peek_last

  subroutine clear(list)
    implicit none
    type(t_linked_list), intent(inout) :: list
    type(t_node), pointer :: node, next

    if (.not.associated(list%head)) return
    node => list%head
    do while (associated(node%next))
      next => node%next
      deallocate(node)
      node => next
    end do
    list%head => null()
    list%tail => null()
    list%num = 0
    return
  end subroutine clear

  function get(list,i) result(item)
    implicit none
    type(t_linked_list), intent(inout) :: list
    integer, intent(in) :: i
    integer :: item, idx
    type(t_node), pointer :: node

    if (i <= (list%num+1)/2) then
      idx = 1
      node => list%head
      do while (idx < i)
        node => node%next
        idx = idx+1
      end do
    else
      idx = list%num
      node => list%tail
      do while (idx > i)
        node => node%prev
        idx = idx-1
      end do
    end if
    item = node%item
    return
  end function get

  function remove(list,i) result(item)
    implicit none
    type(t_linked_list), intent(inout) :: list
    integer, intent(in) :: i
    integer :: item, idx
    type(t_node), pointer :: node

    if (i == 1) then
      item = poll_first(list)
      return
    end if

    if (i == list%num) then
      item = poll_last(list)
      return
    end if

    if (i <= (list%num+1)/2) then
      idx = 1
      node => list%head
      do while (idx < i)
        node => node%next
        idx = idx+1
      end do
    else
      idx = list%num
      node => list%tail
      do while (idx > i)
        node => node%prev
        idx = idx-1
      end do
    end if

    item = node%item
    node%prev%next => node%next
    node%next%prev => node%prev
    deallocate(node)
    list%num = list%num-1
    return
  end function remove

  subroutine replace(list,i,item)
    implicit none
    type(t_linked_list), intent(inout) :: list
    integer, intent(in) :: i, item
    integer :: idx
    type(t_node), pointer :: node

    if (i <= (list%num+1)/2) then
      idx = 1
      node => list%head
      do while (idx < i)
        node => node%next
        idx = idx+1
      end do
    else
      idx = list%num
      node => list%tail
      do while (idx > i)
        node => node%prev
        idx = idx-1
      end do
    end if
    node%item = item
    return
  end subroutine replace

  subroutine show_all(list)
    implicit none
    type(t_linked_list), intent(inout) :: list
    type(t_node), pointer :: node, next

    if (.not.associated(list%head)) return
    node => list%head
    write(*,'(i0)',advance='no') node%item
    do while (associated(node%next))
      node => node%next
      write(*,'(x,i0)',advance='no') node%item
    end do
    write(*,*)
    return
  end subroutine show_all

  function first_index_of(list,item) result(idx)
    implicit none
    type(t_linked_list), intent(inout) :: list
    integer, intent(in) :: item
    integer :: idx
    type(t_node), pointer :: node

    idx = 1
    node => list%head
    do while (associated(node))
      if (node%item == item) return
      node => node%next
      idx = idx+1
    end do
    idx = -1
    return
  end function first_index_of

  function last_index_of(list,item) result(idx)
    implicit none
    type(t_linked_list), intent(inout) :: list
    integer, intent(in) :: item
    integer :: idx
    type(t_node), pointer :: node

    idx = list%num
    node => list%tail
    do while (associated(node))
      if (node%item == item) return
      node => node%prev
      idx = idx-1
    end do
    idx = -1
    return
  end function last_index_of

end module mod_linked_list

また、実装できているか確認するために以下のプログラムも書きました。

test_linked_list.f08

program test_linked_list
  use mod_linked_list
  implicit none
  type(t_linked_list) :: list
  integer :: i, n = 3

  do i = 1, n
    call add_first(list,i)
    write(*,'("add_first: ",i0," size: ",i0)') i, list%num
  end do

  do i = 1, n
    call add_last(list,i)
    write(*,'("add_last: ",i0," size: ",i0)') i, list%num
  end do

  call show_all(list)

  write(*,'("first_index_of 2: ",i0," size: ",i0)') first_index_of(list,2), list%num

  write(*,'("last_index_of 2: ",i0," size: ",i0)') last_index_of(list,2), list%num

  do while (list%num > n)
    write(*,'("poll_first: ",i0," size: ",i0)') poll_first(list), list%num
  end do

  do while (list%num > 0)
    write(*,'("poll_last: ",i0," size: ",i0)') poll_last(list), list%num
  end do

  do i = 1, 2*n
    call add_first(list,i)
    write(*,'("add_first: ",i0," size: ",i0)') i, list%num
  end do

  call show_all(list)

  write(*,'("remove at 3: ",i0," size: ",i0)') remove(list,3), list%num

  call show_all(list)

  call replace(list,3,9)
  write(*,'("replace at 3, size: ",i0)') list%num

  call show_all(list)

  write(*,'("get at 3: ",i0," size: ",i0)') get(list,3), list%num

  call show_all(list)

  call clear(list)
  write(*,'("clear, size: ",i0)') list%num

  call show_all(list)

  call add_last(list,10)
  write(*,'("add_last: ",i0," size: ",i0)') 10, list%num

  call show_all(list)

  stop
end program test_linked_list

実行結果は以下のとおりです。

add_first: 1 size: 1
add_first: 2 size: 2
add_first: 3 size: 3
add_last: 1 size: 4
add_last: 2 size: 5
add_last: 3 size: 6
3 2 1 1 2 3
first_index_of 2: 2 size: 6
last_index_of 2: 5 size: 6
poll_first: 3 size: 5
poll_first: 2 size: 4
poll_first: 1 size: 3
poll_last: 3 size: 2
poll_last: 2 size: 1
poll_last: 1 size: 0
add_first: 1 size: 1
add_first: 2 size: 2
add_first: 3 size: 3
add_first: 4 size: 4
add_first: 5 size: 5
add_first: 6 size: 6
6 5 4 3 2 1
remove at 3: 4 size: 5
6 5 3 2 1
replace at 3, size: 5
6 5 9 2 1
get at 3: 9 size: 5
6 5 9 2 1
clear, size: 0
add_last: 10 size: 1
10

これで Fortran でもリストが使えるようになりました。

追記 2019/08/11

不必要な部分を削り、よりオブジェクト指向な書き方に変更しました (ソースコード) 。