diff --git a/src/rbnode_mod.f90 b/src/rbnode_mod.f90 index f25d015..e8d5403 100644 --- a/src/rbnode_mod.f90 +++ b/src/rbnode_mod.f90 @@ -38,6 +38,7 @@ module rbnode_mod procedure :: blackheight => rbbasetree_blackheight procedure :: size => rbbasetree_size procedure :: graphviz => rbbasetree_graphviz + procedure :: leftmost => rbbasetree_leftmost end type rbbasetree_t integer, parameter :: LEFT_CHILD=1, RIGHT_CHILD=2, NO_PARENT=0 @@ -96,6 +97,17 @@ function nextnode_tbp(this) result(nn) ! TODO prevnode, leftmost?, rightmost? + ! =========================== + ! Rbbasetree_t basic routines + ! =========================== + function rbbasetree_leftmost(this) result(ln) + class(rbbasetree_t), intent(in) :: this + type(rbnode_t), pointer :: ln + ln => null() + if (associated(this%root)) ln => rbnode_leftmost(this%root) + end function + + ! ================================ ! Allocate new node (CONSTRUCTOR) ! Update node data (???) @@ -748,7 +760,7 @@ end subroutine insert_repair ! ======== ! Deletion ! ======== - +!TODO - error treatment in rbnode_delete is not finished subroutine rbnode_delete(tree, what, ierr, deleted_output) !* Remove (and maybe free) a node from the tree. ! Optional pointer `deleted_output` points to the deleted node @@ -760,7 +772,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 ! TODO error processing not finished + integer :: ierr0 type(rbnode_t), pointer :: n, ch integer(kind=DATA_KIND), allocatable :: tmp_dat(:) @@ -1028,6 +1040,7 @@ end subroutine delete_case6 ! ============================= ! Set operations (experimental) ! ============================= +!TODO: after testing, remove one of versions of the procedures recursive function re_root(left,root,right) result(newroot) !* Same job as "rbnode_newroot" but here we do not allocate any new memory. @@ -1142,21 +1155,21 @@ function join2(tl, k, tr) result(tjoin) !* Join two sub-trees and return the pointer to a root of a new tree. ! ! Note: all nodes in the left subtree must have key less than "key", and - ! all nodes in the right subtree must have key greater than "key" ! + ! all nodes in the right subtree must have key greater than "key" !!! ! type(rbnode_t), intent(in), pointer :: tl, tr, k type(rbnode_t), pointer :: tjoin - if (.not. associated(k)) error stop 'join - nill key node' + if (.not. associated(k)) error stop 'join: nil key node' - ! Assert both nodes are roots + ! Assert all nodes are roots if (associated(tl)) then if (associated(tl%parent)) error stop 'join: tl is not root' end if if (associated(tr)) then if (associated(tr%parent)) error stop 'join: tr is not root' end if - if ( associated(k%parent)) error stop 'join - key node must be root' + if (associated(k%parent)) error stop 'join - key node must be root' if (rbnode_blackheight(tl) > rbnode_blackheight(tr)) then tjoin => join_right2(tl, k, tr) @@ -1178,9 +1191,11 @@ function join2(tl, k, tr) result(tjoin) ! both trees have the same black height if ((rbnode_isblack(tl) .eqv. BLACK_COLOUR) .and. & (rbnode_isblack(tr) .eqv. BLACK_COLOUR)) then - tjoin => connect(tl, k, RED_COLOUR, tr) + tjoin => connect(tl, k, tr) + tjoin%isblack = RED_COLOUR else - tjoin => connect(tl, k, BLACK_COLOUR, tr) + tjoin => connect(tl, k, tr) + tjoin%isblack = BLACK_COLOUR end if end function join2 @@ -1189,11 +1204,11 @@ recursive function join_right2(tl, k, tr) result(tjoin) type(rbnode_t), intent(in), pointer :: tl, tr, k type(rbnode_t), pointer :: tjoin + type(rbnode_t), pointer :: tl_left, tl_right, m type(rbbasetree_t) :: t logical(int8) :: tl_isblack -print *, 'in join_right2 ',print_node(tl)//print_node(k)//print_node(tr) - ! Assert both nodes are roots + ! Assert nodes are roots if (associated(tl)) then if (associated(tl%parent)) error stop 'join_right: tl is not root' end if @@ -1204,11 +1219,13 @@ recursive function join_right2(tl, k, tr) result(tjoin) tl_isblack = rbnode_isblack(tl) if (tl_isblack .and. rbnode_blackheight(tl)==rbnode_blackheight(tr)) then - tjoin => connect(tl, k, RED_COLOUR, tr) + tjoin => connect(tl, k, tr) + tjoin%isblack = RED_COLOUR return end if - t%root => connect(tl%left, tl, tl%isblack, join_right2(tl%right, k, tr)) + call disconnect(tl_left, m, tl_right, tl) + t%root => connect(tl_left, m, join_right2(tl_right, k, tr)) if (tl_isblack .and. & ((rbnode_isblack(t%root%right) .eqv. RED_COLOUR) .and. & @@ -1225,11 +1242,11 @@ recursive function join_left2(tl, k, tr) result(tjoin) type(rbnode_t), intent(in), pointer :: tl, tr, k type(rbnode_t), pointer :: tjoin + type(rbnode_t), pointer :: tr_left, tr_right, m type(rbbasetree_t) :: t logical(int8) :: tr_isblack -print *, 'in join_left2 ',print_node(tl)//print_node(k)//print_node(tr) - ! Assert both nodes are roots + ! Assert nodes are roots if (associated(tl)) then if (associated(tl%parent)) error stop 'join_left: tl is not root' end if @@ -1240,11 +1257,13 @@ recursive function join_left2(tl, k, tr) result(tjoin) tr_isblack = rbnode_isblack(tr) if (tr_isblack .and. rbnode_blackheight(tl)==rbnode_blackheight(tr)) then - tjoin => connect(tl, k, RED_COLOUR, tr) + tjoin => connect(tl, k, tr) + tjoin%isblack = RED_COLOUR return end if - t%root => connect(join_left2(tl, k, tr%left), tr, tr%isblack, tr%right) + call disconnect(tr_left, m, tr_right, tr) + t%root => connect(join_left2(tl, k, tr_left), m, tr_right) if (tr_isblack .and. & ((rbnode_isblack(t%root%left) .eqv. RED_COLOUR) .and. & @@ -1257,137 +1276,101 @@ recursive function join_left2(tl, k, tr) result(tjoin) end function join_left2 - function connect(left, root, colour, right) result(new) - type(rbnode_t), pointer, intent(in) :: left, root, right - logical(int8), intent(in) :: colour - type(rbnode_t), pointer :: new + function connect(left, node, right) result(root) + !! connect left and right subtrees as the children of "node" + type(rbnode_t), pointer, intent(in) :: left, node, right + type(rbnode_t), pointer :: root - if (.not. associated(root)) error stop 'connect: root node nil' - new => root + if (.not. associated(node)) error stop 'connect: node is nil' - if (associated(new%left, left)) then - continue - else if (.not. associated(new%left)) then - new%left => left - else - print '("CONNECT ERR: left ptr chng ",a)', print_node(new%left)//'->'//print_node(left) - new%left => left + ! assert both sub-trees are roots + if (associated(left)) then + if (associated(left%parent)) error stop 'connect: left subtree is not root' + endif + if (associated(right)) then + if (associated(right%parent)) error stop 'connect: right subtree is not root' end if - if (associated(new%right, right)) then - continue - else if (.not. associated(new%right)) then - new%right => right - else - print '("CONNECT ERR: righ ptr chng ",a)', print_node(new%right)//'->'//print_node(right) - new%right => right - end if + ! assert node is isolated + if (associated(node%parent) .or. associated(node%left) .or. associated(node%right)) & + error stop 'connect: node is not isolated' - new%isblack = colour + ! make the connections + root => node + root%left => left + root%right => right + if (associated(root%left)) root%left%parent => root + if (associated(root%right)) root%right%parent => root + end function connect - if (associated(new%left)) then - if (associated(new%left%parent, new)) then - continue - else if (.not. associated(new%left%parent)) then - new%left%parent => new - else - print *, '("CONNECT ERR left par ptr chng '//print_node(new%left%parent)//'->'//print_node(new) - end if - end if - if (associated(new%right)) then - if (associated(new%right%parent, new)) then - continue - else if (.not. associated(new%right%parent)) then - new%right%parent => new - else - print *, '("CONNECT ERR right par ptr chng '//print_node(new%right%parent)//'->'//print_node(new) - end if + subroutine disconnect(left, node, right, root) + !! Reverse operation to "connect": disconnect left and right subtrees from + !! the root, return pointers to both subtrees and the old root + type(rbnode_t), pointer, intent(out) :: left, node, right + type(rbnode_t), pointer, intent(in) :: root + + ! assert root exists and that it is root + if (.not. associated(root)) error stop 'disconnect: root is nil' + if (associated(root%parent)) error stop 'disconnect: root is not root' + + left => root%left + node => root + right => root%right + + if (associated(left)) then + if (.not. associated(left%parent, node)) & + error stop 'disconnect: left child is not a child' + left%parent => null() + node%left => null() end if - end function connect + if (associated(right)) then + if (.not. associated(right%parent, node)) & + error stop 'disconnect: right child is not a child' + right%parent => null() + node%right => null() + end if + end subroutine disconnect recursive subroutine split2(l, k, r, t, key, cfun) !* Split tree. Nodes with a value less than "key" go to the left subtree, ! and nodes with a value larger than "key" go to the right subtree. + ! Pointers to the roots of both subtrees are returned. ! - ! If tree contains a node with the same value as "key", this node will not - ! be included in any of the sub-trees. This node can be accessed through the - ! returned pointer "key_node" and it can be freed or inserted to any of the - ! subtrees as needed. + ! If tree contains a node with the same value as "key", this node will be + ! excluded from any of the sub-trees and returned as a "k" pointer. + ! If no such node exists, a null pointer will be returned. ! - type(rbnode_t), pointer, intent(inout) :: l, r, k - !! left and right sub-trees, key node if was present in "t" + type(rbnode_t), pointer, intent(out) :: l, r, k + !! roots of left and right sub-trees, key node if it was present in "t" type(rbnode_t), pointer, intent(in) :: t integer(DATA_KIND), intent(in) :: key(:) procedure(compare_fun) :: cfun - type(rbnode_t), pointer :: tmp - nullify(l, k, r) - if (.not. associated(t)) then - l => null(); k => null(); r => null() - return - end if + type(rbnode_t), pointer :: l1, r1, m + + l => null(); k => null(); r => null() + if (.not. associated(t)) return ! assert T is already a root of a tree if (associated(t%parent)) error stop 'split - working node must be root' - select case(cfun(key, rbnode_read(t))) - case(0) ! key == old_root%key -print *, 'split found key ', print_node(t) - l => t%left - if (associated(l)) l%parent=>null() - r => t%right - if (associated(r)) r%parent=>null() + call disconnect(l, m, r, t) - ! the key-node will no longer be part of any sub-tree - k => t - k%left => null() ! TODO reconsider!!! - k%right => null() - k%parent => null() + select case(cfun(key, rbnode_read(m))) + case(0) ! key == old_root%key + k => m case(-1) ! key < old_root%key - tmp => t%right - if (associated(t%left)) t%left%parent=>null() - if (associated(t%right)) t%right%parent=>null() - call split2(l, k, r, t%left, key, cfun) - nullify(t%left, t%right) - r => join2(r, t, tmp) - - ! TODO is this needed? - ! While "join" returns a correct root node, the parent pointer of the root - ! to the other tree must be nullified here. - if (associated(l)) then - select case(rbnode_whichchild(l)) - case(LEFT_CHILD) - l%parent%left => null() - l%parent => null() - case(RIGHT_CHILD) - l%parent%right => null() - l%parent => null() - case(NO_PARENT) - end select - end if + call split2(l1, k, r1, l, key, cfun) + l => l1 + r => join2(r1, m, r) case(+1) ! key > old_root%key - if (associated(t%right)) t%right%parent=>null() - if (associated(t%left)) t%left%parent=>null() - call split2(l, k, r, t%right, key, cfun) - tmp => t%left - nullify(t%left, t%right) - l => join2(tmp, t, l) - - if (associated(r)) then - select case(rbnode_whichchild(r)) - case(LEFT_CHILD) - r%parent%left => null() - r%parent => null() - case(RIGHT_CHILD) - r%parent%right => null() - r%parent => null() - case(NO_PARENT) - end select - end if + call split2(l1, k, r1, r, key, cfun) + r => r1 + l => join2(l, m, l1) case default error stop 'split: user function returned invalid value' @@ -1523,6 +1506,8 @@ function rbbasetree_isvalid(this, cfun) result(isvalid) integer :: nblacks call rbnode_validate(this%root, cfun, isvalid, nblacks) + if (associated(this%root)) isvalid = isvalid .and. & + .not. associated(this%root%parent) end function rbbasetree_isvalid recursive subroutine rbnode_validate(root, cfun, isvalid, nblacks) diff --git a/test/check.f90 b/test/check.f90 index b1f71d0..b620f39 100644 --- a/test/check.f90 +++ b/test/check.f90 @@ -9,9 +9,9 @@ end subroutine test2 end interface !call tree_test_basic() - !call tree_test_joinsplit() + call tree_test_joinsplit() !call tree_test_union() ! NICE - call tree_test_playground + !call tree_test_playground stop call test1() diff --git a/test/tree_test.f90 b/test/tree_test.f90 index 467eb73..c96498a 100644 --- a/test/tree_test.f90 +++ b/test/tree_test.f90 @@ -104,14 +104,16 @@ subroutine tree_test_union() end subroutine tree_test_union + + subroutine tree_test_joinsplit() type(rbbasetree_t) :: t1, t2, t12, k - type(rbnode_t), pointer :: cursor1, cursor2 + type(rbnode_t), pointer :: cursor1, cursor2, cursork integer, allocatable :: x(:) integer :: i, isplit - logical :: passed + logical :: passed, rejoined real :: time(2), xr - integer, parameter :: N=50 + integer, parameter :: N=25000000 800 format(a,": nodes = ",i0," black_h = ",i0," valid? ",l2) @@ -128,7 +130,7 @@ subroutine tree_test_joinsplit() end do call end_stopwatch(time) - print 800, 'Tree 12', t12%size(), t12%blackheight(), t12%isvalid(tree_test_basic_comp) + print 800, 'tree', t12%size(), t12%blackheight(), t12%isvalid(tree_test_basic_comp) passed = t12%isvalid(tree_test_basic_comp) print '("Allocated nodes counter ",i0)', allocation_counter @@ -141,89 +143,113 @@ subroutine tree_test_joinsplit() call split2(t1%root, k%root, t2%root, t12%root, transfer(isplit,mold), tree_test_basic_comp) call end_stopwatch(time) - print 800, 'Tree 1', t1%size(), t1%blackheight(), t1%isvalid(tree_test_basic_comp) - print 800, 'Tree 2', t2%size(), t2%blackheight(), t2%isvalid(tree_test_basic_comp) - passed = passed .and. t1%isvalid(tree_test_basic_comp) .and. t2%isvalid(tree_test_basic_comp) + print 800, 'splitted left', t1%size(), t1%blackheight(), t1%isvalid(tree_test_basic_comp) + print 800, 'splitted right', t2%size(), t2%blackheight(), t2%isvalid(tree_test_basic_comp) + passed = passed .and. t1%isvalid(tree_test_basic_comp) .and. & + t2%isvalid(tree_test_basic_comp) .and. k%isvalid(tree_test_basic_comp) call t1%graphviz('tree_1', get_node_label) call t2%graphviz('tree_2', get_node_label) - call traverse(t1, 'L') - call traverse(t2, 'R') + !call traverse(t1, 'L') + !call traverse(t2, 'R') call traverse(k, 'K') print '("Allocated nodes counter ",i0)', allocation_counter - stop + ! verify split did not loose any nodes + call start_stopwatch('verifying splits',time) + cursor1 => t1%leftmost() + cursor2 => t2%leftmost() + cursork => k%leftmost() + do i=1, N + if (x(i) cursor1%nextnode() + cycle + end if + else if (x(i)>isplit) then + if (associated(cursor2)) then + passed = passed .and. transfer(rbnode_read(cursor2),1)==x(i) + cursor2 => cursor2%nextnode() + cycle + end if + else ! x(i)==isplit + if (associated(cursork)) then + passed = passed .and. transfer(rbnode_read(cursork),1)==x(i) + cursork => cursork%nextnode() + cycle + end if + end if + passed = .false. + end do + ! all cursors must be byond the last node + passed = passed .and. (.not. associated(cursor1)) .and. (.not. associated(cursor2)) .and. (.not. associated(cursork)) + call end_stopwatch(time) - print 800, 'Tree 12', t12%size(), t12%blackheight(), t12%isvalid(tree_test_basic_comp) - passed = t12%isvalid(tree_test_basic_comp) + ! JOIN trees again (if split was not in tree, we skip this part) + if (k%size()>0) then + call start_stopwatch('re-joining trees',time) + t12%root => join2(t1%root, k%root, t2%root) + call end_stopwatch(time) + + print 800, 're-joined', t12%size(), t12%blackheight(), t12%isvalid(tree_test_basic_comp) + passed = passed .and. t12%isvalid(tree_test_basic_comp) + call t1%graphviz('tree_12', get_node_label) + call traverse(t12, 'L+R') + + ! check that all nodes are present in the joined tree + call start_stopwatch('verifying re-join',time) + cursor1 => t12%leftmost() + do i=1, N + if (associated(cursor1)) then + passed = passed .and. transfer(rbnode_read(cursor1),1)==x(i) + cursor1 => cursor1%nextnode() + cycle + end if + passed = .false. + end do + ! cursors must be byond the last node + passed = passed .and. (.not. associated(cursor1)) + call end_stopwatch(time) + rejoined = .true. + else + print '("join operation skipped, rerun test if needed")' + rejoined = .false. + end if + + ! Delete all trees + call start_stopwatch('deleting nodes', time) + if (rejoined) then + call delete_whole_tree(t12) + else + call delete_whole_tree(t1) + call delete_whole_tree(t2) + end if + call end_stopwatch(time) print '("Allocated nodes counter ",i0)', allocation_counter + passed = passed .and. allocation_counter==0 + if (passed) then + print '("Join/Split test: PASS")' + else + print '("Join/Split test: FAIL")' + end if - !print '("Insertion L - Valid? ",L2," black height is ",i0)', & - ! tree_a%isvalid(tree_test_basic_comp), tree_a%blackheight() - - !do i=NTOT, IMID+1, -2 - !do i=NMID+1, NRIGHT - ! call rbnode_insert(tree_b, rbnode_t(transfer(i,mold)), tree_test_basic_comp, ierr) - ! if (ierr/=0) print *, 'Insert ierr = ',ierr - !end do - !print '("Insertion R - Valid? ",L2," black height is ",i0)', & - ! tree_b%isvalid(tree_test_basic_comp), tree_b%blackheight() - - !call tree_a%graphviz('our_a', get_node_label) - !call tree_b%graphviz('our_b', get_node_label) - !call traverse(tree_a,'tree_a') - !call traverse(tree_b,'tree_b') - - !tree_ab%root => join(tree_a%root, transfer(IMID,mold), tree_b%root) - !print '("Join L+R - Valid? ",L2," black height is ",i0)', & - ! tree_ab%isvalid(tree_test_basic_comp), tree_ab%blackheight() - - !call tree_ab%graphviz('our_ab', get_node_label) - !call traverse(tree_ab,'tree_ab') - - ! Split - !print * - !print *, 'SPLIT' - !call split(tree_a%root,key_in_tree,tree_b%root, & - ! tree_ab%root, transfer(ISPLIT,mold), tree_test_basic_comp) - !print '("Split: key_in_tree ",L2)', associated(key_in_tree) - !if (associated(key_in_tree)) then - ! print *, 'Key =',transfer(rbnode_read(key_in_tree),i) - ! call rbnode_free(key_in_tree) - !end if - !print '("Insertion L - Valid? ",L2," black height is ",i0)', & - ! tree_a%isvalid(tree_test_basic_comp), tree_a%blackheight() - !print '("Insertion R - Valid? ",L2," black height is ",i0)', & - ! tree_b%isvalid(tree_test_basic_comp), tree_b%blackheight() - !call tree_a%graphviz('our_c', get_node_label) - !call tree_b%graphviz('our_d', get_node_label) - !call traverse(tree_b,'tree_b') - !call traverse(tree_a,'tree_a') - - ! Delete everything - print * - print *, 'DELETE' - !do i=1,NRIGHT - ! call rbnode_delete(tree_ab, rbnode_find(tree_ab%root, transfer(i,mold), tree_test_basic_comp)) - !end do - !do i=2,min(ISPLIT-1,NTOT),2 - ! call rbnode_delete(tree_a, rbnode_find(tree_a%root, transfer(i,mold), tree_test_basic_comp)) - !end do - !do i=ISPLIT+2-mod(ISPLIT,2), NTOT,2 - ! call rbnode_delete(tree_b, rbnode_find(tree_b%root, transfer(i,mold), tree_test_basic_comp)) - !end do - - !print '("Empty tree - Valid? ",L2," black height is ",i0)', & - ! tree_ab%isvalid(tree_test_basic_comp), tree_ab%blackheight() - !print '("Empty tree - Valid? ",L2," black height is ",i0)', & - ! tree_a%isvalid(tree_test_basic_comp), tree_a%blackheight() - !print '("Empty tree - Valid? ",L2," black height is ",i0)', & - ! tree_b%isvalid(tree_test_basic_comp), tree_b%blackheight() - !print *, 'Allocated nodes zero? =', allocation_counter + contains + subroutine delete_whole_tree(tree) + type(rbbasetree_t), intent(inout) :: tree + type(rbnode_t), pointer :: cnow + do + cnow => tree%leftmost() + if (.not. associated(cnow)) exit + call rbnode_delete(tree, cnow) + end do + end subroutine end subroutine tree_test_joinsplit + + subroutine tree_test_basic() integer, parameter, dimension(*) :: DATA=[10, 5, 7, 8, 9, 11, 12, 13] integer, parameter :: NSIZE = 52 @@ -289,7 +315,7 @@ subroutine tree_test_playground() integer, parameter, dimension(*) :: & x1 = [20, 4], & x2 = [40, 50, 60] - integer, parameter :: KEY=31, KSPLIT=30 + integer, parameter :: KEY=31, KSPLIT=31 integer :: i do i=1, max(size(x1), size(x2)) ! Insert nodes