Experiment with join

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

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()

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)