[通用算法] 无限多态链表

module anylist_m
  implicit none
  private
  public :: anylist, anyitem, newitem

  type anylist !（任意类型）链表类
    class(anyitem), pointer, private :: firstptr => null() !头指针
  contains
    procedure, non_overridable :: append !尾部增加节点
    procedure, non_overridable :: count_list !节点个数
    procedure, non_overridable :: delete_list !删除所有节点
    procedure, non_overridable :: first !头节点
    procedure, non_overridable :: last !尾节点
    procedure, non_overridable :: prepend !将当前节点前置到链表头部
    procedure, non_overridable :: print_list !打印链表
  end type

  type anyitem !（任意类型）节点类  双向环形链表
    class(*), allocatable            :: value !无限多态类型
    class(anyitem), pointer, private :: nextptr => null(), prevptr => null() !后指针与前指针
    class(anylist), pointer, private :: upptr => null() !节点所在的链表指针
  contains
    procedure, non_overridable :: change !节点改值
    procedure, non_overridable :: delete !删除节点并释放其内存
    procedure, non_overridable :: list !返回节点所在的链表
    procedure, non_overridable :: next !后一个节点
    procedure, non_overridable :: prev !前一个节点
    procedure                  :: print !打印节点 允许子类重载该方法
    procedure, non_overridable :: remove !将该节点从链表中删除，但仍保留该节点和其值
  end type
contains
  function newitem(something) !节点创建函数
    class(*), intent(in)    :: something !无限多态类型
    class(anyitem), pointer :: newitem
    allocate (newitem)
    allocate (newitem%value, source=something) !节点分配内存并赋值
    newitem%prevptr => newitem !节点前置指针指向节点本身
  end function

  subroutine append(list, item) !尾部增加节点
    class(anylist), intent(inout), target :: list
    class(anyitem), target                :: item
    class(anyitem), pointer               :: last

    if (associated(item%upptr)) call remove(item) !如果节点属于某个链表  脱离从属关系
    item%upptr => list !节点属于新的链表
    if (associated(list%firstptr)) then !不是空链表
      last => list%firstptr%prevptr !last为链表尾节点
      last%nextptr => item !尾部插入新节点
      item%prevptr => last !新节点与原尾节点建立链接
      list%firstptr%prevptr => item !item为新的尾节点
    else !空链表 item为第一个节点
      list%firstptr => item
      item%prevptr => item !item%nextptr => null()
    end if
  end subroutine

  integer function count_list(list) !链表节点个数
    class(anylist), intent(in) :: list
    class(anyitem), pointer :: p !遍历指针
    count_list = 0 !累加器
    p => list%firstptr !指向头节点
    do
      if (.not.associated(p)) exit !指针为空退出循环
      count_list = count_list + 1
      p => p%nextptr !下一个节点
    end do
  end function

  subroutine delete_list(list) !删除链表所有节点
    class(anylist), intent(inout) :: list
    do
      if (.not.associated(list%firstptr)) exit !指针为空退出循环
      call delete(list%firstptr) !总是删除头节点
    end do
  end subroutine

  function first(list) !链表头节点
    class(anylist), intent(in) :: list
    class(anyitem), pointer :: first
    first => list%firstptr
  end function

  function last(list) !链表尾节点
    class(anylist), intent(in) :: list
    class(anyitem), pointer :: last
    last => list%firstptr
    if (associated(last)) last => last%prevptr !头节点的上一个位置即尾节点
  end function

  subroutine prepend(list, item) !将节点前置到链表头部
    class(anylist), intent(inout), target :: list
    class(anyitem), target                :: item
    if (associated(item%upptr)) call remove(item) !隔绝节点与原链表的联系
    item%upptr => list !节点属于新链表
    if (associated(list%firstptr)) then !不是空链表
      item%prevptr => list%firstptr%prevptr !将节点前置到链表头部
      item%nextptr => list%firstptr
      list%firstptr%prevptr => item
    else !空链表
      item%prevptr => item
    end if
    list%firstptr => item !链表的头指针指向前置节点
  end subroutine

  subroutine print_list(list, show_item_numbers, show_empty_list) !打印链表
    class(anylist), intent(in) :: list
    logical, intent(in), optional :: show_item_numbers, show_empty_list
    class(anyitem), pointer :: p !遍历指针
    integer :: i
    logical :: show_numbers !是否显示节点序号
    if (present(show_item_numbers)) then
      show_numbers = show_item_numbers
    else
      show_numbers = .true. !是否显示节点序号 默认为真
    end if
    p => list%firstptr !从头开始
    if (.not.associated(p)) then !空链表
      if (present(show_empty_list)) then
        if (show_empty_list) print *, 'List is empty.'
      else
        print *, 'List is empty.'!空链表默认显示
      end if
    else !不是空链表
      do i=1, huge(i)-1 !huge(i)为最大整数
        if (show_numbers) write (*, 1, advance='no') i !显示节点序号
1       format(1x, 'Item ', i0, ':')
        call p%print !打印节点
        p => p%nextptr !下一个节点
        if (.not.associated(p)) exit !空链表退出循环
      end do
    end if
  end subroutine

  subroutine change(item, newvalue) !节点改值
    class(anyitem), intent(inout) :: item
    class(*), intent(in)          :: newvalue !无限多态类型

    deallocate (item%value) !释放原节点内存
    allocate (item%value, source=newvalue) !新节点分配内存并赋值
  end subroutine

  subroutine delete(item) !删除节点并释放其内存
    class(anyitem), target  :: item
    class(anyitem), pointer :: temp
    temp => item
    call remove(item) !将该节点从链表中删除，但仍保留该节点和其值
    deallocate (temp) !释放内存
  end subroutine

  function list(item) !返回节点所在的链表
    class(anyitem), intent(in) :: item
    class(anylist), pointer :: list
    list => item%upptr
  end function

  function next(item) !下一个节点
    class(anyitem), intent(in) :: item
    class(anyitem), pointer :: next
    next => item%nextptr
  end function

  function prev(item) !上一个节点
    class(anyitem), intent(in) :: item
    class(anyitem), pointer :: prev
    prev => item%prevptr
  end function

  subroutine print(this) !打印该节点
    class(anyitem), intent(in) :: this
    integer length
    select type (v=>this%value)
    type is (character(*)) !字符串
      length = len(v) !字符串长度
      if (length>40) then
        print 1, length, v(:36) !打印前36个字符
1       format(1x, 'character(len=', i0, ') = "', a, '"...')
      else
        print *, 'character = "', v, '"' !打印全部字符
      end if
    type is (complex) !单精度复数
      print *, 'complex', v
    type is (complex(kind(0d0))) !双精度复数
      print 2, kind(v), v
2     format(1x, 'complex(kind=', i0, ') = (', es23.16, ', ', es23.16, ')')
    type is (real(kind(0d0))) !双精度浮点数
      print 3, kind(v), v
3     format(1x, 'real(kind=', i0, ') = ', es23.16)
    type is (integer) !整数
      print *, 'integer = ', v
    type is (real) !单精度浮点数
      print *, 'real = ', v
    type is (logical) !逻辑变量
      print *, 'logical = ', v
    class default !未定义类型
      print *, 'unrecognised item type - cannot display value'
    end select
  end subroutine

  subroutine remove(item) !将该节点从链表中删除，但仍保留该节点和其值
    class(anyitem), intent(inout), target :: item
    class(anylist), pointer :: list
    list => item%upptr !节点所在的链表
    if (associated(list)) then !不是空链表
      if (associated(item%prevptr, item)) then !链表中唯一的节点
        ! Single item in list.
        nullify(list%firstptr) !链表头指针置空
      else if (.not.associated(item%nextptr)) then !链表尾节点
        ! Last item in list.
        list%firstptr%prevptr => item%prevptr !尾节点上移
        nullify(item%prevptr%nextptr) !尾节点的标志为后指针为空
      else if (associated(list%firstptr, item)) then !链表头节点
        ! First item in list.
        list%firstptr => item%nextptr         ! first = next. 头节点下移
        item%nextptr%prevptr => item%prevptr  ! next%prev = last.
      else !中间节点
        item%prevptr%nextptr => item%nextptr  ! last%next = item%next.
        item%nextptr%prevptr => item%prevptr  ! next%prev = item%last.
      end if
      item%prevptr => item
    end if
    nullify(item%upptr) !此时节点不属于任何链表
  end subroutine
end module

!
! Module to demonstrate extending anyitem to handle a user-defined type.
!
module myitem_list_m
  use anylist_m
  implicit none

	integer,parameter::FILENUM=11 !输出文件号

  type, extends(anyitem) :: myitem !继承节点类
  contains
    procedure :: print => myprint !重载print方法
  end type

  type :: point3d !派生类型
		real(kind=8)::x=0.0d0
		real(kind=8)::y=0.0d0
		real(kind=8)::z=0.0d0
	end type
contains
  !
  ! Version of print that will handle type rational.
  !
  subroutine myprint(this) !重载print方法
    class(myitem), intent(in) :: this

    select type (v=>this%value)
    class is (point3d) !派生类型
      print *, 'Point3d =', v%x , v%y, v%z
      write(FILENUM,*)v%x , v%y, v%z
    class default !其他类型
      call this%anyitem%print !调用父类方法
    end select
  end subroutine

  function new_myitem(anything) !新的节点创建函数
    class(*), intent(in) :: anything !无限多态类型
    class(myitem), pointer :: new_myitem

    allocate (new_myitem)
    allocate (new_myitem%value, source=anything) !节点分配内存并赋值
  end function
end module

program main
  use myitem_list_m
  implicit none

  type(anylist) :: ll !链表类
  class(anyitem), pointer :: p !节点指针
  type(point3d) :: point !派生类型
  integer(kind=1) :: is !kind=1整数最大127
  integer(kind=4) :: i !kind=4整数最大值2147483647

  write(*,*)"正在读取原文件(DemPoint.txt)数据,请稍等!"
  open(unit=10,file="DemPoint.txt",status="old")
  read(10,*) !文件第一行无数据

  do
    read(10,*,iostat=is)i,i,point%z,point%x,point%y !i仅用于占位  其值并无意义
    if(is<0) exit !文件结尾
    call ll%append(new_myitem(point)) !尾部压入新节点
  end do

  close(unit=10)
  write(*,*)"读取数据结束!"
  write(*,*)"原文件(DemPoint.txt)的节点个数为:",ll%count_list()

  write(*,*)"正在将节点坐标数据写入地形文件(out.xyz),请稍等!"
  open(unit=FILENUM,file="out.xyz",status="replace")
  p => ll%first() !指针指向链表头节点
  !write(FILENUM,*)p%value !注意不能直接访问节点 编译会报错
  !Error: Data transfer element at (1) cannot be polymorphic unless it is processed by a defined input/output procedure
  !遍历链表
  do while(associated(p)) !若指针不为空则一直循环
    call p%print !打印当前节点
    p => p%next()  !下一节点
  end do

  call ll%delete_list !删除链表并释放内存
  close(unit=FILENUM)
  write(*,*)"写入数据结束,请按任意键退出程序!"
  read(*,*)
end program

  !write(FILENUM,*)p%value !注意不能直接访问节点 编译会报错
  !Error: Data transfer element at (1) cannot be polymorphic unless it is processed by a defined input/output procedure