无限多态链表-Fortran算法研究-专业Fortran论坛

weixing1531 发表于 2019-4-2 03:07:56

无限多态链表

本帖最后由 weixing1531 于 2019-4-4 00:09 编辑

由于Fortran没有模板，经常导致编写的算法通用性差一般的解决方法进行预处理
类似于
#define T integer

T function max(x, y)
T :: x, y
if (x < y) then
max = y
else
max = x
endif
end function

下面介绍另外一种方法——无限多态class(*)
源代码如下（源代码摘自《Modern_Fortran_Explained》第433页，下载地址：ftp://ftp.numerical.rl.ac.uk/pub/MRandC/oo.f90）
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

weixing1531 发表于 2019-4-2 03:09:22

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

weixing1531 发表于 2019-4-2 03:13:06

本帖最后由 weixing1531 于 2019-4-4 00:18 编辑

主程序
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

源代码

zoziha 发表于 2022-3-10 17:28:08

本帖最后由 zoziha 于 2022-3-10 17:35 编辑

我搬运了(https://github.com/fortran-lang/stdlib/pull/491/files)的双向链表方案（遵循了MIT许可证），并进行了一定的修改，见码云(https://gitee.com/zoziha/dlinked_list/blob/master/src/dlinked_list.f90#)。
它与你的这份代码很相似，也是采用`class(*), allocatable`，欢迎大家免费使用，注明LICENSE即可，MIT非常宽松。

单向链表与双向链表优缺点存在小的差异，我将编写对应的单链表方案。
建议和代码贡献将十分欢迎~

andy8496 发表于 2022-4-19 16:45:46

!write(FILENUM,*)p%value !注意不能直接访问节点编译会报错
!Error: Data transfer element at (1) cannot be polymorphic unless it is processed by a defined input/output procedure如果不能直接访问节点，那如何进一步利用数据？比如，从一个文本中读取数据后，需要用这些数据进一步计算，该如何实现？仅仅Print一个文本出来似乎使用不便

唐汉发表于 2022-4-20 07:50:51

andy8496 发表于 2022-4-19 16:45
!write(FILENUM,*)p%value !注意不能直接访问节点编译会报错
!Error: Data ...

我估计这里只是一个例子。如果要大量使用IO的话还是重载WRITE(UNFORMATTED)会方便一点。

andy8496 发表于 2022-4-29 15:26:37

VS+ivf 运行出错。有人试过吗?

页: [1]

Fortran Coder's Archiver

无限多态链表