!<BLF/REQUIRE'USR_LIBRARY:PRETTY'>
%TITLE 'Create the color table file for use by the DISPLAY program'
MODULE color_table (MAIN = color_table,
		IDENT = 'V002-0'		! File: COLOR_TABLE.BLI
		) =
BEGIN

!++
!
! FACILITY:	    DECUS pre-symposium seminar 'BLISS for Macro users' examples
!
!		    This routine will show the use of:
!
!		    Run-time library routines
!		    RMS
!		    Simple macro
!		    Require file
!		    Library file
!		    Builtins
!		    Floating point  computation
!		    INCR loops
!		    BLOCK
!		    VECTOR
!		    BLOCKVECTOR
!		    ASCID
!		    PLIT
!
! ABSTRACT:	     This program will generate the color table to be used with
!		    images created by the COMPUTE program. The DISPLAY program
!		    will ask for an image file, and a color table. This program
!		    will create a generic color table using 8 bits per primary
!		    color (red, green, blue), with 256 entries (compatible with
!		    a maximum pixel value of 255 in COMPUTE).
!
!		     This is a very attractive color table, and I've had quite a
!		    bit of success with it. This program can be easily changed
!		    to accomodate graphics hardware with different color table
!		    requirements.
!
! 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:
!
!   color_table		Calculate the color table, and write it to a file
!-

FORWARD ROUTINE
    color_table;

!+
! INCLUDE FILES:
!
!-

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

LIBRARY 'USR_LIBRARY:USRLIB';			! User Definitions.

REQUIRE 'structs';				! 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;


%SBTTL 'COLOR_TABLE - Main entry point for this program'
ROUTINE color_table =

!++
!
! FUNCTIONAL DESCRIPTION:
!
!	 Compute the color table, and write it to a file. See the file
!	STRUCTS for the definition on how to access the color table from
!	any other language.
!
! 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:
!
!	The color table file is created, and written
!
!--

    BEGIN

    LOCAL
	al_red : VECTOR [256, LONG],
	al_grn : VECTOR [256, LONG],
	al_blu : VECTOR [256, LONG],
	d_iter : VECTOR [2, LONG],
	d_temp1 : VECTOR [2, LONG],
	d_temp2 : VECTOR [2, LONG],
	dsc_color : _string_desc (class = d),
	d_bits : VECTOR [2, LONG],
	l_bitp : LONG,
	l_j : LONG,
	l_status : LONG,
	r_color_fab : $fab_decl,
	r_color_rab : $rab_decl,
	r_color_table : BLOCKVECTOR [256, ctbl_s_ctbldef, 1] FIELD (ctbl_ctbldef_fieldset) INITIAL ( REP 256
	    OF (0));

    !+
    ! 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
	    alq = 2, 				! Allocation size
	    fac = put, 				! File access - PUT
	    fop = sqo, 				! File operations - Sequential
	    org = seq, 				! File organization - Sequential
	    rfm = fix, 				! Record format - Fixed
	    mrs = 512);				! Maximum record size
!
	$rab_init (rab = r_color_rab [0, 0, 0, 0], 	! Address of Record Access Block
	    fab = r_color_fab, 			! Address of File Access Block
	    rac = seq, 				! Record access - Sequential
	    rop = wbh, 				! Record operations - Write behind
	    rsz = 512, 				! Record size
	    rbf = r_color_table [0, 0, 0, 0, 0]);	! Record buffer

	!+
	! Create and open the output file
	!-

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

	    IF (l_status = $connect (rab = r_color_rab))
	    THEN
		BEGIN
		l_bitp = 255;
		CVTLD (l_bitp, d_bits);

		!+
		! Define white
		!-

		al_red [0] = 255;
		al_grn [0] = 255;
		al_blu [0] = 255;

		!+
		! Calculate al_red range
		!-

		INCR i FROM 1 TO 31 DO
		    BEGIN
		    CVTLD (i, d_iter);		! d_iter = FLOAT ( i )
		    DIVD (PLIT (%D'64.0'), d_iter, d_temp1);	! d_temp1 = d_iter / 64.0
		    ADDD (PLIT (%D'0.5'), d_temp1, d_temp2);	! d_temp2 = d_temp1 + 0.5
		    MULD (d_bits, d_temp2, d_temp2);	! d_temp2 = d_temp2 * 255
		    CVTDL (d_temp2, al_red [.i]);	! al_red [.i] = INT ( d_temp2 )
		    CVTDL (d_temp1, al_grn [.i]);	! al_grn [.i] = INT ( d_temp1 )
		    al_blu [.i] = 0;
		    END;

		!+
		! Calculate orange range
		!-

		INCR i FROM 32 TO 63 DO
		    BEGIN
		    l_j = .i - 32;
		    CVTLD (l_j, d_iter);
		    DIVD (PLIT (%D'128.0'), d_iter, d_temp1);
		    ADDD (PLIT (%D'0.5'), d_temp1, d_temp2);
		    MULD (d_bits, d_temp2, d_temp2);
		    al_red [.i] = 255;
		    CVTDL (d_temp2, al_grn [.i]);
		    al_blu [.i] = 0;
		    END;

		!+
		! Calculate gold range
		!-

		INCR i FROM 64 TO 95 DO
		    BEGIN
		    l_j = .i - 64;
		    CVTLD (l_j, d_iter);
		    DIVD (PLIT (%D'128.0'), d_iter, d_temp1);
		    ADDD (PLIT (%D'0.75'), d_temp1, d_temp2);
		    MULD (d_bits, d_temp2, d_temp2);
		    al_red [.i] = 255;
		    CVTDL (d_temp2, al_red [.i]);
		    al_blu [.i] = 0;
		    END;

		!+
		! Calculate yellow range
		!-

		INCR i FROM 96 TO 127 DO
		    BEGIN
		    l_j = 128 - .i;
		    CVTLD (l_j, d_iter);
		    DIVD (PLIT (%D'64.0'), d_iter, d_temp1);
		    ADDD (PLIT (%D'0.5'), d_temp1, d_temp2);
		    MULD (d_bits, d_temp2, d_temp2);
		    CVTDL (d_temp2, al_red [.i]);
		    al_grn [.i] = 255;
		    l_j = .i - 96;
		    CVTLD (l_j, d_iter);
		    DIVD (PLIT (%D'64.0'), d_iter, d_temp1);
		    MULD (d_bits, d_temp1, d_temp1);
		    CVTDL (d_temp1, al_blu [.i]);
		    END;

		!+
		! Calculate green range
		!-

		INCR i FROM 128 TO 159 DO
		    BEGIN
		    l_j = 160 - .i;
		    CVTLD (l_j, d_iter);
		    DIVD (PLIT (%D'64.0'), d_iter, d_temp1);
		    MULD (d_bits, d_temp1, d_temp1);
		    CVTDL (d_temp1, al_red [.i]);
		    al_grn [.i] = 255;
		    l_j = .i - 96;
		    CVTLD (l_j, d_iter);
		    DIVD (PLIT (%D'64.0'), d_iter, d_temp1);
		    MULD (d_bits, d_temp1, d_temp1);
		    CVTDL (d_temp1, al_blu [.i]);
		    END;

		!+
		! Calculate cyan range
		!-

		INCR i FROM 160 TO 191 DO
		    BEGIN
		    l_j = 192 - .i;
		    CVTLD (l_j, d_iter);
		    DIVD (PLIT (%D'64.0'), d_iter, d_temp1);
		    ADDD (PLIT (%D'0.5'), d_temp1, d_temp2);
		    MULD (d_bits, d_temp2, d_temp2);
		    al_red [.i] = 0;
		    CVTDL (d_temp2, al_grn [.i]);
		    al_blu [.i] = 255;
		    END;

		!+
		! Calculate al_blue range
		!-

		INCR i FROM 192 TO 224 DO
		    BEGIN
		    l_j = .i - 192;
		    CVTLD (l_j, d_iter);
		    DIVD (PLIT (%D'32.0'), d_iter, d_temp1);
		    MULD (d_bits, d_temp1, d_temp1);
		    CVTDL (d_temp1, al_red [.i]);
		    l_j = 224 - .i;
		    CVTLD (l_j, d_iter);
		    DIVD (PLIT (%D'64.0'), d_iter, d_temp1);
		    MULD (d_bits, d_temp1, d_temp1);
		    CVTDL (d_temp1, al_grn [.i]);
		    al_blu [.i] = 255;
		    END;

		!+
		! Calculate magenta range
		!-

		INCR i FROM 225 TO 254 DO
		    BEGIN
		    l_j = 256 - .i;
		    CVTLD (l_j, d_iter);
		    DIVD (PLIT (%D'64.0'), d_iter, d_temp1);
		    ADDD (PLIT (%D'0.5'), d_temp1, d_temp2);
		    MULD (d_bits, d_temp2, d_temp2);
		    CVTDL (d_temp2, al_red [.i]);
		    l_j = .i - 224;
		    CVTLD (l_j, d_iter);
		    DIVD (PLIT (%D'64.0'), d_iter, d_temp1);
		    MULD (d_bits, d_temp1, d_temp1);
		    CVTDL (d_temp1, al_grn [.i]);
		    l_j = 256 - .i;
		    CVTLD (l_j, d_iter);
		    DIVD (PLIT (%D'64.0'), d_iter, d_temp1);
		    ADDD (PLIT (%D'0.5'), d_temp1, d_temp2);
		    MULD (d_bits, d_temp2, d_temp2);
		    CVTDL (d_temp2, al_blu [.i]);
		    END;

		!+
		! Define black - For pixels that are part of the Mandelbrot set
		!-

		al_red [255] = 0;
		al_grn [255] = 0;
		al_blu [255] = 0;

		!+
		! Condense the three components of the lookup table into one table
		!-

		INCR i FROM 0 TO 255 DO
		    BEGIN
		    r_color_table [.i, ctbl_b_red] = .al_red [.i];
		    r_color_table [.i, ctbl_b_grn] = .al_grn [.i];
		    r_color_table [.i, ctbl_b_blu] = .al_blu [.i];
		    END;

		!+
		! Write out the color table
		!-

		IF (l_status = $put (rab = r_color_rab))
		THEN
		    BEGIN
		    r_color_rab [rab$l_rbf] = .r_color_rab [rab$l_rbf] + 512;	! Point to next block

		    IF NOT (l_status = $put (rab = r_color_rab))	! Write last block
		    THEN
			SIGNAL (.r_color_rab [rab$l_sts], .r_color_rab [rab$l_stv]);

		    END
		ELSE
		    BEGIN

		    !+
		    ! Error writing color table
		    !-

		    SIGNAL (.r_color_rab [rab$l_sts], .r_color_rab [rab$l_stv]);
		    END;

		END
	    ELSE
		BEGIN

		!+
		! Error opening file
		!-

		SIGNAL (.r_color_rab [rab$l_sts], .r_color_rab [rab$l_stv]);
		END;

	    END
	ELSE
	    BEGIN

	    !+
	    ! Error creating file
	    !-

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

	END
    ELSE
	BEGIN

	!+
	! Error reading file name
	!-

	SIGNAL (.l_status);
	END;

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

ELUDOM