!<BLF/REQUIRE'USR_LIBRARY:PRETTY'>
%TITLE 'Display an image of the Mandelbrot set, precomputed by COMPUTE'
MODULE display (MAIN = display,
		IDENT = 'V002-0'		! File: DISPLAY.BLI
		) =
BEGIN

!++
!
! FACILITY:	    DECUS pre-symposium seminar 'BLISS for Macro users' examples
!
!		    This routine will show the use of:
!
!		    Run-time library routines
!		    System services
!		    RMS
!		    Keyword macro
!		    Simple macro
!		    Require file
!		    Library file
!		    Builtins
!		    Floating point  computation
!		    INCR loops
!		    OWN storage
!		    BLOCK
!		    VECTOR
!		    ASCID
!		    PLIT
!
! ABSTRACT:
!
! ENVIRONMENT:	    VAX/VMS, user mode
!
! AUTHOR:	    Brian K Catlin
!
! CREATED:	    11-MAY-1988
!
! MODIFICATION
! HISTORY:
!
!	V002-0	Brian K Catlin	    4-MAY-1990
!		Cleanup for submission to DECUS
!
!	V001-1	Brian K Catlin	    11-MAY-1988
!		Original version
!
!
!--


%SBTTL 'Declarations'

!+
! SWITCHES:
!-

SWITCHES ADDRESSING_MODE (EXTERNAL = GENERAL, NONEXTERNAL = WORD_RELATIVE);

!+
! LINKAGES:
!-

!	None.

!+
! TABLE OF CONTENTS:
!
!   display
!-

FORWARD ROUTINE
    display;

!+
! INCLUDE FILES:
!
!-

LIBRARY 'SYS$LIBRARY:LIB';			! VMS executive macros/symbols.

LIBRARY 'USR_LIBRARY:USRLIB';			! User Definitions.

REQUIRE 'structs';				! r_header definitions

!+
! MACROS:
!-

MACRO

    !+
    ! Find first whitespace character (space, tab, cr, lf, vt, nul)
    !-

    _find_whitespace (dsc_string) =
	BEGIN

	LOCAL
	    i : LONG INITIAL (0);

	BIND
	    ab_line = .dsc_string [dsc$a_pointer] : VECTOR [, BYTE];

	WHILE ( NOT (_cvt_is_white (.ab_line [.i]) OR _cvt_is_mechan (.ab_line [.i])) AND (.i LSSU .dsc_string
	    [dsc$w_length])) DO
	    BEGIN
	    i = .i + 1;
	    END;

	.i
	END
    %;

!+
! FIELDS:
!-

!	None.

!+
! STRUCTURES:
!-

!	None.

!+
! PSECTS:
!-

!	None.

!+
! EQUATED SYMBOLS:
!-

!	None.

!+
! OWN STORAGE:
!-

!	None.

!+
! BUILTIN DECLARATIONS:
!-

BUILTIN
    CVTDL,
    CVTLD,
    ADDD,
    DIVD,
    MULD,
    SUBD;

!+
! EXTERNAL REFERENCES:
!
!	LIB$GET_INPUT	    Get input from the user
!-

EXTERNAL ROUTINE
    lib$get_input,
    usr_close_device,
    usr_display_header,
    usr_display_image,
    usr_dummy,
    usr_load_color_table,
    usr_open_device;


%SBTTL 'DISPLAY - Main entry point for this program'
ROUTINE display =

!++
!
! FUNCTIONAL DESCRIPTION:
!
! CALLING SEQUENCE:
!
!	display ()	    Called by VMS as the entry point of this program
!
! FORMAL PARAMETERS:
!
!	None.
!
! IMPLICIT INPUTS:
!
!	None.
!
! IMPLICIT OUTPUTS:
!
!	None.
!
! COMPLETION CODES:
!
!	SS$_NORMAL	Normal successful completion.
!
! SIDE AFFECTS:
!
!	None.
!
!--

    BEGIN

    LOCAL
	al_retadr : VECTOR [2, LONG],
	dsc_color : _string_desc (class = d),
	dsc_file : _string_desc (class = d),
	l_status : LONG,
	r_color_fab : $fab_decl,
	r_color_table : REF ctbldef,
	r_header : REF hdrdef,
	r_image_fab : $fab_decl,
	r_screen : REF VECTOR [, BYTE];

    !+
    ! Get the name of the image file
    !-

    IF (l_status = lib$get_input (dsc_file [0, 0, 0, 0], %ASCID'File name > '))
    THEN
	BEGIN

	!+
	! Trim off white space
	!-

	dsc_file [dsc$w_length] = _find_whitespace (dsc_file);

	!+
	! Declare the image file
	!-

	$fab_init (fab = r_image_fab [0, 0, 0, 0], 	! Address of File Access Block
	    fna = .dsc_file [dsc$a_pointer], 	! Address of file name
	    fns = .dsc_file [dsc$w_length], 	! Length of file name
	    dnm = '.pic', 			! Default file name
	    rtv = -1, 				! Mapping pointers - map entire file
	    fop = ufo);				! File operations - User File Open

	!+
	! Open the image file
	!-

	IF (l_status = $open (fab = r_image_fab [0, 0, 0, 0]))
	THEN
	    BEGIN

	    !+
	    ! Map the image file into my address space
	    !-

	    IF (l_status = $crmpsc (inadr = UPLIT (0, 0), retadr = al_retadr [0], flags = (sec$m_expreg),
		    chan = .r_image_fab [fab$l_stv]))
	    THEN
		BEGIN
		r_header = .al_retadr [0];
		r_screen = .al_retadr [0] + 512;

		!+
		! Get the name of the color table file
		!-

		IF (l_status = lib$get_input (dsc_color [0, 0, 0, 0], %ASCID'Color table name > '))
		THEN
		    BEGIN

		    !+
		    ! Trim off white space
		    !-

		    dsc_color [dsc$w_length] = _find_whitespace (dsc_color);

		    !+
		    ! Declare the color table file
		    !-

		    $fab_init (fab = r_color_fab [0, 0, 0, 0], 	! Address of File Access Block
			fna = .dsc_color [dsc$a_pointer], 	! Address of file name
			fns = .dsc_color [dsc$w_length], 	! Length of file name
			dnm = '.ctbl', 		! Default file name
			rtv = -1, 		! Mapping pointers - map entire file
			fop = ufo);		! File operations - User File Open

		    !+
		    ! Open the color table file
		    !-

		    IF (l_status = $open (fab = r_color_fab [0, 0, 0, 0]))
		    THEN
			BEGIN

			!+
			! Map the color table file into my address space
			!-

			IF (l_status = $crmpsc (inadr = UPLIT (0, 0), retadr = al_retadr [0],
				flags = (sec$m_expreg), chan = .r_color_fab [fab$l_stv]))
			THEN
			    BEGIN
			    r_color_table = .al_retadr [0];

			    !+
			    ! Pass the header to a user routine to do what ever the user
			    ! wants to do.
			    !-

			    usr_display_header (r_header [0, 0, 0, 0]);

			    !+
			    ! Call the user routine to open the graphics device
			    !-

			    usr_open_device ();

			    !+
			    ! Call the user routine to load the color table
			    !-

			    usr_load_color_table (r_color_table [0, 0, 0, 0]);

			    !+
			    ! Call the user routine to display the image data
			    !-

			    usr_display_image (r_screen [0]);

			    !+
			    ! Call the user dummy routine to do something else while
			    ! the graphics device is open
			    !-

			    usr_dummy ();

			    !+
			    ! Call the user routine to close the graphics device
			    !-

			    usr_close_device ();

			    !+
			    ! Close the color table file
			    !-

			    IF NOT (l_status = $close (fab = r_color_fab [0, 0, 0, 0]))
			    THEN
				SIGNAL (.r_color_fab [fab$l_sts], .r_color_fab [fab$l_stv]);

			    END
			ELSE
			    BEGIN

			    !+
			    ! Error mapping the color table file
			    !-

			    SIGNAL (.l_status);

			    !+
			    ! Close the image file
			    !-

			    IF NOT (l_status = $close (fab = r_image_fab [0, 0, 0, 0]))
			    THEN
				SIGNAL (.r_image_fab [fab$l_sts], .r_image_fab [fab$l_stv]);

			    END;

			END
		    ELSE
			BEGIN

			!+
			! Error opening the color table file
			!-

			SIGNAL (.r_color_fab [fab$l_sts], .r_color_fab [fab$l_stv]);

			!+
			! Close the image file
			!-

			IF NOT (l_status = $close (fab = r_image_fab [0, 0, 0, 0]))
			THEN
			    SIGNAL (.r_image_fab [fab$l_sts], .r_image_fab [fab$l_stv]);

			END;

		    END
		ELSE
		    BEGIN

		    !+
		    ! Error getting color table file name
		    !-

		    SIGNAL (.l_status);

		    !+
		    ! Close the image file
		    !-

		    IF NOT (l_status = $close (fab = r_image_fab [0, 0, 0, 0]))
		    THEN
			SIGNAL (.r_image_fab [fab$l_sts], .r_image_fab [fab$l_stv]);

		    END;

		END
	    ELSE
		BEGIN

		!+
		! Error mapping image section
		!-

		SIGNAL (.l_status);
		END;

	    END
	ELSE
	    BEGIN

	    !+
	    ! Error opening image file
	    !-

	    SIGNAL (.r_image_fab [fab$l_sts], .r_image_fab [fab$l_stv]);
	    END;

	END
    ELSE
	BEGIN

	!+
	! Error getting file name
	!-

	SIGNAL (.l_status);
	END;

    ss$_normal					! Routine value
    END;					! End of routine DISPLAY
END						! End of module DISPLAY

ELUDOM