-- Demonstration of the generic sorting package. WITH TEXT_IO ; USE TEXT_IO ; -- make standard text I/O available WITH text_handler ; USE text_handler ; -- varying length strings WITH gensort ; -- make generic sorting package available PROCEDURE sortdemo2 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 spvec IS ARRAY ( INTEGER RANGE <> ) OF spectral_class ; 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' ) ; -- Global Variables : test_array : spvec ( 1..10 ) ; -- array to be sorted -- 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 scsort IS NEW gensort ( spectral_class, spvec, ">" ) ; PACKAGE spio IS NEW ENUMERATION_IO ( sp ) ; PACKAGE lcio IS NEW ENUMERATION_IO ( lc ) ; USE scsort, spio, lcio ; -- Local Procedures : -- 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 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 firts 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 ; ----------------------------------------- -- 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 ; ---------------------------------------- BEGIN -- sortdemo2 -- get values for array to be sorted FOR index IN test_array'RANGE LOOP PUT ( "? Spectral Class > " ) ; input_spectral_class ( test_array ( index ) ) ; END LOOP ; -- sort this array quicksort ( test_array ) ; NEW_LINE ; PUT_LINE ( "Sorted :" ) ; NEW_LINE ; -- write out results FOR index IN test_array'RANGE LOOP output_spectral_class ( test_array ( index ) ) ; NEW_LINE ; END LOOP ; END sortdemo2 ; ----------------------------------------------------