! pointer4.f90

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

! made "insert" non recursive and balanced
! added more to "delete" subroutine

program pointer4
  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 *, " pointer4, made insert balanced 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 output(root_ptr)
  call insert(root_ptr, "D ", "4 ")
  call output(root_ptr)
  call insert(root_ptr, "E ", "5 ")
  call output(root_ptr)
  call insert(root_ptr, "F ", "6 ")
  call output(root_ptr)
  call insert(root_ptr, "G ", "7 ")
  call output(root_ptr)
  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 output(root_ptr)
  print *, " deleting L"
  call delete(root_ptr, "L ")
  call output(root_ptr)
  print *, " find L ", find(root_ptr, "L ")   ! gone
  print *, " deleting H"
  call delete(root_ptr, "H ")
  call output(root_ptr)
  print *, " find H ", find(root_ptr, "H ")   ! gone
  print *, " pointer4 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 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
        if(name /= p%name) return
                                           ! found, do delete cases
        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
          print *, " have a node to replace the deleted node ", p2%name

        else if (associated(p%left) .and. .not.associated(p%right)) then
          print *, " left, right=null  not implemented"
        else if (.not.associated(p%left) .and. associated(p%right)) then
          print *, " left=null, right  not implemented"
        end if
        exit                                 ! have deleted node, done
      end if
    end do
  end subroutine delete

end program pointer4