-- Demonstrates the generic tree handling package

    WITH TEXT_IO ; USE TEXT_IO ; -- make standard text I/O available
    WITH text_handler ; USE text_handler ; -- for varying length strings
    WITH tree_handler ; -- make generic tree handling package available

    PROCEDURE treedemo IS

-- Global Types :

    TYPE sp IS ( W, O, B, A, F, G, K, M, R, N, S ) ; -- spectral types
    SUBTYPE st IS CHARACTER RANGE '0'..'9' ; -- spectral sub-types
    TYPE lc IS ( I, II, III, IV, V ) ; -- luminosity class

    TYPE spectral_class IS RECORD
       sp_type    : sp ;
       sp_sub     : st ;
       luminosity : lc ;
       extras     : text ;
    END RECORD ;

    TYPE spconv IS ARRAY ( sp ) OF CHARACTER ; -- used for type conv

-- Global Constants :

    spchar : CONSTANT spconv :=
      ( 'W', 'O', 'B', 'A', 'F', 'G', 'K', 'M', 'R', 'N', 'S' ) ;

-- Generic Package Instantiation :

-- have to predeclare ">" & output_spectral_class
    FUNCTION ">" ( left, right : spectral_class ) RETURN BOOLEAN ;
    PROCEDURE output_spectral_class ( mk : spectral_class ) ;

    PACKAGE sptree IS NEW
      tree_handler ( spectral_class, ">", output_spectral_class ) ;
    USE sptree ;

-- Global Variables :

    mk_tree : tree ; -- input data tree

    mk_class : spectral_class ; -- input from user

-- Global Exceptions :

    input_finished : exception ; -- raised when data input finished

-- Local Functions :

-- ">" => Is first spectral class "greater than" the second ?
    FUNCTION ">" ( left, right : spectral_class ) RETURN BOOLEAN IS

-- Local Variables :

    result : BOOLEAN := FALSE ; -- initialise result to FALSE

    BEGIN -- ">"

-- first test spectral types
    result := left.sp_type > right.sp_type ;
    IF NOT result AND THEN left.sp_type = right.sp_type THEN

--    test spectral sub-types
       result := left.sp_sub > right.sp_sub ;
       IF NOT result AND THEN left.sp_sub = right.sp_sub THEN

--       test luminosity class
          result := left.luminosity > right.luminosity ;
       END IF ;
    END IF ;

-- return result
    RETURN result ;

    END ">" ; ----------------------------------------------------------

-- Generic Package Instantiations :

    PACKAGE spio IS NEW ENUMERATION_IO ( sp ) ;
    PACKAGE lcio IS NEW ENUMERATION_IO ( lc ) ;
    USE spio, lcio ;

-- Local Procedures :

-- output_spectral_class => Output a spectral class.
    PROCEDURE output_spectral_class ( mk : spectral_class ) IS

    BEGIN -- output_spectral_class

-- just output components in appropriate order
    PUT ( mk.sp_type ) ;
    PUT ( mk.sp_sub ) ;
    PUT ( mk.luminosity ) ;
    PUT ( mk.extras ) ;

    END output_spectral_class ; ----------------------------------------

-- input_spectral_class => Input a spectral class one from a line.
    PROCEDURE input_spectral_class ( mk : IN OUT spectral_class ) IS

-- Description :
--  A line of input is read & then split up into the various
--  components of the type spectral class i.e. type, sub-type,
--  luminosity & extra details.

-- Local Constants :

    roman_1 : CONSTANT CHARACTER := 'I' ;
    roman_5 : CONSTANT CHARACTER := 'V' ;

-- Local Variables :

    input_line     : text ; -- line containing spectral class
    input_line_len : INTEGER ; -- length of input line
    error : BOOLEAN := TRUE ; -- error interpreting spectral class ?
    nextch : INTEGER ; -- character index

    BEGIN -- input_spectral_class

-- get a line of text
    GET ( input_line ) ;

-- check for end-of-data-input flag
    IF ch_present ( input_line, 1, '!' ) THEN
       RAISE input_finished ;
    END IF ;

-- check that input contains at least 3 characters
    input_line_len := length ( input_line ) ;
    IF input_line_len >= 3 THEN

--    try to extract a spectral type from first character of input
       FOR a_type IN sp LOOP
          IF ltr_present ( input_line, 1, spchar ( a_type ) ) THEN
             mk.sp_type := a_type ;
             error := FALSE ;
             EXIT ;
          END IF ;
       END LOOP ;

--    if no error so far try to extract spectral sub-type
       IF NOT error THEN
          error := TRUE ; -- reset so errors in next section are trapped
          FOR stype IN st LOOP
             IF stype = textch ( input_line, 2 ) THEN
                mk.sp_sub := stype ;
                error := FALSE ;
                EXIT ;
             END IF ;
          END LOOP ;
       END IF ;

--    if no error so far try to sort out luminosity class
       IF NOT error THEN
          IF ltr_present ( input_line, 3, roman_1 ) THEN
             IF ltr_present ( input_line, 4, roman_1 ) THEN
                IF ltr_present ( input_line, 5, roman_1 ) THEN

--                must be giant
                   mk.luminosity := III ;
                   nextch := 6 ;
                ELSE

--                must be intermediate giant/super-giant
                   mk.luminosity := II ;
                   nextch := 5 ;
                END IF ;
             ELSIF ltr_present ( input_line, 4, roman_5 ) THEN

--             intermediate class, giant/dwarf
                mk.luminosity := IV ;
                nextch := 5 ;
             ELSE

--             must be super-giant
                mk.luminosity := I ;
                nextch := 4 ;
             END IF ;
          ELSIF ltr_present ( input_line, 3, roman_5 ) THEN

--          main sequence type ( dwarf )
             mk.luminosity := V ;
             nextch := 4 ;
          ELSE

--          must be incorrect luminosity class
             error := TRUE ;
          END IF ;
       END IF ;

--    if no error so far extract extra info string
       IF NOT error THEN
          IF nextch <= input_line_len THEN
             mk.extras := subtext ( input_line, nextch, input_line_len ) ;
          ELSE
             set ( mk.extras, " " ) ;
          END IF ;
       END IF ;
    END IF ;

-- if an error has occured then raise exception for data errors
    IF error THEN
       RAISE data_error ;
    END IF ;

    END input_spectral_class ; -----------------------------------------

    BEGIN -- treedemo

    LOOP -- loop indefinately
       PUT ( "? Spectral Class > " ) ;
       input_spectral_class ( mk_class ) ;
       insert ( mk_tree, mk_class ) ;
    END LOOP ;


-- exception handler => catch end of data input
    EXCEPTION

       WHEN input_finished =>

          NEW_LINE ; PUT ( "Tree is as follows :" ) ; NEW_LINE ;
          NEW_LINE ; put ( mk_tree ) ;

    END treedemo ; -----------------------------------------------------