! pointer5.f90

! This is the fifth of a series of programs to demonstrate use
! of derived types and pointers.

! add an "output_by_level" subroutine, non recursive, non looping
! added more to "delete" subroutine

program pointer5
  implicit none

  ! define the type "node" to be a node in a tree
  type node
    integer (kind=selected_int_kind(1)) :: BF    ! balance factor
    type (node), pointer                :: left  ! left tree branch (smaller)
    type (node), pointer                :: right ! right tree branch (larger)
    character (len=2)                   :: name  ! sort key (can be any type)
    character (len=2)                   :: phone ! any amount of stuff
  end type node

  type (node), pointer :: root_ptr               ! the root of the tree
  integer :: depth = 0
  integer, parameter :: balanced = 0  ! state of BF
  integer, parameter :: right_hi = 1  ! state of BF
  integer, parameter :: left_big = -1 ! state of BF

  print *, " pointer5, output_by_level and added to delete"
  nullify(root_ptr)                              ! begin with empty tree

  ! build the tree to test the "insert" and "output" procedures
  ! note the worse order for previous insert
  !
  !                            H 8
  !                         /        \
  !                       /            \
  !                     /                \
  !                 D 4                    L 12
  !                /   \                   /   \
  !              /       \               /       \
  !           B 2         F 6         J 10        N 14
  !          /   \       /   \       /   \       /    \
  !        A 1   C 3   E 5   G 7   I 9   K 11  M 13   O 15

  call insert(root_ptr, "A ", "1 ")
  call insert(root_ptr, "B ", "2 ")
  call insert(root_ptr, "C ", "3 ")
  call insert(root_ptr, "D ", "4 ")
  call insert(root_ptr, "E ", "5 ")
  call insert(root_ptr, "F ", "6 ")
  call insert(root_ptr, "G ", "7 ")
  call insert(root_ptr, "H ", "8 ")
  call insert(root_ptr, "I ", "9 ")
  call insert(root_ptr, "J ", "10")
  call insert(root_ptr, "K ", "11")
  call insert(root_ptr, "L ", "12")
  call insert(root_ptr, "M ", "13")
  call insert(root_ptr, "N ", "14")
  call insert(root_ptr, "O ", "15")
  call insert(root_ptr, "Z0", "0 ")
  call insert(root_ptr, "Z1", "1 ")
  call insert(root_ptr, "Z2", "2 ")
  call insert(root_ptr, "Z3", "3 ")
  call insert(root_ptr, "Z4", "4 ")
  call insert(root_ptr, "Z5", "5 ")
  call insert(root_ptr, "Z6", "6 ")
  call insert(root_ptr, "Z7", "7 ")
  call insert(root_ptr, "Z8", "8 ")
  call insert(root_ptr, "Z9", "9 ")
  call insert(root_ptr, "ZA", "A ")
  call insert(root_ptr, "ZB", "B ")
  call insert(root_ptr, "ZC", "C ")
  call insert(root_ptr, "ZD", "D ")
  call insert(root_ptr, "ZE", "E ")
  call insert(root_ptr, "ZF", "F ")
  call output(root_ptr)
  print *, " deleting A"
  call delete(root_ptr, "A ")
  call output(root_ptr)
  print *, " deleting B"
  call delete(root_ptr, "B ")
  call output(root_ptr)
  print *, " deleting ZF"
  call delete(root_ptr, "ZF")
  call output(root_ptr)
  print *, " deleting ZE"
  call delete(root_ptr, "ZE")
  call output(root_ptr)
  print *, " deleting L"
  call delete(root_ptr, "L ")
  call output_by_level(root_ptr)
  call output(root_ptr)
  print *, " find L ", find(root_ptr, "L ")   ! gone
  print *, " deleting H"
  call delete(root_ptr, "H ")
  call output_by_level(root_ptr)
  call output(root_ptr)
  print *, " find H ", find(root_ptr, "H ")   ! gone
  print *, " deleting Z0"
  call delete(root_ptr, "Z0")
  call output_by_level(root_ptr)
  call output(root_ptr)
  print *, " deleting Z8"
  call delete(root_ptr, "Z8")
  call output_by_level(root_ptr)
  call output(root_ptr)
  print *, " deleting Z4"
  call delete(root_ptr, "Z4")
  call output_by_level(root_ptr)
  call output(root_ptr)
  print *, " pointer5 finished"
contains

  ! needed to simulate constructor  node(0, name, phone, null, null)
  function make_node(name, phone) result(new_node)
    character (len=2), intent(in) :: name
    character (len=2), intent(in) :: phone
    type (node), pointer :: new_node

    allocate(new_node)
    new_node%bf = 0                 ! initial balance factor zero
    nullify(new_node%left)          ! initial left pointer null
    nullify(new_node%right)         ! initial right pointer null
    new_node%name = name            ! fill in name
    new_node%phone = phone          ! fill in phone
  end function make_node            ! return pointer to constructed node

  ! subroutine to output an indented tree given a pointer to the root
  recursive subroutine output(t)
    type (node), pointer :: t

    if(depth==0) print *, " . . . . . . . . . . . . . . . . . . . . . . . . ."
    depth = depth + 1                    ! indentation
    if(associated(t)) then
      call output(t%left)
      print *, repeat("     ", depth), t%name, " ", t%phone
      call output(t%right)
    end if
    depth = depth -1                     ! unindent
  end subroutine output

  ! subroutine to output an indented tree by level
  subroutine output_by_level(t)
    type (node), pointer :: t
    type ptr
      type (node), pointer :: p
    end type ptr
    type (ptr), dimension(1:1024) :: used  ! hard to get array of pointers
    integer :: nused
    integer :: level
    integer :: i
    integer :: j
    integer :: n
    logical :: found
    logical :: duplicate
    character (len=4) :: flag
    type (node), pointer :: p

    print *, " . . . . . . . . . . . . . . . . . . . . . . . . ."
    if(.not.associated(t)) return
    do i=1,1024
      nullify(used(i)%p)
    end do
    used(1)%p => t
    nused = 1
    duplicate = .false.
    print *, " ", t%name, " ", t%phone
    do level=1,11
      n = 2**(level-1)
      found = .false.
      do i = 1,n
        p => used(n+i-1)%p
        if(associated(p)) then
          if(associated(p%left)) then
            flag = "    "
            do j = 1,nused
              if(associated(p%left,used(j)%p)) then
                duplicate = .true.
                flag = " ***"
              end if
            end do
            print *, repeat("     ", level), p%left%name, " ", p%left%phone,flag
            found = .true.
            used(nused+1)%p => p%left
          end if
          if(associated(p%right)) then
            flag = "    "
            do j = 1,nused+1
              if(associated(p%right,used(j)%p)) then
                duplicate = .true.
                flag = " ***"
              end if
            end do
            print *, repeat("     ", level), p%right%name, " ", p%right%phone,flag
            found = .true.
            used(nused+2)%p => p%right
          end if
        end if
        nused = nused+2
      end do
      if(.not.found) exit
      if(duplicate) then
        print *, " DUPLICATE pointer in tree at this level, LOOP!"
        stop
      end if
    end do
  end subroutine output_by_level

  ! subroutine to insert a new node into a tree, keeping it balanced
  subroutine insert(t, name, phone)
    type (node), pointer :: t
    character (len=2), intent(in) :: name
    character (len=2), intent(in) :: phone
    type (node), pointer :: p   ! working pointer
    type (node), pointer :: q   ! parent of p
    type (node), pointer :: a   ! last seen unbalanced node
    type (node), pointer :: f   ! parent of a
    type (node), pointer :: b   ! mid node of a,b,c rotate group
    type (node), pointer :: c   ! bottom node of a,b,c rotate group
    type (node), pointer :: cr  ! right child of c
    type (node), pointer :: cl  ! left child of c
    type (node), pointer :: y   ! newly created node pointer
    integer :: DBF              ! new balance factor

    if(.not. associated(t)) then
      t => make_node(name, phone)          ! new root node
      return
    end if

    p => t           ! initialization
    nullify(q)
    a => t
    nullify(f)
    nullify(b)
    nullify(c)

    do while(associated(p)) ! search for insertion point
      if (p%BF /= balanced) then
        a => p
        f => q
      end if
      if (name < p%name) then
        q => p         ! save parent
        p => p%left    ! smaller, go left
      else if (name > p%name) then
        q => p         ! save parent
        p => p%right   ! bigger, go right
      else             ! name already in book, just update phone number
        p%phone = phone
        return         ! done. No new node created
      end if
    end do

    y => make_node(name, phone)          ! new root node
    if (name < q%name) then
      q%left => y
    else
      q%right => y
    end if
    if (name > a%name) then
      p => a%right
      b => p
      DBF = right_hi
    else
      p => a%left
      b => p
      DBF = left_big
    end if
    do while (.not.associated(p,y))
      if (name > p%name) then
        p%BF = right_hi
        p => p%right
      else
        p%BF = left_big
        p => p%left
      end if
    end do
    if (a%BF == balanced) then
      a%BF = DBF
      return
    else if (( a%BF == left_big .and. DBF == right_hi) .or. &
            ( a%BF == RIGHT_HI .and. DBF == left_big)) then
      a%BF = balanced
      return
    end if
    if (DBF == left_big) then       ! left imbalance must be fixed
        if (b%BF == left_big) then  ! type LL rotation
          a%left => b%right
          b%right => a
          b%BF = balanced
          a%BF = balanced
        else              ! type LR rotation
          c => b%right
          if (.not.associated(c)) then
            return
          end if 
          cl => c%left
          cr => c%right
          b%right => cl
          a%left => cr
          c%left => b
          c%right => a
          if (c%BF == left_big) then
            a%BF = right_hi
            b%BF = balanced
          else if (c%BF == right_hi) then
            b%BF = left_big
            a%BF = balanced
          else
            b%BF = balanced
            a%BF = balanced
          end if
          c%BF = balanced
          b => c
        end if
    else  !                   right imbalance must be fixed
        if (b%BF == right_hi) then ! type RR rotation
          a%right => b%left
          b%left => a
          b%BF = balanced
          b%BF = balanced
        else                       ! type LR rotation
          c => b%left
          if (.not.associated(c)) then
            return
          end if
          cl => c%left
          cr => c%right
          b%left => cr
          a%right => cl
          c%right => b
          c%left => a
          if (c%BF == right_hi) then
            a%BF = left_big
            b%BF = balanced
          else if (c%BF == left_big) then
            b%BF = right_hi
            a%BF = balanced
          else
            b%BF = balanced
            a%BF = balanced
          end if
          c%BF = balanced
          b => c
        end if
    end if
    if (.not.associated(f)) then
      t => b
    else if (associated(a,f%left)) then
      f%left => b
    else if (associated(a,f%right)) then
      f%right => b
    end if
  end subroutine insert

  ! function to find a phone given a name
  recursive function find(t, name) result (phone)
    type (node), pointer :: t
    character (len=2), intent(in) :: name
    character (len=2) :: phone

    phone = "**"                       ! default name if not found

    if(associated(t)) then
      if(name < t%name) then
        phone = find(t%left, name)     ! smaller goes left
      else if(name > t%name) then
        phone = find(t%right, name)    ! larger goes right
      else
        phone = t%phone                ! found it
      end if
    end if
  end function find

  ! subroutine to delete a node in a tree (partial, students finish)
  subroutine delete(t, name)
    type (node), pointer :: t
    character (len=2), intent(in) :: name
    type (node), pointer :: p, p2         ! working node, walks tree
    type (node), pointer :: q, q2         ! next higher node

    if(.not.associated(t)) return
    p => t
    q => t
    do while(associated(p))
      if(name < p%name) then
        q => p
        p => p%left                          ! smaller goes left
      else if(name > p%name) then
        q => p
        p => p%right                         ! larger goes right
      else                                   ! may have found
        exit
      end if
    end do
    if(name /= p%name) return

    if((.not.associated(p%left)) .and. &
       (.not.associated(p%right))) then ! simple case, delete node
        if(associated(p,t)) then
          deallocate(t)
        else if(associated(p,q%left)) then
          deallocate(q%left)
        else  ! associated(p,q%right)
          deallocate(q%right)
        end if
    else if (associated(p%left) .and. associated(p%right)) then
        ! toughest case  find node to be deleted
        !                go left one (or go right one)
        !                go right as far as possible  (or left)
        !                this node replaces the deleted node
        q2 => p
        p2 => p%left     ! go left one
        do while(associated(p2%right))
          q2 => p2
          p2 => p2%right
        end do

        if(associated(p2%left)) then   ! more complicated
          print *, "not implemented  p2%left not null"
        else
          p2%right => p%right
          p2%left  => p%left
          if(associated(p,t)) then
            t => p2
            deallocate(p)
          else if(associated(p,q%left)) then
            if(associated(p2,q2%left)) then
              q%left => p2
              nullify(q2%left)
              deallocate(p)
            else if(associated(p2,q2%right)) then
              q%left => p2
              nullify(q2%right)
              deallocate(p)
            else
              print *, "Error 101: internal failure in delete"
            end if
          else  ! associated(p,q%right)
            if(associated(p2,q2%left)) then
              q%right => p2
              nullify(q2%left)
              deallocate(p)
            else if(associated(p2,q2%right)) then
              q%right => p2
              nullify(q2%right)
              deallocate(p)
            else
              print *, "Error 102: internal failure in delete"
            end if
          end if
        end if
    else if (associated(p%left) .and. .not.associated(p%right)) then
        if(associated(p,t)) then
          deallocate(t)
        else if(associated(p,q%left)) then
          q%left => p%left
          deallocate(p)
        else  ! associated(p,q%right)
          q%right => p%left
          deallocate(p)
        end if
    else if (.not.associated(p%left) .and. associated(p%right)) then
        if(associated(p,t)) then
          deallocate(t)
        else if(associated(p,q%left)) then
          q%left => p%right
          deallocate(p)
        else  ! associated(p,q%right)
          q%right => p%right
          deallocate(p)
        end if
    end if
  end subroutine delete

end program pointer5