-
Notifications
You must be signed in to change notification settings - Fork 0
/
tree_test.f90
183 lines (149 loc) · 5.61 KB
/
tree_test.f90
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
module tree_test_mod
use common_mod, only : mold, DATA_KIND
use rbnode_mod
implicit none
contains
subroutine tree_test_join()
integer, parameter, dimension(*) :: dat_a=[1, 5, 6, 7, 8, 11, 12, 13, 15, 17, 19, 2, 3, 4, 9]
integer, parameter, dimension(*) :: dat_b=[21, 25, 27, 35]
type(rbbasetree_t) :: tree_a, tree_b, tree_ab
integer :: i, ierr
do i=1, size(dat_a)
call rbnode_insert(tree_a, rbnode_t(transfer(dat_a(i),mold)), tree_test_basic_comp, ierr)
if (ierr/=0) print *, 'Insert ierr = ',ierr
end do
print '("Is tree valid after inserion?",L2)', tree_a%isvalid(tree_test_basic_comp)
do i=1, size(dat_b)
call rbnode_insert(tree_b, rbnode_t(transfer(dat_b(i),mold)), tree_test_basic_comp, ierr)
if (ierr/=0) print *, 'Insert ierr = ',ierr
end do
print '("Is tree valid after inserion?",L2)', tree_b%isvalid(tree_test_basic_comp)
call dump_graphviz('our_a', tree_a)
call dump_graphviz('our_b', tree_b)
tree_ab%root => join(tree_a%root, transfer(20,mold), tree_b%root)
print '("Is tree valid after join?",L2)', tree_ab%isvalid(tree_test_basic_comp)
call dump_graphviz('our_ab', tree_ab)
end subroutine tree_test_join
subroutine tree_test_basic()
integer, parameter, dimension(*) :: DATA=[10, 5, 7, 8, 9, 11, 12, 13]
integer, parameter :: NSIZE = 52
!integer, parameter :: NSIZE = 150000
type(rbnode_t), pointer :: current, output
type(rbbasetree_t) :: tree
integer :: ierr, i, nblacks
integer, allocatable :: y1(:), y2(:)
logical :: isvalid
y1 = get_array(NSIZE)
y2 = shuffle_array(y1)
do i=1, size(y2)
!call rbnode_insert(tree, rbnode_t(transfer(DATA(i),mold)), tree_test_basic_comp, ierr)
call rbnode_insert(tree, rbnode_t(transfer(y2(i),mold)), tree_test_basic_comp, ierr)
if (ierr/=0) print *, 'Insert ierr = ',ierr
end do
print '("Is tree valid after inserion?",L2)', &
tree%isvalid(tree_test_basic_comp)
call dump_graphviz('our_tree', tree)
! traversing
current=>rbnode_leftmost(tree%root)
do
if (.not. associated(current)) exit
write(*,'("[",i0,l2,": ",i0,"]",3x)',advance='no') &
transfer(rbnode_read(current),i), current%is_node_black(), rbnode_blackheight(current)
current => current%nextnode()
end do
write(*,*)
! Deletion
do i=1, size(y2)
call rbnode_delete(tree, rbnode_find(tree%root, &
transfer(y2(i),mold), tree_test_basic_comp) )
if (mod(i,10000)/=0) cycle
isvalid = tree%isvalid(tree_test_basic_comp)
!print *, 'removed ',y2(i), isvalid
if (.not. isvalid) stop 'tree is not valid'
end do
! Root is
if (associated(tree%root)) then
print *, "Root is: ", transfer(rbnode_read(tree%root),i), tree%root%is_node_black()
else
print *, "Root is null:"
end if
! Validation
call rbnode_validate(tree%root, tree_test_basic_comp, isvalid, nblacks)
print '("Is tree valid ?",L2, " black nodes count = ",i0)',isvalid, nblacks
end subroutine
subroutine dump_graphviz(basename, tree)
character(len=*), intent(in) :: basename
type(rbbasetree_t), intent(in) :: tree
integer :: fid, cmdstat, exitstat
character(len=200) cmdmsg
if (.not. associated(tree%root)) then
print *, 'Warning: graphviz dump skiped for empty tree'
return
end if
open(newunit=fid, file=basename//'.gv.txt', status='replace')
write(fid,'(a,/,a)') 'digraph {','node [fontname="Arial"];'
call visit_nodes(tree%root, fid)
write(fid,'(a)') '}'
flush(fid)
call execute_command_line('dot -Tpng < '//basename//'.gv.txt'//' > '//basename//'.png', &
exitstat=exitstat, cmdstat=cmdstat, cmdmsg=cmdmsg)
if (exitstat/=0 .or. cmdstat/=0) print *, exitstat, cmdstat, cmdmsg
close(fid, status='delete')
end subroutine dump_graphviz
recursive subroutine visit_nodes(current, fid)
type(rbnode_t), pointer, intent(in) :: current
integer, intent(in) :: fid
type(rbnode_t), pointer :: par, left, right
character(len=11) bufcur, bufpar
write(bufcur,'(i11)') transfer(rbnode_read(current),fid)
if (.not. current%is_node_black()) then
write(fid,'(a)') trim(adjustl(bufcur))//' [color=red]'
end if
par => current%upnode()
if (associated(par)) then
write(bufpar,'(i11)') transfer(rbnode_read(par),fid)
write(fid,'(a)') trim(adjustl(bufpar))//' -> '//trim(adjustl(bufcur))
end if
left => current%leftnode()
right => current%rightnode()
if (associated(left)) call visit_nodes(left, fid)
if (associated(right)) call visit_nodes(right, fid)
end subroutine visit_nodes
integer function tree_test_basic_comp(a,b) result(comp)
integer(DATA_KIND), intent(in), dimension(:) :: a, b
integer :: aval, bval
aval = transfer(a,aval)
bval = transfer(b,bval)
if (aval<bval) then
comp = -1
else if (aval>bval) then
comp = 1
else
comp = 0
end if
end function tree_test_basic_comp
pure function get_array(n) result(y)
integer, allocatable :: y(:)
integer, intent(in) :: n
integer :: i
allocate(y(n))
y = [(i, i=1,n)]
end function get_array
function shuffle_array(yin) result(yout)
integer, intent(in) :: yin(:)
integer :: yout(size(yin))
integer :: i, j, n, ytmp
real :: xran
yout = yin
n = size(yin)
do i=1, n-1
call random_number(xran)
! j is in the range
! * i==1: 1...n, i==2: 2..n, i==3: 3..n, i==n-1: n-1..n
j = i-1 + int(xran*(n-i+1))+1
ytmp = yout(j)
yout(j) = yout(i)
yout(i) = ytmp
end do
end function shuffle_array
end module tree_test_mod