head     56.3;
access   paws bayes jws larry quist brad dew jwh;
symbols  ;
locks    ; strict;
comment  @# @;


56.3
date     93.01.27.13.29.48;  author jwh;  state Exp;
branches ;
next     56.2;

56.2
date     93.01.27.12.07.14;  author jwh;  state Exp;
branches ;
next     56.1;

56.1
date     91.11.05.09.51.36;  author jwh;  state Exp;
branches ;
next     55.1;

55.1
date     91.08.25.10.27.06;  author jwh;  state Exp;
branches ;
next     54.1;

54.1
date     91.03.18.15.30.07;  author jwh;  state Exp;
branches ;
next     53.1;

53.1
date     91.03.11.19.30.07;  author jwh;  state Exp;
branches ;
next     52.1;

52.1
date     91.02.19.09.14.06;  author jwh;  state Exp;
branches ;
next     51.1;

51.1
date     91.01.30.16.14.02;  author jwh;  state Exp;
branches ;
next     50.1;

50.1
date     90.10.29.16.28.49;  author jwh;  state Exp;
branches ;
next     49.1;

49.1
date     90.08.14.14.12.43;  author jwh;  state Exp;
branches ;
next     48.1;

48.1
date     90.07.26.11.19.02;  author jwh;  state Exp;
branches ;
next     47.1;

47.1
date     90.05.14.11.02.45;  author dew;  state Exp;
branches ;
next     46.1;

46.1
date     90.05.07.08.49.51;  author jwh;  state Exp;
branches ;
next     45.1;

45.1
date     90.04.19.15.57.47;  author jwh;  state Exp;
branches ;
next     44.1;

44.1
date     90.04.01.22.14.55;  author jwh;  state Exp;
branches ;
next     43.1;

43.1
date     90.03.20.14.06.54;  author jwh;  state Exp;
branches ;
next     42.1;

42.1
date     90.01.23.17.51.39;  author jwh;  state Exp;
branches ;
next     41.1;

41.1
date     89.12.22.11.33.56;  author jwh;  state Exp;
branches ;
next     40.1;

40.1
date     89.09.29.11.55.15;  author jwh;  state Exp;
branches ;
next     39.1;

39.1
date     89.09.26.16.39.51;  author dew;  state Exp;
branches ;
next     38.1;

38.1
date     89.08.29.11.31.52;  author jwh;  state Exp;
branches ;
next     37.1;

37.1
date     89.05.12.11.45.12;  author dew;  state Exp;
branches ;
next     36.1;

36.1
date     89.02.06.10.22.59;  author dew;  state Exp;
branches ;
next     35.1;

35.1
date     89.02.02.13.38.13;  author dew;  state Exp;
branches ;
next     34.1;

34.1
date     89.01.23.16.13.26;  author jwh;  state Exp;
branches ;
next     33.1;

33.1
date     89.01.16.11.45.07;  author dew;  state Exp;
branches ;
next     32.1;

32.1
date     89.01.10.11.54.05;  author bayes;  state Exp;
branches ;
next     31.1;

31.1
date     88.12.14.18.15.09;  author bayes;  state Exp;
branches ;
next     30.1;

30.1
date     88.12.09.13.52.04;  author dew;  state Exp;
branches ;
next     29.1;

29.1
date     88.10.31.15.36.57;  author bayes;  state Exp;
branches ;
next     28.1;

28.1
date     88.10.06.11.03.21;  author dew;  state Exp;
branches ;
next     27.1;

27.1
date     88.09.29.11.43.52;  author bayes;  state Exp;
branches ;
next     26.1;

26.1
date     88.09.28.13.21.44;  author bayes;  state Exp;
branches ;
next     25.2;

25.2
date     88.03.30.09.15.23;  author bayes;  state Exp;
branches ;
next     25.1;

25.1
date     88.03.02.09.37.49;  author bayes;  state Exp;
branches ;
next     24.1;

24.1
date     87.08.31.10.03.55;  author jws;  state Exp;
branches ;
next     23.1;

23.1
date     87.08.26.10.41.54;  author bayes;  state Exp;
branches ;
next     22.1;

22.1
date     87.08.17.11.28.04;  author bayes;  state Exp;
branches ;
next     21.1;

21.1
date     87.08.12.14.10.02;  author bayes;  state Exp;
branches ;
next     20.1;

20.1
date     87.07.30.11.23.59;  author bayes;  state Exp;
branches ;
next     19.1;

19.1
date     87.06.01.08.37.05;  author jws;  state Exp;
branches ;
next     18.1;

18.1
date     87.05.20.15.40.06;  author bayes;  state Exp;
branches ;
next     17.1;

17.1
date     87.04.30.10.48.37;  author jws;  state Exp;
branches ;
next     16.1;

16.1
date     87.04.26.15.59.33;  author jws;  state Exp;
branches ;
next     15.1;

15.1
date     87.04.13.09.37.39;  author jws;  state Exp;
branches ;
next     14.1;

14.1
date     87.04.01.15.44.37;  author jws;  state Exp;
branches ;
next     13.1;

13.1
date     87.02.28.18.43.44;  author jws;  state Exp;
branches ;
next     12.1;

12.1
date     87.02.02.13.35.40;  author jws;  state Exp;
branches ;
next     11.1;

11.1
date     87.01.19.10.02.03;  author jws;  state Exp;
branches ;
next     10.1;

10.1
date     86.12.24.11.14.27;  author jws;  state Exp;
branches ;
next     9.1;

9.1
date     86.12.12.14.57.30;  author bayes;  state Exp;
branches ;
next     8.1;

8.1
date     86.11.27.12.10.37;  author jws;  state Exp;
branches ;
next     7.1;

7.1
date     86.11.20.14.15.52;  author hal;  state Exp;
branches ;
next     6.2;

6.2
date     86.11.19.17.08.13;  author bayes;  state Exp;
branches ;
next     6.1;

6.1
date     86.11.04.18.14.30;  author paws;  state Exp;
branches ;
next     5.2;

5.2
date     86.10.29.14.43.53;  author geli;  state Exp;
branches ;
next     5.1;

5.1
date     86.10.28.17.02.46;  author hal;  state Exp;
branches ;
next     4.1;

4.1
date     86.09.30.19.59.05;  author hal;  state Exp;
branches ;
next     3.3;

3.3
date     86.09.26.12.42.31;  author hal;  state Exp;
branches ;
next     3.2;

3.2
date     86.09.03.10.00.16;  author hal;  state Exp;
branches ;
next     3.1;

3.1
date     86.09.01.12.09.19;  author hal;  state Exp;
branches ;
next     2.1;

2.1
date     86.07.30.14.58.02;  author hal;  state Exp;
branches ;
next     1.1;

1.1
date     86.06.30.15.57.18;  author danm;  state tmp;
branches ;
next     ;


desc
@Base file for PWS 3.2 release.

@


56.3
log
@
pws2rcs automatic delta on Wed Jan 27 13:14:25 MST 1993
@
text
@{                                                                           }
{ Pascal work station graphics library                                      }
{                                                                           }
{ Module    = DGL_LIB                                                       }
{ Programer = BJS                                                           }
{ Date      = 2/1/81                                                        }

{ Rev history:                                                              }
{  5/21/82  BJS  Set display and locator names to '      ' on term          }
{  5/21/82  BJS  Fixed inverted window/set_echo_pos bug                     }
{  8/25/82  BJS  Major mods for GLE                                         }
{  2/17/84  BDS  Changed dynamic to global allocation for Pascal 3.0        }
{  4/09/85  SFB  Added HPHIL locator esc support opcodes 1090, 4290         }
{ Purpose: Hold normal user interface routines                              }

{     (c) Copyright Hewlett-Packard Company, 1985.
      All rights are reserved.  Copying or other
      reproduction of this program except for archival
      purposes is prohibited without the prior
      written consent of Hewlett-Packard Company.


		  RESTRICTED RIGHTS LEGEND

      Use, duplication, or disclosure by the Government
      is subject to restrictions as set forth in
      paragraph (b) (3) (B) of the Rights in Technical
      Data and Computer Software clause in
      DAR 7-104.9(a).

      HEWLETT-PACKARD COMPANY
      Fort Collins, Colorado                              }

$modcal$
$include 'OPTIONS'$
$linenum 20000$
$SEARCH_SIZE 15$
$search 'TYPES',
	'DGL_VARS',
	'GEN',
	'GLE_LIB',
	'DGL_C_OUT',
	'DGL_C_IN',
	'DGL_TOOLS',
	'DGL_AUTL',
	'DGL_IBODY'$


module DGL_LIB;

import dgl_types;

export
  procedure graphics_init;
  procedure set_aspect (x, y : real);
  procedure set_viewport (vxmin, vxmax, vymin, vymax : real );
  procedure set_window   (wxmin, wxmax, wymin, wymax : real );
  procedure display_finit (   fname : gstring255;
			      device_name : gstring255;
			      control : integer;
			  var ierr : integer );
  procedure display_init (    dev_adr : integer;
			      control : integer;
			  var ierr : integer );
  procedure display_term;
  procedure make_pic_current;
  procedure set_timing ( opcode : integer );
  procedure graphics_term;
  procedure locator_term;

  procedure set_color_model ( model : integer);
  procedure set_line_style ( index : integer);
  procedure set_color ( index : integer);
  procedure set_line_width ( index : integer);
  procedure locator_init (    dev_adr : integer;
			  var ierr : integer );

  function graphicserror : integer;

  procedure move (x,y:real );
  procedure line (x,y:real );
  procedure int_polyline ( num_points : integer;
		       anyvar xvec, yvec : gshortint_list );
  procedure polyline ( num_points : integer;
		       anyvar xvec, yvec : greal_list );
  procedure int_move (ix,iy : gshortint);
  procedure int_line (ix,iy : gshortint);
  procedure marker (marker_number : integer);
  procedure set_display_lim (    dxmin, dxmax,
				 dymin, dymax : real;
			     var ierr : integer);
  procedure clear_display;
  procedure input_esc (       opcode : integer;
			      isize  : integer;
			      rsize  : integer;
		       anyvar ilist  : gint_list;
		       anyvar rlist  : greal_list;
		       var    ierr   : integer  );

  procedure output_esc (       opcode : integer;
			       isize  : integer;
			       rsize  : integer;
			anyvar ilist  : gint_list;
			anyvar rlist  : greal_list;
			var    ierr   : integer  );

  procedure set_text_rot (dx, dy : real);
  procedure set_char_size (width,height : real);
  procedure gtext( s : gstring255 );

  procedure set_echo_pos (wx,wy : real);

  procedure await_locator (     echo   : integer;
			    var button : integer;
			    var rx, ry : real );

  procedure sample_locator (     echo   : integer;
			     var rx, ry : real );

  procedure set_locator_lim (    lxmin,lxmax,lymin,lymax : real;
			     var ierr : integer              );

  procedure set_color_table ( index : integer;
			      parm1 : real;
			      parm2 : real;
			      parm3 : real);

  procedure convert_wtodmm ( wx, wy : real; var mmx,mmy : real);
  procedure convert_wtolmm ( wx, wy : real; var mmx,mmy : real);

implement

import sysglobals,
       sysdevs,
       {asm,}
       dgl_vars,
       dgl_autl,
       dgl_gen,
       gle_types,
       gle_GEN,
       gle_geni,
       gle_hphil_absi,  {SFB 4/9/85}
       dgl_confg_out,
       dgl_confg_in,
       dgl_tools,
       dgl_ibody,
       iodeclarations;

{procedure hpm_dispose ( var object : anyptr; bytesize : integer ); external;}

function graphicserror : integer;

{ Purpose:  To return the most resent graphics error number                 }

begin
  graphicserror := graphics_error;
end; { graphicserror }

procedure display_move ( x,y : integer );

begin
  with gle_gcb^ do
    begin
      end_x := x;
      end_y := y;
      call (move,gle_gcb);
    end;
end;

procedure display_draw ( x,y : integer );

begin
  with gle_gcb^ do
    begin
      end_x := x;
      end_y := y;
      call (draw,gle_gcb);
    end;
end;

procedure adjust_echo (var dx,dy : integer);

{ Purpose : To adjust echo for rubber band line effects }

begin
  case current_echo_type of
    5 : dy:=d_loc_echo_y;           { horz rubber band line }
    6 : dx:=d_loc_echo_x;           { vert rubber band line }
    7 :                             { snap horz / vert rubber band line }
	if abs(dx-d_loc_echo_x) >= abs(dy-d_loc_echo_y) then
	  dy:=d_loc_echo_y
	else
	  dx:=d_loc_echo_x;
     otherwise      ;                { all other echos are ok }
  end;  { of  case }
end; { adjust_echo }

procedure cursor ( x,y : integer);

begin
  display_move(x-8,y);
  display_draw(x+8,y);

  display_move(x,y+8);
  display_draw(x,y-8);
end;

procedure echo_cursor (dx,dy : integer);

{ Purpose : To perform the current echo on a raster display }

begin

  case current_echo_type of

    1,2 : cursor(dx,dy);

    3 :
	with gcb^,gcb^.max_disp_lim do
	  begin {full screen}
	    display_move(trunc(xmin),dy);
	    display_draw(trunc(xmax),dy);
	    display_move(dx,trunc(ymin));
	    display_draw(dx,trunc(ymax));
	    display_move(dx,dy);         { set cp to cursor center }
	  end;

    4,5,6,7 :
	begin {rubber bands}
	  adjust_echo (dx,dy);          { are dx, dy correct for this echo? }
	  display_move(d_loc_echo_x,d_loc_echo_y);
	  display_draw(dx,dy);
	  cursor(dx,dy);
	end;

    8 :
	begin {rubber band box}
	  display_move(d_loc_echo_x,d_loc_echo_y);
	  display_draw(d_loc_echo_x,dy);
	  display_draw(dx,dy);
	  display_draw(dx,d_loc_echo_y);
	  display_draw(d_loc_echo_x,d_loc_echo_y);
	  cursor(dx,dy);
	end;

     otherwise ;    { no echo }

  end;  { of case }

end; { display_echo }

procedure DGL_CURSOR (  gle_gcb : graphics_control_block_ptr );

VAR
  x,y : integer;
  CPX : INTEGER;
  CPY : INTEGER;

begin
  with gle_gcb^ do
    begin
      x := info1;
      y := info2;
      CPX := CURRENT_POS_X; { SAVE CP }
      CPY := CURRENT_POS_Y;
      gle_await_blanking(gle_gcb);
      if current_cursor_state = 1 then  { remove old cursor }
	echo_cursor (current_cursor_x, current_cursor_y);
      if (info3 = 1) then               { draw new cursor }
	echo_cursor (x,y);

      current_cursor_state := info3;
      current_cursor_x := x;
      current_cursor_y := y;

      END_X := CPX;        { RESTORE CP }
      END_Y := CPY;
      GLE_MOVE(GLE_GCB);
    end;
end;

procedure convert_wtodmm ( wx, wy : real; var mmx,mmy : real);

var
  dx,dy : real;

begin
  ck_system_init;
  ck_display_init;
  dx := wx * xwtod_scale + xwtod_offset;
  dy := wy * ywtod_scale + ywtod_offset;
  with gcb^,gcb^.max_disp_lim,gle_gcb^ do
    begin
      mmx := (dx - xmin) / display_res_x;
      mmy := (dy - ymin) / display_res_y;
    end;
end;

procedure convert_wtolmm ( wx, wy : real; var mmx,mmy : real);

var
  dx,dy : real;
  tx,ty : real;

begin
  ck_system_init;
  ck_locator_init;
  dx := wx * xwtod_scale + xwtod_offset;
  dy := wy * ywtod_scale + ywtod_offset;
  with gcb^,gle_gcbi^ do
    begin
      { convert display to locator }
      tx := ((dx-cur_disp_lim.xmin) / xltod_scale) + log_loc_lim.xmin;
      ty := ((dy-cur_disp_lim.ymin) / yltod_scale) + log_loc_lim.ymin;

      { convert to mm }
      mmx := (tx - max_loc_lim.xmin) / input_res_x;
      mmy := (ty - max_loc_lim.ymin) / input_res_y;
    end;
end;

procedure set_viewport (vxmin, vxmax, vymin, vymax : real );

{ Purpose:  To set the viewport                                           }

begin
  ck_system_init;

  {ck parms}

  if (vxmin >= vxmax) or (vymin >= vymax) then error (err_bad_parms);

  with gcb^ do
    begin
      if (vxmin < 0.0) or                {ck with vir limits}
	 (vymin < 0.0) or
	 (vxmax > cur_vir_lim.xlim) or
	 (vymax > cur_vir_lim.ylim) then
	error (err_out_virt);

      with viewport_lim do
	begin
	  xmin := vxmin;                 { set the new limits }
	  xmax := vxmax;
	  ymin := vymin;
	  ymax := vymax;
	end;

      calculate_viewing;

      { set flag so character size will be recalculated }

      calc_text_xform := true;
    end
end; { set_viewport }

procedure set_window (wxmin, wxmax, wymin, wymax : real );

{ Purpose:  To set the window                                               }

begin
  ck_system_init;

  {ck parms}

  if (wxmin = wxmax) or (wymin = wymax) then error (err_bad_parms);

  with gcb^ do
    with window_lim do
      begin
	xmin := wxmin;               { set the new window }
	xmax := wxmax;
	ymin := wymin;
	ymax := wymax;
      end;

  calculate_viewing;

  { set flag so character xform will be recalculated }

  calc_text_xform := true;
end; { set_window }

procedure set_aspect (x, y : real);

{ Purpose:  To set the aspect ratio                                         }

begin
  ck_system_init;

  {ck parms }
  if (x <= 0.0) or (y <= 0.0) then error (err_aspect);

  with gcb^ do
    { calc new limits }
    with cur_vir_lim do
      begin
	aspect_ratio := y / x;
	if aspect_ratio <= 1.0 then
	  begin
	    xlim := 1.0;
	    ylim := aspect_ratio;
	  end
	else
	  begin
	    xlim := 1.0 / aspect_ratio;
	    ylim := 1.0;
	  end;
	{ set viewport to new limits }
	set_viewport( 0.0, xlim, 0.0, ylim);
      end;
end; { set_aspect }

procedure make_pic_current;

begin
  ck_system_init;
  ck_display_init;
  gle_flush_buffer ( gle_gcb );
end;

procedure set_timing ( opcode : integer );

begin
  ck_system_init;
  if (opcode < 0) or (opcode >1) then error(err_bad_parms);
  gcb^.dgl_current_timming_mode := opcode;
  if disp_init then
    begin
      gle_gcb^.info1 := opcode;
      gle_buffer_mode ( gle_gcb );
    end;
end;

procedure set_color_model ( model : integer);

begin
  ck_system_init;

  if (model<1) or (model>2) then error(err_bad_parms);
  gcb^.dgl_current_color_model := model;
end;

procedure set_color_table ( index : integer;
			    parm1 : real;
			    parm2 : real;
			    parm3 : real);

begin
  ck_system_init;
  ck_display_init;
  with gcb^,gle_gcb^ do
    begin
      if (index >= 0) and  (index <= color_table_size) then
	begin
	  dgl_polygon_color_current := false;  { dither pattern is wrong }
	  if ((0 > parm1) or (parm1 > 1)) or
	     ((0 > parm2) or (parm2 > 1)) or
	     ((0 > parm3) or (parm3 > 1)) then error (err_bad_parms);
	  call (proc_color_table,index,parm1,parm2,parm3);
	  { always recalculate line color (2.1 buug fix) }
	  call (proc_color,dgl_current_color);
	end;
    end;
end;

procedure set_line_width (index : integer);

{ Purpose:  To set the line width primitives will be drawn with              }

begin
  ck_system_init;
  ck_display_init;
  with gle_gcb^ do
    begin
      if (index < 1 ) or ( index > linewidths ) then index := 1;
      gcb^.dgl_current_linewidth := index;
      info1 := index;
      gle_linewidth ( gle_gcb );
    end;
end; { set_linewidth }

procedure set_color (index : integer);

{ Purpose:  To set the color primitives will be drawn with                  }

begin
  ck_system_init;
  ck_display_init;

  with gcb^,gle_gcb^ do
    begin
      if  (index < 0) or
	 ((index > gamut) and
	 ((color_table_size = 0) or (index > color_table_size))) then index := 1;
      { optimize changing color on raster devices (2.1 bug fix) }
      if ((dgl_current_color <> index) or (complement_support <> 1))  then
	begin
	  call (proc_color,index);
	  dgl_current_color := index;
	end;
    end;
end; { set_color }

procedure set_line_style ( index : integer);

{ Purpose:  To set the linestyle that primitives are drawn with             }

begin
  ck_system_init;
  ck_display_init;

  with gcb^ do
    begin
      if (index < 1) or (index > number_dgl_linestyles) then index := 1;
      {if dgl_current_linestyle <> index then
	begin}
	  dgl_current_linestyle := index;
	  call (proc_linestyle,index);
	{end;}
    end;
end; { set_line_style }

procedure set_display_lim (    dxmin, dxmax, dymin, dymax : real;
			   var ierr : integer);

{ Purpose : To set the logical display limits                             }

var
  txmin : real;
  txmax : real;
  tymin : real;
  tymax : real;

begin
  ck_system_init;
  ck_display_init;

  { ck parms }
  if ((dxmin < dxmax) and (dymin < dymax)) then
    with gcb^ do
      with max_disp_lim do
	begin
	  with gle_gcb^ do
	    begin
	      txmin := (dxmin * display_res_x) + xmin;
	      txmax := (dxmax * display_res_x) + xmin;

	      tymin := (dymin * display_res_y) + ymin;
	      tymax := (dymax * display_res_y) + ymin;
	    end;

	  { make sure new logical imits are within the physical limits       }
	  if (txmin >= xmin) and (txmax <= xmax + eight_diget_epsilon) and
	     (tymin >= ymin) and (tymax <= ymax + eight_diget_epsilon) then
	    begin
	      display_limits (txmin,txmax,tymin,tymax);

	      { set flag indicating that the char size needs to be
		recalculated.  This is done since the physical character size
		may change due to this procedure                             }

	      calc_text_xform := true;

	      ierr := 0;
	    end
	  else ierr := 2;
	end
  else
    ierr := 1;
end; { set_display_lim }


procedure clear_display;

{ Purpose : To clear to display                                           }

begin
  ck_system_init;
  ck_display_init;

  with gle_gcb^ do
    begin
      info1 := -1;        { clear all planes }
      info2 := gcb^.dgl_background_index;
      gle_clear ( gle_gcb );
    end;
end; { Clear_display }


$stackcheck off$
procedure move (x, y : real);

{ Purpose : To change the current position                                }

begin
  if disp_init then
    begin
      { save world cp }
      int_cp := false; { cp saved as real value }
      world_real_cpx := x;
      world_real_cpy := y;

      { calc new device dependent cp }
      cpx := trunc ( x * xwtod_scale + xwtod_offset );
      cpy := trunc ( y * ywtod_scale + ywtod_offset );

      with gle_gcb^ do
	begin
	  end_x := cpx;
	  end_y := cpy;
	  call (move,gle_gcb);
	end;
    end
  else
    if system_init then error (err_dis_int)
    else error (err_sys_int);
end; { move }


procedure line (x, y : real);

{ Purpose : To draw a line                                                }

begin
  if disp_init then
    begin
      { save world cp }
      int_cp := false; { cp saved as real value }
      world_real_cpx := x;
      world_real_cpy := y;

      { calc new device dependent cp }
      cpx := trunc ( x * xwtod_scale + xwtod_offset );
      cpy := trunc ( y * ywtod_scale + ywtod_offset );

      with gle_gcb^ do
	begin
	  end_x := cpx;
	  end_y := cpy;
	  call (draw,gle_gcb);
	end;
    end
  else
    if system_init then error (err_dis_int)
    else error (err_sys_int);
end; { line }

procedure int_move (ix, iy : gshortint);

{ Purpose : To move the current position                                  }

begin
  if disp_init then
    begin
      { use the normal move routine unless the short flag is set }
      if short_flag then
	begin
	  { save world cp }
	  int_cp := true;      { cp saved as gshortint }
	  world_int_cpx := ix;
	  world_int_cpy := iy;

	  with gle_gcb^ do
	    begin
	      end_x := ix;
	      end_y := iy;
	      dgl_scaled_move; { perform a scaled move }
	    end;
	end
      else move(ix,iy);
    end
  else
    if system_init then error (err_dis_int)
    else error (err_sys_int);
end; { int_move }


procedure int_line (ix, iy : gshortint);


{ Purpose : To set the logical display limits                             }

begin
  if disp_init then
    begin
      { use normal line unless short_flag is set }
      if short_flag then
	begin
	  { save world cp }
	  int_cp := true;      { cp saved as gshortint }
	  world_int_cpx := ix;
	  world_int_cpy := iy;
	  with gle_gcb^ do
	    begin
	      end_x := ix;
	      end_y := iy;
	      dgl_scaled_draw;   { perform a scaled draw }
	    end;
	end
      else
	line(ix,iy);
    end
  else
    if system_init then error (err_dis_int)
    else error (err_sys_int);
end; { int_line }

procedure int_polyline ( num_points : integer;
		     anyvar xvec, yvec : gshortint_list );
var
  i : integer;

begin
  ck_system_init;
  ck_display_init;

  if num_points <= 0 then error(err_neg_points);

  int_move ( xvec[1], yvec[1] );
  for i := 2 to num_points do
    int_line ( xvec[i], yvec[i]);
end;

procedure polyline ( num_points : integer;
		     anyvar xvec, yvec : greal_list );
var
  i : integer;

begin
  ck_system_init;
  ck_display_init;

  if num_points <= 0 then error(err_neg_points);

  move ( xvec[1], yvec[1] );
  for i := 2 to num_points do
    line ( xvec[i], yvec[i]);
end;
$stackcheck on$

procedure gtext( s : gstring255 );

{ PURPOSE : To draw a text string                                            }

begin
  if disp_init then
    begin
      if calc_text_xform then
	with gcb^ do
	  begin
	    set_char_size (dgl_char_width, dgl_char_height);
	    set_text_rot  (char_rot_w, char_rot_h);
	    calc_text_xform := false;
	  end;
      with gle_gcb^ do
	begin
	  info_ptr1 := addr(s[1]);
	  info1 := strlen(s);
	end;
      gle_text ( gle_gcb );
    end
  else
    if system_init then error (err_dis_int)
    else error (err_sys_int);
end; { gtext }

procedure marker ( marker_number : integer );

begin
  ck_system_init;
  ck_display_init;
  if (marker_number < 1) or (marker_number > 19) then marker_number := 1;

  with gle_gcb^ do
    begin
      info1 := marker_number;
      gle_set_marker ( gle_gcb );
      gle_marker ( gle_gcb );
    end;
end;

procedure input_esc (       opcode : integer;
			    isize  : integer;
			    rsize  : integer;
		     anyvar ilist  : gint_list;
		     anyvar rlist  : greal_list;
		     var    ierr   : integer  );

{ Purpose : To perform an input escape function                           }

begin
  ck_system_init;
  ck_display_init;

  ierr := opcode_ck ( opcode,isize,rsize);
  call (gcb^.proc_input_esc,opcode,isize,rsize,ilist,rlist,ierr);

end; { input_esc }

procedure output_esc (       opcode : integer;
			     isize  : integer;
			     rsize  : integer;
		      anyvar ilist  : gint_list;
		      anyvar rlist  : greal_list;
		      var    ierr   : integer  );

{ Purpose : To perform an output escape funtion                           }

begin
  ck_system_init;
  ck_display_init;

  ierr := opcode_ck ( opcode,isize,rsize);
  call (gcb^.proc_output_esc,opcode,isize,rsize,ilist,rlist,ierr);
end; { output_esc }

procedure set_text_rot (dx, dy : real);

{ PURPOSE : To set the new text rotation vectors                             }

{ calc normalize vector and save }
{ set flag so text xform is recalculated }

var
  r : real;

begin
  ck_system_init;
  ck_display_init;

  if (dx = 0) and (dy = 0) then error (err_bad_parms);

  with gcb^ do
    begin
      r := sqrt ( dx*dx + dy*dy);
      char_rot_w := dx / r;
      char_rot_h := dy / r;
      with gle_gcb^ do
	begin
	  info1 := trunc(char_rot_w * 32768);
	  info2 := trunc(char_rot_h * 32768);
	end;
      gle_text_dir ( gle_gcb );
    end
end; { set_text_rot }


procedure set_char_size (width,height:real);

{ PURPOSE : To set the new character size                                    }

{ save width and height, set flag so text xform is recalculated         }

begin
  ck_system_init;
  ck_display_init;

  {if (width = 0.0) or (height = 0.0) then error (err_bad_parms);}

  with gcb^ do
    begin
      dgl_char_width := width;
      dgl_char_height := height;
      with gle_gcb^ do
	begin
	  info1 := abs(trunc((width * xwtod_scale * 7 / 9) * 8));
	  info2 := abs(trunc((height * ywtod_scale * 9 / 15) * 8));
	  gle_char_size ( gle_gcb );

	  info1 := abs(trunc((width * xwtod_scale * 2 / 9) * 8));
	  info2 := abs(trunc((height * ywtod_scale * 6 / 15) * 8));
	  gle_text_spacing ( gle_gcb );
	end;
    end
end; { set_char_size }


procedure set_echo_pos (wx,wy : real);

{ Purpose : To set the locator echo position                                }

  function between ( x1, p, x2 : real ) : boolean; { added for 2.1 bug fix }

  begin
    between := (((x1 <= p) and ( p <= x2)) or
		((x2 <= p) and ( p <= x1)));
  end;

begin
  ck_system_init;
  ck_display_init;
  ck_locator_init;

  with gcb^ do
    with window_lim do
      begin
	{ ck bounds }
	if (between (xmin,wx,xmax) and            { 2.1 bug fix }
	    between (ymin,wy,ymax)) then
	  begin
	    { set world coord echo pos }
	    w_loc_echo_x := wx;
	    w_loc_echo_y := wy;

	    { convert to display units }
	    convert_wtod (w_loc_echo_x,w_loc_echo_y,d_loc_echo_x,d_loc_echo_y);
	  end
	{ ignor call if outside window }
      end
end; { set_echo_pos }

procedure set_locator_lim (    lxmin,lxmax,lymin,lymax : real;
			   var ierr : integer              );


{ Purpose : To set the locator echo position                                }

var
  txmin : real;
  txmax : real;
  tymin : real;
  tymax : real;

begin
  ck_system_init;
  ck_locator_init;

  { input limits can only be changed if the input device is not the same
    physical device as the display                                       }
  with gcb^ do
    if not disp_eq_loc then
      begin
	{ ck parms }
	if (lxmin < lxmax) and (lymin < lymax) then
	   with gle_gcbi^ do
	     with max_loc_lim do
	       begin
	       { convert limits form mil to locator cord }
		 txmin := ((lxmin * input_res_x) + xmin);
		 txmax := ((lxmax * input_res_x) + xmin);
		 tymin := ((lymin * input_res_y) + ymin);
		 tymax := ((lymax * input_res_y) + ymin);

		 { make sure new logical imits are within the physical
		  limits                                                   }
		 if (txmin >= xmin) and
		   (txmax <= xmax + eight_diget_epsilon) and
		   (tymin >= ymin) and
		   (tymax <= ymax + eight_diget_epsilon) then
		    begin
		      { set new limits }
		      locator_limits (txmin,txmax,tymin,tymax);
		      ierr := 0;
		    end
		  else { bad limits }
		    ierr := 2;
	       end
	else { bad parms }
	  ierr := 1;
      end
    else { locator and display are same device }
      ierr := 3;
end; { set_locator_lim }


procedure sample_locator(    echo   : integer;
			 var rx,ry  : real    );

{ Purpose : To sample the locator device                                    }

begin
  if loc_init then
    begin
      if disp_init then make_pic_current;
      call (gcb^.proc_sample_locator,echo,rx,ry);
    end
  else
    if system_init then error(err_loc_int)
    else error(err_sys_int);

end; { sample_locator }

procedure await_locator(    echo   : integer;
			var button : integer;
			var rx,ry  : real    );


{ Purpose : To activate the locator, and wait for operator termination      }


var
  saved_pattern,
  saved_linewidth,
  saved_linestyle,
  saved_length,
  saved_mode,
  saved_drawing_mode : integer;

begin
  ck_system_init;
  ck_locator_init;
  if disp_init then
    with gcb^,gle_gcb^ do
      begin
	make_pic_current;
	saved_pattern      := current_linestyle_pattern;
	saved_linewidth    := current_linewidth;
	saved_linestyle    := current_linestyle;
	saved_length       := current_pattern_length;
	saved_mode         := current_linestyle_mode;
	saved_drawing_mode := current_drawing_mode;

	info1 := 0;
	info2 := 0;
	info3 := 0;
	info4 := -1;
	gle_linestyle ( gle_gcb );

	info1 := 1;
	gle_linewidth ( gle_gcb );

	call (proc_color,cursor_color);

	info1 := complement_mode;
	gle_define_drawing_mode ( gle_gcb );
      end;

  call (gcb^.proc_await_locator,echo,button,rx,ry);

  if disp_init then
    begin
      with gcb^,gle_gcb^ do
	begin
	  info1 := saved_linestyle;
	  info2 := saved_length;
	  info3 := saved_mode;
	  info4 := saved_pattern;
	  gle_linestyle ( gle_gcb );

	  info1 := saved_linewidth;
	  gle_linewidth ( gle_gcb );

	  info1 := saved_drawing_mode;
	  gle_define_drawing_mode ( gle_gcb );

	  call (proc_color,dgl_current_color);
	end;

      if echo > 1 then
	if not int_cp then move ( world_real_cpx, world_real_cpy )
	else               int_move ( world_int_cpx, world_int_cpy );
    end;

end; { await_locator }

procedure display_term;

{ Purpose:  To terminate the graphics display                               }

begin
  ck_system_init;
  ck_display_init;

  with gcb^ do
    begin
      disp_init := false;
      disp_file_name := '';
      disp_dev_adr := 0;

      { reset display limits to default }

      with init_display_lim do
	display_limits(xmin,xmax,ymin,ymax);

      if disp_eq_loc then with def_loc_lim do   { locator limits no longer }
	locator_limits (xmin,xmax,ymin,ymax);   { are effected by the display }

      disp_eq_loc := not loc_init;   { if both disabled then they are equal }

      try
	call (gcb^.proc_color,0);
	gle_flush_buffer ( gle_gcb );
	gle_get_p1p2 ( gle_gcb );      { Force read from device.  This syncs
					 the OS with buffered devices    }
	gle_term(gle_gcb);
      recover
	{ ignore timeout errors }
	 if (escapecode <> -26) or (ioe_result <> 17) then escape(escapecode);

    end;

end; { display_term }

{rules for proc_locator_input/output_esc:
  o if it's your opcode you may set ierr appropriately
  o if it's not your opcode don't touch ierr
  o new output drivers should make a call to proc_locator_xxx_esc only
    after the display handler has had a chance at the opcode (and
    has set ierr to 1 if it wasn't processed by the display, or appropriate
    ierr number if the display did claim it)
  o opcodes to be handled by the display and those to be handled by the
    locator MUST NEVER have the same opcode number! It is recommended to
    use numbers with a 9 in the tens digit for locator opcodes.
}
procedure dummy_esc(         opc,isize,rsize : integer;
		      anyvar ilist : gint_list;
		      anyvar rlist : greal_list;
			 var ierr  : integer);
begin
end;

{hili escs put here so can access locator_init, locator_term SFB 4/10/85}

procedure hili_input_esc (opc,isize,rsize : integer;
			     anyvar ilist : gint_list;
			     anyvar rlist : greal_list;
				var ierr  : integer);
begin
 if (opc = 4290) and (isize = 4) and (rsize = 2) and
    (ilist[1] >= 1) and (ilist[1] <= 7) then
  with loopcontrol^.loopdevices[ilist[1]].descrip do
   begin
    ilist[1] := id;
    ilist[2] := maxcountx;
    ilist[3] := maxcounty;
    ilist[4] := nbuttons;
    rlist[1] := counts/10.0;
    if not size16 then
     rlist[1] := rlist[1]/100.0;
    rlist[2] := rlist[1];
    ierr     := 0
   end
 else
  if opc = 4290 then
   ierr := 4;    {my opcode but bad parameters}
end;


procedure hili_output_esc(opc,isize,rsize : integer;
			     anyvar ilist : gint_list;
			     anyvar rlist : greal_list;
				var ierr  : integer);
var err  : integer;     {for call to locator_init}
    dev_adr : integer;
    myop : boolean;
    old_extend : integer;
begin
  myop := (opc = 1090) or (opc = 1091);
  if myop and (isize = 1) and (rsize = 0) and
    (ilist[1] >= 0) then
  begin
   ierr := 0;
   dev_adr := gcb^.loc_dev_adr; {save locator address before losing it}
   if opc = 1091 then
    if dev_adr = 202 then       {only relative locator}
     dvr_rec^.extend := ilist[1] {save kbd_terminator info in extend false = 0,
				  true = other}
    else
     ierr := 1
   else
    begin
     old_extend := dvr_rec^.extend;
     locator_term;        {terminate previous locator so locator_init won't}
     dvr_rec^.devices := ilist[1] mod 128; {set up driver with devices mask}
     locator_init(dev_adr,err);   {and re-init using new devices to scale}
     dvr_rec^.extend := old_extend;
     if err <> 0 then             {and check nothing went wrong}
      begin
       dvr_rec^.devices := 127;   {re-enable all HIL locators in dvr because}
       ierr  := 1                 {we don't support for some reason, or all
				   devices were deactivated}
      end;
    end;
  end
 else
  if myop then
   ierr  := 4;           {bad parameters but my opcode}
end;

procedure locator_term;

{ Purpose:  To terminate the locator device                                 }

begin
  ck_system_init;
  ck_locator_init;

  loc_init := false;
  with gcb^, gle_gcbi^ do
   begin
    if (input_handler_name = 'HILABS') or
       (input_handler_name = 'HILREL') then      {4/9/85 SFB}
     begin
      proc_locator_input_esc  := dummy_esc;
      proc_locator_output_esc := dummy_esc;
     end;
     disp_eq_loc := not disp_init;   { if both disabled then they are equal }
     loc_dev_adr := 0;
    end;

  { reset to default locator limits }
  with init_locator_lim do
    locator_limits (xmin,xmax,ymin,ymax);

  gle_input_term(gle_gcbi);

end; { locator_term }

procedure graphics_term;

{ Purpose:  To terminate the graphics system                                }

begin
  ck_system_init;

  { make sure all devices are terminated }
  if disp_init then display_term;
  if loc_init then locator_term;
  if dvr_rec <> nil then       {enable all HPHIL locators in driver}
   dvr_rec^.devices := 127;

  { set system initialized flag to disabled }
  system_init := false;
end; { graphics_term }

procedure setup_display ( var ierr : integer);

var
  i : integer;

  { Purpose:  To set up display state after it has been initialized     }

begin
  with gcb^ do
    begin
      with gle_gcb^ do
	begin
	  max_disp_lim.xmin := display_min_x;
	  max_disp_lim.xmax := display_max_x;
	  max_disp_lim.ymin := display_min_y;
	  max_disp_lim.ymax := display_max_y;

	  gle_get_p1p2 ( gle_gcb );

	  def_disp_lim.xmin := info1;
	  def_disp_lim.xmax := info2;
	  def_disp_lim.ymin := info3;
	  def_disp_lim.ymax := info4;
	end;

      disp_init := true;
      disp_eq_loc :=  ((disp_dev_adr = loc_dev_adr) or
		      ((disp_dev_adr = internal_display) and
		       (loc_dev_adr = internal_locator)));

      { set up display limits }

      with def_disp_lim do
	display_limits(xmin,xmax,ymin,ymax);

      { set up default text size and rotation attributes }

      dgl_char_width := init_char_width_factor *
	abs (window_lim.xmax - window_lim.xmin);
      dgl_char_height := init_char_height_factor *
	abs (window_lim.ymax - window_lim.ymin);
      set_char_size ( dgl_char_width, dgl_char_height );

      char_rot_w := init_char_rot_w;
      char_rot_h := init_char_rot_h;

      set_text_rot ( char_rot_w, char_rot_h );

      { set up all attributes here        }

      dgl_current_polygon_edge := true;
      dgl_current_polygon_crosshatch := false;
      dgl_current_polygon_linestyle := init_linestyle;
      dgl_current_polygon_style := 1;
      dgl_current_polygon_color := init_color;
      dgl_polygon_color_current := false;  { color not set in gle }
      dgl_current_polygon_density := 0;
      dgl_current_polygon_angle := 0;
      set_timing ( dgl_current_timming_mode );
      dgl_current_color := -1; { force calc of color }
      set_color(init_color);
      set_line_style(init_linestyle);
      set_line_width(init_linewidth);

      { init_cpy is in device units }
      cpx := init_cpx;
      cpy := init_cpy;

      with gle_gcb^ do
	begin
	  marker_size_x := trunc(display_res_x * 2.5 + 0.5); { markers are 2.5 mm in size }
	  marker_size_y := marker_size_x;
	  info1 := marker_size_x;
	  info2 := marker_size_y;
	  gle_marker_size ( gle_gcb );

	  info1 := 1;
	  gle_graphics_on_off ( gle_gcb );  { make sure graphics is on }
	end;
    end;
end; { setup_display }

procedure display_finit (   fname : gstring255;
			    device_name : gstring255;
			    control : integer;
			var ierr : integer );

{ Purpose:  To initialize the display device                                }

var
  cnt : integer;

begin
  ck_system_init;

  { make sure no display is currently enabled }
  if disp_init then display_term;

  if strlen(strrtrim(strltrim(device_name))) <> 0 then
    with gle_gcb^ do
      begin
	device_info := addr(fname[1]);
	device_info_char_count := strlen(fname);
	spooling := 1;
	display_name := '      ';
	display_name_char_count := min(strlen(device_name),6);
	for cnt := 1 to display_name_char_count do
	  display_name [cnt] := device_name[cnt];
	info1 := control;
	info2 := 0; { config DGL stuff }
	configure_gle (gle_gcb);
	ierr := error_return;
      end
  else
    ierr := 2;

  if ierr = 0 then
    try
      with gcb^ do
	begin
	  disp_dev_adr := -1;     { indicate file name }
	  disp_file_name := fname;
	  setup_display ( ierr );
	end;
    recover
      begin
	if escapecode = -20 then escape(escapecode); { ignor all errors except stop key }
	ierr := 2;
      end
  else
    ierr := 2;

end; { display_finit }

procedure display_init (    dev_adr : integer;
			    control : integer;
			var ierr : integer );

{ Purpose:  To initialize the display device                                }

var
  s : string[10];
  cnt : integer;

begin
  ck_system_init;

  { make sure no display is currently enabled }
  if disp_init then display_term;

  with gle_gcb^ do
    begin
      s := '';
      strwrite(s,1,cnt,dev_adr:0);
      device_info_char_count := strlen(s);
      device_info := addr(s[1]);
      spooling := 0;
      info1 := control;
      info2 := 0; { config DGL stuff }
      configure_gle (gle_gcb);
      ierr := error_return;
    end;

  if ierr = 0 then
    try
      with gcb^ do
	begin
	  disp_dev_adr := dev_adr;
	  disp_file_name := '';
	end;
      setup_display ( ierr );

      if gle_gcb^.complement_support = 1
	then gle_gcb^.cursor := dgl_cursor;
    recover
      begin
	if escapecode = -20 then escape(escapecode); { ignor all errors exect stop key }
	ierr := 2;
      end
  else
    ierr := 2;

end; { display_init }


procedure locator_init (    dev_adr : integer;
			var ierr    : integer );

{ Purpose:  To initialize the locator device                                }

var
  s : string[10];
  i : integer;

begin
  ck_system_init;

  { make sure no locator is enabled }
  if loc_init then locator_term;

  { try to init a locator }

  if disp_init then make_pic_current;

  with gcb^,gle_gcbi^ do
    begin
      s := '';
      strwrite(s,1,i,dev_adr:0);
      device_info_char_count := strlen(s);
      device_info := addr(s[1]);
      info1 := 0;                          { init sample loc value }
      info2 := 0;
      if disp_init then {SFB 3/27/85}   {tell gle_init_knob_input whether}
       begin
	info3 := gle_gcb^.pallette;      {color or mono display}
	input_max_x := gle_gcb^.display_max_x;  {for DGL_REL SFB 10-27-86 }
	input_max_y := gle_gcb^.display_max_y;  {for DGL_REL SFB 10-27-86 }
       end
      else
       begin
	info3 := 0;                      {or display not initialized}
	input_max_x := 32767;  {for DGL_REL SFB 10-27-86 }
	input_max_y := 32767;  {for DGL_REL SFB 10-27-86 }
       end;

      configure_input_gle ( gle_gcbi );

      ierr := error_return;

      if ierr = 0 then
	begin
	  loc_init := true;
	  loc_dev_adr := dev_adr;

	  with gle_gcbi^,gcb^.max_loc_lim do
	    begin
	      xmin := input_min_x;
	      xmax := input_max_x;
	      ymin := input_min_y;
	      ymax := input_max_y;
	    end;

	  gle_get_input_p1p2 ( gle_gcbi );

	  with gle_gcbi^,gcb^,gcb^.def_loc_lim do
	    begin
	      xmin := info1;
	      xmax := info2;
	      ymin := info3;
	      ymax := info4;
	    end;

	  disp_eq_loc := disp_init and
			 ((disp_dev_adr = loc_dev_adr) or
			 ((disp_dev_adr = internal_display) and
			 (loc_dev_adr = internal_locator)));

	  { If locator is not the same physical device as the graphics display,
	    then the locator limits are set to the default locator limits.
	    If the locator is the same device, then the locator limits
	    are set to the current display limits.                              }

	  with gcb^ do
	    begin
	      if disp_eq_loc then
		with cur_disp_lim do locator_limits (xmin,xmax,ymin,ymax)
	      else
		with def_loc_lim do locator_limits (xmin,xmax,ymin,ymax);
	    end;


	  if (input_handler_name = 'HILABS') or
	     (input_handler_name = 'HILREL') then {SFB 4/9/85}
	   begin
	    proc_locator_output_esc := hili_output_esc;
	    proc_locator_input_esc :=  hili_input_esc;
	   end;
	end
      else
	ierr := 2;
  end;
end; { locator_init }


procedure graphics_init;

{ Purpose:  To initialize the graphics system                               }

begin
  { make sure the system is not already init }
  if system_init then graphics_term;

  { set state flags }
  system_init := true;
  disp_init   := false;
  loc_init    := false;


  { get storage space -- changed from dynamic to global 2/84 BDS }
  gcb := addr(gcb_space);             { DGL high level storage }

  gle_gcb := addr(gle_gcb_space);     { display output device }
  gle_init_gcb ( gle_gcb );

  gle_gcbi := addr(gle_gcbi_space);   { locator input device  }
  gle_init_input_gcb ( gle_gcbi );

  gle_knob_echo_gcb := addr(gle_knob_echo_gcb_space);
				      {knob echo output device (internal crt)}
  gle_init_gcb ( gle_knob_echo_gcb );

  { kbdlangjumper is imported from sysglobales.  Kata becomes true if
    the kata keyboard is instaled                                      }
  if kbdlang = katakana_kbd then gle_gcb^.kata := 1
  else gle_gcb^.kata := 0;

  { set up defaults }
  with gcb^ do
    begin
      { When first inited that display and locator are the same device }
      disp_eq_loc := true;
      disp_dev_adr := init_dev_adr;
      disp_file_name := '';
      loc_dev_adr  := init_dev_adr;
      window_lim   := init_window;
      aspect_ratio := init_aspect;
      cur_vir_lim  := init_vir_lim;
      viewport_lim := init_viewport;

      { setup the default display/ locator limits to some large number }

      with init_display_lim do
	display_limits ( xmin, xmax, ymin, ymax );
      with init_locator_lim do
	locator_limits ( xmin, xmax, ymin, ymax );

      { explicitly set the cp to init_value }

      cpx := init_cpx;
      cpy := init_cpy;
      int_cp := true;
      world_int_cpx := init_cpx;
      world_int_cpy := init_cpy;

      { set up default text size and rotation attributes }

      dgl_char_width := init_char_width;
      dgl_char_height := init_char_height;

      char_rot_w := init_char_rot_w;
      char_rot_h := init_char_rot_h;

      { set flag, indicating that the text xform needs to be recalulated      }

      calc_text_xform := true;

      dgl_current_color := init_color;
      dgl_current_linestyle := init_linestyle;
      dgl_current_linewidth := init_linewidth;
      dgl_current_timming_mode := init_timming_mode;
      cursor_color := init_color;
      disp_just := centered;
      display_echo_mult := 1;
      graphics_error := 0;

      number_polygon_styles := default_poly_table_size;
      color_table_size := default_color_table_size;
      dgl_current_polygon_color := 1;
      dgl_current_polygon_linestyle := 1;
      dgl_current_polygon_density := 0;
      dgl_current_polygon_angle := 90;
      dgl_current_polygon_edge := true;
      dgl_current_polygon_crosshatch := false;
      dgl_current_polygon_style := 1;
      dgl_current_color_model := 1;
      proc_locator_output_esc := dummy_esc;     {SFB 4/9/85}
      proc_locator_input_esc :=  dummy_esc;     {SFB 4/9/85}
    end;

   if dvr_rec <> nil then       {enable all HPHIL locators in driver}
    dvr_rec^.devices := 127;

end; { graphics_init }

end. {module DGL_LIB}


$LIST ON$

@


56.2
log
@
pws2rcs automatic delta on Wed Jan 27 11:57:27 MST 1993
@
text
@d1 1615
@


56.1
log
@Automatic bump of revision number for PWS version 3.25
@
text
@a0 1615
{                                                                           }
{ Pascal work station graphics library                                      }
{                                                                           }
{ Module    = DGL_LIB                                                       }
{ Programer = BJS                                                           }
{ Date      = 2/1/81                                                        }

{ Rev history:                                                              }
{  5/21/82  BJS  Set display and locator names to '      ' on term          }
{  5/21/82  BJS  Fixed inverted window/set_echo_pos bug                     }
{  8/25/82  BJS  Major mods for GLE                                         }
{  2/17/84  BDS  Changed dynamic to global allocation for Pascal 3.0        }
{  4/09/85  SFB  Added HPHIL locator esc support opcodes 1090, 4290         }
{ Purpose: Hold normal user interface routines                              }

{     (c) Copyright Hewlett-Packard Company, 1985.
      All rights are reserved.  Copying or other
      reproduction of this program except for archival
      purposes is prohibited without the prior
      written consent of Hewlett-Packard Company.


		  RESTRICTED RIGHTS LEGEND

      Use, duplication, or disclosure by the Government
      is subject to restrictions as set forth in
      paragraph (b) (3) (B) of the Rights in Technical
      Data and Computer Software clause in
      DAR 7-104.9(a).

      HEWLETT-PACKARD COMPANY
      Fort Collins, Colorado                              }

$modcal$
$include 'OPTIONS'$
$linenum 20000$
$SEARCH_SIZE 15$
$search 'TYPES',
	'DGL_VARS',
	'GEN',
	'GLE_LIB',
	'DGL_C_OUT',
	'DGL_C_IN',
	'DGL_TOOLS',
	'DGL_AUTL',
	'DGL_IBODY'$


module DGL_LIB;

import dgl_types;

export
  procedure graphics_init;
  procedure set_aspect (x, y : real);
  procedure set_viewport (vxmin, vxmax, vymin, vymax : real );
  procedure set_window   (wxmin, wxmax, wymin, wymax : real );
  procedure display_finit (   fname : gstring255;
			      device_name : gstring255;
			      control : integer;
			  var ierr : integer );
  procedure display_init (    dev_adr : integer;
			      control : integer;
			  var ierr : integer );
  procedure display_term;
  procedure make_pic_current;
  procedure set_timing ( opcode : integer );
  procedure graphics_term;
  procedure locator_term;

  procedure set_color_model ( model : integer);
  procedure set_line_style ( index : integer);
  procedure set_color ( index : integer);
  procedure set_line_width ( index : integer);
  procedure locator_init (    dev_adr : integer;
			  var ierr : integer );

  function graphicserror : integer;

  procedure move (x,y:real );
  procedure line (x,y:real );
  procedure int_polyline ( num_points : integer;
		       anyvar xvec, yvec : gshortint_list );
  procedure polyline ( num_points : integer;
		       anyvar xvec, yvec : greal_list );
  procedure int_move (ix,iy : gshortint);
  procedure int_line (ix,iy : gshortint);
  procedure marker (marker_number : integer);
  procedure set_display_lim (    dxmin, dxmax,
				 dymin, dymax : real;
			     var ierr : integer);
  procedure clear_display;
  procedure input_esc (       opcode : integer;
			      isize  : integer;
			      rsize  : integer;
		       anyvar ilist  : gint_list;
		       anyvar rlist  : greal_list;
		       var    ierr   : integer  );

  procedure output_esc (       opcode : integer;
			       isize  : integer;
			       rsize  : integer;
			anyvar ilist  : gint_list;
			anyvar rlist  : greal_list;
			var    ierr   : integer  );

  procedure set_text_rot (dx, dy : real);
  procedure set_char_size (width,height : real);
  procedure gtext( s : gstring255 );

  procedure set_echo_pos (wx,wy : real);

  procedure await_locator (     echo   : integer;
			    var button : integer;
			    var rx, ry : real );

  procedure sample_locator (     echo   : integer;
			     var rx, ry : real );

  procedure set_locator_lim (    lxmin,lxmax,lymin,lymax : real;
			     var ierr : integer              );

  procedure set_color_table ( index : integer;
			      parm1 : real;
			      parm2 : real;
			      parm3 : real);

  procedure convert_wtodmm ( wx, wy : real; var mmx,mmy : real);
  procedure convert_wtolmm ( wx, wy : real; var mmx,mmy : real);

implement

import sysglobals,
       sysdevs,
       {asm,}
       dgl_vars,
       dgl_autl,
       dgl_gen,
       gle_types,
       gle_GEN,
       gle_geni,
       gle_hphil_absi,  {SFB 4/9/85}
       dgl_confg_out,
       dgl_confg_in,
       dgl_tools,
       dgl_ibody,
       iodeclarations;

{procedure hpm_dispose ( var object : anyptr; bytesize : integer ); external;}

function graphicserror : integer;

{ Purpose:  To return the most resent graphics error number                 }

begin
  graphicserror := graphics_error;
end; { graphicserror }

procedure display_move ( x,y : integer );

begin
  with gle_gcb^ do
    begin
      end_x := x;
      end_y := y;
      call (move,gle_gcb);
    end;
end;

procedure display_draw ( x,y : integer );

begin
  with gle_gcb^ do
    begin
      end_x := x;
      end_y := y;
      call (draw,gle_gcb);
    end;
end;

procedure adjust_echo (var dx,dy : integer);

{ Purpose : To adjust echo for rubber band line effects }

begin
  case current_echo_type of
    5 : dy:=d_loc_echo_y;           { horz rubber band line }
    6 : dx:=d_loc_echo_x;           { vert rubber band line }
    7 :                             { snap horz / vert rubber band line }
	if abs(dx-d_loc_echo_x) >= abs(dy-d_loc_echo_y) then
	  dy:=d_loc_echo_y
	else
	  dx:=d_loc_echo_x;
     otherwise      ;                { all other echos are ok }
  end;  { of  case }
end; { adjust_echo }

procedure cursor ( x,y : integer);

begin
  display_move(x-8,y);
  display_draw(x+8,y);

  display_move(x,y+8);
  display_draw(x,y-8);
end;

procedure echo_cursor (dx,dy : integer);

{ Purpose : To perform the current echo on a raster display }

begin

  case current_echo_type of

    1,2 : cursor(dx,dy);

    3 :
	with gcb^,gcb^.max_disp_lim do
	  begin {full screen}
	    display_move(trunc(xmin),dy);
	    display_draw(trunc(xmax),dy);
	    display_move(dx,trunc(ymin));
	    display_draw(dx,trunc(ymax));
	    display_move(dx,dy);         { set cp to cursor center }
	  end;

    4,5,6,7 :
	begin {rubber bands}
	  adjust_echo (dx,dy);          { are dx, dy correct for this echo? }
	  display_move(d_loc_echo_x,d_loc_echo_y);
	  display_draw(dx,dy);
	  cursor(dx,dy);
	end;

    8 :
	begin {rubber band box}
	  display_move(d_loc_echo_x,d_loc_echo_y);
	  display_draw(d_loc_echo_x,dy);
	  display_draw(dx,dy);
	  display_draw(dx,d_loc_echo_y);
	  display_draw(d_loc_echo_x,d_loc_echo_y);
	  cursor(dx,dy);
	end;

     otherwise ;    { no echo }

  end;  { of case }

end; { display_echo }

procedure DGL_CURSOR (  gle_gcb : graphics_control_block_ptr );

VAR
  x,y : integer;
  CPX : INTEGER;
  CPY : INTEGER;

begin
  with gle_gcb^ do
    begin
      x := info1;
      y := info2;
      CPX := CURRENT_POS_X; { SAVE CP }
      CPY := CURRENT_POS_Y;
      gle_await_blanking(gle_gcb);
      if current_cursor_state = 1 then  { remove old cursor }
	echo_cursor (current_cursor_x, current_cursor_y);
      if (info3 = 1) then               { draw new cursor }
	echo_cursor (x,y);

      current_cursor_state := info3;
      current_cursor_x := x;
      current_cursor_y := y;

      END_X := CPX;        { RESTORE CP }
      END_Y := CPY;
      GLE_MOVE(GLE_GCB);
    end;
end;

procedure convert_wtodmm ( wx, wy : real; var mmx,mmy : real);

var
  dx,dy : real;

begin
  ck_system_init;
  ck_display_init;
  dx := wx * xwtod_scale + xwtod_offset;
  dy := wy * ywtod_scale + ywtod_offset;
  with gcb^,gcb^.max_disp_lim,gle_gcb^ do
    begin
      mmx := (dx - xmin) / display_res_x;
      mmy := (dy - ymin) / display_res_y;
    end;
end;

procedure convert_wtolmm ( wx, wy : real; var mmx,mmy : real);

var
  dx,dy : real;
  tx,ty : real;

begin
  ck_system_init;
  ck_locator_init;
  dx := wx * xwtod_scale + xwtod_offset;
  dy := wy * ywtod_scale + ywtod_offset;
  with gcb^,gle_gcbi^ do
    begin
      { convert display to locator }
      tx := ((dx-cur_disp_lim.xmin) / xltod_scale) + log_loc_lim.xmin;
      ty := ((dy-cur_disp_lim.ymin) / yltod_scale) + log_loc_lim.ymin;

      { convert to mm }
      mmx := (tx - max_loc_lim.xmin) / input_res_x;
      mmy := (ty - max_loc_lim.ymin) / input_res_y;
    end;
end;

procedure set_viewport (vxmin, vxmax, vymin, vymax : real );

{ Purpose:  To set the viewport                                           }

begin
  ck_system_init;

  {ck parms}

  if (vxmin >= vxmax) or (vymin >= vymax) then error (err_bad_parms);

  with gcb^ do
    begin
      if (vxmin < 0.0) or                {ck with vir limits}
	 (vymin < 0.0) or
	 (vxmax > cur_vir_lim.xlim) or
	 (vymax > cur_vir_lim.ylim) then
	error (err_out_virt);

      with viewport_lim do
	begin
	  xmin := vxmin;                 { set the new limits }
	  xmax := vxmax;
	  ymin := vymin;
	  ymax := vymax;
	end;

      calculate_viewing;

      { set flag so character size will be recalculated }

      calc_text_xform := true;
    end
end; { set_viewport }

procedure set_window (wxmin, wxmax, wymin, wymax : real );

{ Purpose:  To set the window                                               }

begin
  ck_system_init;

  {ck parms}

  if (wxmin = wxmax) or (wymin = wymax) then error (err_bad_parms);

  with gcb^ do
    with window_lim do
      begin
	xmin := wxmin;               { set the new window }
	xmax := wxmax;
	ymin := wymin;
	ymax := wymax;
      end;

  calculate_viewing;

  { set flag so character xform will be recalculated }

  calc_text_xform := true;
end; { set_window }

procedure set_aspect (x, y : real);

{ Purpose:  To set the aspect ratio                                         }

begin
  ck_system_init;

  {ck parms }
  if (x <= 0.0) or (y <= 0.0) then error (err_aspect);

  with gcb^ do
    { calc new limits }
    with cur_vir_lim do
      begin
	aspect_ratio := y / x;
	if aspect_ratio <= 1.0 then
	  begin
	    xlim := 1.0;
	    ylim := aspect_ratio;
	  end
	else
	  begin
	    xlim := 1.0 / aspect_ratio;
	    ylim := 1.0;
	  end;
	{ set viewport to new limits }
	set_viewport( 0.0, xlim, 0.0, ylim);
      end;
end; { set_aspect }

procedure make_pic_current;

begin
  ck_system_init;
  ck_display_init;
  gle_flush_buffer ( gle_gcb );
end;

procedure set_timing ( opcode : integer );

begin
  ck_system_init;
  if (opcode < 0) or (opcode >1) then error(err_bad_parms);
  gcb^.dgl_current_timming_mode := opcode;
  if disp_init then
    begin
      gle_gcb^.info1 := opcode;
      gle_buffer_mode ( gle_gcb );
    end;
end;

procedure set_color_model ( model : integer);

begin
  ck_system_init;

  if (model<1) or (model>2) then error(err_bad_parms);
  gcb^.dgl_current_color_model := model;
end;

procedure set_color_table ( index : integer;
			    parm1 : real;
			    parm2 : real;
			    parm3 : real);

begin
  ck_system_init;
  ck_display_init;
  with gcb^,gle_gcb^ do
    begin
      if (index >= 0) and  (index <= color_table_size) then
	begin
	  dgl_polygon_color_current := false;  { dither pattern is wrong }
	  if ((0 > parm1) or (parm1 > 1)) or
	     ((0 > parm2) or (parm2 > 1)) or
	     ((0 > parm3) or (parm3 > 1)) then error (err_bad_parms);
	  call (proc_color_table,index,parm1,parm2,parm3);
	  { always recalculate line color (2.1 buug fix) }
	  call (proc_color,dgl_current_color);
	end;
    end;
end;

procedure set_line_width (index : integer);

{ Purpose:  To set the line width primitives will be drawn with              }

begin
  ck_system_init;
  ck_display_init;
  with gle_gcb^ do
    begin
      if (index < 1 ) or ( index > linewidths ) then index := 1;
      gcb^.dgl_current_linewidth := index;
      info1 := index;
      gle_linewidth ( gle_gcb );
    end;
end; { set_linewidth }

procedure set_color (index : integer);

{ Purpose:  To set the color primitives will be drawn with                  }

begin
  ck_system_init;
  ck_display_init;

  with gcb^,gle_gcb^ do
    begin
      if  (index < 0) or
	 ((index > gamut) and
	 ((color_table_size = 0) or (index > color_table_size))) then index := 1;
      { optimize changing color on raster devices (2.1 bug fix) }
      if ((dgl_current_color <> index) or (complement_support <> 1))  then
	begin
	  call (proc_color,index);
	  dgl_current_color := index;
	end;
    end;
end; { set_color }

procedure set_line_style ( index : integer);

{ Purpose:  To set the linestyle that primitives are drawn with             }

begin
  ck_system_init;
  ck_display_init;

  with gcb^ do
    begin
      if (index < 1) or (index > number_dgl_linestyles) then index := 1;
      {if dgl_current_linestyle <> index then
	begin}
	  dgl_current_linestyle := index;
	  call (proc_linestyle,index);
	{end;}
    end;
end; { set_line_style }

procedure set_display_lim (    dxmin, dxmax, dymin, dymax : real;
			   var ierr : integer);

{ Purpose : To set the logical display limits                             }

var
  txmin : real;
  txmax : real;
  tymin : real;
  tymax : real;

begin
  ck_system_init;
  ck_display_init;

  { ck parms }
  if ((dxmin < dxmax) and (dymin < dymax)) then
    with gcb^ do
      with max_disp_lim do
	begin
	  with gle_gcb^ do
	    begin
	      txmin := (dxmin * display_res_x) + xmin;
	      txmax := (dxmax * display_res_x) + xmin;

	      tymin := (dymin * display_res_y) + ymin;
	      tymax := (dymax * display_res_y) + ymin;
	    end;

	  { make sure new logical imits are within the physical limits       }
	  if (txmin >= xmin) and (txmax <= xmax + eight_diget_epsilon) and
	     (tymin >= ymin) and (tymax <= ymax + eight_diget_epsilon) then
	    begin
	      display_limits (txmin,txmax,tymin,tymax);

	      { set flag indicating that the char size needs to be
		recalculated.  This is done since the physical character size
		may change due to this procedure                             }

	      calc_text_xform := true;

	      ierr := 0;
	    end
	  else ierr := 2;
	end
  else
    ierr := 1;
end; { set_display_lim }


procedure clear_display;

{ Purpose : To clear to display                                           }

begin
  ck_system_init;
  ck_display_init;

  with gle_gcb^ do
    begin
      info1 := -1;        { clear all planes }
      info2 := gcb^.dgl_background_index;
      gle_clear ( gle_gcb );
    end;
end; { Clear_display }


$stackcheck off$
procedure move (x, y : real);

{ Purpose : To change the current position                                }

begin
  if disp_init then
    begin
      { save world cp }
      int_cp := false; { cp saved as real value }
      world_real_cpx := x;
      world_real_cpy := y;

      { calc new device dependent cp }
      cpx := trunc ( x * xwtod_scale + xwtod_offset );
      cpy := trunc ( y * ywtod_scale + ywtod_offset );

      with gle_gcb^ do
	begin
	  end_x := cpx;
	  end_y := cpy;
	  call (move,gle_gcb);
	end;
    end
  else
    if system_init then error (err_dis_int)
    else error (err_sys_int);
end; { move }


procedure line (x, y : real);

{ Purpose : To draw a line                                                }

begin
  if disp_init then
    begin
      { save world cp }
      int_cp := false; { cp saved as real value }
      world_real_cpx := x;
      world_real_cpy := y;

      { calc new device dependent cp }
      cpx := trunc ( x * xwtod_scale + xwtod_offset );
      cpy := trunc ( y * ywtod_scale + ywtod_offset );

      with gle_gcb^ do
	begin
	  end_x := cpx;
	  end_y := cpy;
	  call (draw,gle_gcb);
	end;
    end
  else
    if system_init then error (err_dis_int)
    else error (err_sys_int);
end; { line }

procedure int_move (ix, iy : gshortint);

{ Purpose : To move the current position                                  }

begin
  if disp_init then
    begin
      { use the normal move routine unless the short flag is set }
      if short_flag then
	begin
	  { save world cp }
	  int_cp := true;      { cp saved as gshortint }
	  world_int_cpx := ix;
	  world_int_cpy := iy;

	  with gle_gcb^ do
	    begin
	      end_x := ix;
	      end_y := iy;
	      dgl_scaled_move; { perform a scaled move }
	    end;
	end
      else move(ix,iy);
    end
  else
    if system_init then error (err_dis_int)
    else error (err_sys_int);
end; { int_move }


procedure int_line (ix, iy : gshortint);


{ Purpose : To set the logical display limits                             }

begin
  if disp_init then
    begin
      { use normal line unless short_flag is set }
      if short_flag then
	begin
	  { save world cp }
	  int_cp := true;      { cp saved as gshortint }
	  world_int_cpx := ix;
	  world_int_cpy := iy;
	  with gle_gcb^ do
	    begin
	      end_x := ix;
	      end_y := iy;
	      dgl_scaled_draw;   { perform a scaled draw }
	    end;
	end
      else
	line(ix,iy);
    end
  else
    if system_init then error (err_dis_int)
    else error (err_sys_int);
end; { int_line }

procedure int_polyline ( num_points : integer;
		     anyvar xvec, yvec : gshortint_list );
var
  i : integer;

begin
  ck_system_init;
  ck_display_init;

  if num_points <= 0 then error(err_neg_points);

  int_move ( xvec[1], yvec[1] );
  for i := 2 to num_points do
    int_line ( xvec[i], yvec[i]);
end;

procedure polyline ( num_points : integer;
		     anyvar xvec, yvec : greal_list );
var
  i : integer;

begin
  ck_system_init;
  ck_display_init;

  if num_points <= 0 then error(err_neg_points);

  move ( xvec[1], yvec[1] );
  for i := 2 to num_points do
    line ( xvec[i], yvec[i]);
end;
$stackcheck on$

procedure gtext( s : gstring255 );

{ PURPOSE : To draw a text string                                            }

begin
  if disp_init then
    begin
      if calc_text_xform then
	with gcb^ do
	  begin
	    set_char_size (dgl_char_width, dgl_char_height);
	    set_text_rot  (char_rot_w, char_rot_h);
	    calc_text_xform := false;
	  end;
      with gle_gcb^ do
	begin
	  info_ptr1 := addr(s[1]);
	  info1 := strlen(s);
	end;
      gle_text ( gle_gcb );
    end
  else
    if system_init then error (err_dis_int)
    else error (err_sys_int);
end; { gtext }

procedure marker ( marker_number : integer );

begin
  ck_system_init;
  ck_display_init;
  if (marker_number < 1) or (marker_number > 19) then marker_number := 1;

  with gle_gcb^ do
    begin
      info1 := marker_number;
      gle_set_marker ( gle_gcb );
      gle_marker ( gle_gcb );
    end;
end;

procedure input_esc (       opcode : integer;
			    isize  : integer;
			    rsize  : integer;
		     anyvar ilist  : gint_list;
		     anyvar rlist  : greal_list;
		     var    ierr   : integer  );

{ Purpose : To perform an input escape function                           }

begin
  ck_system_init;
  ck_display_init;

  ierr := opcode_ck ( opcode,isize,rsize);
  call (gcb^.proc_input_esc,opcode,isize,rsize,ilist,rlist,ierr);

end; { input_esc }

procedure output_esc (       opcode : integer;
			     isize  : integer;
			     rsize  : integer;
		      anyvar ilist  : gint_list;
		      anyvar rlist  : greal_list;
		      var    ierr   : integer  );

{ Purpose : To perform an output escape funtion                           }

begin
  ck_system_init;
  ck_display_init;

  ierr := opcode_ck ( opcode,isize,rsize);
  call (gcb^.proc_output_esc,opcode,isize,rsize,ilist,rlist,ierr);
end; { output_esc }

procedure set_text_rot (dx, dy : real);

{ PURPOSE : To set the new text rotation vectors                             }

{ calc normalize vector and save }
{ set flag so text xform is recalculated }

var
  r : real;

begin
  ck_system_init;
  ck_display_init;

  if (dx = 0) and (dy = 0) then error (err_bad_parms);

  with gcb^ do
    begin
      r := sqrt ( dx*dx + dy*dy);
      char_rot_w := dx / r;
      char_rot_h := dy / r;
      with gle_gcb^ do
	begin
	  info1 := trunc(char_rot_w * 32768);
	  info2 := trunc(char_rot_h * 32768);
	end;
      gle_text_dir ( gle_gcb );
    end
end; { set_text_rot }


procedure set_char_size (width,height:real);

{ PURPOSE : To set the new character size                                    }

{ save width and height, set flag so text xform is recalculated         }

begin
  ck_system_init;
  ck_display_init;

  {if (width = 0.0) or (height = 0.0) then error (err_bad_parms);}

  with gcb^ do
    begin
      dgl_char_width := width;
      dgl_char_height := height;
      with gle_gcb^ do
	begin
	  info1 := abs(trunc((width * xwtod_scale * 7 / 9) * 8));
	  info2 := abs(trunc((height * ywtod_scale * 9 / 15) * 8));
	  gle_char_size ( gle_gcb );

	  info1 := abs(trunc((width * xwtod_scale * 2 / 9) * 8));
	  info2 := abs(trunc((height * ywtod_scale * 6 / 15) * 8));
	  gle_text_spacing ( gle_gcb );
	end;
    end
end; { set_char_size }


procedure set_echo_pos (wx,wy : real);

{ Purpose : To set the locator echo position                                }

  function between ( x1, p, x2 : real ) : boolean; { added for 2.1 bug fix }

  begin
    between := (((x1 <= p) and ( p <= x2)) or
		((x2 <= p) and ( p <= x1)));
  end;

begin
  ck_system_init;
  ck_display_init;
  ck_locator_init;

  with gcb^ do
    with window_lim do
      begin
	{ ck bounds }
	if (between (xmin,wx,xmax) and            { 2.1 bug fix }
	    between (ymin,wy,ymax)) then
	  begin
	    { set world coord echo pos }
	    w_loc_echo_x := wx;
	    w_loc_echo_y := wy;

	    { convert to display units }
	    convert_wtod (w_loc_echo_x,w_loc_echo_y,d_loc_echo_x,d_loc_echo_y);
	  end
	{ ignor call if outside window }
      end
end; { set_echo_pos }

procedure set_locator_lim (    lxmin,lxmax,lymin,lymax : real;
			   var ierr : integer              );


{ Purpose : To set the locator echo position                                }

var
  txmin : real;
  txmax : real;
  tymin : real;
  tymax : real;

begin
  ck_system_init;
  ck_locator_init;

  { input limits can only be changed if the input device is not the same
    physical device as the display                                       }
  with gcb^ do
    if not disp_eq_loc then
      begin
	{ ck parms }
	if (lxmin < lxmax) and (lymin < lymax) then
	   with gle_gcbi^ do
	     with max_loc_lim do
	       begin
	       { convert limits form mil to locator cord }
		 txmin := ((lxmin * input_res_x) + xmin);
		 txmax := ((lxmax * input_res_x) + xmin);
		 tymin := ((lymin * input_res_y) + ymin);
		 tymax := ((lymax * input_res_y) + ymin);

		 { make sure new logical imits are within the physical
		  limits                                                   }
		 if (txmin >= xmin) and
		   (txmax <= xmax + eight_diget_epsilon) and
		   (tymin >= ymin) and
		   (tymax <= ymax + eight_diget_epsilon) then
		    begin
		      { set new limits }
		      locator_limits (txmin,txmax,tymin,tymax);
		      ierr := 0;
		    end
		  else { bad limits }
		    ierr := 2;
	       end
	else { bad parms }
	  ierr := 1;
      end
    else { locator and display are same device }
      ierr := 3;
end; { set_locator_lim }


procedure sample_locator(    echo   : integer;
			 var rx,ry  : real    );

{ Purpose : To sample the locator device                                    }

begin
  if loc_init then
    begin
      if disp_init then make_pic_current;
      call (gcb^.proc_sample_locator,echo,rx,ry);
    end
  else
    if system_init then error(err_loc_int)
    else error(err_sys_int);

end; { sample_locator }

procedure await_locator(    echo   : integer;
			var button : integer;
			var rx,ry  : real    );


{ Purpose : To activate the locator, and wait for operator termination      }


var
  saved_pattern,
  saved_linewidth,
  saved_linestyle,
  saved_length,
  saved_mode,
  saved_drawing_mode : integer;

begin
  ck_system_init;
  ck_locator_init;
  if disp_init then
    with gcb^,gle_gcb^ do
      begin
	make_pic_current;
	saved_pattern      := current_linestyle_pattern;
	saved_linewidth    := current_linewidth;
	saved_linestyle    := current_linestyle;
	saved_length       := current_pattern_length;
	saved_mode         := current_linestyle_mode;
	saved_drawing_mode := current_drawing_mode;

	info1 := 0;
	info2 := 0;
	info3 := 0;
	info4 := -1;
	gle_linestyle ( gle_gcb );

	info1 := 1;
	gle_linewidth ( gle_gcb );

	call (proc_color,cursor_color);

	info1 := complement_mode;
	gle_define_drawing_mode ( gle_gcb );
      end;

  call (gcb^.proc_await_locator,echo,button,rx,ry);

  if disp_init then
    begin
      with gcb^,gle_gcb^ do
	begin
	  info1 := saved_linestyle;
	  info2 := saved_length;
	  info3 := saved_mode;
	  info4 := saved_pattern;
	  gle_linestyle ( gle_gcb );

	  info1 := saved_linewidth;
	  gle_linewidth ( gle_gcb );

	  info1 := saved_drawing_mode;
	  gle_define_drawing_mode ( gle_gcb );

	  call (proc_color,dgl_current_color);
	end;

      if echo > 1 then
	if not int_cp then move ( world_real_cpx, world_real_cpy )
	else               int_move ( world_int_cpx, world_int_cpy );
    end;

end; { await_locator }

procedure display_term;

{ Purpose:  To terminate the graphics display                               }

begin
  ck_system_init;
  ck_display_init;

  with gcb^ do
    begin
      disp_init := false;
      disp_file_name := '';
      disp_dev_adr := 0;

      { reset display limits to default }

      with init_display_lim do
	display_limits(xmin,xmax,ymin,ymax);

      if disp_eq_loc then with def_loc_lim do   { locator limits no longer }
	locator_limits (xmin,xmax,ymin,ymax);   { are effected by the display }

      disp_eq_loc := not loc_init;   { if both disabled then they are equal }

      try
	call (gcb^.proc_color,0);
	gle_flush_buffer ( gle_gcb );
	gle_get_p1p2 ( gle_gcb );      { Force read from device.  This syncs
					 the OS with buffered devices    }
	gle_term(gle_gcb);
      recover
	{ ignore timeout errors }
	 if (escapecode <> -26) or (ioe_result <> 17) then escape(escapecode);

    end;

end; { display_term }

{rules for proc_locator_input/output_esc:
  o if it's your opcode you may set ierr appropriately
  o if it's not your opcode don't touch ierr
  o new output drivers should make a call to proc_locator_xxx_esc only
    after the display handler has had a chance at the opcode (and
    has set ierr to 1 if it wasn't processed by the display, or appropriate
    ierr number if the display did claim it)
  o opcodes to be handled by the display and those to be handled by the
    locator MUST NEVER have the same opcode number! It is recommended to
    use numbers with a 9 in the tens digit for locator opcodes.
}
procedure dummy_esc(         opc,isize,rsize : integer;
		      anyvar ilist : gint_list;
		      anyvar rlist : greal_list;
			 var ierr  : integer);
begin
end;

{hili escs put here so can access locator_init, locator_term SFB 4/10/85}

procedure hili_input_esc (opc,isize,rsize : integer;
			     anyvar ilist : gint_list;
			     anyvar rlist : greal_list;
				var ierr  : integer);
begin
 if (opc = 4290) and (isize = 4) and (rsize = 2) and
    (ilist[1] >= 1) and (ilist[1] <= 7) then
  with loopcontrol^.loopdevices[ilist[1]].descrip do
   begin
    ilist[1] := id;
    ilist[2] := maxcountx;
    ilist[3] := maxcounty;
    ilist[4] := nbuttons;
    rlist[1] := counts/10.0;
    if not size16 then
     rlist[1] := rlist[1]/100.0;
    rlist[2] := rlist[1];
    ierr     := 0
   end
 else
  if opc = 4290 then
   ierr := 4;    {my opcode but bad parameters}
end;


procedure hili_output_esc(opc,isize,rsize : integer;
			     anyvar ilist : gint_list;
			     anyvar rlist : greal_list;
				var ierr  : integer);
var err  : integer;     {for call to locator_init}
    dev_adr : integer;
    myop : boolean;
    old_extend : integer;
begin
  myop := (opc = 1090) or (opc = 1091);
  if myop and (isize = 1) and (rsize = 0) and
    (ilist[1] >= 0) then
  begin
   ierr := 0;
   dev_adr := gcb^.loc_dev_adr; {save locator address before losing it}
   if opc = 1091 then
    if dev_adr = 202 then       {only relative locator}
     dvr_rec^.extend := ilist[1] {save kbd_terminator info in extend false = 0,
				  true = other}
    else
     ierr := 1
   else
    begin
     old_extend := dvr_rec^.extend;
     locator_term;        {terminate previous locator so locator_init won't}
     dvr_rec^.devices := ilist[1] mod 128; {set up driver with devices mask}
     locator_init(dev_adr,err);   {and re-init using new devices to scale}
     dvr_rec^.extend := old_extend;
     if err <> 0 then             {and check nothing went wrong}
      begin
       dvr_rec^.devices := 127;   {re-enable all HIL locators in dvr because}
       ierr  := 1                 {we don't support for some reason, or all
				   devices were deactivated}
      end;
    end;
  end
 else
  if myop then
   ierr  := 4;           {bad parameters but my opcode}
end;

procedure locator_term;

{ Purpose:  To terminate the locator device                                 }

begin
  ck_system_init;
  ck_locator_init;

  loc_init := false;
  with gcb^, gle_gcbi^ do
   begin
    if (input_handler_name = 'HILABS') or
       (input_handler_name = 'HILREL') then      {4/9/85 SFB}
     begin
      proc_locator_input_esc  := dummy_esc;
      proc_locator_output_esc := dummy_esc;
     end;
     disp_eq_loc := not disp_init;   { if both disabled then they are equal }
     loc_dev_adr := 0;
    end;

  { reset to default locator limits }
  with init_locator_lim do
    locator_limits (xmin,xmax,ymin,ymax);

  gle_input_term(gle_gcbi);

end; { locator_term }

procedure graphics_term;

{ Purpose:  To terminate the graphics system                                }

begin
  ck_system_init;

  { make sure all devices are terminated }
  if disp_init then display_term;
  if loc_init then locator_term;
  if dvr_rec <> nil then       {enable all HPHIL locators in driver}
   dvr_rec^.devices := 127;

  { set system initialized flag to disabled }
  system_init := false;
end; { graphics_term }

procedure setup_display ( var ierr : integer);

var
  i : integer;

  { Purpose:  To set up display state after it has been initialized     }

begin
  with gcb^ do
    begin
      with gle_gcb^ do
	begin
	  max_disp_lim.xmin := display_min_x;
	  max_disp_lim.xmax := display_max_x;
	  max_disp_lim.ymin := display_min_y;
	  max_disp_lim.ymax := display_max_y;

	  gle_get_p1p2 ( gle_gcb );

	  def_disp_lim.xmin := info1;
	  def_disp_lim.xmax := info2;
	  def_disp_lim.ymin := info3;
	  def_disp_lim.ymax := info4;
	end;

      disp_init := true;
      disp_eq_loc :=  ((disp_dev_adr = loc_dev_adr) or
		      ((disp_dev_adr = internal_display) and
		       (loc_dev_adr = internal_locator)));

      { set up display limits }

      with def_disp_lim do
	display_limits(xmin,xmax,ymin,ymax);

      { set up default text size and rotation attributes }

      dgl_char_width := init_char_width_factor *
	abs (window_lim.xmax - window_lim.xmin);
      dgl_char_height := init_char_height_factor *
	abs (window_lim.ymax - window_lim.ymin);
      set_char_size ( dgl_char_width, dgl_char_height );

      char_rot_w := init_char_rot_w;
      char_rot_h := init_char_rot_h;

      set_text_rot ( char_rot_w, char_rot_h );

      { set up all attributes here        }

      dgl_current_polygon_edge := true;
      dgl_current_polygon_crosshatch := false;
      dgl_current_polygon_linestyle := init_linestyle;
      dgl_current_polygon_style := 1;
      dgl_current_polygon_color := init_color;
      dgl_polygon_color_current := false;  { color not set in gle }
      dgl_current_polygon_density := 0;
      dgl_current_polygon_angle := 0;
      set_timing ( dgl_current_timming_mode );
      dgl_current_color := -1; { force calc of color }
      set_color(init_color);
      set_line_style(init_linestyle);
      set_line_width(init_linewidth);

      { init_cpy is in device units }
      cpx := init_cpx;
      cpy := init_cpy;

      with gle_gcb^ do
	begin
	  marker_size_x := trunc(display_res_x * 2.5 + 0.5); { markers are 2.5 mm in size }
	  marker_size_y := marker_size_x;
	  info1 := marker_size_x;
	  info2 := marker_size_y;
	  gle_marker_size ( gle_gcb );

	  info1 := 1;
	  gle_graphics_on_off ( gle_gcb );  { make sure graphics is on }
	end;
    end;
end; { setup_display }

procedure display_finit (   fname : gstring255;
			    device_name : gstring255;
			    control : integer;
			var ierr : integer );

{ Purpose:  To initialize the display device                                }

var
  cnt : integer;

begin
  ck_system_init;

  { make sure no display is currently enabled }
  if disp_init then display_term;

  if strlen(strrtrim(strltrim(device_name))) <> 0 then
    with gle_gcb^ do
      begin
	device_info := addr(fname[1]);
	device_info_char_count := strlen(fname);
	spooling := 1;
	display_name := '      ';
	display_name_char_count := min(strlen(device_name),6);
	for cnt := 1 to display_name_char_count do
	  display_name [cnt] := device_name[cnt];
	info1 := control;
	info2 := 0; { config DGL stuff }
	configure_gle (gle_gcb);
	ierr := error_return;
      end
  else
    ierr := 2;

  if ierr = 0 then
    try
      with gcb^ do
	begin
	  disp_dev_adr := -1;     { indicate file name }
	  disp_file_name := fname;
	  setup_display ( ierr );
	end;
    recover
      begin
	if escapecode = -20 then escape(escapecode); { ignor all errors except stop key }
	ierr := 2;
      end
  else
    ierr := 2;

end; { display_finit }

procedure display_init (    dev_adr : integer;
			    control : integer;
			var ierr : integer );

{ Purpose:  To initialize the display device                                }

var
  s : string[10];
  cnt : integer;

begin
  ck_system_init;

  { make sure no display is currently enabled }
  if disp_init then display_term;

  with gle_gcb^ do
    begin
      s := '';
      strwrite(s,1,cnt,dev_adr:0);
      device_info_char_count := strlen(s);
      device_info := addr(s[1]);
      spooling := 0;
      info1 := control;
      info2 := 0; { config DGL stuff }
      configure_gle (gle_gcb);
      ierr := error_return;
    end;

  if ierr = 0 then
    try
      with gcb^ do
	begin
	  disp_dev_adr := dev_adr;
	  disp_file_name := '';
	end;
      setup_display ( ierr );

      if gle_gcb^.complement_support = 1
	then gle_gcb^.cursor := dgl_cursor;
    recover
      begin
	if escapecode = -20 then escape(escapecode); { ignor all errors exect stop key }
	ierr := 2;
      end
  else
    ierr := 2;

end; { display_init }


procedure locator_init (    dev_adr : integer;
			var ierr    : integer );

{ Purpose:  To initialize the locator device                                }

var
  s : string[10];
  i : integer;

begin
  ck_system_init;

  { make sure no locator is enabled }
  if loc_init then locator_term;

  { try to init a locator }

  if disp_init then make_pic_current;

  with gcb^,gle_gcbi^ do
    begin
      s := '';
      strwrite(s,1,i,dev_adr:0);
      device_info_char_count := strlen(s);
      device_info := addr(s[1]);
      info1 := 0;                          { init sample loc value }
      info2 := 0;
      if disp_init then {SFB 3/27/85}   {tell gle_init_knob_input whether}
       begin
	info3 := gle_gcb^.pallette;      {color or mono display}
	input_max_x := gle_gcb^.display_max_x;  {for DGL_REL SFB 10-27-86 }
	input_max_y := gle_gcb^.display_max_y;  {for DGL_REL SFB 10-27-86 }
       end
      else
       begin
	info3 := 0;                      {or display not initialized}
	input_max_x := 32767;  {for DGL_REL SFB 10-27-86 }
	input_max_y := 32767;  {for DGL_REL SFB 10-27-86 }
       end;

      configure_input_gle ( gle_gcbi );

      ierr := error_return;

      if ierr = 0 then
	begin
	  loc_init := true;
	  loc_dev_adr := dev_adr;

	  with gle_gcbi^,gcb^.max_loc_lim do
	    begin
	      xmin := input_min_x;
	      xmax := input_max_x;
	      ymin := input_min_y;
	      ymax := input_max_y;
	    end;

	  gle_get_input_p1p2 ( gle_gcbi );

	  with gle_gcbi^,gcb^,gcb^.def_loc_lim do
	    begin
	      xmin := info1;
	      xmax := info2;
	      ymin := info3;
	      ymax := info4;
	    end;

	  disp_eq_loc := disp_init and
			 ((disp_dev_adr = loc_dev_adr) or
			 ((disp_dev_adr = internal_display) and
			 (loc_dev_adr = internal_locator)));

	  { If locator is not the same physical device as the graphics display,
	    then the locator limits are set to the default locator limits.
	    If the locator is the same device, then the locator limits
	    are set to the current display limits.                              }

	  with gcb^ do
	    begin
	      if disp_eq_loc then
		with cur_disp_lim do locator_limits (xmin,xmax,ymin,ymax)
	      else
		with def_loc_lim do locator_limits (xmin,xmax,ymin,ymax);
	    end;


	  if (input_handler_name = 'HILABS') or
	     (input_handler_name = 'HILREL') then {SFB 4/9/85}
	   begin
	    proc_locator_output_esc := hili_output_esc;
	    proc_locator_input_esc :=  hili_input_esc;
	   end;
	end
      else
	ierr := 2;
  end;
end; { locator_init }


procedure graphics_init;

{ Purpose:  To initialize the graphics system                               }

begin
  { make sure the system is not already init }
  if system_init then graphics_term;

  { set state flags }
  system_init := true;
  disp_init   := false;
  loc_init    := false;


  { get storage space -- changed from dynamic to global 2/84 BDS }
  gcb := addr(gcb_space);             { DGL high level storage }

  gle_gcb := addr(gle_gcb_space);     { display output device }
  gle_init_gcb ( gle_gcb );

  gle_gcbi := addr(gle_gcbi_space);   { locator input device  }
  gle_init_input_gcb ( gle_gcbi );

  gle_knob_echo_gcb := addr(gle_knob_echo_gcb_space);
				      {knob echo output device (internal crt)}
  gle_init_gcb ( gle_knob_echo_gcb );

  { kbdlangjumper is imported from sysglobales.  Kata becomes true if
    the kata keyboard is instaled                                      }
  if kbdlang = katakana_kbd then gle_gcb^.kata := 1
  else gle_gcb^.kata := 0;

  { set up defaults }
  with gcb^ do
    begin
      { When first inited that display and locator are the same device }
      disp_eq_loc := true;
      disp_dev_adr := init_dev_adr;
      disp_file_name := '';
      loc_dev_adr  := init_dev_adr;
      window_lim   := init_window;
      aspect_ratio := init_aspect;
      cur_vir_lim  := init_vir_lim;
      viewport_lim := init_viewport;

      { setup the default display/ locator limits to some large number }

      with init_display_lim do
	display_limits ( xmin, xmax, ymin, ymax );
      with init_locator_lim do
	locator_limits ( xmin, xmax, ymin, ymax );

      { explicitly set the cp to init_value }

      cpx := init_cpx;
      cpy := init_cpy;
      int_cp := true;
      world_int_cpx := init_cpx;
      world_int_cpy := init_cpy;

      { set up default text size and rotation attributes }

      dgl_char_width := init_char_width;
      dgl_char_height := init_char_height;

      char_rot_w := init_char_rot_w;
      char_rot_h := init_char_rot_h;

      { set flag, indicating that the text xform needs to be recalulated      }

      calc_text_xform := true;

      dgl_current_color := init_color;
      dgl_current_linestyle := init_linestyle;
      dgl_current_linewidth := init_linewidth;
      dgl_current_timming_mode := init_timming_mode;
      cursor_color := init_color;
      disp_just := centered;
      display_echo_mult := 1;
      graphics_error := 0;

      number_polygon_styles := default_poly_table_size;
      color_table_size := default_color_table_size;
      dgl_current_polygon_color := 1;
      dgl_current_polygon_linestyle := 1;
      dgl_current_polygon_density := 0;
      dgl_current_polygon_angle := 90;
      dgl_current_polygon_edge := true;
      dgl_current_polygon_crosshatch := false;
      dgl_current_polygon_style := 1;
      dgl_current_color_model := 1;
      proc_locator_output_esc := dummy_esc;     {SFB 4/9/85}
      proc_locator_input_esc :=  dummy_esc;     {SFB 4/9/85}
    end;

   if dvr_rec <> nil then       {enable all HPHIL locators in driver}
    dvr_rec^.devices := 127;

end; { graphics_init }

end. {module DGL_LIB}


$LIST ON$

@


55.1
log
@Automatic bump of revision number for PWS version 3.25A
@
text
@@


54.1
log
@Automatic bump of revision number for PWS version 3.24
@
text
@@


53.1
log
@Automatic bump of revision number for PWS version 3.24B
@
text
@@


52.1
log
@Automatic bump of revision number for PWS version 3.24A
@
text
@@


51.1
log
@Automatic bump of revision number for PWS version 3.24d
@
text
@@


50.1
log
@Automatic bump of revision number for PWS version 3.23c
@
text
@@


49.1
log
@Automatic bump of revision number for PWS version 3.24b
@
text
@@


48.1
log
@Automatic bump of revision number for PWS version 3.24a
@
text
@@


47.1
log
@Automatic bump of revision number for PWS version 3.23
@
text
@@


46.1
log
@Automatic bump of revision number for PWS version 3.23
@
text
@@


45.1
log
@Automatic bump of revision number for PWS version 3.23C
@
text
@@


44.1
log
@Automatic bump of revision number for PWS version 3.23B
@
text
@@


43.1
log
@Automatic bump of revision number for PWS version 3.23aA
@
text
@@


42.1
log
@Automatic bump of revision number for PWS version 3.23e
@
text
@@


41.1
log
@Automatic bump of revision number for PWS version 3.23d
@
text
@@


40.1
log
@Automatic bump of revision number for PWS version 3.23c
@
text
@@


39.1
log
@Automatic bump of revision number for PWS version 3.23b
@
text
@@


38.1
log
@Automatic bump of revision number for PWS version 3.23a
@
text
@@


37.1
log
@Automatic bump of revision number for PWS version 3.3a
@
text
@@


36.1
log
@Automatic bump of revision number for PWS version 3.22
@
text
@@


35.1
log
@Automatic bump of revision number for PWS version 3.22
@
text
@@


34.1
log
@Automatic bump of revision number for PWS version 3.22
@
text
@@


33.1
log
@Automatic bump of revision number for PWS version 3.22D
@
text
@@


32.1
log
@Automatic bump of revision number for PWS version 3.22C
@
text
@@


31.1
log
@Automatic bump of revision number for PWS version 3.22B
@
text
@@


30.1
log
@Automatic bump of revision number for PWS version 3.22A
@
text
@@


29.1
log
@Automatic bump of revision number for PWS version 3.22b
@
text
@@


28.1
log
@Automatic bump of revision number for PWS version 3.3b
@
text
@@


27.1
log
@Automatic bump of revision number for PWS version 3.3a
@
text
@@


26.1
log
@Automatic bump of revision number for PWS version 3.3 Synch
@
text
@@


25.2
log
@For CATSEYE support
@
text
@@


25.1
log
@Automatic bump of revision number for PWS version 3.2Y
@
text
@@


24.1
log
@Automatic bump of revision number for PWS version 3.2
@
text
@@


23.1
log
@Automatic bump of revision number for PWS version 3.2P
@
text
@@


22.1
log
@Automatic bump of revision number for PWS version 3.2N
@
text
@@


21.1
log
@Automatic bump of revision number for PWS version 3.2M
@
text
@@


20.1
log
@Automatic bump of revision number for PWS version 3.2L
@
text
@@


19.1
log
@Automatic bump of revision number for PWS version 3.2K
@
text
@@


18.1
log
@Automatic bump of revision number for PWS version 3.2J
@
text
@@


17.1
log
@Automatic bump of revision number for PWS version 3.2I+
@
text
@@


16.1
log
@Automatic bump of revision number for PWS version 3.2I
@
text
@@


15.1
log
@Automatic bump of revision number for PWS version 3.2H
@
text
@@


14.1
log
@Automatic bump of revision number for PWS version 3.2G
@
text
@@


13.1
log
@Automatic bump of revision number for PWS version 3.2F
@
text
@@


12.1
log
@Automatic bump of revision number for PWS version 3.2E
@
text
@@


11.1
log
@Automatic bump of revision number for PWS version 3.2D
@
text
@@


10.1
log
@Automatic bump of revision number for PWS version 3.2C
@
text
@@


9.1
log
@Automatic bump of revision number for PWS version 3.2B
@
text
@@


8.1
log
@Automatic bump of revision number for PWS version 3.2A
@
text
@@


7.1
log
@Automatic bump of revision number for PWS version 3.2l
@
text
@@


6.2
log
@Pws2unix automatic delta on Wed Nov 19 15:16:12 MST 1986
@
text
@@


6.1
log
@Automatic bump of revision number for PWS version 3.2k
@
text
@d1440 5
a1444 1
       info3 := gle_gcb^.pallette       {color or mono display}
d1446 6
a1451 1
       info3 := 0;                      {or display not initialized}
@


5.2
log
@Changes from Scott Bayes
@
text
@@


5.1
log
@Automatic bump of revision number for PWS version 3.2j
@
text
@d1115 4
a1118 4
procedure hili_input_esc (         opc,isize,rsize : integer;
			    anyvar ilist : gint_list;
			    anyvar rlist : greal_list;
			       var ierr  : integer);
d1140 4
a1143 4
procedure hili_output_esc(         opc,isize,rsize : integer;
			    anyvar ilist : gint_list;
			    anyvar rlist : greal_list;
			       var ierr  : integer);
d1145 3
d1149 2
a1150 1
 if (opc = 1090) and (isize = 1) and (rsize = 0) and
d1153 8
a1160 5
   locator_term;        {terminate previous locator so locator_init won't}
   dvr_rec^.devices := ilist[1] mod 128; {set up driver with devices mask}
   locator_init(201,err);       {and re-init using new devices to scale}
   if err <> 0 then             {and check nothing went wrong}
    ierr  := 1                  {don't support for some reason}
d1162 13
a1174 1
    ierr  := 0;
d1177 1
a1177 1
  if opc = 1090 then
d1192 2
a1193 1
    if input_handler_name = 'HILABS' then      {4/9/85 SFB}
d1220 2
d1489 2
a1490 1
	  if input_handler_name = 'HILABS' then {SFB 4/9/85}
d1597 1
a1597 1
   if dvr_rec <> nil then       {enable all HPHIL abs locators in driver}
@


4.1
log
@Automatic bump of revision number for PWS version 3.2i
@
text
@@


3.3
log
@Revert to 3.1 version so we can turn 3.2i.
@
text
@@


3.2
log
@Change sent from Scott Bayes.  Something to do with
addition of relative HIL driver.
@
text
@d1115 4
a1118 4
procedure hili_input_esc (opc,isize,rsize : integer;
			     anyvar ilist : gint_list;
			     anyvar rlist : greal_list;
				var ierr  : integer);
d1140 4
a1143 4
procedure hili_output_esc(opc,isize,rsize : integer;
			     anyvar ilist : gint_list;
			     anyvar rlist : greal_list;
				var ierr  : integer);
a1144 3
    dev_adr : integer;
    myop : boolean;
    old_extend : integer;
d1146 1
a1146 2
  myop := (opc = 1090) or (opc = 1091);
  if myop and (isize = 1) and (rsize = 0) and
d1149 5
a1153 8
   ierr := 0;
   dev_adr := gcb^.loc_dev_adr; {save locator address before losing it}
   if opc = 1091 then
    if dev_adr = 202 then       {only relative locator}
     dvr_rec^.extend := ilist[1] {save kbd_terminator info in extend false = 0,
				  true = other}
    else
     ierr := 1
d1155 1
a1155 13
    begin
     old_extend := dvr_rec^.extend;
     locator_term;        {terminate previous locator so locator_init won't}
     dvr_rec^.devices := ilist[1] mod 128; {set up driver with devices mask}
     locator_init(dev_adr,err);   {and re-init using new devices to scale}
     dvr_rec^.extend := old_extend;
     if err <> 0 then             {and check nothing went wrong}
      begin
       dvr_rec^.devices := 127;   {re-enable all HIL locators in dvr because}
       ierr  := 1                 {we don't support for some reason, or all
				   devices were deactivated}
      end;
    end;
d1158 1
a1158 1
  if myop then
d1173 1
a1173 2
    if (input_handler_name = 'HILABS') or
       (input_handler_name = 'HILREL') then      {4/9/85 SFB}
a1199 2
  if dvr_rec <> nil then       {enable all HPHIL locators in driver}
   dvr_rec^.devices := 127;
d1467 1
a1467 2
	  if (input_handler_name = 'HILABS') or
	     (input_handler_name = 'HILREL') then {SFB 4/9/85}
d1574 1
a1574 1
   if dvr_rec <> nil then       {enable all HPHIL locators in driver}
@


3.1
log
@Automatic bump of revision number for PWS version 3.2h
@
text
@d1115 4
a1118 4
procedure hili_input_esc (         opc,isize,rsize : integer;
			    anyvar ilist : gint_list;
			    anyvar rlist : greal_list;
			       var ierr  : integer);
d1140 4
a1143 4
procedure hili_output_esc(         opc,isize,rsize : integer;
			    anyvar ilist : gint_list;
			    anyvar rlist : greal_list;
			       var ierr  : integer);
d1145 3
d1149 2
a1150 1
 if (opc = 1090) and (isize = 1) and (rsize = 0) and
d1153 8
a1160 5
   locator_term;        {terminate previous locator so locator_init won't}
   dvr_rec^.devices := ilist[1] mod 128; {set up driver with devices mask}
   locator_init(201,err);       {and re-init using new devices to scale}
   if err <> 0 then             {and check nothing went wrong}
    ierr  := 1                  {don't support for some reason}
d1162 13
a1174 1
    ierr  := 0;
d1177 1
a1177 1
  if opc = 1090 then
d1192 2
a1193 1
    if input_handler_name = 'HILABS' then      {4/9/85 SFB}
d1220 2
d1489 2
a1490 1
	  if input_handler_name = 'HILABS' then {SFB 4/9/85}
d1597 1
a1597 1
   if dvr_rec <> nil then       {enable all HPHIL abs locators in driver}
@


2.1
log
@Auto bump rev number to 2.1 for sys 3.2e.
@
text
@@


1.1
log
@Initial revision
@
text
@@
