From d5649c7d71e94c95c7a5c8c655adde6273dd19ec Mon Sep 17 00:00:00 2001 From: Zdenek Grof Date: Fri, 18 Aug 2023 20:32:01 +0200 Subject: [PATCH] Experiment with join --- src/rbnode_mod.f90 | 136 ++++++++++++++++++++++++++++++++++++++++++++- test/check.f90 | 3 +- test/tree_test.f90 | 89 +++++++++++++++++++++++++---- 3 files changed, 214 insertions(+), 14 deletions(-) diff --git a/src/rbnode_mod.f90 b/src/rbnode_mod.f90 index 9c3a8e2..49deee3 100644 --- a/src/rbnode_mod.f90 +++ b/src/rbnode_mod.f90 @@ -26,7 +26,7 @@ module rbnode_mod procedure :: nextnode => nextnode_tbp end type rbnode_t interface rbnode_t - module procedure rbnode_new + module procedure rbnode_new, rbnode_newroot !module procedure rbnode_import !module procedure rbnode_copy end interface @@ -35,9 +35,12 @@ module rbnode_mod type(rbnode_t), pointer :: root => null() contains procedure :: isvalid => rbbasetree_isvalid + procedure :: blackheight => rbbasetree_blackheight end type rbbasetree_t integer, parameter :: LEFT_CHILD=1, RIGHT_CHILD=2, NO_PARENT=0 + logical(int8), parameter :: RED_COLOUR=.false.,BLACK_COLOUR=.true. + integer, parameter :: MAX_SAFE_DEPTH=1000000 !! Defensive test to avoid infinite loops in the code @@ -46,7 +49,8 @@ module rbnode_mod public rbnode_find public rbnode_leftmost, rbnode_nextnode, rbnode_prevnode public rbnode_insert, rbnode_delete - public rbnode_validate + public rbnode_validate, rbnode_blackheight + public join contains @@ -112,6 +116,31 @@ function rbnode_new(dat) result(new) end function rbnode_new + function rbnode_newroot(left,dat,colour,right) result(new) + type(rbnode_t), intent(in), pointer :: left, right + integer(DATA_KIND), intent(in) :: dat(:) + logical(int8), intent(in) :: colour + type(rbnode_t), pointer :: new + + integer :: ierr + + allocate(new, stat=ierr) + if (ierr /= 0) & + error stop 'could not allocate new rbtr node' + allocate(new%dat(size(dat)), stat=ierr) + if (ierr /= 0) & + error stop 'could not allocate data in new rbtr node' + new%dat = dat + new%isblack = colour + new%left => left + new%right => right + new%parent => null() + + if (associated(new%left)) new%left%parent => new + if (associated(new%right)) new%right%parent => new + end function rbnode_newroot + + subroutine rbnode_update(node, newdata) !! Update the data content of the node by newdata !! TODO may invalidate the red-black tree!!! @@ -715,7 +744,7 @@ subroutine rbnode_delete(tree, what, ierr, deleted_output) integer, optional, intent(out) :: ierr type(rbnode_t), pointer, intent(out), optional :: deleted_output - integer :: ierr0 + integer :: ierr0 ! TODO error processing not finished type(rbnode_t), pointer :: n, ch integer(kind=DATA_KIND), allocatable :: tmp_dat(:) @@ -980,6 +1009,80 @@ subroutine delete_case6(tree, m) end subroutine delete_case6 + ! ============================= + ! Set operations (experimental) + ! ============================= + + recursive function join_right(tl, key, tr) result(newroot) + type(rbnode_t), intent(in), pointer :: tl, tr + integer(DATA_KIND), intent(in) :: key(:) + type(rbnode_t), pointer :: newroot + + type(rbbasetree_t) :: t + type(rbnode_t), pointer :: tmp + + if (tl%isblack .and. rbnode_blackheight(tl)==rbnode_blackheight(tr)) then + newroot => rbnode_t(tl, key, RED_COLOUR, tr) + return + end if + + t%root => rbnode_t(tl%left, rbnode_read(tl), tl%isblack, & + join_right(tl%right, key, tr)) + + if (rbnode_isblack(tl) .and. & + ((rbnode_isblack(t%root%right) .eqv. RED_COLOUR) .and. & + (rbnode_isblack(t%root%right%right) .eqv. RED_COLOUR))) then + t%root%right%right%isblack = BLACK_COLOUR + tmp => rotate_left(t%root, t) + newroot => tmp + return + end if + newroot => t%root + end function join_right + + + recursive function join_left(tl, key, tr) result(newroot) + type(rbnode_t), intent(in), pointer :: tl, tr + integer(DATA_KIND), intent(in) :: key(:) + type(rbnode_t), pointer :: newroot + + type(rbbasetree_t) :: t + type(rbnode_t), pointer :: tmp + + stop 'not ready' + end function join_left + + + function join(tl, key, tr) result(newroot) + type(rbnode_t), intent(in), pointer :: tl, tr + integer(DATA_KIND), intent(in) :: key(:) + type(rbnode_t), pointer :: newroot + + type(rbbasetree_t) :: t + + if (rbnode_blackheight(tl) > rbnode_blackheight(tr)) then + t%root => join_right(tl, key, tr) + if ((rbnode_isblack(t%root) .eqv. RED_COLOUR) .and. & + (rbnode_isblack(t%root%right) .eqv. RED_COLOUR )) then + t%root%isblack = BLACK_COLOUR + end if + newroot => t%root + return + end if + + if (rbnode_blackheight(tl) < rbnode_blackheight(tr)) then + stop 'not ready' + end if + + if ((rbnode_isblack(tl) .eqv. BLACK_COLOUR) .and. & + (rbnode_isblack(tr) .eqv. BLACK_COLOUR)) then + newroot => rbnode_t(tl,key,RED_COLOUR,tr) + else + newroot => rbnode_t(tl,key,BLACK_COLOUR,tr) + end if + end function join + + ! ================================ ! Validation and debugging helpers ! ================================ @@ -1039,4 +1142,31 @@ recursive subroutine rbnode_validate(root, cfun, isvalid, nblacks) end subroutine rbnode_validate + + function rbnode_blackheight(node) result(bh) + !* The black height of a red–black tree is the number of black nodes in any + ! path from the root to the leaves. The black height of a node is the black + ! height of the subtree rooted by it. The black height of a NIL node shall + ! be set to 0, because its subtree is empty, and its tree height is also 0. + ! + type(rbnode_t), pointer, intent(in) :: node + integer :: bh + type(rbnode_t), pointer :: current + + bh = 0 + current => node + do + if (.not. associated(current)) exit + if (current%isblack) bh = bh + 1 + current => current%left ! if tree is valid, the choice is arbitrary + end do + end function rbnode_blackheight + + + function rbbasetree_blackheight(this) result(bh) + class(rbbasetree_t), intent(in) :: this + integer :: bh + bh = rbnode_blackheight(this%root) + end function rbbasetree_blackheight + end module rbnode_mod diff --git a/test/check.f90 b/test/check.f90 index 4aa122e..956a433 100644 --- a/test/check.f90 +++ b/test/check.f90 @@ -8,7 +8,8 @@ subroutine test2() end subroutine test2 end interface - call tree_test_basic() + !call tree_test_basic() + call tree_test_join() stop call test1() diff --git a/test/tree_test.f90 b/test/tree_test.f90 index c5bb067..6609c6a 100644 --- a/test/tree_test.f90 +++ b/test/tree_test.f90 @@ -5,10 +5,35 @@ module tree_test_mod 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 = 1025 - integer, parameter :: NSIZE = 150000 + integer, parameter :: NSIZE = 52 + !integer, parameter :: NSIZE = 150000 type(rbnode_t), pointer :: current, output type(rbbasetree_t) :: tree @@ -20,22 +45,20 @@ subroutine tree_test_basic() y2 = shuffle_array(y1) do i=1, size(y2) - !call rbnode_insert(root, & - ! 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) + !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,2x)',advance='no') transfer(rbnode_read(current),i), current%is_node_black() + 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(*,*) @@ -61,9 +84,55 @@ subroutine tree_test_basic() 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 - end subroutine + 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)