with TEXT_IO ; use TEXT_IO ;

procedure TACCESS7 is  -- NOW, PRED, SUCC and DELETE procedures 

  type NODE ;  -- just introduce type name
  type NODE_PTR is access NODE ;  -- define an access type
  type NODE is  -- now, really define the type NODE
     
    record BF : INTEGER ;  -- balance factor for later use
      LEFT : NODE_PTR ;  -- this records predecessor
      RIGHT : NODE_PTR ;  -- this records sucessor
      NAME : STRING ( 1 .. 2 ) ;  -- data, the "sort" key
      PHONE : STRING ( 1 .. 2 ) ;  -- more tag along data
    end record ;
  ROOT_PTR : NODE_PTR := null ;  -- initially null
  TEMP_PTR : NODE_PTR ;
  MY_NAME : STRING ( 1 .. 2 ) ;
  MY_PHONE : STRING ( 1 .. 2 ) ;
  DEPTH : INTEGER := 1 ;  -- indentation depth

  procedure OUTPUT ( T : NODE_PTR ) is  -- remains recursive

    procedure INDENT is

    begin
      for I in 1 .. DEPTH loop
        PUT ( "    " ) ;
      end loop ;
    end INDENT ;
  begin
    DEPTH := DEPTH + 1 ;  -- count depth "down" upon entry
    if T /= null then
      OUTPUT ( T.LEFT ) ;
      INDENT ;
      PUT ( T.NAME ) ;
      PUT_LINE ( T.PHONE ) ;
      OUTPUT ( T.RIGHT ) ;
    end if ;
    DEPTH := DEPTH - 1 ;  -- count depth "up" upon exit
  end OUTPUT ;

  procedure INSERT ( T : in out NODE_PTR ;
                     NAME , PHONE : STRING ) is

    P , Q : NODE_PTR := T ;  -- working pointer to walk tree
    type CHILD is ( ROOT , LEFT , RIGHT ) ;
    FROM : CHILD := ROOT ;
  begin
    while P /= null loop
      if NAME < P.NAME then
        Q := P ;  -- save parent
        P := P.LEFT ;  -- smaller, go left
        FROM := LEFT ;
      elsif NAME > P.NAME then
        Q := P ;  -- save parent
        P := P.RIGHT ;  -- bigger, go right
        FROM := RIGHT ;
      else  -- name already in phone book, just update phone number
        P.PHONE := PHONE ;
        return ;  -- done. No new node created
      end if ;
    end loop ;

    case FROM is
      when ROOT =>
        T := new NODE' ( 0 , null , null , NAME , PHONE ) ;
      when LEFT =>
        Q.LEFT := new NODE' ( 0 , null , null , NAME , PHONE ) ;
      when RIGHT =>
        Q.RIGHT := new NODE' ( 0 , null , null , NAME , PHONE ) ;
    end case ;
  end INSERT ;

  function FIND ( T : NODE_PTR ;
                  NAME : STRING ) return STRING is

    PHONE : STRING ( 1 .. 2 ) := "**" ;  -- default ** for no find
    P : NODE_PTR := T ;  -- initial node pointer
  begin
    while P /= null loop  -- this is the search loop
      if NAME < P.NAME then
        P := P.LEFT ;  -- go looking left
      elsif NAME > P.NAME then
        P := P.RIGHT ;  -- go looking right
      else  -- found name
        PHONE := P.PHONE ;
        exit ;  -- exit loop
      end if ;
    end loop ;  -- falls through for "no find", "exits" for find
    return PHONE ;
  end FIND ;

  function PRED ( T : NODE_PTR ) return NODE_PTR is

    P : NODE_PTR := T.LEFT ;  -- initial node pointer to left is smaller
  begin
    if P = null then
      return null ;  -- No predecessor
    else
      while P.RIGHT /= null loop
        P := P.RIGHT ;
      end loop ;
      return P ;
    end if ;
  end PRED ;

  function SUCC ( T : NODE_PTR ) return NODE_PTR is

    P : NODE_PTR := T.RIGHT ;  -- initial node pointer to right is larger
  begin
    if P = null then
      return null ;  -- No successor
    else
      while P.LEFT /= null loop
        P := P.LEFT ;
      end loop ;
      return P ;
    end if ;
  end SUCC ;

  procedure DELETE ( T : NODE_PTR ;
                     NAME : STRING ) is

    P : NODE_PTR := T ;  -- initial node pointer
    Q : NODE_PTR := T ;  -- scratch pointer used to get R
    R : NODE_PTR := T ;  -- parent of P if not equal P

    procedure DELETE_NODE ( T , R , P : NODE_PTR ) is

    begin

--         eliminate special cases
      if P.LEFT = null and
         P.RIGHT = null then
        if R.RIGHT = P then
          R.RIGHT := null ;
        elsif R.LEFT = P then
          R.LEFT := null ;
        end if ;
      end if ;
    end DELETE_NODE ;
  begin
    while P /= null loop  -- this is the search loop
      R := Q ;
      Q := P ;
      if NAME < P.NAME then
        P := P.LEFT ;  -- go looking left
      elsif NAME > P.NAME then
        P := P.RIGHT ;  -- go looking right
      else  -- found name

-- DELETE NODE
        PUT_LINE ( "T,R,Q,P = " & T.NAME & " " & R.NAME & " " & Q.NAME & " " &
            P.NAME ) ;
        DELETE_NODE ( T , R , P ) ;
        return ;
      end if ;
    end loop ;  -- falls through for "no find"
  end DELETE ;
begin
  PUT_LINE ( " TREE INSERTION AND PRINTOUT" ) ;

-- build a tree using the INSERT procedure
  INSERT ( ROOT_PTR , "D " , "4 " ) ;  -- initial node at root

-- first tier
  INSERT ( ROOT_PTR , "B " , "2 " ) ;
  INSERT ( ROOT_PTR , "F " , "6 " ) ;

-- second tier
  INSERT ( ROOT_PTR , "A " , "1 " ) ;
  INSERT ( ROOT_PTR , "C " , "3 " ) ;
  INSERT ( ROOT_PTR , "E " , "5 " ) ;
  INSERT ( ROOT_PTR , "G " , "7 " ) ;
  OUTPUT ( ROOT_PTR ) ;  -- look at tree produced. The order of the tree

-- build was carefully planned to get a balanced
-- binary tree
  MY_NAME := "E " ;
  MY_PHONE := FIND ( ROOT_PTR , MY_NAME ) ;  -- test FIND function
  PUT_LINE ( MY_NAME & " has a phone number " & MY_PHONE ) ;
  MY_PHONE := FIND ( ROOT_PTR , "D " ) ;  -- test FIND function on root
  PUT_LINE ( "D " & " has a phone number " & MY_PHONE ) ;
  MY_PHONE := FIND ( ROOT_PTR , "XX" ) ;  -- test FIND function on name

-- not in directory
  PUT_LINE ( "XX" & " has a phone number " & MY_PHONE ) ;
  TEMP_PTR := PRED ( ROOT_PTR ) ;
  PUT_LINE ( " Predecessor of " & ROOT_PTR.NAME & " is " & TEMP_PTR.NAME ) ;
  TEMP_PTR := SUCC ( ROOT_PTR ) ;
  PUT_LINE ( " Successor of " & ROOT_PTR.NAME & " is " & TEMP_PTR.NAME ) ;
  DELETE ( ROOT_PTR , "G " ) ;
  OUTPUT ( ROOT_PTR ) ;
  DELETE ( ROOT_PTR , "A " ) ;
  OUTPUT ( ROOT_PTR ) ;
  DELETE ( ROOT_PTR , "D " ) ;
  OUTPUT ( ROOT_PTR ) ;
end TACCESS7 ;