


		    ards.gdt                        11/18/82  1706.3rew 11/18/82  1625.2       12663


          /* A table for the ARDS terminal */
          /* Written by C. D. Tavares, September 23, 1973 */
          /* converted from 4012 to ARDS 74.09.14 by DAM */

Name:               ARDS;

Type:               static;
Procedure:          ards_util_;

Character_size:     16, 13, 3;

/* Effector         Action */

setposition:        call position;
setpoint:           call position;
vector:             call position;
shift:              call position;
point:              call position;

scaling:            expand, call set_maps;
rotation:           expand, call set_maps;
clipping:           ignore;
intensity:          expand, call set_modes;
line_type:          expand, call set_line_type;
blinking:           ignore;
sensitivity:        ignore;
color:              ignore;
symbol:             ignore;
text:               call text;
data:               ignore;

pause:              flush, call pause;
reference:          error;
increment:          error;
alter:              error;
node_begin:         call node_in;
node_end:           call node_out;
control:            error;
display:            ignore;
query:              error;
erase:              call erase;
synchronize:        flush;
delete:             ignore;

input:              error;
text_mode:                    call mode_switch;
graphic_mode:                 call mode_switch;
expansion:                    call expansion;

end;
 



		    ards_util_.pl1                  11/18/82  1706.3rew 11/18/82  1627.7      129024


/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


/* Graphic Support Procedure for ARDS.  Modified from CDT's Tektronix GSP,
   74.09.13 by Dave Moon */
/* Last modified 07/23/75 by C. D. Tavares, to add order call "start_xmit_hd" to
   circumvent gross ARDS blanking protocol problem, and to handle vectors of
   length > 1024 by breaking them up. */

ards_util_: proc;
	return;

dcl  effector fixed bin parameter,
     n_chars_out fixed bin (21) parameter,
    (instring, outstring) char (*) parameter;

dcl  graphic_code_util_$decode_spi ext entry (pointer, fixed bin, (*) fixed bin),
     graphic_code_util_$decode_dpi ext entry (pointer, fixed bin, (*) fixed bin),
    (graphic_code_util_$decode_scl,
     graphic_code_util_$decode_scl_nozero) ext entry (pointer, fixed bin, (*) float bin);

dcl  graphic_matrix_util_$make_matrix ext entry ((3) fixed bin, (3) float bin, (3, 3) float bin),
     graphic_matrix_util_$multiply_3x3_x_1x3 ext entry ((3, 3) float bin, (3) float bin, (3) float bin);

dcl (addr, substr, round) builtin;

dcl  instring_array (262144) char (1) defined (instring) position (1);

dcl (satisfied, maps_active, visible, dotted) bit (1) aligned static;
dcl  cur_mode fixed bin static,
    (Text_Mode fixed bin static init (0),
     Short_Mode fixed bin static init (1),
     Long_Mode fixed bin static init (2));

dcl (matrix (3, 3),
     identity_matrix (3, 3) initial
    (1e0, 0e0, 0e0, 0e0, 1e0, 0e0, 0e0, 0e0, 1e0)) float bin static;

dcl (xyz static, xyz_temp, xyz_temp2, array_copy) (3) float bin;
dcl  round_copy (3) fixed bin (35, 7);

dcl (rotations fixed, scalings float) bin static dimension (3);
dcl (Erase init ("000001100"b),
     TextMode init ("000011100"b),
     CR init ("000001101"b),
     ShortVectorMode init ("000011111"b),
     LongVectorMode init ("000011110"b),
     SetPoint init ("000011101"b)) bit (9) static;

dcl 1 coordinate_sequence unaligned,
    2 first,
      3 one bit (3),
      3 mag bit (5),
      3 sign bit (1),
    2 second,
      3 one bit (3),
      3 dot bit (1),
      3 mag bit (5);

dcl (i, j) fixed bin,
     float_array (3) float bin,
     fixed_array (3) fixed bin;

dcl 1 stack (20) aligned static,			/* to keep track of abs position */
    2 node_val char (3) aligned,
    2 xyz_copy (3) float bin,
    2 satisfied_copy bit (1) aligned;

dcl  stack_depth fixed bin static initial (0);

position:	entry (effector, instring, outstring, n_chars_out);

	n_chars_out = 0;

	call graphic_code_util_$decode_scl (addr (instring_array (2)), 3, xyz_temp); /* get coord values */

	if maps_active then do;			/* map into rotated or scaled coords */
	     xyz_temp2 = xyz_temp;			/* because (xyz_temp) in call blows up pl1 */
	     call graphic_matrix_util_$multiply_3x3_x_1x3 (matrix, xyz_temp2, xyz_temp);
	end;

	goto pos (effector);			/* handle by type */

pos (48): pos (49):					/* setposition and setpoint */
	xyz = xyz_temp;				/* set to abs position */

	if effector = 49 then call draw_to (xyz);	/* draw the point */
	else satisfied = ""b;			/* else say we haven't put it out yet */
	return;

pos (50):	xyz_temp = xyz + xyz_temp;			/* add to abs position */
	call draw_to (xyz_temp);			/* draw the vector */
	return;

pos (51):	xyz = xyz + xyz_temp;			/* add shift to abs position */
	satisfied = ""b;
	return;

pos (52):	xyz = xyz + xyz_temp;			/* add shift to abs position */
	satisfied = ""b;
	call draw_to (xyz);				/* draw the point */
	return;


node_in:	entry (effector, instring, outstring, n_chars_out);

dcl  subscriptrange condition;

	n_chars_out = 0;				/* we swallow them */
	stack_depth = stack_depth + 1;		/* push the stack */
	if stack_depth > hbound (stack, 1) then signal subscriptrange; /* just in case */

	stack (stack_depth).xyz_copy (*) = xyz (*);	/* copy where we are */
	stack (stack_depth).satisfied_copy = satisfied;	/* copy if we really are */
	stack (stack_depth).node_val = substr (instring, 3, 3); /* copy identifier */
	return;

node_out:	entry (effector, instring, outstring, n_chars_out);

	n_chars_out = 0;				/* we swallow these too */
	stack_depth = stack_depth - 1;		/* pop the stack */
	if stack_depth < 0 then signal subscriptrange;	/* just in case */

	return;

expansion: entry (effector, instring, outstring, n_chars_out);

dcl  no_node_match condition;

	n_chars_out = 0;				/* no output needed */
	do i = 1 to stack_depth while (substr (instring, 3, 3) ^= stack (i).node_val);
	end;					/* find where we've expanded to */

	if i > stack_depth then signal no_node_match;	/* should NEVER happen */

	stack_depth = i;				/* pop stack to here again */
	satisfied = stack (stack_depth).satisfied_copy;	/* copy all current position */
	xyz (*) = stack (stack_depth).xyz_copy (*);	/* indicators from where we were */
	cur_mode = -1;

	return;

mode_switch: entry (effector, instring, outstring, n_chars_out);

dcl  iox_$control ext entry (pointer, char (*), pointer, fixed bin (35)),
     code fixed bin (35),
     iox_$look_iocb ext entry (char (*), pointer, fixed bin (35)),
     switch_ptr pointer,
     keep_modes static char (128) initial ("");

dcl  baud_per_del fixed bin static initial (17);

dcl 1 info_structure aligned,
    2 id char (4),
    2 flags aligned,
      3 baud_rate fixed bin (17) unaligned,
      3 pad bit (54) unaligned,
    2 tw_type fixed bin;

	n_chars_out = 0;				/* we swallow this */

	call iox_$look_iocb (instring, switch_ptr, code);
	if code ^= 0 then do;
	     n_chars_out = -code;
	     return;
	end;

	if effector = Prepare_for_graphics then do;	/* put ARDS in graphic mode */
	     if ^ got_speed then do;			/* select adjustable wait length after flash */
		call iox_$control (switch_ptr, "info", addr (info_structure), code);

		number_nuls = 0;
		if code ^= 0 then baud_rate = 1200;	/* not direct to screen, assume 1200 baud */
		number_nuls = baud_rate / baud_per_del;
		got_speed = "1"b;
	     end;

	     call iox_$control (switch_ptr, "start_xmit_hd", null (), code);
						/* don't check code until hardcore control order is known
						   to have been installed at every site */

	     stack_depth = 0;			/* initialize stuff */
	     xyz = 0;
	     matrix = identity_matrix;
	     scalings = 1e0;
	     rotations = 0;
	     visible = "1"b;
	     satisfied = ""b;
	     cur_mode = -1;				/* mode not known */
	     dotted = "0"b;
	end;

	else do;					/* go to text mode */
	     xyz (1) = -508;			/* go to top of page */
	     xyz (2) = 660;
	     xyz (3) = 0;
	     satisfied = ""b;
	     call draw_to (xyz);
	     call put_out (TextMode);
	     call put_out (CR);
	     cur_mode = Text_Mode;

	     call iox_$control (switch_ptr, "stop_xmit_hd", null (), code);
						/* don't check code yet -- see above comment */

	end;

	return;

set_modes: entry (effector, instring, outstring, n_chars_out);

	n_chars_out = 0;				/* we swallow modes */
	call graphic_code_util_$decode_spi (addr (instring_array (2)), 1, fixed_array); /* get mode value */
	if fixed_array (1) = 0 then visible = ""b;	/* we are only called for */
	else visible = "1"b;			/* the intensity mode */
	return;

set_maps:	entry (effector, instring, outstring, n_chars_out);

	n_chars_out = 0;				/* we swallow maps */
	goto mapping_effector (effector);		/* handle by type */

mapping_effector (53):				/* scaling */
	call graphic_code_util_$decode_scl_nozero (addr (instring_array (2)), 3, scalings); /* get scale factors */
	goto map_common;

mapping_effector (54):				/* rotation */
	call graphic_code_util_$decode_dpi (addr (instring_array (2)), 3, rotations); /* get angles */

map_common:
	call graphic_matrix_util_$make_matrix (rotations, scalings, matrix); /* make the mappings */

	do i = 1 to 3;
	     do j = 1 to 3;				/* see if it's really not unity matrix */
		if matrix (i, j) ^= identity_matrix (i, j) then do; /* not unity */
		     maps_active = "1"b;
		     return;
		end;
	     end;
	end;

	maps_active = ""b;				/* matrix is nugatory */
	return;

set_line_type: entry (effector, instring, outstring, n_chars_out);

	n_chars_out = 0;
	call graphic_code_util_$decode_spi (addr (instring_array (2)), 1, fixed_array);
	dotted = (fixed_array (1) ^= 0);		/* 0 = solid, all else dotted (i.e. dashed => dotted) */
	return;

text:	entry (effector, instring, outstring, n_chars_out);

dcl (alignment, string_length) fixed bin,
    (x_offset, y_offset) float bin,
     charsizes (3) float bin initial (16, 13, 3) static;

	n_chars_out = 0;
	if ^visible then return;

	call graphic_code_util_$decode_spi (addr (instring_array (2)), 1, fixed_array); /* get alignment of string */
	alignment = fixed_array (1);

	call graphic_code_util_$decode_dpi (addr (instring_array (3)), 1, fixed_array); /* get length of string */
	string_length = fixed_array (1);

	x_offset, y_offset = 0;			/* from where we currently are */

	y_offset = divide (alignment - 1, 3, 17, 0) / 2 * charsizes (1); /* align by non-top somewhere */

	i = mod (alignment-1, 3) + 1;			/* get x-alignment */
	if i > 1 then x_offset = -string_length * charsizes (2) /* not aligned by left edge */
	     - (string_length - 1) * charsizes (3);
	if i = 2 then x_offset = x_offset / 2e0;	/* aligned by center */

	if ^satisfied | x_offset + y_offset ^= 0 then do; /* must move */
	     call put_out (SetPoint);
	     float_array (1) = xyz (1) + x_offset;
	     float_array (2) = xyz (2) + y_offset;
	     round_copy = float_array;
	     array_copy = round (round_copy, 0);	/* because expand_assign blows up creating temps */
	     call encode (array_copy, "0"b);		/* go to correct position */
	end;

	call put_out (TextMode);			/* go to text mode */
	substr (outstring, n_chars_out + 1, string_length) = substr (instring, 5, string_length);
	n_chars_out = n_chars_out + string_length;	/* return text string here */

	cur_mode = -1;				/* arbitrarily screwed */
	satisfied = ""b;

	return;

pause:	entry (effector, instring, outstring, n_chars_out);

dcl  iox_$get_line ext entry (pointer, pointer, fixed bin, fixed bin, fixed bin (35)),
     iox_$user_input pointer external,
     junk char (200) aligned;

	call iox_$get_line (iox_$user_input, addr (junk), 200, 0, code); /* wait for LF */
	n_chars_out = - code;			/* if nonzero, error */
	return;

erase:	entry (effector, instring, outstring, n_chars_out);

dcl  NUL char (1) static aligned initial (" "),
     got_speed bit (1) initial (""b) aligned static,
     number_nuls fixed bin static initial (100);

	n_chars_out = 1 + number_nuls;
	unspec (substr (outstring, 1, 1)) = Erase;
	substr (outstring, 2, n_chars_out) = copy (NUL, number_nuls); /* this erases screen */
	cur_mode = -1;				/* clears mode in hardware */
	return;


draw_to:	proc (coordinates);

dcl  coordinates (3) float bin;

dcl (i, n_sub_components) fixed bin,
     max_component float bin;

	     if ^visible then do;			/* we don't put out many little shifts */
		satisfied = ""b;
		xyz = coordinates;
		return;
	     end;

	     if ^satisfied then do;			/* go to where we should be */
		call put_out (SetPoint);
		cur_mode = -1;
		round_copy = xyz;
		array_copy = round (round_copy, 0);
		call encode (array_copy, "0"b);	/* put out coordinates */
		satisfied = "1"b;			/* we are where we think we are */
	     end;
	     round_copy = coordinates - xyz;
	     array_copy = round (round_copy, 0);

	     max_component = max (abs (array_copy (1)), abs (array_copy (2)));

	     if max_component = 0 then return;		/* done for now */

	     if dotted | max_component >= 32 then do;	/* have to use long mode */
		if cur_mode ^= Long_Mode then do;
		     call put_out (LongVectorMode);
		     cur_mode = Long_Mode;
		end;

		if max_component < 1024 then call encode (array_copy, "1"b); /* simple case */

		else do;				/* split up into more than one vector */
		     n_sub_components = max_component / 1024 + 1;
		     array_copy = array_copy / n_sub_components;

		     do i = 1 to n_sub_components;
			call encode (array_copy, "1"b);
		     end;

		end;
	     end;

	     else do;				/* use short mode */
		if cur_mode ^= Short_Mode then do;
		     call put_out (ShortVectorMode);
		     cur_mode = Short_Mode;
		end;
						/* now put a 2-char short vector */

		first.one = "001"b;
		first.mag = bit (fixed (array_copy (1), 5), 5);
		first.sign = (array_copy (1) < 0);
		call put_out (unspec (first));

		first.mag = bit (fixed (array_copy (2), 5), 5);
		first.sign = (array_copy (2) < 0);
		call put_out (unspec (first));
	     end;
	     xyz = coordinates;			/* remind ourselves we are really there now */
	     return;

	end draw_to;

encode:	proc (float_coords, vis);			/* puts out a vector to (float_coords) */

dcl (float_coords (3)) float bin parameter,
     vis bit (1) aligned parameter,
     coords (3) fixed bin,
     fromword fixed bin;

	     coords = float_coords;

	     fromword = coords (1);			/* do X - hardware clips so don't bother */
	     if fromword < 0 then do;
		fromword = - fromword;
		first.sign = "1"b;
	     end;
	     else first.sign = "0"b;
	     first.one, second.one = "001"b;
	     first.mag = substr (unspec (fromword), 32, 5); /* low */
	     second.mag = substr (unspec (fromword), 27, 5); /* high */
	     second.dot = ^ vis;			/* hardware stupidity requires ^ */

	     call put_out (unspec (first));
	     call put_out (unspec (second));

	     fromword = coords (2);			/* do Y */
	     if fromword < 0 then do;
		fromword = - fromword;
		first.sign = "1"b;
	     end;
	     else first.sign = "0"b;
	     first.mag = substr (unspec (fromword), 32, 5); /* low */
	     second.mag = substr (unspec (fromword), 27, 5); /* high */
	     second.dot = dotted;

	     call put_out (unspec (first));
	     call put_out (unspec (second));

	     return;

	end encode;

put_out:	proc (char);				/* puts one char into outstring */

dcl  char bit (9);

	     n_chars_out = n_chars_out + 1;
	     unspec (substr (outstring, n_chars_out, 1)) = char;
	     return;
	end put_out;

%include graphic_device_table;

     end ards_util_;



		    calcomp_915.gdt                 11/18/82  1706.3rew 11/18/82  1625.2        9369


	/* A graphic device table for the CalComp 915/1036 plotter */
	/* Written by C. D. Tavares, May 10, 1974 */

Name:		CalComp_915;

Type:		static;
Procedure:	calcomp_915_;

Character_size:	13.63636, 7.792208, 5.844156;

/* Effector	Action */

setposition:	call position;
setpoint:		call position;
vector:		call position;
shift:		call position;
point:		call position;

scaling:		expand, call set_maps;
rotation:		expand, call set_maps;
clipping:		ignore;
intensity:	expand, call set_modes;
line_type:	expand, call set_modes;
blinking:		ignore;
sensitivity:	ignore;
color:		expand, call set_modes;
symbol:		ignore;
text:		call text;
data:		ignore;

pause:		ignore;
reference:	error;
increment:	error;
alter:		error;
node_begin:	call node_in;
node_end:		call node_out;
control:		error;
display:		ignore;
query:		error;
erase:		call erase;
synchronize:	ignore;
delete:		ignore;

input:		error;

text_mode:		call exit_graphic_mode;
graphic_mode:		call enter_graphic_mode;
expansion:		call expansion;

open:			call open;
close:			call close;

end;
   



		    calcomp_915_.pl1                11/18/82  1706.3rew 11/18/82  1627.7      206334


/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


calcomp_915_: proc;

/* This module is a graphic support procedure for the CalComp 915/1036 plotter.
   Written Dec. 1974 by C. D. Tavares */
/* Modified 03/20/75 by CDT to remove call to read_list_ to get tape number, since it
   parsed out the ",7track" suffix! */
/* Modified by C. D. Tavares 03/26/75 to use the new open and close keywords in the GDT
   to expedite detaching of the tape stream without having the hack in remove_graphics. */
/* Last modified 09/29/75 by CDT to note that pen is up whenever doing a pen_select.
   This is a curious feature of 915 which is not shared by their other products, and not documented. */

	return;

%include graphic_device_table;

dcl 1 USASCII static aligned,
    2 control_chars char (32) unaligned initial ((32) " "), /* translate controls to space (- o40) */
    2 space_to_rightbracket char (62) unaligned,
    2 nonimplemented char (3) unaligned initial ("  "),
    2 lowercase char (26) unaligned,
    2 nonimplemented2 char (5) unaligned initial ((5) " ");

dcl  symbol_mode char (3) aligned static,		/* initialized in enter_graphic_mode */
     sm_ninebit (0:2) bit (9) unaligned based (addr (symbol_mode)),
     char_size fixed bin (35) static,
     cs_sixbit (6) bit (6) unaligned based (addr (char_size));

position:	entry (effector, instring, outstring, n_chars_out);

dcl (effector, n_chars_out) fixed bin parameter,
    (instring, outstring) char (*) parameter;

dcl  graphic_code_util_$decode_spi ext entry (pointer, fixed bin, (*) fixed bin),
     graphic_code_util_$decode_dpi ext entry (pointer, fixed bin, (*) fixed bin),
    (graphic_code_util_$decode_scl,
     graphic_code_util_$decode_scl_nozero) ext entry (pointer, fixed bin, (*) float bin);

dcl  graphic_matrix_util_$make_matrix ext entry ((3) fixed bin, (3) float bin, (3, 3) float bin),
     graphic_matrix_util_$multiply_3x3_x_1x3 ext entry ((3, 3) float bin, (3) float bin, (3) float bin);

dcl (addr, substr, round, max, min, divide, collate, string) builtin;

dcl  instring_array (262144) char (1) defined (instring) position (1);

dcl (pen_is_down, pen_is_satisfied, maps_active, visible) bit (1) aligned static;

dcl (matrix (3, 3),
     identity_matrix (3, 3) initial
    (1e0, 0e0, 0e0, 0e0, 1e0, 0e0, 0e0, 0e0, 1e0)) float bin static;

dcl ((pen_wants_at, pen_is_at_in_CC_units) static, xyz_temp, xyz_temp2, array_copy) (3) float bin;
dcl  round_copy (3) fixed bin (35, 7);

dcl  limiting bit (1) aligned static initial ("1"b),
     erased bit (1) static initial ("0"b) aligned;

dcl  plot_command bit (5) initial ("00001"b) aligned static,
    (pen_up initial (""), pen_down initial ("")) char (1) aligned static;

dcl (rotations fixed, scalings float) bin static dimension (3);

dcl  i fixed bin (21),
     j fixed bin,
     float_array (3) float bin,
     fixed_array (3) fixed bin;

dcl 1 stack (0:20) aligned static,			/* to keep track of abs position */
    2 node_val char (3) aligned,			/* NOTE: 20 is currently max depth.  pl1 wouldn't */
    2 xyz_copy (3) float bin,				/* allow an exprn here.  This may have to be changed. */
    2 pen_is_satisfied_copy bit (1) aligned;

dcl  stack_depth fixed bin static initial (0);

dcl  scale float bin static initial (0),
     scale_not_settable bit (1) aligned initial (""b) static,
     paper_size float bin static initial (11.0),		/* comes in 2 sizes: 11.0 and 33.5 */
     points_per_inch fixed bin static initial (1000),
     quadrant_size float bin static initial (650.0);

	n_chars_out = 0;				/* initialize output count */

	call graphic_code_util_$decode_scl (addr (instring_array (2)), 3, xyz_temp); /* get coord values */

	if maps_active then do;			/* map into rotated or scaled coords */
	     xyz_temp2 = xyz_temp;			/* because (xyz_temp) in call blows up pl1 */
	     call graphic_matrix_util_$multiply_3x3_x_1x3 (matrix, xyz_temp2, xyz_temp);
	end;					/* kerchunk goes the grinder */

	goto pos (effector);			/* handle by type */

pos (48): pos (49):					/* setposition and setpoint */
	pen_wants_at = xyz_temp;			/* set to abs position */
	pen_is_satisfied = ""b;			/* say we haven't put it out yet */

	if effector = 49 then goto draw_point;		/* draw the point */
	return;

pos (50):	xyz_temp = pen_wants_at + xyz_temp;		/* add to abs position */
	call draw_to (xyz_temp);			/* draw the vector */
	return;

pos (51):	pen_wants_at = pen_wants_at + xyz_temp;		/* add shift to abs position */
	pen_is_satisfied = ""b;			/* don't bother to put it out yet */
	return;

pos (52):	pen_wants_at = pen_wants_at + xyz_temp;		/* add shift to abs position */
	pen_is_satisfied = ""b;			/* don't bother to put it out yet */
draw_point:
	call draw_to (pen_wants_at);			/* draw the point */
	do i = 3, -3;				/* got to do a little cha-cha to make */
	     pen_wants_at (1) = pen_wants_at (1) + i;	/* a visible point appear */
	     call draw_to (pen_wants_at);		/* so we draw a little square */
	     pen_wants_at (2) = pen_wants_at (2) + i;	/* and say take it or leave it. */
	     call draw_to (pen_wants_at);
	end;

	return;


node_in:	entry (effector, instring, outstring, n_chars_out);

dcl  subscriptrange condition;

	n_chars_out = 0;				/* we swallow them */
	stack (stack_depth).xyz_copy (*) = pen_wants_at (*); /* copy where we are */
	stack (stack_depth).pen_is_satisfied_copy = pen_is_satisfied; /* copy if we really are */

	stack_depth = stack_depth + 1;		/* push the stack */
	if stack_depth > hbound (stack, 1) then signal subscriptrange; /* just in case */

	stack (stack_depth).node_val = substr (instring, 3, 3); /* copy identifier */
	return;

node_out:	entry (effector, instring, outstring, n_chars_out);

	n_chars_out = 0;				/* we swallow these too */
	stack_depth = stack_depth - 1;		/* pop the stack */
	if stack_depth < 0 then signal subscriptrange;	/* just in case */

	return;

expansion: entry (effector, instring, outstring, n_chars_out);

dcl  no_node_match condition;

	n_chars_out = 0;				/* no output needed */
	do i = stack_depth to 1 by -1 while (substr (instring, 3, 3) ^= stack (i).node_val);
	end;					/* find where we've expanded to */

	if i < 1 then signal no_node_match;		/* should NEVER happen */

	stack_depth = i - 1;			/* pop stack to here again */
	pen_is_satisfied = stack (stack_depth).pen_is_satisfied_copy; /* copy all current position */
	pen_wants_at (*) = stack (stack_depth).xyz_copy (*); /* indicators from where we were */

	return;


open:	entry (effector, instring, outstring, n_chars_out);

dcl  char1 char (1) aligned,
     bit9 bit (9) aligned based (addr (char1));

dcl  search_address fixed bin static,
     sa_sixbit (6) unaligned bit (6) based (addr (search_address));

dcl  iox_$get_line ext entry (pointer, pointer, fixed bin (21), fixed bin (21), fixed bin (35)),
     iox_$user_input ext pointer,
     ioa_$nnl ext entry options (variable),
     tape_number char (168),
     iox_$attach_ioname ext entry (char (*), pointer, char (*), fixed bin (35)),
     iox_$open ext entry (pointer, fixed bin, bit (1) aligned, fixed bin (35));

dcl  iocb_ptr pointer static;

%include iox_modes;

dcl  search_marker char (1) aligned static initial ("");

	n_chars_out = 0;				/* initialize output count */

get_tape:
	call ioa_$nnl ("Type number of tape to be mounted:  "); /* hey you... */
	call iox_$get_line (iox_$user_input, addr (tape_number), 168, i, code);
	if i = 1 then goto get_tape;			/* Hm. Shaky fingers. */

	substr (tape_number, i) = " ";		/* kill newline */

	call iox_$attach_ioname (instring, iocb_ptr, "calcomp_915_dim_ " || tape_number, code);
						/* use calcomp_915_dim_ for formatting */
	if code ^= 0 then do;
complain:	     n_chars_out = - code;			/* the defined way of complaining */
	     return;
	end;

	call iox_$open (iocb_ptr, Stream_output, ""b, code);
	if code ^= 0 then goto complain;

	space_to_rightbracket = substr (collate (), 1, 62); /* 915 works on modified USASCII */
	lowercase = substr (collate (), 34, 26);	/* uppercase-only type of code. Barf. */

	scale_not_settable = "1"b;

	return;


enter_graphic_mode: entry (effector, instring, outstring, n_chars_out);

	search_address = 1;				/* useful feature of 915 controller. */
	call put_out_search_address;			/* you can search for plots by the numbers */

put_out_search_address: proc;

	     call put_out (search_marker);		/* I am a search address */

	     do i = 4 to 6;
		bit9 = "000"b || sa_sixbit (i);	/* my address is: */
		call put_out (char1);
	     end;

	     search_address = search_address + 1;	/* bump */

	end;

	if scale = 0 then call set_scale (paper_size);

set_scale: proc (ps);

dcl  ps float bin;

	     scale = ps * points_per_inch / (2 * quadrant_size); /* this should be very clear */
	     char_size = ps * 7800.0 / quadrant_size;	/* magic constant. Don't ask me why. */

	     substr (symbol_mode, 1, 1) = "(";		/* also magic constant */

	     do i = 1, 2;
		sm_ninebit (i) = "000"b || cs_sixbit (i+4);
	     end;

	     paper_size = ps;

	end set_scale;

	limiting = ""b;				/* we don't care to stay inside paper margins */
	visible = "1"b;

	call put_out (pen_up);			/* whirr */
	pen_is_down = ""b;

	do i = 1 to 3;				/* ram into right end of carriage */
	     pen_is_at_in_CC_units = 0;
	     pen_wants_at = 0;
	     pen_wants_at (2) = -2000;
	     pen_is_satisfied = ""b;
	     call draw_to (pen_wants_at);		/* chunk! */
	end;					/* have to do this in 3 steps, not enough precision */

	pen_wants_at = quadrant_size;			/* find the center of the paper */
	pen_wants_at (2) = pen_wants_at (2) + 100;	/* to get over the paper perforation margin */
	pen_is_at_in_CC_units = 0;
	pen_is_satisfied = ""b;
	call draw_to (pen_wants_at);			/* go to the center */
	pen_is_satisfied = ""b;

	stack_depth = 0;				/* initialize stuff */
	maps_active = ""b;
	dotted = ""b;
	pen_is_at_in_CC_units, pen_wants_at = 0;
	limiting = "1"b;				/* NOW we wish to stay inside paper margins */
	erased = "1"b;				/* 2 erases in a row is wasteful */
	matrix = identity_matrix;
	scalings = 1e0;
	rotations = 0;

	return;

put_pen_up: proc;

	     if ^pen_is_down then return;
	     pen_is_down = ""b;
	     call put_out (pen_up);
	     return;

put_pen_down:  entry;

	     if pen_is_down then return;
	     pen_is_down = "1"b;
	     call put_out (pen_down);
	     return;

	end;

exit_graphic_mode: entry (effector, instring, outstring, n_chars_out);

	n_chars_out = 0;
	pen_wants_at = 0;				/* do a courtesy paper feed */
	pen_wants_at (1) = 1200;
	limiting = ""b;				/* to let us go outside our bounds to new frame */
	pen_is_satisfied = ""b;
	call draw_to (pen_wants_at);			/* whirr */
	call put_pen_up;
	scale = 0.0;				/* close up shop */
	search_address = 9999;
	call put_out_search_address;			/* this tells plotter to quit */

	scale_not_settable = ""b;
	return;

close:	entry (effector, instring, outstring, n_chars_out);

dcl  iox_$close ext entry (pointer, fixed bin (35)),
     iox_$detach_iocb ext entry (pointer, fixed bin (35));

	call iox_$close (iocb_ptr, code);
	if code ^= 0 then goto complain;

	call iox_$detach_iocb (iocb_ptr, code);
	n_chars_out = -code;

	return;


set_modes: entry (effector, instring, outstring, n_chars_out);

	n_chars_out = 0;

	goto mode_effector (effector);		/* one of several */

mode_effector (56):					/* intensity */
	call graphic_code_util_$decode_spi (addr (instring_array (2)), 1, fixed_array); /* get mode value */
	if fixed_array (1) = 0 then visible = ""b;	/* no other value makes sense */
	else visible = "1"b;			/* except visible or invisible */
	return;

mode_effector (57):					/* line_type */

dcl (dash_length, space_length) float bin static initial (0),
     dotted bit (1) aligned static initial (""b);

	call graphic_code_util_$decode_spi (addr (instring_array (2)), 1, fixed_array);
	if fixed_array (1) = 0 then dotted = ""b;	/* solid lines */
	else do;					/* some dotted type */
	     dotted = "1"b;
	     if fixed_array (1) = 1 then do;		/* dashed line */
		dash_length = 10;
		space_length = 4;			/* this looks about right on this plotter */
	     end;
	     else do;				/* dotted line */
		dash_length = 3;			/* this looks right on this plotter */
		space_length = 2;
	     end;
	end;

	return;

mode_effector (60):					/* color */

dcl  pen_select char (1) aligned static initial (""),	/* 004, pen_select */
     based_string_array (4) based char (1) unaligned;

	call graphic_code_util_$decode_spi (addr (instring_array (2)), 3, fixed_array);

	j = 1;
	do i = 2 to 3;				/* we expect pens to be L to R: red, green, blue */
	     if fixed_array (4-i) > fixed_array (4-j) then j = i; /* and the darkest takes precedence */
	end;

	call put_out (pen_select);
	call put_out ((addr (j) -> based_string_array (4))); /* which pen */

	pen_is_down = ""b;				/* pen select forces pen up on 915 */
	return;

set_maps:	entry (effector, instring, outstring, n_chars_out);

	n_chars_out = 0;				/* we swallow maps */
	goto mapping_effector (effector);		/* handle by type */

mapping_effector (53):				/* scaling */
	call graphic_code_util_$decode_scl_nozero (addr (instring_array (2)), 3, scalings); /* get scale factors */
	goto map_common;

mapping_effector (54):				/* rotation */
	call graphic_code_util_$decode_dpi (addr (instring_array (2)), 3, rotations); /* get angles */

map_common:
	call graphic_matrix_util_$make_matrix (rotations, scalings, matrix); /* make the mappings */

	do i = 1 to 3;
	     do j = 1 to 3;				/* see if it's really not unity matrix */
		if matrix (i, j) ^= identity_matrix (i, j) then do; /* not unity */
		     maps_active = "1"b;
		     return;
		end;
	     end;
	end;

	maps_active = ""b;				/* matrix is nugatory */
	return;


text:	entry (effector, instring, outstring, n_chars_out);

dcl (alignment, string_length) fixed bin,
     sl_sixbit (6) bit (6) unaligned based (addr (string_length)),
    (x_offset, y_offset) float bin,
     charsizes (3) float bin initial (13.63636, 7.792208, 5.844156) static;

dcl  hack_plotter bit (1) aligned static initial (""b);

/* hack_plotter bit neccessary because plotter does not correctly return to beginning of charstring
   until next move _a_f_t_e_r writing string.  If next move is a vector, it starts in the wrong place,
   although ending up in the right place.  So we remove our restriction on zero-length moves if it
   is after a character string. */

	n_chars_out = 0;
	if ^visible then return;
	call graphic_code_util_$decode_spi (addr (instring_array (2)), 1, fixed_array); /* get alignment of string */
	alignment = fixed_array (1);

	call graphic_code_util_$decode_dpi (addr (instring_array (3)), 1, fixed_array); /* get length of string */
	string_length = fixed_array (1);
	if string_length = 0 then return;

	y_offset = -divide (9 - alignment, 3, 35, 0) * charsizes (1) / 2; /* compute y alignment */

	i = mod (alignment-1, 3) + 1;			/* get x-alignment */
	x_offset = 0;
	if i > 1 then x_offset = -string_length * charsizes (2) /* not aligned by left edge */
	     - (string_length - 1) * charsizes (3);
	if i = 2 then x_offset = x_offset / 2e0;	/* aligned by center */

	xyz_temp2 = pen_wants_at;

	if ^pen_is_satisfied | x_offset + y_offset ^= 0 then do; /* must move */
	     pen_is_satisfied = ""b;			/* we want to move to correct place */
	     float_array (1) = pen_wants_at (1) + x_offset;
	     float_array (2) = pen_wants_at (2) + y_offset;
	     float_array (3) = 0;
	     round_copy = float_array;
	     array_copy = round (round_copy, 6);	/* because expand_assign blows up creating temps */
	     pen_wants_at = array_copy;
	     call draw_to (array_copy);		/* go to correct position */
	end;

	call put_out (symbol_mode);

	bit9 = "000"b || sl_sixbit (6);

	call put_out (char1);

	substr (outstring, n_chars_out + 1, string_length)
	     = translate (substr (instring, 5, string_length), string (USASCII)); /* MAGIC! ASCII -> USASCII */
	n_chars_out = n_chars_out + string_length;	/* return text string here */

	pen_wants_at = xyz_temp2;
	pen_is_satisfied = ""b;
	hack_plotter = "1"b;

	return;

erase:	entry (effector, instring, outstring, n_chars_out);

	n_chars_out = 0;
	if erased then return;			/* don't paperfeed twice */
	call put_out_search_address;			/* new search address here */
	call put_pen_up;
	pen_wants_at = 0;				/* advance the paper */
	pen_is_satisfied = ""b;
	pen_wants_at (1) = 1200;
	limiting = "0"b;				/* let us go outside our cage */
	call draw_to (pen_wants_at);
	limiting = "1"b;				/* replace the bars */
	dotted = ""b;
	maps_active = ""b;				/* none of this is necessary, it is all paranoia */
	erased = "1"b;
	pen_wants_at = 0;
	pen_is_at_in_CC_units = 0;
	return;


draw_to:	proc (coordinates);

dcl  coordinates (3) float bin,
     dash_count fixed bin,
    (relative_coordinates, dash_increment, space_increment) (3) float bin,
     line_length float bin,
    (sqrt, sum) builtin,
     array_copy (3) float bin,
     round_copy (3) fixed bin (35, 7);


	     if ^visible then do;			/* we don't put out many little shifts */
		pen_is_satisfied = ""b;
		pen_wants_at = coordinates;		/* note we want to be somewhere else */
		return;
	     end;

	     if ^pen_is_satisfied then do;		/* go to where we should be */
		call put_pen_up;			/* precedes invisible vector */
		round_copy = pen_wants_at;
		array_copy = round (round_copy, 6);
		call encode (array_copy);		/* put out coordinates */
		pen_is_satisfied = "1"b;		/* we are where we think we are */
	     end;

	     if sum ((pen_wants_at - coordinates) ** 2) < .001 then return; /* array = array or abs (array - array) loses */

	     call put_pen_down;

	     if dotted then do;			/* the hard part */
		relative_coordinates = coordinates - pen_wants_at;
		line_length = sqrt (sum (relative_coordinates ** 2)); /* isn't v2pl1 cool? */
		dash_increment = dash_length * relative_coordinates / line_length; /* gives one a sense */
		space_increment = space_length * relative_coordinates / line_length; /* of perspective */
		dash_count = line_length / (dash_length + space_length);

		do i = 1 to dash_count;		/* ping ping ping ping */
		     pen_wants_at, round_copy = pen_wants_at + dash_increment;
		     array_copy = round (round_copy, 6);
		     call encode (array_copy);	/* draw a dash */
		     call put_pen_up;
		     pen_wants_at, round_copy = pen_wants_at + space_increment;
		     array_copy = round (round_copy, 6);
		     call encode (array_copy);	/* "draw" a space */
		     call put_pen_down;
		end;
	     end;					/* the normal case code finishes the line nicely */

	     round_copy = coordinates;		/* go to where we want to end up */
	     array_copy = round (round_copy, 6);
	     call encode (array_copy);		/* go where we want to be */
	     pen_wants_at = coordinates;		/* remind ourselves we are really there now */
	     return;

	end draw_to;

encode:	proc (float_coords);			/* puts out a vector to (float_coords) */

dcl  coords (3) float bin,
     rel_coords_in_CC_units (3) fixed bin,
     float_coords (3) float bin parameter;

dcl (x_significant_bit, y_significant_bit) fixed bin,
    (x_bits bit (36) aligned, x_sixbit_char (6) unaligned bit (6)) based (addr (rel_coords_in_CC_units (1))),
    (y_bits bit (36) aligned, y_sixbit_char (6) unaligned bit (6)) based (addr (rel_coords_in_CC_units (2)));

dcl (no_x_chars, no_y_chars) fixed bin (3),
     search_bit bit (1) aligned;

dcl  i fixed bin;

	     if limiting then coords = max (-quadrant_size, min (quadrant_size, float_coords)) * scale; /* stay in your cage */
	     else coords = float_coords * scale;	/* roam free */

	     rel_coords_in_CC_units = coords - pen_is_at_in_CC_units;
	     pen_is_at_in_CC_units = pen_is_at_in_CC_units + rel_coords_in_CC_units; /* pen_is_at_in_CC_units is independent of pen_wants_at */
						/* to make roundoff error correct itself */

	     search_bit = ^substr (x_bits, 1, 1);	/* see how many chars needed to describe x */
	     x_significant_bit = index (x_bits, search_bit) - 1;
	     if x_significant_bit = -1 then if search_bit then no_x_chars = 0;
		else no_x_chars = 1;
	     else no_x_chars = min (3, divide (42 - x_significant_bit, 6, 2, 0)); /* this many. */

	     search_bit = ^substr (y_bits, 1, 1);	/* do the same for y */
	     y_significant_bit = index (y_bits, search_bit) - 1;
	     if y_significant_bit = -1 then if search_bit then no_y_chars = 0;
		else no_y_chars = 1;
	     else no_y_chars = min (3, divide (42 - y_significant_bit, 6, 2, 0));

	     if no_x_chars + no_y_chars = 0 then
		if ^hack_plotter then return;		/* no move, why bother? */
		else hack_plotter = ""b;

	     bit9 = plot_command || substr (bit (no_x_chars), 2, 2) || substr (bit (no_y_chars), 2, 2);
	     call put_out (char1);			/* construct the "move in x-y" command header */

	     do i = 7 - no_x_chars to 6;		/* put out all x chars necessary */
		bit9 = "000"b || x_sixbit_char (i);
		call put_out (char1);
	     end;

	     do i = 7 - no_y_chars to 6;		/* do same for y chars */
		bit9 = "000"b || y_sixbit_char (i);
		call put_out (char1);
	     end;

	     return;
	end encode;

put_out:	proc (chars);				/* puts chars into outstring */

dcl  chars char (*) aligned,
     l fixed bin;

	     l = length (chars);
	     erased = ""b;
	     substr (outstring, n_chars_out+1, l) = chars;
	     n_chars_out = n_chars_out + l;
	     return;
	end put_out;

set_calcomp_paper_size: scps: entry;

dcl  cu_$arg_ptr ext entry (fixed bin, pointer, fixed bin, fixed bin (35)),
     com_err_ ext entry options (variable),
     error_table_$noarg ext fixed bin (35),
     error_table_$request_not_recognized ext fixed bin (35),
     code fixed bin (35),
     ap pointer,
     al fixed bin,
     arg char (al) based (ap);

	call cu_$arg_ptr (1, ap, al, code);		/* get arg */
	if code ^= 0 then do;			/* got to be an arg */
say_err:	     call com_err_ (code, "set_calcomp_paper_size", "^a^/^a",
		"Usage is: ""scps -size-""", "  -size- must be ""narrow"" (11.0 in.) or ""wide"" (33.5 in.)");
	     return;				/* talk about non-standard command options! */
	end;

	if scale_not_settable then do;		/* already plotting, would screw up program */
	     call com_err_ (0, "set_calcomp_paper_size", "Paper size cannot be set when this module is in use.");
	     return;				/* also plotter operator! */
	end;
	if arg = "narrow" then call set_scale (11.0);	/* more magic constants */
	else if arg = "wide" then call set_scale (33.5);	/* in this case, they're inches. */
	else do;
	     code = error_table_$request_not_recognized;	/* huh? wot? */
	     goto say_err;
	end;

     end calcomp_915_;
  



		    calcomp_915_dim_.pl1            11/18/82  1706.3rew 11/18/82  1625.2       81027


/* ***********************************************************
   *                                                         *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   *                                                         *
   *********************************************************** */

/* ******************************************************
   *                                                    *
   *                                                    *
   * Copyright (c) 1972 by Massachusetts Institute of   *
   * Technology and Honeywell Information Systems, Inc. *
   *                                                    *
   *                                                    *
   ****************************************************** */

calcomp_915_dim_attach: proc (iocb_ptr, option_array, com_err_sw, code);

/* This code is a tape dim for the CalComp 915 (and similar) plotter
   controller.  The 915 hacks its characters in this format:

   The tape can be either 7- or 9-track, and ALWAYS uses 6-bit characters
   (despite what the lying documentation says).  The records are specified to
   be 480 to 512 chars long; we use up to 510 chars/record.  The first record
   is a dummy record.  It's supposed to contain the ID of the system it was
   created on (a CalComp protective mechanism) but nothing looks at it.  We
   just put out "I am a plot record - stop plot." All significant records must
   start with an octal 37 31 31 37, meaning "I am a plot record." Each record
   must end with the octal code 17, meaning "stop plot" (so it doesn't try to
   plot inter-record gaps - they're wild stuff.)

   The input to this routine is exactly the codes which are to go to the 915.
   The dim has to know about the lengths of commands, because it seems you
   can't split commands across record boundaries.  You also can't put search
   address in mid-record -- the plotter will find them when plotting, but not
   when searching.  The commands are packed in a Multics 9-bit ASCII character
   instead of being in 6-bit.  The conversion from 9-bit to 6-bit is done in
   this DIM.

   Written 5/3/74 by C. D. Tavares */
/* Modified 03/20/75 by CDT to make 9-track tapes possible. */
/* Modified 03/31/75 by CDT to convert to IOX-style module */
/* Modified 04/30/81 by CDT to clean up attach table on attach errors */
/* Last modified 05/19/81 by CDT to remove unused and buggy changemode entry */

dcl  iocb_ptr pointer parameter,
     option_array (*) char (*) varying parameter,
     com_err_sw bit (1) aligned parameter,
     code fixed bin (35) parameter;

dcl  com_err_ ext entry options (variable),
     explanation char (64);

dcl  iox_$attach_ioname ext entry (char (*), pointer, char (*), fixed bin (35)),
     iox_$open ext entry (pointer, fixed bin, bit (1) aligned, fixed bin (35));

dcl  sys_area_p pointer static initial (null),
     sys_area area based (sys_area_p),
     get_system_free_area_ ext entry returns (pointer);

%include iocbv;

dcl 1 switch_data_block aligned based (iocb.attach_descrip_ptr),
    2 attach_description char (64) varying,
    2 open_description char (64) varying,
    2 target_switch pointer,
    2 outdx fixed bin,
    2 buffer bit (buffer_size_in_bits) aligned;

dcl  buffer_size_in_bits fixed bin (24) static initial (3060), /* 510 * 6 */
     buffer_size_in_chars fixed bin (21) static initial (340); /* 510 * 6 / 9 */

dcl  Start_plot bit (24) initial ("011111011001011001011111"b) static,
     Stop_plot bit (6) initial ("001111"b) static;


dcl (error_table_$not_attached,
     error_table_$not_detached,
     error_table_$multiple_io_attachment) ext fixed bin (35);

dcl (null, substr, index) builtin;


	if iocb.attach_descrip_ptr ^= null then do;
	     code = error_table_$not_detached;
	     explanation = "";
	     goto attach_error;
	end;

	if sys_area_p = null then sys_area_p = get_system_free_area_ ();

	allocate switch_data_block in (sys_area) set (iocb.attach_descrip_ptr); /* make an SDB */

	switch_data_block.attach_description = "calcomp_915_dim_ " || option_array (1);

	iocb.open = calcomp_915_open;
	iocb.detach_iocb = calcomp_915_detach;

	switch_data_block.outdx = 0;

	call iox_$attach_ioname ((option_array (1)), target_switch,
	     "ntape_ " || option_array (1) || " -raw -write", code);
	if code ^= 0 then do;
	     explanation = "Attempting to attach tape.";
	     goto attach_error;
	end;

	code = 0;

	call iox_$propagate (iocb_ptr);

	return;

attach_error:
	if com_err_sw then
	     call com_err_ (code, "calcomp_915_dim_", explanation);

	if iocb.attach_descrip_ptr ^= null then do;
	     free iocb.attach_descrip_ptr -> switch_data_block in (sys_area);
	     iocb.attach_descrip_ptr = null;
	end;

	return;

calcomp_915_open: entry (iocb_ptr, mode, append, code);

dcl  mode fixed bin parameter,
     append bit (1) aligned parameter;

%include iox_modes;

dcl  iox_$propagate ext entry (pointer);

	call iox_$open (target_switch, Sequential_output, ""b, code);
	if code ^= 0 then return;

	outdx = 0;
	buffer = Start_plot || Stop_plot;		/* 37 31 31 37 17 - "I am a plot record - stop plot" */
						/* The calcomp wants a dummy record to begin with. */
	call iox_$write_record (target_switch, addr (buffer), buffer_size_in_chars, code); /* put it out there */
	if code ^= 0 then return;			/* Hm! */

	actual_iocb_ptr -> iocb.put_chars = calcomp_915_write;

	open_description = "stream_output";
	iocb.open_descrip_ptr = addr (open_description);

	iocb.close = calcomp_915_close;

	call iox_$propagate (actual_iocb_ptr);

	return;					/* You got it. */
%page;
calcomp_915_close: entry (iocb_ptr, code);

dcl  iox_$detach_iocb ext entry (pointer, fixed bin (35)),
     iox_$close ext entry (pointer, fixed bin (35));

	call put_out;				/* flush last bufferful */

	call iox_$close (target_switch, code);
	if code ^= 0 then return;

	actual_iocb_ptr -> iocb.open = calcomp_915_open;
	actual_iocb_ptr -> iocb.detach_iocb = calcomp_915_detach;
	actual_iocb_ptr -> iocb.open_descrip_ptr = null;

	call iox_$propagate (actual_iocb_ptr);

	return;

calcomp_915_detach: entry (iocb_ptr, code);

	call iox_$detach_iocb (target_switch, code);	/* Whirr! */
	if code ^= 0 then return;

	free iocb.attach_descrip_ptr -> switch_data_block in (sys_area);
	iocb.attach_descrip_ptr = null;

	call iox_$propagate (actual_iocb_ptr);
	return;
%page;
calcomp_915_write: entry (iocb_ptr, wksp, nelem, code);

dcl  nelem fixed bin (21);

dcl  instring bit (inlen) based (wksp),
    (i, j, n_chars) fixed bin,
     wksp pointer,
     indx fixed bin (24);

dcl  inlen fixed bin (24),
     divide builtin,
     before builtin,
     addr builtin,
     error_table_$negative_nelem fixed bin (35) external;

dcl  iox_$write_record ext entry (pointer, pointer, fixed bin (21), fixed bin (35));

dcl  text fixed bin static initial (2),
     search_address fixed bin static initial (1),
     lookup_table (0 : 31) fixed bin static initial
    (1, 4, 1, 1, 2, (11) -1,
     1, 2, 3, 4, 2, 3, 4, 5, 3, 4, 5, 6, 4, 5, 6, 7);

dcl  nelemt fixed bin (21);

	if nelem < 0 then do;			/* there's always a joker. */
	     code = error_table_$negative_nelem;	/* slap his wrists */
	     return;
	end;

	nelemt = 0;

	code = 0;
	if nelem = 0 then return;			/* write nothing - that's easy. */

	inlen = nelem * 9;				/* inlen is in bits */
	indx = 4;					/* first bit we are interested in is fourth. */

	if outdx = 0 then call start_record;		/* we are beginning a tape record */

another_element:
	if fixed (substr (instring, indx - 1, 3)) = text then do;
	     i = fixed (substr (instring, indx + 2, 2));
	     j = fixed (substr (instring, indx + 4, 2));
	     n_chars = fixed (substr (instring, indx + i * 9 + j * 9 + 6, 9)) + i + j + 2;
	end;

	else do;
	     i = fixed (substr (instring, indx - 1, 7));
	     if i = search_address then if outdx ^= length (Start_plot) + 1 then call put_out;
	     n_chars = lookup_table (i);
	end;

	if outdx + n_chars * 6 >= buffer_size_in_bits - 6 then call put_out;

	do i = 1 to n_chars;
	     substr (buffer, outdx, 6) = substr (instring, indx, 6);
	     outdx = outdx + 6;
	     indx = indx + 9;
	end;


	nelemt = nelemt + n_chars;
	if nelemt < nelem then goto another_element;

	return;

put_out:	proc;					/* procedure to append "stop plot", write, and reinitialize buffer */

	     substr (buffer, outdx, 6) = Stop_plot;	/* stop plot. */
	     call iox_$write_record (target_switch, addr (buffer), buffer_size_in_chars, code);
						/* put out the buffer on one record */
	     if code ^= 0 then goto returner;		/* tape dim barfed */

start_record:  entry;				/* entry to reinitialize buffer without writing it out */

	     buffer = Start_plot;			/* 37 31 31 37 - "I am a plot record" */
	     outdx = length (Start_plot) + 1;		/* note that many used */
	     return;
	end put_out;

returner:	return;

     end calcomp_915_dim_attach;
 



		    graphic_gsp_utility_.pl1        11/18/82  1706.3rew 11/18/82  1625.3       93222


/* ***********************************************************
   *                                                         *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   *                                                         *
   *********************************************************** */

/* format: style1,^inddcls,ifthenstmt,ifthendo,ifthen,indcomtxt,dclind5 */
graphic_gsp_utility_: proc;
	return;

/* This program implements common utility functions so that writers of
   graphic support procedures (GSP's) have a source of easy-to-use
   algorithms. */

/* Written 10/17/80 by C. D. Tavares */
%page;
%include graphic_etypes;
%page;
clip_line: entry (from, to, limits, shifting,
	goto_new_from, new_from, goto_new_to, new_to);

/* This entry clips a line to the screen boundaries using a rather simple
   algorithm copped from "Principles of Interactive Computer Graphics" by
   Newman and Sproull. */

/* PARAMETERS */
/* INPUT args: */
dcl  (from,					/* one endpoint */
     to)		        (2) float bin parameter,	/* the other */
     limits	        (2, 2) float bin parameter,	/* screen boundaries */
     shifting	        bit (1) parameter,		/* on if shift as opposed to vector */
						/* OUTPUT args: */
     (new_from,					/* clipped version */
     new_to)	        (2) float bin parameter,	/* clipped version */
     (goto_new_from,				/* on if user should explicitly move to there */
     goto_new_to)	        bit (1) parameter;		/* ditto */

/* AUTOMATIC */

dcl  (from_code, to_code)   bit (4);

/* CONSTANTS */

dcl  (Off_left	        initial ("1000"b),
     Off_right	        initial ("0100"b),
     Off_low	        initial ("0010"b),
     Off_high	        initial ("0001"b)) bit (4) static options (constant);

	new_from = from;
	new_to = to;

	from_code = compute_code (from, limits);
	to_code = compute_code (to, limits);

/* If the AND of these codes is not zero, the line is totally offscreen. */

	if (from_code & to_code) ^= "0000"b then do;
		goto_new_from, goto_new_to = "0"b;
		return;
	     end;

/* If we're shifting, the location of the start point is moot anyway. */

	if shifting then goto_new_from = ""b;

/* If not shifting, compute new start point.  If different from current
   position, tell the caller to go there.  (We assume he's already AT the
   point he gives as the current position.) */

	else do;
		if from_code ^= "0000"b then do;
			call crush (from, from_code, to, limits,
			     new_from);
			goto_new_from = "1"b;
		     end;
		else goto_new_from = "0"b;
	     end;

/* If we are shifting to a point onscreen OR we are drawing a visible vector
   that crosses the screen (even if it doesn't end onscreen) then we want the
   caller to go to the end point.  (If we are drawing a vector and we get here,
   we KNOW at least part of it is onscreen because we handled the totally
   offscreen case previously.) */

	if ^shifting | (to_code = "0000"b) then do;
		if to_code ^= "0000"b then
		     call crush (to, to_code, from, limits, new_to);
		goto_new_to = "1"b;
	     end;
	else goto_new_to = ""b;

	return;
%skip (5);
compute_code: proc (coords, limits) returns (bit (4));

dcl  coords	        (2) float bin parameter,
     limits	        (2, 2) float bin parameter;

dcl  code		        bit (4);

	code = "0000"b;

	if coords (1) < limits (1, 1) then code = Off_left;
	else if coords (1) > limits (2, 1) then code = Off_right;
	if coords (2) < limits (1, 2) then code = code | Off_low;
	else if coords (2) > limits (2, 2) then code = code | Off_high;

	return (code);
     end compute_code;
%skip (5);
crush: proc (point, code, otherpoint, limits, new_point);

dcl  (point,
     otherpoint,
     new_point)	        (2) float bin parameter,
     code		        bit (4) parameter,
     limits	        (2, 2) float bin parameter;

dcl  (delta_x, delta_y)     float bin;

	new_point = point;
	delta_x = otherpoint (1) - point (1);
	delta_y = otherpoint (2) - point (2);

	if (code & Off_left) ^= "0000"b then do;
		new_point (2) = new_point (2) +
		     (limits (1, 1) - new_point (1)) * delta_y / delta_x;
		new_point (1) = limits (1, 1);
		code = compute_code (new_point, limits);
	     end;

	if (code & Off_right) ^= "0000"b then do;
		new_point (2) = new_point (2) +
		     (limits (2, 1) - new_point (1)) * delta_y / delta_x;
		new_point (1) = limits (2, 1);
		code = compute_code (new_point, limits);
	     end;

	if (code & Off_low) ^= "0000"b then do;
		new_point (1) = new_point (1) +
		     (limits (1, 2) - new_point (2)) * delta_x / delta_y;
		new_point (2) = limits (1, 2);
		code = compute_code (new_point, limits);
	     end;

	if (code & Off_high) ^= "0000"b then do;
		new_point (1) = new_point (1) +
		     (limits (2, 2) - new_point (2)) * delta_x / delta_y;
		new_point (2) = limits (2, 2);
	     end;

	return;
     end crush;
%page;
clip_text: entry (text_string, alignment, charsizes, curpos, limits,
	hw_origin, init_shift, str_origin, str_len);

/* This entry clips a text string given the current position, the relevant
   alignments, and some other things.  It tells the user how much of the
   string should be eventually output and where. */

/* PARAMETERS */
/* INPUT args: */
dcl  (text_string	        char (*),			/* the string to be clipped */
     alignment	        fixed bin,			/* the desired alignment */
     charsizes	        (3) float bin,		/* characteristic of the terminal */
     curpos	        (2) float bin,		/* the current graphic position */
						/* parameter "limits" declared above */
     hw_origin	        fixed bin,			/* where the hardware aligns its strings */
						/* OUTPUT args: */
     init_shift	        (2) float bin,		/* user must shift this much before emitting string */
     str_origin	        fixed bin,			/* first char of string to emit */
     str_len	        fixed bin) parameter;		/* length of portion to emit */

/* AUTOMATIC */

dcl  char_width	        float bin,
     str_width	        float bin,
     flatsize	        fixed bin,
     realign	        (2) float bin,
     string_pos	        (2) float bin;

/* BUILTINS */

dcl  (divide, hbound, lbound, length, mod, rank, substr) builtin;


	str_origin = 1;
	str_len = length (text_string);
	init_shift = 0;

	flatsize = compute_flatsize (text_string);

	char_width = charsizes (2) + charsizes (3);

	str_width = flatsize * char_width - charsizes (3);
						/* subtract final intercharacter space */

/* We do all out clipping computations from the upper left-hand corner of
   the string (alignment 1). */

	realign (1) = -mod (alignment - 1, 3) / 2e0 * str_width;
	realign (2) = divide (alignment - 1, 3, 17) / 2e0 * charsizes (1);

	string_pos = curpos + realign;

/* If this string is clipped off the screen, just ignore it. */

/* Check for top of string over top of screen... */

	if string_pos (2) > limits (2, 2) then str_len = 0;

/* ... bottom of string under bottom of screen... */

	else if string_pos (2) - charsizes (1) < limits (1, 2) then
	     str_len = 0;

/* ... left edge of string past right edge of screen... */

	else if string_pos (1) >= limits (2, 1) then str_len = 0;

/* ... and right edge of string past left edge of screen */

	else if string_pos (1) + str_width <= limits (1, 1) then
	     str_len = 0;

	if str_len = 0 then return;

/* Now check for the case where we have to clip somewhere in mid-string. */

/* Check for right edge of string past right edge of screen */

	if string_pos (1) + str_width > limits (2, 1) then
	     call clip_right_edge (text_string, str_len, string_pos (1),
		limits (2, 1), charsizes (2), charsizes (3));

/* and left edge of string past left edge of screen */

	else if string_pos (1) < limits (1, 1) then
	     call clip_left_edge (text_string, str_origin, str_len,
		string_pos (1), limits (1, 1), charsizes (2),
		charsizes (3));

	init_shift = string_pos - curpos;
	if hw_origin = Left then
	     init_shift (2) = init_shift (2) - (charsizes (1) / 2e0);
	else if hw_origin = Lower_left then
	     init_shift (2) = init_shift (2) - charsizes (1);

	return;
%skip (5);
compute_flatsize: proc (str) returns (fixed bin);

dcl  str		        char (*) parameter;

/* AUTOMATIC */

dcl  flatsize	        fixed bin,
     i		        fixed bin;

	flatsize = 0;

	do i = 1 to length (str);
	     flatsize = flatsize +
		compute_colwidth (substr (str, i, 1), i);
	end;

	return (flatsize);
%skip (2);
clip_right_edge: entry (str, strlen, startpos, edge, charwidth, charspace);

dcl  (strlen	        fixed bin,
     startpos	        float bin,
     edge		        float bin,
     (charwidth,
     charspace)	        float bin) parameter;

dcl  temp_float	        float bin,
     fullwidth	        float bin;

/* set up a position counter; adjust to ignore trailing intercharacter space */

	temp_float = startpos - charspace;
	fullwidth = charwidth + charspace;

	do i = 1 to length (str) while (temp_float <= edge);
	     temp_float = temp_float +
		compute_colwidth (substr (str, i, 1), i) * fullwidth;
	end;

	strlen = i - 2;

	return;
%skip (2);
clip_left_edge:
     entry (str, strorig, strlen, startpos, edge, charwidth, charspace);

dcl  strorig	        fixed bin parameter;

	fullwidth = charwidth + charspace;

	do i = 1 to length (str) while (startpos < edge);
	     startpos = startpos +
		compute_colwidth (substr (str, i, 1), i) * fullwidth;
	end;

	strlen = strlen - i + 1;
	strorig = i;

	return;
%skip (5);
compute_colwidth: proc (ch, idx) returns (fixed bin);

dcl  ch		        char (1) parameter,
     idx		        fixed bin parameter;

/* AUTOMATIC */

dcl  colwidth	        fixed bin,
     i		        fixed bin;

/* CONSTANTS */

dcl  Columns_taken	        (0:127) fixed bin static options (constant) initial
		        ((8) 0,			/* NUL- BEL */
		        -1, 1, (6) 0,		/* BS - 017 */
		        (8) 0,			/* DLE - ETX */
		        (3) 0, -2, (4) 0,		/* CAN - US */
		        (95) 1, 0);			/* printing chars and PAD */

	i = rank (ch);
	if i > hbound (Columns_taken, 1) then
	     i = lbound (Columns_taken, 1);
	colwidth = Columns_taken (i);
	if colwidth = -2 then do;			/* ESC-anything takes no column */
		colwidth = -1;
		idx = idx + 1;
	     end;

	return (colwidth);
     end compute_colwidth;
     end compute_flatsize;

     end graphic_gsp_utility_;
  



		    rg512.gdt                       11/18/82  1706.3rew 11/18/82  1625.3       18324


/* ***********************************************************
   *                                                         *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   *                                                         *
   *********************************************************** */

/* ******************************************************
   *                                                    *
   *                                                    *
   * Copyright (c) 1972 by Massachusetts Institute of   *
   * Technology and Honeywell Information Systems, Inc. *
   *                                                    *
   *                                                    *
   ****************************************************** */

/* A table for the RG512 graphic card for the ADM3A graphic terminal */
/* Created from tek_4012.gdt by C. Hornig, October 1980 */
/* Last modified 10/16/80 by C. D. Tavares */

Name:		rg512;

Type:		static;
Procedure:	tektronix_40XX_;

Character_size:	20, 15, 3.38;
Points_per_inch:	160;
Message_size:	1024;

/* Effector	Action */

setposition:	call position;
setpoint:		call position;
vector:		call position;
shift:		call position;
point:		call position;

scaling:		error;
rotation:		error;
clipping:		error;

intensity:	ignore;
line_type:	call line_type;
blinking:		ignore;
sensitivity:	ignore;
color:		ignore;

symbol:		ignore;
text:		call text;
data:		ignore;

pause:		flush, call pause;
reference:	error;
increment:	error;
alter:		error;
node_begin:	expand, call node_in; /* That should expand everything */
node_end:		ignore;
control:		error;
display:		ignore;
query:		call query;
erase:		call erase;
synchronize:	flush;
delete:		ignore;

input:		call input;

text_mode:	call mode_switch;
graphic_mode:	call mode_switch;
expansion:	ignore;

open:		call open_rg512;
close:		call close;
modes:		call changemode;

end;



		    tek_4002.gdt                    11/18/82  1706.3rew 11/18/82  1625.2       18027


/* ***********************************************************
   *                                                         *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   *                                                         *
   *********************************************************** */

/* ******************************************************
   *                                                    *
   *                                                    *
   * Copyright (c) 1972 by Massachusetts Institute of   *
   * Technology and Honeywell Information Systems, Inc. *
   *                                                    *
   *                                                    *
   ****************************************************** */

/* A table for the Tektronix 4002 graphic terminal */
/* Last modified 10/16/80 by C. D. Tavares */

Name:		tek_4002;

Type:		static;
Procedure:	tektronix_40XX_;

Character_size:	20, 15, 3.38;
Points_per_inch:	164.1026;		/* 1024/780/.008; manual, p. 2-5 */
Message_size:	1024;

/* Effector	Action */

setposition:	call position;
setpoint:		call position;
vector:		call position;
shift:		call position;
point:		call position;

scaling:		error;
rotation:		error;
clipping:		error;

intensity:	ignore;
line_type:	call line_type;
blinking:		ignore;
sensitivity:	ignore;
color:		ignore;

symbol:		ignore;
text:		call text;
data:		ignore;

pause:		flush, call pause;
reference:	error;
increment:	error;
alter:		error;
node_begin:	expand, call node_in; /* That should expand everything */
node_end:		ignore;
control:		error;
display:		ignore;
query:		call query;
erase:		call erase;
synchronize:	flush;
delete:		ignore;

input:		call input;

text_mode:	call mode_switch;
graphic_mode:	call mode_switch;
expansion:	ignore;

open:		call open_4002;
close:		call close;
modes:		call changemode;

end;
 



		    tek_4012.gdt                    11/18/82  1706.3rew 11/18/82  1625.2       18045


/* ***********************************************************
   *                                                         *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   *                                                         *
   *********************************************************** */

/* ******************************************************
   *                                                    *
   *                                                    *
   * Copyright (c) 1972 by Massachusetts Institute of   *
   * Technology and Honeywell Information Systems, Inc. *
   *                                                    *
   *                                                    *
   ****************************************************** */

/* A table for the Tektronix 4012 graphic terminal */
/* Last modified 10/16/80 by C. D. Tavares */

Name:		tek_4012;

Type:		static;
Procedure:	tektronix_40XX_;

Character_size:	20, 15, 3.38;
Points_per_inch:	170.4962;		/* 1024/780/.0077; manual, p. 3-16 */
Message_size:	1024;

/* Effector	Action */

setposition:	call position;
setpoint:		call position;
vector:		call position;
shift:		call position;
point:		call position;

scaling:		error;
rotation:		error;
clipping:		error;

intensity:	ignore;
line_type:	call line_type;
blinking:		ignore;
sensitivity:	ignore;
color:		ignore;

symbol:		ignore;
text:		call text;
data:		ignore;

pause:		flush, call pause;
reference:	error;
increment:	error;
alter:		error;
node_begin:	expand, call node_in; /* That should expand everything */
node_end:		ignore;
control:		error;
display:		ignore;
query:		call query;
erase:		call erase;
synchronize:	flush;
delete:		ignore;

input:		call input;

text_mode:	call mode_switch;
graphic_mode:	call mode_switch;
expansion:	ignore;

open:		call open_4012;
close:		call close;
modes:		call changemode;

end;
   



		    tek_4014.gdt                    11/18/82  1706.3rew 11/18/82  1625.2       18045


/* ***********************************************************
   *                                                         *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   *                                                         *
   *********************************************************** */

/* ******************************************************
   *                                                    *
   *                                                    *
   * Copyright (c) 1972 by Massachusetts Institute of   *
   * Technology and Honeywell Information Systems, Inc. *
   *                                                    *
   *                                                    *
   ****************************************************** */

/* A table for the Tektronix 4014 graphics terminal */
/* Last modified 10/16/80 by C. D. Tavares */

Name:		tek_4014;

Type:		static;
Procedure:	tektronix_40XX_;

Character_size:	20, 15, 3.38;
Points_per_inch:	93.77289;		/* 1024/780/.014; manual, p. 3-26 */
Message_size:	1024;

/* Effector	Action */

setposition:	call position;
setpoint:		call position;
vector:		call position;
shift:		call position;
point:		call position;

scaling:		error;
rotation:		error;
clipping:		error;

intensity:	ignore;
line_type:	call line_type;
blinking:		ignore;
sensitivity:	ignore;
color:		ignore;

symbol:		ignore;
text:		call text;
data:		ignore;

pause:		flush, call pause;
reference:	error;
increment:	error;
alter:		error;
node_begin:	expand, call node_in; /* That should expand everything */
node_end:		ignore;
control:		error;
display:		ignore;
query:		call query;
erase:		call erase;
synchronize:	flush;
delete:		ignore;

input:		call input;

text_mode:	call mode_switch;
graphic_mode:	call mode_switch;
expansion:	ignore;

open:		call open_4014;
close:		call close;
modes:		call changemode;

end;
   



		    tek_4662.gdt                    11/18/82  1706.3rew 11/18/82  1625.2       17937


/* ***********************************************************
   *                                                         *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   *                                                         *
   *********************************************************** */

/* ******************************************************
   *                                                    *
   *                                                    *
   * Copyright (c) 1972 by Massachusetts Institute of   *
   * Technology and Honeywell Information Systems, Inc. *
   *                                                    *
   *                                                    *
   ****************************************************** */

/* A table for the Tektronix 4662 graphic plotter */
/* Last modified 10/16/80 by C. D. Tavares */

Name:		tek_4662;

Type:		static;
Procedure:	tektronix_40XX_;

Character_size:	20, 15, 3.38;
Points_per_inch:	102.4;		/* 1024/10; manual, p. A-2 */
Message_size:	1024;

/* Effector	Action */

setposition:	call position;
setpoint:		call position;
vector:		call position;
shift:		call position;
point:		call position;

scaling:		error;
rotation:		error;
clipping:		error;

intensity:	ignore;
line_type:	call line_type;
blinking:		ignore;
sensitivity:	ignore;
color:		ignore;

symbol:		ignore;
text:		call text;
data:		ignore;

pause:		flush, call pause;
reference:	error;
increment:	error;
alter:		error;
node_begin:	expand, call node_in; /* That should expand everything */
node_end:		ignore;
control:		error;
display:		ignore;
query:		call query;
erase:		call erase;
synchronize:	flush;
delete:		ignore;

input:		call input;

text_mode:	call mode_switch;
graphic_mode:	call mode_switch;
expansion:	ignore;

open:		call open_4662;
close:		call close;
modes:		call changemode;

end;
   



		    tektronix_40XX_.pl1             11/18/82  1706.3rew 11/18/82  1625.3      278001


/* ***********************************************************
   *                                                         *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   *                                                         *
   *********************************************************** */

/* ******************************************************
   *                                                    *
   *                                                    *
   * Copyright (c) 1972 by Massachusetts Institute of   *
   * Technology and Honeywell Information Systems, Inc. *
   *                                                    *
   *                                                    *
   ****************************************************** */

tektronix_40XX_: proc;
	return;

/* Graphic support procedure for all Tektronix 40_n_n terminals. */
/* Modified 03/25/80 by CDT to compensate for the fact that hardware
   design bug causes terminal to lose its mind if you send optimized code
   when running 9600 baud or faster */
/* Modified by C. Hornig, October 1980, to add support for ADM3A/RG512 */
/* Modified 10/17/80 by CDT to make it clip vectors and text properly
   off the screen edges, to implement the device and model modes, and to
   generally clean up the code. */
/* Last modified 02/27/81 by CDT to use breakall for crosshair input. */


/* PARAMETERS (COMMON TO ALL ENTRIES) */

dcl (effector fixed bin,
     n_chars_out fixed bin (21),
    (instring, outstring) char (*),
     data_ptr pointer,
     code fixed bin (35)) parameter;

/* AUTOMATIC */

dcl  accumulator fixed bin (35),
     alignment fixed bin,
     ch char (1),
     char_width float bin,
     chars_read fixed bin (21),
     data_ptr_copy pointer,
     fixed_array (1) fixed bin,
     float_array (3) float bin,
    (i, j, k) fixed bin,
     input_buffer char (200),
     input_ptr pointer,
     int_code fixed bin (35),
     line_type fixed bin,
     mode_string char (256),
     new_string_length fixed bin,
     original_pos (2) float bin,
     output_ptr pointer,
     single_mode char (12),
     string_flatsize fixed bin,
     string_length fixed bin,
     string_origin fixed bin,
     string_width float bin,
     temp_float float bin,
     temp_model_type fixed bin,
     temp_unvar_string char (32),
     temp_var_string char (32) varying,
     text_string_length fixed bin,
     text_string_ptr pointer,
     tuvs_len fixed bin,
    (x_offset, y_offset) float bin,
     xy_temp (2) float bin;

dcl 1 accumulator_bits aligned automatic,
    2 pad bit (26) unaligned,
    2 most_significant bit (5) unaligned,
    2 least_significant bit (5) unaligned;

dcl 1 term_info like terminal_info aligned automatic;

/* BASED AND DEFINED */

dcl 1 static_data aligned based (data_ptr_copy),
    2 flags aligned,
      3 extended_addr_wanted bit (1) unaligned,
      3 optimization_ok bit (1) unaligned,
      3 pad bit (34) unaligned,
    2 target_switch_ptr pointer,
    2 number_nuls fixed bin,
    2 chars_per_second fixed bin,
    2 delay_chars_owed fixed bin,
    2 current_pos (2) float bin,
    2 (prev_highy_char,
     prev_highx_char,
     prev_lowy_char,
     prev_extra_char) char (1),
    2 (prev_x_fromword,
     prev_y_fromword) fixed bin (35, 2),
    2 model_type fixed bin,
    2 plotter_address char (1);

dcl  based_temp_unvar_string char (tuvs_len) based (addr (temp_unvar_string)),
     instring_array (262144) char (1) defined (instring) position (1),
     system_free_area area based (system_free_ptr),
     text_string char (text_string_length) based (text_string_ptr),
     text_string_array (text_string_length) char (1) unaligned based (text_string_ptr);

/* EXTERNAL STATIC */

dcl (error_table_$bad_conversion,
     error_table_$bad_mode) ext fixed bin (35) static;

dcl (graphic_error_table_$malformed_input,
     graphic_error_table_$term_bad_effector,
     graphic_error_table_$unimplemented_effector) ext fixed bin (35);

/* STATIC */

dcl  system_free_ptr pointer static initial (null);

/* CONSTANTS */

dcl 1 Char_constants static options (constant),
    2 NUL char (1) initial (" "),
    2 BS char (1) initial (""),
    2 Plotter_ring_bell char (3) initial (""),		/* US BEL BEL */
    2 Plotter_on_and_reset_template char (8) initial ("^aE^aN"), /* ESC #E ESC #N */
    2 Plotter_on_prompt_off_template char (8) initial ("^aE^aL"), /* ESC #E ESC #L */
    2 Plotter_pause_template char (10) initial ("^aK^aF"), /* US BEL ESC #K ESC #F */
    2 Plotter_off_template char (7) initial ("^aF"),	/* US ESC FF ESC #F */
    2 Erase_rg512 char (2) initial (""),		/* US EM */
    2 Disable_rg512 char (2) initial (""),
						/* CR CAN */
    2 Erase char (2) initial (""),			/* ESC FF */
    2 Exit_graphic_mode char (2) initial (""),
						/* US CR */
    2 Enter_text_mode_at_curpos char (1) initial (""),	/* US */
    2 Shift_prefix char (1) initial (""),		/* GS */
    2 Small_char_size char (2) initial (";"),		/* ESC ; */
    2 Large_char_size char (2) initial ("8"),		/* ESC 8 */
    2 Enable_crosshairs char (2) initial (""),		/* ESC SUB */
    2 Set_linetype (0:4) char (2) initial
    ("`",					/* ESC ` */
     "c",					/* ESC c */
     "a",					/* ESC a */
     "b",					/* ESC b */
     "d");					/* ESC d */

dcl (type_4012 initial (1),
     type_4014 initial (2),
     type_4002 initial (3),
     type_4662 initial (4),
     type_rg512 initial (5)) fixed bin static options (constant);

dcl  Model_names (5) char (8) static options (constant) initial
    ("4012", "4014", "4002", "4662", "rg512");

dcl 1 Mode_ok (5) static options (constant),
    2 device bit (1) initial ("0"b, "0"b, "0"b, "1"b, "0"b),
    2 extaddr bit (1) initial ("0"b, "1"b, "0"b, "1"b, "0"b);

dcl  char_delay_values (32:126) float bin static options (constant) initial
    (.100e0, .278e0, .265e0, .585e0, .523e0, .536e0, .424e0, .158e0,
     .266e0, .268e0, .424e0, .301e0, .179e0, .160e0, .139e0, .170e0,
     .400e0, .204e0, .312e0, .448e0, .274e0, .368e0, .421e0, .239e0,
     .519e0, .418e0, .239e0, .291e0, .231e0, .322e0, .232e0, .371e0,
     .509e0, .362e0, .476e0, .343e0, .367e0, .368e0, .344e0, .394e0,
     .314e0, .326e0, .256e0, .329e0, .270e0, .264e0, .254e0, .377e0,
     .325e0, .438e0, .378e0, .402e0, .251e0, .280e0, .201e0, .265e0,
     .314e0, .255e0, .257e0, .257e0, .165e0, .257e0, .180e0, .158e0,
     .155e0, .387e0, .412e0, .327e0, .398e0, .377e0, .383e0, .440e0,
     .295e0, .275e0, .338e0, .378e0, .178e0, .364e0, .268e0, .347e0,
     .391e0, .399e0, .244e0, .415e0, .331e0, .289e0, .180e0, .321e0,
     .309e0, .233e0, .252e0, .320e0, .280e0, .322e0, .216e0);

dcl 1 Device_constants static options (constant),
    2 outscale float bin initial (.761719e0),		/* 780/1024 */
    2 outscale_inches float bin initial (9.670261e-3),	/* 780/1024 * 13 / 1024, for 4662 plotter */
    2 inscale float bin initial (1.312821),		/* 1024/780 */
    2 clipping_limits (2, 2) float bin initial
    (-672.1641e0, -512e0, 670.8513e0, 511e0),
    2 screen_offsets (2) fixed bin initial (512, 390),
    2 charsizes (3) float bin initial (20, 15, 3.38e0),
    2 baud_per_nul fixed bin initial (9);

/* ENTRIES */

dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin),
    (ioa_$rsnnl, ioa_$rsnpnnl) entry options (variable),
     get_system_free_area_ entry returns (pointer);

dcl (graphic_code_util_$decode_spi,
     graphic_code_util_$decode_dpi) entry (pointer, fixed bin, (*) fixed bin),
     graphic_code_util_$decode_scl entry (pointer, fixed bin, (*) float bin),
     graphic_code_util_$encode_scl entry ((*) float bin, fixed bin, pointer);

dcl  graphic_gsp_utility_$clip_line entry ((2) float bin, (2) float bin,
    (2, 2) float bin, bit (1), bit (1), (2) float bin, bit (1), (2) float bin),
     graphic_gsp_utility_$clip_text entry (char (*), fixed bin, (3) float bin,
    (2) float bin, (2, 2) float bin, fixed bin, (2) float bin, fixed bin,
     fixed bin);

/* BUILTINS AND CONDITIONS */

dcl (addr, copy, dim, divide, fixed, hbound, high9, index, lbound, length,
     mod, null, rank, rtrim, string, substr, sum, translate, unspec) builtin;

/* INCLUDE FILES */

%include graphic_input_formats;
%page;
%include graphic_code_dcl;
%page;
%include graphic_etypes;
%page;
%include graphic_device_table;
%page;
%include terminal_info;
%page;
%include iox_dcls;
%page;
position:	entry (effector, instring, outstring, n_chars_out, data_ptr, code);

	data_ptr_copy = data_ptr;

	call graphic_code_util_$decode_scl (addr (instring_array (2)), 2, xy_temp); /* get coord values */

	goto pos (effector);			/* handle by type */

pos (48): pos (49):					/* setposition and setpoint */
	call shift_to (xy_temp);			/* go to the position */
	if effector = 49 then call draw_to (xy_temp);	/* draw the point */
	return;

pos (50):	xy_temp = static_data.current_pos + xy_temp;	/* add to abs position */
	call draw_to (xy_temp);			/* draw the vector */
	return;

pos (51):	xy_temp = static_data.current_pos + xy_temp;	/* add shift to abs position */
	call shift_to (xy_temp);
	return;

pos (52):	xy_temp = static_data.current_pos + xy_temp;	/* add shift to abs position */
	call shift_to (xy_temp);
	call draw_to (xy_temp);			/* draw the point */
	return;
%skip (5);
open_4012: entry (effector, instring, outstring, n_chars_out, data_ptr, code);

	temp_model_type = type_4012;
	goto open_common;

open_4014: entry (effector, instring, outstring, n_chars_out, data_ptr, code);

	temp_model_type = type_4014;
	goto open_common;

open_4002: entry (effector, instring, outstring, n_chars_out, data_ptr, code);

	temp_model_type = type_4002;
	goto open_common;

open_4662: entry (effector, instring, outstring, n_chars_out, data_ptr, code);

	temp_model_type = type_4662;
	goto open_common;

open_rg512: entry (effector, instring, outstring, n_chars_out, data_ptr, code);

	temp_model_type = type_rg512;
	goto open_common;

open_common:
	n_chars_out = 0;

	system_free_ptr = get_system_free_area_ ();
	allocate static_data in (system_free_area);
	data_ptr = data_ptr_copy;

	static_data.model_type = temp_model_type;
	static_data.extended_addr_wanted = "0"b;	/* for starters */

	call initialize_state;

	call iox_$look_iocb (instring, static_data.target_switch_ptr, code);
	if code ^= 0 then return;

	term_info.version = terminal_info_version;

	call iox_$control (static_data.target_switch_ptr, "terminal_info",
	     addr (term_info), int_code);

	if int_code ^= 0 then term_info.baud_rate = 1200; /* assume 1200 baud, probably using file */
	static_data.number_nuls =
	     divide (term_info.baud_rate, Device_constants.baud_per_nul, 17);
	static_data.chars_per_second = divide (term_info.baud_rate, 10, 17);
	static_data.optimization_ok = (term_info.baud_rate < 9600);

	if static_data.model_type = type_4662 then do;
	     call ioa_$rsnnl (Char_constants.Plotter_off_template,
		temp_unvar_string, tuvs_len, static_data.plotter_address);
	     call put_out (based_temp_unvar_string);	/* turn plotter off */
	end;

	return;
%skip (5);
initialize_state: proc;				/* internal proc resets all defaults */
	     static_data.current_pos = -1000;		/* not possible, but will put in long enough delay for 4662 */
	     static_data.delay_chars_owed = -50;	/* Plotter buffer much bigger than this anyway. */
	     static_data.prev_highy_char,
		static_data.prev_highx_char,
		static_data.prev_lowy_char,
		static_data.prev_extra_char = high9 (1);
	     static_data.prev_x_fromword, static_data.prev_y_fromword = -100;
	     static_data.plotter_address = "A";

	end initialize_state;
%skip (5);
close:	entry (effector, instring, outstring, n_chars_out, data_ptr, code);

	data_ptr_copy = data_ptr;

	n_chars_out = 0;
	free static_data in (system_free_area);
	data_ptr = null;
	return;
%skip (5);
changemode: entry (effector, instring, outstring, n_chars_out, data_ptr, code);

	data_ptr_copy = data_ptr;

/* first, construct string representing old modes. */

	call ioa_$rsnpnnl
	     ("model=^a,^[^[^;^^^]extaddr,^;^s^]^[device=^a,^;^s^]baud=^d.",
	     outstring, n_chars_out,
	     Model_names (static_data.model_type),
	     Mode_ok.extaddr (static_data.model_type),
	     static_data.extended_addr_wanted,
	     Mode_ok.device (static_data.model_type),
	     static_data.plotter_address,
	     static_data.chars_per_second * 10e0);

/* now read modes coming in. */

	mode_string = instring;

	do while (mode_string ^= "");
	     i = index (mode_string, ",") - 1;
	     if i < 0 then i = length (rtrim (mode_string, " "));

	     single_mode = substr (mode_string, 1, i);
	     mode_string = copy (substr (mode_string, i+2), 1);

	     i = length (rtrim (single_mode));
	     if substr (single_mode, i, 1) = "." then
		substr (single_mode, i, 1) = " ";	/* trailing periods are a bother. */

	     if substr (single_mode, 1, 5) = "baud=" then do;
		i = cv_dec_check_ (substr (single_mode, 6), code);
		if code ^= 0 then do;
		     code = error_table_$bad_conversion;
		     return;
		end;
		term_info.baud_rate = i;
		static_data.chars_per_second =
		     divide (term_info.baud_rate, 10, 17);
		static_data.number_nuls =
		     divide (term_info.baud_rate,
		     Device_constants.baud_per_nul, 17);
	     end;

/* check for possible model change before checking modes that may be rejected
   if model not compatible */

	     else if substr (single_mode, 1, 6) = "model=" then do;
		temp_var_string = substr (single_mode, 7);

		do i = 1 to dim (Model_names, 1)
			while (Model_names (i) ^= temp_var_string);
		end;

		if i > dim (Model_names, 1) then goto bad_mode;

		static_data.model_type = i;
	     end;

	     else if single_mode = "extaddr" then
		if Mode_ok.extaddr (static_data.model_type) then
		     static_data.extended_addr_wanted = "1"b;
		else goto bad_mode;

	     else if single_mode = "^extaddr" then
		if Mode_ok.extaddr (static_data.model_type) then
		     static_data.extended_addr_wanted = "0"b;
		else goto bad_mode;

	     else if substr (single_mode, 1, 7) = "device=" then
		if Mode_ok.device (static_data.model_type) then do;
		     temp_var_string =
			rtrim (translate (substr (single_mode, 8),
			"ABCD", "abcd"));
		     if length (temp_var_string) ^= 1 then
			goto bad_mode;
		     if index ("ABCD", temp_var_string) = 0 then
			goto bad_mode;
		     static_data.plotter_address = temp_var_string;
		end;
		else goto bad_mode;

	     else do;
bad_mode:		code = error_table_$bad_mode;
		return;
	     end;
	end;

	return;
%skip (5);
mode_switch: entry (effector, instring, outstring, n_chars_out, data_ptr, code);

	data_ptr_copy = data_ptr;

	n_chars_out = 0;				/* we swallow this */

	if effector = Prepare_for_graphics then do;	/* put 401X in graphic mode */
	     call initialize_state;

	     if static_data.model_type = type_4662 then do;
		call ioa_$rsnnl
		     (Char_constants.Plotter_on_and_reset_template,
		     temp_unvar_string, tuvs_len,
		     static_data.plotter_address);
		call put_out (based_temp_unvar_string);
	     end;
	end;

	else if static_data.model_type = type_4662 then do; /* exit graphic mode for plotter */
	     call ioa_$rsnnl (Char_constants.Plotter_off_template,
		temp_unvar_string, tuvs_len, static_data.plotter_address);
	     call put_out (based_temp_unvar_string);	/* plotter home and off */
	end;

	else if static_data.model_type = type_rg512 then	/* put RG512 in ADM mode */
	     call put_out (Char_constants.Disable_rg512);

	else do;					/* exit graphic mode for everything else */
	     xy_temp (1) = clipping_limits (1, 1);	/* top of screen */
	     xy_temp (2) = clipping_limits (2, 2);
	     call shift_to (xy_temp);
	     call put_out (Char_constants.Exit_graphic_mode);
	end;

	return;
%skip (5);
text:	entry (effector, instring, outstring, n_chars_out, data_ptr, code);

	data_ptr_copy = data_ptr;

	n_chars_out = 0;

	call graphic_code_util_$decode_spi (addr (instring_array (2)), 1, fixed_array); /* get alignment of string */
	alignment = fixed_array (1);

	call graphic_code_util_$decode_dpi (addr (instring_array (3)), 1, fixed_array); /* get length of string */
	string_length = fixed_array (1);
	string_origin = 5;

	text_string_ptr = addr (instring_array (string_origin));
	text_string_length = string_length;

	call graphic_gsp_utility_$clip_text
	     (text_string, alignment, Device_constants.charsizes,
	     static_data.current_pos, Device_constants.clipping_limits,
	     Lower_left, xy_temp, string_origin, new_string_length);

	if new_string_length = 0 then return;		/* clip sliding away */

/* If we get here, we have something to put out. */

	text_string_ptr = addr (text_string_array (string_origin));
	text_string_length, string_length = new_string_length;

	original_pos (*) = static_data.current_pos (*);	/* remember place to return to after drawing string */

	if sum (xy_temp) ^= 0 then do;		/* have to shift */
	     xy_temp = xy_temp + static_data.current_pos;
	     call shift_to (xy_temp);
	end;

	call put_out (Char_constants.Enter_text_mode_at_curpos);

	if static_data.model_type = type_4014 then
	     call put_out (Char_constants.Large_char_size);

	if static_data.model_type = type_4662 then
	     do i = 1 to length (text_string);
	     ch = substr (text_string, i, 1);
	     j = rank (ch);
	     if j >= lbound (char_delay_values, 1) then
		if j <= hbound (char_delay_values, 1) then do;
		     k = compute_delay (char_delay_values (j), 1);
		     call put_out (ch);
		     if k > 0 then
			call put_out_copy (Char_constants.NUL, k);
		end;

	end;

	else call put_out (text_string);

	if static_data.model_type = type_4014 then
	     call put_out (Char_constants.Small_char_size);

	else if static_data.model_type = type_4002 then do;

/* 4002 loses its memory when it leaves graphic mode.  So we have to lose
   ours too, to ensure a full 4-char send in the next graphic transmission. */

	     static_data.prev_highx_char,
		static_data.prev_highy_char,
		static_data.prev_lowy_char,
		static_data.prev_extra_char = high9 (1);
	     static_data.prev_x_fromword,
		static_data.prev_y_fromword = -100;
	end;

	call shift_to (original_pos);

	return;
%skip (5);
pause:	entry (effector, instring, outstring, n_chars_out, data_ptr, code);

	data_ptr_copy = data_ptr;

	if static_data.model_type = type_4662 then do;

/* ring bell, turn plotter off, activate keyboard. */

	     call ioa_$rsnnl (Char_constants.Plotter_pause_template,
		temp_var_string, 0, static_data.plotter_address);
	     temp_unvar_string = temp_var_string;

	     call iox_$put_chars (static_data.target_switch_ptr,
		addr (temp_unvar_string), length (temp_var_string), code);
	     if code ^= 0 then return;
	end;

	call iox_$get_line (static_data.target_switch_ptr,
	     addr (input_buffer), length (input_buffer), 0, code); /* wait for LF */
	if code ^= 0 then return;

	if static_data.model_type = type_4662 then do;

/* Turn plotter on, turn prompt light off */

	     call ioa_$rsnnl (Char_constants.Plotter_on_prompt_off_template,
		temp_var_string, 0, static_data.plotter_address);
	     temp_unvar_string = temp_var_string;

	     call iox_$put_chars (static_data.target_switch_ptr,
		addr (temp_unvar_string), length (temp_var_string), code);
	end;

	return;
%skip (5);
node_in:	entry (effector, instring, outstring, n_chars_out, data_ptr, code);

	data_ptr_copy = data_ptr;

	n_chars_out = 0;
	call initialize_state;
	xy_temp = 0;
	call shift_to (xy_temp);			/* implicit beginning at (0, 0) */
	code = 0;
	return;
%skip (5);
erase:	entry (effector, instring, outstring, n_chars_out, data_ptr, code);

	data_ptr_copy = data_ptr;

	n_chars_out = 0;

	if static_data.model_type = type_rg512 then
	     call put_out (Char_constants.Erase_rg512);

	else if static_data.model_type = type_4662 then
	     call put_out (Char_constants.Plotter_ring_bell);

/* This code does not do anything which would allow the user time to change
   the paper.  Remember that erases usually precede drawings.  The first erase
   will thus be useless since the paper is clean.  Subsequent erases, if not
   accompanied by explicit pauses, will overwrite the picture; but then again,
   on a 4014 you don't put out a picture and immediately erase it without
   pausing either.  So we rely on the user to provide pauses just like he would
   on a 4014. */

	else do;
	     call put_out (Char_constants.Erase);
	     call put_out_copy (Char_constants.NUL, static_data.number_nuls);
	end;

	call initialize_state;

	return;
%skip (5);
line_type: entry (effector, instring, outstring, n_chars_out, data_ptr, code);

	data_ptr_copy = data_ptr;

	n_chars_out = 0;

	if (static_data.model_type = type_rg512
	| static_data.model_type = type_4012
	| static_data.model_type = type_4002) then return;
						/* ignore for these models */

	call graphic_code_util_$decode_spi (addr (instring_array (2)), 1, fixed_array);

	line_type = fixed_array (1);
	if line_type > 4 then line_type = 0;

	call put_out (Char_constants.Set_linetype (line_type));

	return;
%page;
shift_to:	proc (float_coords);

dcl  float_coords (2) float bin parameter;

dcl (start_point, end_point) (2) float bin,
    (goto_start_point, goto_end_point) bit (1),
     shifting bit (1);

	     shifting = "1"b;
	     goto draw_common;

draw_to:	     entry (float_coords);

	     shifting = ""b;
	     goto draw_common;

draw_common:   call graphic_gsp_utility_$clip_line
		(static_data.current_pos, float_coords,
		Device_constants.clipping_limits, shifting,
		goto_start_point, start_point,
		goto_end_point, end_point);

	     if goto_start_point then do;
		call put_out (Char_constants.Shift_prefix);
		call encode (start_point, n_chars_out);
	     end;

	     if goto_end_point then do;
		if shifting then
		     call put_out (Char_constants.Shift_prefix);
		call encode (end_point, n_chars_out);
	     end;

	     static_data.current_pos = float_coords;
	     return;


/* ---------------------------------------- */

encode:	     proc (new_coords, n_chars_out);

dcl  new_coords (2) float bin parameter,
     n_chars_out fixed (21) bin parameter;

/* AUTOMATIC */

dcl  base_char_count fixed bin (21),
     new_tek_coords (2) fixed bin (35, 2),
     onechar char (1),
     temp_lowy_char char (1),
    (x_fromword, y_fromword) fixed bin (35, 2),
     xy_diff (2) float bin,
     vector_len_sq float bin,
     time float bin,
     k fixed bin,
    (lowy_sent, highy_sent, extra_sent) bit (1);		/* to optimize 40XX series transmission rate */

dcl 1 x_bits aligned automatic,
    2 pad bit (24) unaligned,
    2 high bit (5) unaligned,
    2 low bit (5) unaligned,
    2 frac bit (2) unaligned;

dcl 1 y_bits aligned automatic like x_bits;

/* ENTRIES */

dcl  sub_err_ entry () options (variable);

/* BUILTINS */

dcl (fixed, null, round, sqrt) builtin;

		base_char_count = n_chars_out;

		new_tek_coords =
		     round (fixed (new_coords * Device_constants.outscale
		     + Device_constants.screen_offsets, 35, 6), 2);


		lowy_sent, highy_sent, extra_sent = ""b;
		x_fromword = new_tek_coords (1);
		y_fromword = new_tek_coords (2);
		unspec (x_bits) = unspec (x_fromword);
		unspec (y_bits) = unspec (y_fromword);

		if (x_fromword < 0
		| y_fromword < 0
		| x_fromword > 1023.75
		| y_fromword > 779.75)
		then call sub_err_ (0, "tektronix_40XX_", "h", null, 0,
		     "System error-- coordinate value out of range.");

		if y_fromword ^= static_data.prev_y_fromword then do;
		     unspec (onechar) = "0001"b || y_bits.high; /* set up first char out */
		     if onechar ^= static_data.prev_highy_char then do;
			highy_sent = "1"b;		/* if we need it, put it out */
			call put_out (onechar);
			static_data.prev_highy_char = onechar;
		     end;

		     if static_data.extended_addr_wanted then do;
			unspec (onechar) = "00110"b || y_bits.frac || x_bits.frac;
			if onechar ^= static_data.prev_extra_char then do;
			     extra_sent = "1"b;
			     call put_out (onechar);
			     static_data.prev_extra_char = onechar;
			end;
		     end;

		     unspec (onechar) = "0011"b || y_bits.low; /* set up second char out */
		     temp_lowy_char = onechar;

		     if (onechar ^= static_data.prev_lowy_char
		     | extra_sent
		     | static_data.model_type = type_4002) then do; /* 4002 ALWAYS requires low y */
			lowy_sent = "1"b;
			call put_out (onechar);
			static_data.prev_lowy_char = onechar;
		     end;

		     if static_data.optimization_ok then static_data.prev_y_fromword = y_fromword;
		end;

		if x_fromword ^= static_data.prev_x_fromword then do;
		     unspec (onechar) = "0001"b || x_bits.high;
		     if onechar ^= static_data.prev_highx_char then do; /* need new high x character */
			if ^lowy_sent then do;
			     call put_out (temp_lowy_char); /* guess we needed low y sent */
			     lowy_sent = "1"b;
			end;

			call put_out (onechar);	/* send high x */
			static_data.prev_highx_char = onechar;
		     end;

		     if static_data.optimization_ok then static_data.prev_x_fromword = x_fromword;
		end;

		unspec (onechar) = "0010"b || x_bits.low; /* set up last char */
		call put_out (onechar);		/* put it out */

		if static_data.model_type = type_4662 then do;
		     xy_diff = (new_coords - static_data.current_pos) * Device_constants.outscale_inches;
		     vector_len_sq = sum (xy_diff * xy_diff);
		     time = -1.32497e-3 * vector_len_sq + 8.14581e-2 * sqrt (vector_len_sq) + 4.84891e-2;
						/* don't ask why, this is the best that a least squares program */
						/* could do.  The plotter manual only had a timing chart! */
		     k = compute_delay (time, n_chars_out - base_char_count);
		     if k > 0 then
			call put_out_copy (Char_constants.NUL, k);
		end;


		return;
	     end encode;

/* ---------------------------------------- */

	end shift_to;
%skip (5);

/* ---------------------------------------- */

compute_delay: proc (incr_delay, chars_used) returns (fixed bin);

dcl  incr_delay float bin parameter,
     chars_used fixed bin parameter,
     n fixed bin;

dcl  max builtin;

	     static_data.delay_chars_owed = static_data.delay_chars_owed - chars_used + (incr_delay * static_data.chars_per_second);
	     n = max (fixed (static_data.delay_chars_owed), 0);
	     static_data.delay_chars_owed = static_data.delay_chars_owed - n;
	     return (n);
	end compute_delay;

put_out:	proc (chars);				/* puts chars into outstring */

dcl  chars char (*) parameter;

	     substr (outstring, n_chars_out + 1, length (chars)) = chars;
	     n_chars_out = n_chars_out + length (chars);
	     return;

put_out_copy:  entry (ch1, count);

dcl  ch1 char (1) parameter,
     count fixed bin parameter;

	     substr (outstring, n_chars_out + 1, count) = copy (ch1, count);
	     n_chars_out = n_chars_out + count;
	     return;

	end put_out;
%skip (5);
query:	entry (effector, instring, outstring, n_chars_out, data_ptr, code);

	data_ptr_copy = data_ptr;

	if (static_data.model_type = type_4662
	| static_data.model_type = type_4002) then do;

/* We use unimplemented_effector instead of term_bad_effector to simulate
   the "error" keyword in the GDT.  There really should be an error keyword
   in the GDT for these devices, but in the interests of keeping them nearly
   identical we let them call in here and in the input entry. */

	     code = graphic_error_table_$unimplemented_effector;
	     return;
	end;

	if substr (instring, 2, 1) ^= Where_char then do;
	     code = graphic_error_table_$term_bad_effector;
	     return;
	end;

/* We used to throw up the crosshairs here, but we don't any more because of
   a window problem where setting breakall after the input has already been
   typed-ahead doesn't work.  So we throw them up in the input entry. */

	n_chars_out = 0;
	return;
%skip (5);
input:	entry (effector, instring, outstring, n_chars_out, data_ptr, code);

dcl 1 tek_input_format unaligned,
    2 whatever_key_hit char (1),
    2 position (2),
      3 a_0001 bit (4),
      3 most_significant bit (5),
      3 b_0001 bit (4),
      3 least_significant bit (5);

dcl  graphic_input_buffer (1:8) char (1) unaligned,
     chars_left fixed bin (21),
     chars_gotten fixed bin,
     buffer_ptr pointer;

dcl  cleanup condition;


	data_ptr_copy = data_ptr;

/* Do a resetread to flush any typeahead before going into breakall mode */

	call iox_$control (static_data.target_switch_ptr, "resetread",
	     null, 0);

	on cleanup call revert_breakall;

	call iox_$modes (static_data.target_switch_ptr, "breakall", "", 0);

/* Throw up the crosshairs. */

	call iox_$put_chars (static_data.target_switch_ptr,
	     addr (Char_constants.Enable_crosshairs),
	     length (Char_constants.Enable_crosshairs), code);
	if code ^= 0 then return;

/* Read the input from the crosshairs.  Welcome to the great Breakall Race,
   in which Multics tries to read and return the input faster than the terminal
   hardware can send it at line speed, and usually does.  Thus we have to loop
   at make sure we get all five characters. */

	chars_left = 5;
	chars_gotten = 0;
	graphic_input_buffer (*) = high9 (1);		/* err hedge */

	do while (chars_left > 0);
	     buffer_ptr = addr (graphic_input_buffer (chars_gotten + 1));

	     call iox_$get_chars (static_data.target_switch_ptr,
		buffer_ptr, chars_left, chars_read, code);
	     if code ^= 0 then return;

	     chars_left = chars_left - chars_read;
	     chars_gotten = chars_gotten + chars_read;
	end;

	call revert_breakall;

/* ----- */

revert_breakall: proc;

	     call iox_$modes (static_data.target_switch_ptr, "^breakall", "", 0);

	end revert_breakall;

/* ----- */

	revert cleanup;

(nostringsize):
	unspec (tek_input_format) = unspec (string (graphic_input_buffer));

	call iox_$control
	     (static_data.target_switch_ptr, "resetread", null, code);

	do i = 1 to 2;
	     if tek_input_format.position (i).a_0001 ^= "0001"b
	     | tek_input_format.position (i).b_0001 ^= "0001"b
	     then do;
		code = graphic_error_table_$malformed_input;
		return;
	     end;
	end;

	do i = 1 to 2;
	     unspec (accumulator_bits) = ""b;
	     accumulator_bits.most_significant =
		tek_input_format.most_significant (i);
	     accumulator_bits.least_significant =
		tek_input_format.least_significant (i);

	     unspec (accumulator) = unspec (accumulator_bits);
	     float_array (i) = (accumulator - Device_constants.screen_offsets (i)) * Device_constants.inscale;
	end;

	float_array (3) = 0;

	output_ptr = addr (outstring);

	output_ptr -> where_format.node_begin = Node_begin_char;
	output_ptr -> where_format.array_indicator = Array_char;
	output_ptr -> where_format.mbz = zero_node_id;
	output_ptr -> where_format.setpos_indicator = Setposition_char;
	output_ptr -> where_format.node_end = Node_end_char;

	call graphic_code_util_$encode_scl (float_array, 3, addr (output_ptr -> where_format.xpos));

	n_chars_out = length (string (null -> where_format));

	return;

     end tektronix_40XX_;


		    bull_copyright_notice.txt       08/30/05  1008.4r   08/30/05  1007.3    00020025

                                          -----------------------------------------------------------


Historical Background

This edition of the Multics software materials and documentation is provided and donated
to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. 
as a contribution to computer science knowledge.  
This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology,
Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull
and Bull HN Information Systems Inc. to the development of this operating system. 
Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970),
renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership
of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for 
managing computer hardware properly and for executing programs. Many subsequent operating systems
incorporated Multics principles.
Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., 
as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. .

                                          -----------------------------------------------------------

Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without
fee is hereby granted,provided that the below copyright notice and historical background appear in all copies
and that both the copyright notice and historical background and this permission notice appear in supporting
documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining
to distribution of the programs without specific prior written permission.
    Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc.
    Copyright 2006 by Bull HN Information Systems Inc.
    Copyright 2006 by Bull SAS
    All Rights Reserved