ROMS/TOMS Developers

Back in June I wrote about a balanced binary tree problem I was having. We have since come up with a C++ solution and it’s working really well, though we have to link to some extra C++ stuff.

Today, out of the blue, I got an email from David Car who not only read the original blog post, but sent me a version which actually runs! This is what he had to say:

I came across your Fortran implementation of the Red Black Tree while reading a post by Mike Page on LinkedIn. I’ve attached an implementation that works built on what you did. At the moment I’m scratching my head as to why I had to do what I did in the attached code. Basically, I tracked down that in rotate_left (and rotate_right), the pointer x was reassigned to x%parent after the line

y%parent => x%parent

i.e. between your print statements. I don’t know why that happens. I discovered this by stepping through that section with gdb and also ran valgrind on it. You probably noticed that too. What I did was to simply treat the dummy argument to rotate_left(…) as simply a treenode with the target attribute rather than a pointer. I then use a local pointer x to point to it and it works fine. I often do this because it allows me to pass in a pointer or a an actual type as a dummy argument, but in this case it fixed the problem. I’m trying to track down why this is and will let you know what I find. I did some rearranging of the code and created a RedBlackTree type and a few other things.

BTW, I say your recent blog post on git. I think git is the best version control out there. I hope you find the same.

He later sent me this link which explains what happened.

Who is this person, you ask? This is what he’s up to:

BTW, I have written a templating preprocessor for Fortran 95/2003. I’m not sure how familiar you are with generic programming, but since you’re using C++, you are most likely knowledgeable in the Standard Template Library. I know of two other projects that try to provide this kind of capability in Fortran: Forpedo and Parametric Fortran. My project tried to achieve a more native look and feel to the language. The pre-processor is written in Python and I’m working on the Wiki. I have an ACM Fortran Forum article coming up in April on it. The main site is:

blockit

You’ll want to look at the Wiki for more documentation (link is in the upper left). The project comes with PyF95++ which is the templating preprocessor front end. It also included a pretty good start to a standard template library in Fortran. It has different types of linked lists, hashtable, pairs, etc. that are all generic containers, i.e. templated. It also has a unit testing framework for Fortran. You may have colleagues that could use such functionality in Fortran. It’s all under the MIT license. All the best.

Edit: A few days, a few iterations later, the code now looks like:

MODULE mod_tree
!
!================================================== Kate Hedstrom ======
!    Fixes and improvements by David Car (david.car7@gmail.com)        !
!=======================================================================
!  Copyright (c) 2002-2010 The ROMS/TOMS Group                         !
!    Licensed under a MIT/X style license                              !
!    See License_ROMS.txt                                              !
!=======================================================================
!  Set up tree structure and functions.                                !
!=======================================================================
!
  implicit none  !................................................................................
  type treenode
     type(treenode), pointer :: left => null()
     type(treenode), pointer :: right => null()
     type(treenode), pointer :: parent => null()
     logical :: red = .FALSE.
     integer :: eggs = 0 
     real(kind=8)  :: dist = 0.d0
  end type treenode

  type RedBlackTree
     type(treenode), pointer :: root => null()
     integer :: nitems = 0
  end type RedBlackTree
  !................................................................................

  !................................................................................
  ! Global nil node for leaves and parent of root.
  !................................................................................
  type(treenode), target, save :: nil

  PUBLIC :: insert, RedBlackTree
  PRIVATE :: nil

CONTAINS

  SUBROUTINE init(this)
    type (RedBlackTree) :: this
    this%root => nil
  END SUBROUTINE init

  !................................................................................  SUBROUTINE insert(this, eggs, dist)
    !..............................................................................    
    ! Insert a node into the tree
    !..............................................................................
    type (RedBlackTree), target :: this
  
    integer, intent(in) :: eggs
    real(kind=8), intent(in) :: dist
    type(treenode), pointer :: cur, p, x, y

    ! Empty tree, deposit eggs at the top
    if (.not. associated(this % root)) return

    ALLOCATE(cur)
    cur % eggs = eggs
    cur % dist = dist
    cur % left => nil
    cur % right => nil
    this % nitems = this % nitems + 1

    IF (ASSOCIATED(this % root, nil)) THEN
       this % root => cur
       this % root % parent => nil
       RETURN
    ENDIF

    ! Otherwise find somewhere to put these eggs
    ! New nodes end up at the bottom until a rebalance
    p => this%root

    DO
       IF (dist <= p % dist) THEN
          IF (.not. isLeaf(p % left)) THEN
             p => p % left
             CYCLE
          ELSE 
             p % left => cur
             cur % parent => p
             EXIT
          END IF
       ELSE
          IF (.not. isLeaf(p % right)) THEN
             p => p % right
             CYCLE 
          ELSE
             p % right => cur
             cur % parent => p
             EXIT
          END IF
       END IF
    END DO
    ! Balance the thing... red-black for now, until I get smarter about
    ! balancing eggs.
    cur % red = .true.
    x => cur
    p => null()

    DO WHILE (x % parent % red)
       IF (ASSOCIATED(x % parent % parent % left, x % parent)) THEN
          y => x % parent % parent % right   ! uncle
          IF (y % red) THEN
             x % parent % red = .false.
             y % red = .false.
             x % parent % parent % red = .true.
             x => x % parent % parent
          ELSE
             IF (ASSOCIATED(x, x % parent % right)) THEN
                x => x % parent
                CALL rotate_left(this, x)
             END IF
             x % parent % red = .false.
             x % parent % parent % red = .true.
             CALL rotate_right(this, x % parent % parent)
          END IF
       ELSE
          ! Must be right grandchild to get here
          y => x % parent % parent % left    ! aunt
          IF (y % red) THEN
             x % parent % red = .false.
             y % red = .false.
             x % parent % parent % red = .true.
             x => x % parent % parent
          ELSE 
             IF (ASSOCIATED(x, x % parent % left)) THEN
                x => x % parent
                CALL rotate_right(this, x)
             END IF
             x % parent % red = .false.
             x % parent % parent % red = .true.
             CALL rotate_left(this, x % parent % parent)
          END IF
       END IF
    END DO

    this % root % red = .false.

  END SUBROUTINE insert

  !
  ! For the rotating, I’m working from C code I found online for red-black trees,
  ! with reference to Introduction to Algorithms by Cormen, Leiserson,
  ! Rivest (Chapter 14). It makes right child of x into the parent of x.

  !................................................................................
  SUBROUTINE rotate_left(this, x_)
    !..............................................................................
    ! Rotate node x_ to the left in tree `this`
    !..............................................................................
    type(RedBlackTree), intent(inout) :: this
    type(treenode), target, intent(inout) :: x_
    type(treenode), pointer :: x => null()
    type(treenode), pointer :: y => null()
    integer :: mine, theirs

    x => x_
    y => x % right
    x % right => y % left

    IF (.not. isLeaf(y % left)) THEN
       y % left % parent => x
    END IF

    y % parent => x % parent

    IF (ASSOCIATED(x % parent, nil)) THEN
       this % root => y
    ELSE
       IF (ASSOCIATED(x, x % parent % left)) THEN
          x % parent % left => y
       ELSE
          x % parent % right => y
       ENDIF
    END IF
    y % left => x
    x % parent => y
  END SUBROUTINE rotate_left
    
  !................................................................................
  SUBROUTINE rotate_right(this, x_)
    !.............................................................................. 
    ! Rotate node x_ to the right in tree `this`
    !..............................................................................
    type(RedBlackTree), intent(inout) :: this
    type(treenode), target, intent(inout) :: x_
    type(treenode), pointer :: x => null()
    type(treenode), pointer :: y => null()

    x => x_
    y => x % left
    x % left => y % right
    
    IF (.not. isLeaf(y % right)) THEN
       y % right % parent => x
    END IF

    y % parent => x % parent

    IF (ASSOCIATED(x % parent, nil)) THEN
       this % root => y
    ELSE
       IF (ASSOCIATED(x, x % parent % right)) THEN
          x % parent % right => y
       ELSE
          x % parent % left => y
       ENDIF
    END IF
    y % right => x
    x % parent => y
  END SUBROUTINE rotate_right

  !................................................................................
  ! None of these are used at the moment
  !................................................................................

  !................................................................................
  FUNCTION isLeft(x, y) result(b)
    !..............................................................................
    ! Check if node y is left child of x
    !..............................................................................
    type (treenode), pointer :: x, y
    logical :: b
    
    b = ASSOCIATED(x % left, y)
  END FUNCTION isLeft

  !................................................................................
  FUNCTION isRight(x, y) result(b)
    !..............................................................................
    ! Check if node y is right child of x
    !..............................................................................
    type (treenode), pointer :: x, y
    logical :: b

    b = ASSOCIATED(x % right, y)
  END FUNCTION isRight

  !................................................................................
  FUNCTION isLeaf(x) result(b)
    !..............................................................................
    ! Check if node x is a leaf
    !..............................................................................
    type (treenode), pointer :: x
    logical :: b
    b = ASSOCIATED(x, nil)
  END FUNCTION isLeaf
END MODULE mod_tree


!................
! Test code
!................
program main
  use mod_tree
  implicit none
  integer, parameter :: num = 8
  type(RedBlackTree) :: tree
  integer :: caviar(num)
  real(kind=8)  :: dist(num)
  integer :: i

  dist = (/ 21, 2, 3, 56, 78, 5, 7, 4 /)
  caviar = 100*dist

  call init(tree)

  do i=1,num
     call insert(tree, caviar(i), dist(i))
  end do

  print *, 'Done'

end program main