无限多态链表

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）

[Fortran] 纯文本查看 复制代码

001module anylist_m
002  implicit none
003  private
004  public :: anylist, anyitem, newitem
005 
006  type anylist !（任意类型）链表类
007    class(anyitem), pointer, private :: firstptr => null() !头指针
008  contains
009    procedure, non_overridable :: append !尾部增加节点
010    procedure, non_overridable :: count_list !节点个数
011    procedure, non_overridable :: delete_list !删除所有节点
012    procedure, non_overridable :: first !头节点
013    procedure, non_overridable :: last !尾节点
014    procedure, non_overridable :: prepend !将当前节点前置到链表头部
015    procedure, non_overridable :: print_list !打印链表
016  end type
017 
018  type anyitem !（任意类型）节点类  双向环形链表
019    class(*), allocatable            :: value !无限多态类型
020    class(anyitem), pointer, private :: nextptr => null(), prevptr => null() !后指针与前指针
021    class(anylist), pointer, private :: upptr => null() !节点所在的链表指针
022  contains
023    procedure, non_overridable :: change !节点改值
024    procedure, non_overridable :: delete !删除节点并释放其内存
025    procedure, non_overridable :: list !返回节点所在的链表
026    procedure, non_overridable :: next !后一个节点
027    procedure, non_overridable :: prev !前一个节点
028    procedure                  :: print !打印节点 允许子类重载该方法
029    procedure, non_overridable :: remove !将该节点从链表中删除，但仍保留该节点和其值
030  end type
031contains
032  function newitem(something) !节点创建函数
033    class(*), intent(in)    :: something !无限多态类型
034    class(anyitem), pointer :: newitem
035    allocate (newitem)
036    allocate (newitem%value, source=something) !节点分配内存并赋值
037    newitem%prevptr => newitem !节点前置指针指向节点本身
038  end function
039 
040  subroutine append(list, item) !尾部增加节点
041    class(anylist), intent(inout), target :: list
042    class(anyitem), target                :: item
043    class(anyitem), pointer               :: last
044 
045    if (associated(item%upptr)) call remove(item) !如果节点属于某个链表  脱离从属关系
046    item%upptr => list !节点属于新的链表
047    if (associated(list%firstptr)) then !不是空链表
048      last => list%firstptr%prevptr !last为链表尾节点
049      last%nextptr => item !尾部插入新节点
050      item%prevptr => last !新节点与原尾节点建立链接
051      list%firstptr%prevptr => item !item为新的尾节点
052    else !空链表 item为第一个节点
053      list%firstptr => item
054      item%prevptr => item !item%nextptr => null()
055    end if
056  end subroutine
057 
058  integer function count_list(list) !链表节点个数
059    class(anylist), intent(in) :: list
060    class(anyitem), pointer :: p !遍历指针
061    count_list = 0 !累加器
062    p => list%firstptr !指向头节点
063    do
064      if (.not.associated(p)) exit !指针为空退出循环
065      count_list = count_list + 1
066      p => p%nextptr !下一个节点
067    end do
068  end function
069 
070  subroutine delete_list(list) !删除链表所有节点
071    class(anylist), intent(inout) :: list
072    do
073      if (.not.associated(list%firstptr)) exit !指针为空退出循环
074      call delete(list%firstptr) !总是删除头节点
075    end do
076  end subroutine
077 
078  function first(list) !链表头节点
079    class(anylist), intent(in) :: list
080    class(anyitem), pointer :: first
081    first => list%firstptr
082  end function
083 
084  function last(list) !链表尾节点
085    class(anylist), intent(in) :: list
086    class(anyitem), pointer :: last
087    last => list%firstptr
088    if (associated(last)) last => last%prevptr !头节点的上一个位置即尾节点
089  end function
090 
091  subroutine prepend(list, item) !将节点前置到链表头部
092    class(anylist), intent(inout), target :: list
093    class(anyitem), target                :: item
094    if (associated(item%upptr)) call remove(item) !隔绝节点与原链表的联系
095    item%upptr => list !节点属于新链表
096    if (associated(list%firstptr)) then !不是空链表
097      item%prevptr => list%firstptr%prevptr !将节点前置到链表头部
098      item%nextptr => list%firstptr
099      list%firstptr%prevptr => item
100    else !空链表
101      item%prevptr => item
102    end if
103    list%firstptr => item !链表的头指针指向前置节点
104  end subroutine
105 
106  subroutine print_list(list, show_item_numbers, show_empty_list) !打印链表
107    class(anylist), intent(in) :: list
108    logical, intent(in), optional :: show_item_numbers, show_empty_list
109    class(anyitem), pointer :: p !遍历指针
110    integer :: i
111    logical :: show_numbers !是否显示节点序号
112    if (present(show_item_numbers)) then
113      show_numbers = show_item_numbers
114    else
115      show_numbers = .true. !是否显示节点序号 默认为真
116    end if
117    p => list%firstptr !从头开始
118    if (.not.associated(p)) then !空链表
119      if (present(show_empty_list)) then
120        if (show_empty_list) print *, 'List is empty.'
121      else
122        print *, 'List is empty.'!空链表默认显示
123      end if
124    else !不是空链表
125      do i=1, huge(i)-1 !huge(i)为最大整数
126        if (show_numbers) write (*, 1, advance='no') i !显示节点序号
1271       format(1x, 'Item ', i0, ':')
128        call p%print !打印节点
129        p => p%nextptr !下一个节点
130        if (.not.associated(p)) exit !空链表退出循环
131      end do
132    end if
133  end subroutine
134 
135  subroutine change(item, newvalue) !节点改值
136    class(anyitem), intent(inout) :: item
137    class(*), intent(in)          :: newvalue !无限多态类型
138 
139    deallocate (item%value) !释放原节点内存
140    allocate (item%value, source=newvalue) !新节点分配内存并赋值
141  end subroutine
142 
143  subroutine delete(item) !删除节点并释放其内存
144    class(anyitem), target  :: item
145    class(anyitem), pointer :: temp
146    temp => item
147    call remove(item) !将该节点从链表中删除，但仍保留该节点和其值
148    deallocate (temp) !释放内存
149  end subroutine
150 
151  function list(item) !返回节点所在的链表
152    class(anyitem), intent(in) :: item
153    class(anylist), pointer :: list
154    list => item%upptr
155  end function
156 
157  function next(item) !下一个节点
158    class(anyitem), intent(in) :: item
159    class(anyitem), pointer :: next
160    next => item%nextptr
161  end function
162 
163  function prev(item) !上一个节点
164    class(anyitem), intent(in) :: item
165    class(anyitem), pointer :: prev
166    prev => item%prevptr
167  end function
168 
169  subroutine print(this) !打印该节点
170    class(anyitem), intent(in) :: this
171    integer length
172    select type (v=>this%value)
173    type is (character(*)) !字符串
174      length = len(v) !字符串长度
175      if (length>40) then
176        print 1, length, v(:36) !打印前36个字符
1771       format(1x, 'character(len=', i0, ') = "', a, '"...')
178      else
179        print *, 'character = "', v, '"' !打印全部字符
180      end if
181    type is (complex) !单精度复数
182      print *, 'complex', v
183    type is (complex(kind(0d0))) !双精度复数
184      print 2, kind(v), v
1852     format(1x, 'complex(kind=', i0, ') = (', es23.16, ', ', es23.16, ')')
186    type is (real(kind(0d0))) !双精度浮点数
187      print 3, kind(v), v
1883     format(1x, 'real(kind=', i0, ') = ', es23.16)
189    type is (integer) !整数
190      print *, 'integer = ', v
191    type is (real) !单精度浮点数
192      print *, 'real = ', v
193    type is (logical) !逻辑变量
194      print *, 'logical = ', v
195    class default !未定义类型
196      print *, 'unrecognised item type - cannot display value'
197    end select
198  end subroutine
199 
200  subroutine remove(item) !将该节点从链表中删除，但仍保留该节点和其值
201    class(anyitem), intent(inout), target :: item
202    class(anylist), pointer :: list
203    list => item%upptr !节点所在的链表
204    if (associated(list)) then !不是空链表
205      if (associated(item%prevptr, item)) then !链表中唯一的节点
206        ! Single item in list.
207        nullify(list%firstptr) !链表头指针置空
208      else if (.not.associated(item%nextptr)) then !链表尾节点
209        ! Last item in list.
210        list%firstptr%prevptr => item%prevptr !尾节点上移
211        nullify(item%prevptr%nextptr) !尾节点的标志为后指针为空
212      else if (associated(list%firstptr, item)) then !链表头节点
213        ! First item in list.
214        list%firstptr => item%nextptr         ! first = next. 头节点下移
215        item%nextptr%prevptr => item%prevptr  ! next%prev = last.
216      else !中间节点
217        item%prevptr%nextptr => item%nextptr  ! last%next = item%next.
218        item%nextptr%prevptr => item%prevptr  ! next%prev = item%last.
219      end if
220      item%prevptr => item
221    end if
222    nullify(item%upptr) !此时节点不属于任何链表
223  end subroutine
224end module

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

[Fortran] 纯文本查看 复制代码

01!
02! Module to demonstrate extending anyitem to handle a user-defined type.
03!
04module myitem_list_m
05  use anylist_m
06  implicit none
07 
08  integer,parameter::FILENUM=11 !输出文件号
09 
10  type, extends(anyitem) :: myitem !继承节点类
11  contains
12    procedure :: print => myprint !重载print方法
13  end type
14 
15  type :: point3d !派生类型
16    real(kind=8)::x=0.0d0
17    real(kind=8)::y=0.0d0
18    real(kind=8)::z=0.0d0
19  end type
20contains
21  !
22  ! Version of print that will handle type rational.
23  !
24  subroutine myprint(this) !重载print方法
25    class(myitem), intent(in) :: this
26 
27    select type (v=>this%value)
28    class is (point3d) !派生类型
29      print *, 'Point3d =', v%x , v%y, v%z
30      write(FILENUM,*)v%x , v%y, v%z
31    class default !其他类型
32      call this%anyitem%print !调用父类方法
33    end select
34  end subroutine
35 
36  function new_myitem(anything) !新的节点创建函数
37    class(*), intent(in) :: anything !无限多态类型
38    class(myitem), pointer :: new_myitem
39 
40    allocate (new_myitem)
41    allocate (new_myitem%value, source=anything) !节点分配内存并赋值
42  end function
43end module

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

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

主程序

[Fortran] 纯文本查看 复制代码

01program main
02  use myitem_list_m
03  implicit none
04 
05  type(anylist) :: ll !链表类
06  class(anyitem), pointer :: p !节点指针
07  type(point3d) :: point !派生类型
08  integer(kind=1) :: is !kind=1整数最大127
09  integer(kind=4) :: i !kind=4整数最大值2147483647
10 
11  write(*,*)"正在读取原文件(DemPoint.txt)数据,请稍等!"
12  open(unit=10,file="DemPoint.txt",status="old")
13  read(10,*) !文件第一行无数据
14 
15  do
16    read(10,*,iostat=is)i,i,point%z,point%x,point%y !i仅用于占位  其值并无意义
17    if(is<0) exit !文件结尾
18    call ll%append(new_myitem(point)) !尾部压入新节点
19  end do
20 
21  close(unit=10)
22  write(*,*)"读取数据结束!"
23  write(*,*)"原文件(DemPoint.txt)的节点个数为:",ll%count_list()
24 
25  write(*,*)"正在将节点坐标数据写入地形文件(out.xyz),请稍等!"
26  open(unit=FILENUM,file="out.xyz",status="replace")
27  p => ll%first() !指针指向链表头节点
28  !write(FILENUM,*)p%value !注意不能直接访问节点 编译会报错
29  !Error: Data transfer element at (1) cannot be polymorphic unless it is processed by a defined input/output procedure
30  !遍历链表
31  do while(associated(p)) !若指针不为空则一直循环
32    call p%print !打印当前节点
33    p => p%next()  !下一节点
34  end do
35 
36  call ll%delete_list !删除链表并释放内存
37  close(unit=FILENUM)
38  write(*,*)"写入数据结束,请按任意键退出程序!"
39  read(*,*)
40end program

源代码

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

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

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

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

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

[Fortran] 纯文本查看 复制代码

`1`	`!write(FILENUM,*)p%value !注意不能直接访问节点编译会报错`

`2`	`!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
[mw_shl_code=fortran,true] !write(FILENUM,*)p%value !注意不能直接访问节点编译会报错
!Error: Data ...

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

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

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

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

评分