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


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

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

56.1
date     91.11.05.09.48.58;  author jwh;  state Exp;
branches ;
next     55.3;

55.3
date     91.11.04.15.07.20;  author jwh;  state Exp;
branches ;
next     55.2;

55.2
date     91.10.10.09.00.06;  author cfb;  state Exp;
branches ;
next     55.1;

55.1
date     91.08.25.10.25.20;  author jwh;  state Exp;
branches ;
next     54.4;

54.4
date     91.08.21.13.19.11;  author jwh;  state Exp;
branches ;
next     54.3;

54.3
date     91.07.11.08.57.57;  author cfb;  state Exp;
branches ;
next     54.2;

54.2
date     91.07.09.09.46.55;  author cfb;  state Exp;
branches ;
next     54.1;

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

14.1
date     87.04.01.15.36.56;  author jws;  state Exp;
branches ;
next     13.2;

13.2
date     87.04.01.10.29.48;  author jws;  state Exp;
branches ;
next     13.1;

13.1
date     87.02.28.18.38.44;  author jws;  state Exp;
branches ;
next     12.2;

12.2
date     87.02.17.12.46.52;  author bayes;  state Exp;
branches ;
next     12.1;

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

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

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

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

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

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

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

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

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

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

4.1
date     86.09.30.19.53.58;  author hal;  state Exp;
branches ;
next     3.1;

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

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

1.1
date     86.06.30.15.37.16;  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_POLY                                                      }
{ Programer = BJS                                                           }
{ Date      = 11/10/82                                                      }
{ Rev history:                                                              }
{  Modified    6/01/85 SFB - Added big_color_table stuff for bobcat/gatorbox}

{ Purpose: Hold polygon user 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$
$ALLOW_PACKED ON$ {JWS 3/31/87}
$search 'TYPES',
	'DGL_VARS',
	'GEN',
	'GLE_LIB',
	'LIB',
	'DGL_RAS'$   { DGL_RAS added Nov 84 SFB }


module DGL_POLY;

import dgl_types;

export
  procedure set_pgn_ls ( index : integer);
  procedure set_pgn_color ( index : integer);
  procedure set_pgn_table ( index : integer;
			  pdensity : real;
			  porient : real;
			  pedge   : integer);

  procedure set_pgn_style ( index : integer );
  procedure int_polygon_dd ( num_points : integer;
		       anyvar xvec, yvec : gshortint_list;
		       anyvar opcodes    : gshortint_list );
  procedure polygon_dev_dep ( num_points : integer;
		       anyvar xvec, yvec : greal_list;
		       anyvar opcodes    : gshortint_list );
  procedure int_polygon ( num_points : integer;  anyvar xvec,yvec : gshortint_list;
				 anyvar opcodes   : gshortint_list );
procedure polygon ( num_points : integer;
		       anyvar xvec, yvec : greal_list;
		       anyvar opcodes    : gshortint_list );
implement

import dgl_vars,
       dgl_gen,
       gle_types,
       gle_GEN,
       dgl_lib,
       asm,
       dgl_raster;       {SFB Nov 84}

const
  deg_to_rad     = 0.01745329252;
  normalized_one = 32768;

type vec_ptr_def  = ^gint_list;
     work_ptr_def = ^gshortint_list;

var
  saved_linestyle : integer;
  saved_linewidth : integer;
  stack_ptr       : work_ptr_def;

procedure set_polygon_color;

{ Purpose:  To set the color polygons will be drawn with (send to gle)       }

var
  pass_rgb : boolean;
  h,s,l    : real;

begin
  with gcb^,gle_gcb^ do
    begin
      { If dither is to be used (b&w, moonunit, or 9836C with index > 15) then
	RGB values need to be passed.  Otherwise the index is passed.     }

      pass_rgb :=    (dither_support = 1) and
		  ( ((color_map_support = 1) and
		     (dgl_current_polygon_color > gamut)) or
		    ( color_map_support = 0));
      if pass_rgb then
       begin
	info1 := 0;
	if gamut = 1 { black and white } then
	 with color_table_ptr^[dgl_current_polygon_color] do
	  begin
	   if (display_name <> '98542A') and (display_name <> '98544A') and
	      (display_name <> '98548A') then   {SFB 2/2/88}
	   { define only one parm for dither, use lit to set }
	   { calc brite as defined from CIE diagram          }
	    info2 := trunc((0.3*red+0.59*green+0.11*blue)*1023+0.5)
	   else
	    with big_color_table_ptr_def(
			  color_table_ptr)^[dgl_current_polygon_color] do
	     info2 := trunc(( 0.30*dglfloat(red  )
			     +0.59*dglfloat(green)
			     +0.11*dglfloat(blue ))*1023+0.5);
	   info3 := 0;
	   info4 := 0;
	   gle_fill_index_color(gle_gcb);
	  end { black and white }
	 else         { multi color device }
	  begin
	   if  (display_name = '98700A')
	    or (display_name = '98543A') or (display_name = '98545A')
	    or (display_name = '98547A') or (display_name = '98549A')      {SFB 2/2/88}
	    or (display_name = '98550A')                            {SFB 2/2/88}
	    or (display_name = 'E640  ') or (display_name = 'E1024 ')
	    or (display_name = 'E1280 ') or (display_name = 'E640G ')
	    or (display_name = 'E1280G') then
								   {CFB 30JUL91}
	   with big_color_table_ptr_def(
			  color_table_ptr)^[dgl_current_polygon_color] do
	     begin
	      info2 := trunc(dglfloat(red)*1023+0.5);
	      info3 := trunc(dglfloat(green)*1023+0.5);
	      info4 := trunc(dglfloat(blue)*1023+0.5);
	     end
	   else
	    with color_table_ptr^[dgl_current_polygon_color] do
	     begin
	      info2 := trunc(red*1023+0.5);
	      info3 := trunc(green*1023+0.5);
	      info4 := trunc(blue*1023+0.5);
	     end;
	   gle_fill_index_color(gle_gcb);
	  end; { multi color device }
	end { if pass_rgb }
       else
	begin
	  info1 := 1;
	  info2 := dgl_current_polygon_color;
	  gle_fill_index_color(gle_gcb);
	end;
      dgl_polygon_color_current := true;
    end;
end; { set_polygon_color }

procedure set_pgn_color (index : integer);

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

var
  pass_rgb : boolean;
  h,s,l    : real;

begin
  ck_system_init;
  ck_display_init;

  with gcb^,gle_gcb^ do
    begin                     { Bad values of index are set to index 1 }
      if  (index < 0) or
	 ((index > gamut) and
	 ((color_table_size = 0) or (index > color_table_size))) then index := 1;
      dgl_current_polygon_color := index;
      dgl_polygon_color_current := false;
    end;

end; { set_pgn_color }


procedure set_pgn_ls ( index : integer);

{ Purpose:  To set the linestyle that polygons 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;
      dgl_current_polygon_linestyle := index;
    end;

end; { set_pgn_line_style }

procedure set_pgn_style ( index : integer );

{ Purpose:  To set the polygon style that polygons will be drawn with }

begin
  ck_system_init;
  ck_display_init;

  with gcb^ do
    begin
      if (index < 1) or (index > number_polygon_styles) then index := 1;
      with poly_table_ptr^ [ index ] do
	begin
	  { decode table and setup local vars }
	  dgl_current_polygon_crosshatch := density < 0;
	  dgl_current_polygon_density := density;
	  dgl_current_polygon_angle := orient;
	  dgl_current_polygon_edge  := edge;
	  dgl_current_polygon_style := index;
	end;
    end;
end;

procedure set_pgn_table ( index : integer;
			pdensity : real;
			porient : real;
			pedge   : integer);

{ Purpose:  To define an entry in the polygon table  }

begin
  ck_system_init;
  ck_display_init;

  with gcb^ do
    begin
      if ((index < 1) or (index > number_polygon_styles)) or
	 ((pedge <> 0) and (pedge <> 1)) or
	 ((pdensity < -1) or (pdensity > 1)) or
	 ((porient < -90) or (porient > 90)) then error(err_bad_parms);
      with poly_table_ptr^ [ index ] do
	begin
	  density := pdensity;
	  orient := porient;
	  edge := pedge = 1;
	  if index = dgl_current_polygon_style then set_pgn_style(dgl_current_polygon_style);
	end;
    end;
end;

procedure edge_polygon (        num_points         : integer;
			 anyvar vector             : gint_list;
			 anyvar opcodes            : gshortint_list;
				polygon_simulation : boolean );

{ Purpose : To draw edges around the specified polygon }

var
  vector_count    : integer;
  next_subpolygon : integer;
  i               : integer;
  saved_color     : integer;
  saved_linestyle : integer;
  saved_linewidth : integer;

begin
  with gcb^, gle_gcb^ do
    begin
      if (polygon_simulation) and (dgl_current_polygon_density <> 0) then
	begin
	  saved_color := dgl_current_color;
	  saved_linestyle := dgl_current_linestyle;
	  saved_linewidth := dgl_current_linewidth;
	  set_color(dgl_current_polygon_color);
	  set_line_style(dgl_current_polygon_linestyle);
	  set_line_width(1);
	end;

      vector_count    := 1;
      next_subpolygon := 1;

      for i := 1 to num_points do
	begin
	  if vector_count = next_subpolygon then
	    begin
	      end_x := vector[vector_count+1];
	      end_y := vector[vector_count+2];
	      gle_move ( gle_gcb );
	      next_subpolygon := vector_count + vector[vector_count] * 2 + 1;
	      vector_count := vector_count + 3;
	    end
	  else
	    begin
	      end_x := vector[vector_count];
	      end_y := vector[vector_count+1];
	      if opcodes[i] = 1 then gle_draw ( gle_gcb )
	      else                   gle_move ( gle_gcb );
	      vector_count := vector_count + 2;
	    end;
	end;

      if (polygon_simulation) and (dgl_current_polygon_density <> 0) then
	begin
	  set_color(saved_color);
	  set_line_style(saved_linestyle);
	  set_line_width(saved_linewidth);
	end;
    end;
end;

function int_div ( a, b : integer ) : integer;

{ Purpose : To perform an integer div with rounding }

var temp : integer;

begin
  temp := (2 * a ) div b;
  if odd ( temp ) then
    if temp > 0 then temp := temp + 1
    else             temp := temp - 1;
  int_div := temp div 2;
end;

procedure line_line_intersection ( p1x, p1y, p2x, p2y,
				   p3x, p3y, p4x, p4y : integer;
			       var ix,  iy            : integer );

{ Purpose : To calculate the intersection of two lines }
{           Note: The two lines must intersect.        }

var
  num, denom,
  delta_x_21,
  delta_y_21,
  delta_x_31,
  delta_y_31,
  delta_x_43,
  delta_y_43  : integer;
  real_num,
  real_denom,
  real_factor : real;

begin
$range on$
  delta_x_21 := p2x - p1x;
  delta_y_21 := p2y - p1y;

  delta_x_31 := p3x - p1x;
  delta_y_31 := p3y - p1y;

  delta_x_43 := p4x - p3x;
  delta_y_43 := p4y - p3y;

  try
    denom := delta_y_21 * delta_x_43 - delta_x_21 * delta_y_43;
    num   := delta_x_21 * delta_y_31 - delta_y_21 * delta_x_31;

    {deleted SFB 9/16/86 and replaced as below
    ix := p3x + int_div((p4x-p3x)*num, denom);
    iy := p3y + int_div((p4y-p3y)*num, denom);
    }

    {to help correct uneven polygon crosshatch lines (not complete fix)
     SFB 9/16/86}

    real_factor := num/denom;
    ix := round(p3x + (p4x-p3x)*real_factor);
    iy := round(p3y + (p4y-p3y)*real_factor);

    {end insertion SFB 9/16/86}

$range off$

  recover
    if escapecode = -4 { integer overflow } then
      begin
	real_denom := 1.0 * delta_y_21 * delta_x_43 - 1.0 * delta_x_21 * delta_y_43;
	real_num   := 1.0 * delta_x_21 * delta_y_31 - 1.0 * delta_y_21 * delta_x_31;
	real_factor := real_num / real_denom;
	ix := trunc(p3x + (p4x-p3x) * real_factor + 0.5);
	iy := trunc(p3y + (p4y-p3y) * real_factor + 0.5);
      end
    else
      escape(escapecode);
end;

procedure draw_pg ( anyvar vector, work                   : gint_list;
			   dgl_current_polygon_color,
			   dgl_current_polygon_linestyle,
			   normalized_sin,normalized_cos  : integer;
			   dgl_current_polygon_crosshatch : boolean;
			   dgl_current_polygon_spacing    : integer);

{ PURPOSE:  To draw a polygon using the current polygon attributes     }

{           The input format for vector is as follows (GLE polygon format):

	      VECTOR [ Number of pts in segment 1 ( 1st subpolygon ) ]
		     [          X1                                   ]
		     [          Y1                                   ]
		     [          X2                                   ]
		     [          Y2                                   ]
		     [           :                                   ]
		     [           :                                   ]
		     [          Xn                                   ]
		     [          Yn                                   ]

		     [ Number of pts in segment 2 ( 2nd subpolygon   ]
		     [          X1                                   ]
		     [          Y1                                   ]
		     [           :                                   ]
		     [           :                                   ]
		     [          Xm                                   ]
		     [          Ym                                   ]

				 :
				 :

		     [           0                                   ] }

{       The basic algorithm is as follow:

	  - Calculate dist between fill lines
	  - Calculate fill line slope in terms of dx, dy
	  - For every edge in the polygon, calculate the x intercept
	    ( or y intercept for x major fill slope ) along a line parallel
	    to the fill lines for each end point.  With this information
	    build a record with minimum intercept, maximum intercept, and
	    both end points ordered by maximum intercept value.

	    Maintain a minimum and maximum intercept value for all edge
	    end points in the polygon.  This information will be used to
	    indicate where to start filling the polygon with fill lines.

	  - Calculate using the minimum intercept value the first fill
	    line that may intersect the polygon.

	  - For each possible fill line do the following:

	      - For each intercept record look for intersections.  An
		intersection is determined by the current intercept value
		of the current fill line, falling between the minimum
		and maximum intercept values of the record.

		If an intersection is found, find the end point of
		the intersection and save the point.

		After all intersections for a given fill line are found,
		sort the end points.  The sort alternates between top
		down, and bottom up for each fill line.  This minimizes
		motion on mechanical devices.

		Plot the end points alternating between moves and draws. }

const
  normal_vertex = 0;
  short_vertex  = 1;
  edge_vertex   = 2;

  edge_index    = 2;

type
  point_def1  = array [0..1] of integer;
  point_def   = array [0..2] of integer;

  point_array = array [1..maxint] of point_def1;

  intercept_rec_def = record
	    intercept_p_min,
	    intercept_p_max      : integer;
	    intercept_min_points : point_def;
	    intercept_max_points : point_def;
	  end;

  intercept_array = array [1..maxint] of intercept_rec_def;

var
  intercept_list_ptr  : ^intercept_array;
  p_list_ptr          : ^point_array;
  p_count         : integer;
  t, i, j         : integer;
  intercept_count : integer;
  intercept_min   : integer;
  intercept_max   : integer;
  intercept_inc   : integer;
  xmin, ymin      : integer;
  dx, dy          : integer;
  local_spacing   : integer;
  vector_index    : integer;
  num_vert        : integer;
  last_index      : integer;
  move_it         : boolean;
  top_down_sort   : boolean;
  x_major         : boolean;
  hatch           : boolean;
  saved_color     : integer;
  vedge_index     : integer;
  major_index     : integer;
  first_index     : integer;
  nxt_edge        : integer;
  found_fill_line_on_edge : boolean;

  procedure calc_intercept (  pt_1_index : integer;
			      pt_2_index : integer;
			      switch_xy  : boolean);

  { Purpose : For each end point of the edge defined by pt_1_index and
	      pt_2_index, calculate the intercept of a line which runs
	      though the end point and is parallel with the fill line. }

  var
    p1,p2,tp   : integer;
    pt1x,pt1y  : integer;
    pt2x,pt2y  : integer;
    ix,iy      : integer;
    tdx,tdy    : integer;

  begin
    if switch_xy then
      begin
	ix := 1;    iy := 0;
	tdx := dy;  tdy := dx;
      end
    else
      begin
	ix := 0;    iy := 1;
	tdx := dx;  tdy := dy;
      end;

    with intercept_list_ptr^[intercept_count] do
      begin
	pt1x := vector[pt_1_index+ix];
	pt1y := vector[pt_1_index+iy];
	pt2x := vector[pt_2_index+ix];
	pt2y := vector[pt_2_index+iy];

	p1 := pt1y - int_div(tdy * pt1x,tdx);       { calc intercept }
	p2 := pt2y - int_div(tdy * pt2x,tdx);

	if p1 > p2 then
	  begin                                     { swap points }
	    tp := p2;   p2   := p1;   p1   := tp;
	    tp := pt2x; pt2x := pt1x; pt1x := tp;
	    tp := pt2y; pt2y := pt1y; pt1y := tp;
	  end;
						    { save intercepts }
	intercept_count := intercept_count + 1;
	intercept_p_min := p1;
	intercept_p_max := p2;
	intercept_max := max(intercept_max,intercept_p_max);
	intercept_min := min(intercept_min,intercept_p_min);
	if p1 = p2 then
	  begin
	    intercept_min_points[edge_index] := edge_vertex;
	    intercept_max_points[edge_index] := edge_vertex;
	    if pt1x <= pt2x then
	      begin
		intercept_min_points[ix] := pt1x;
		intercept_min_points[iy] := pt1y;
		intercept_max_points[ix] := pt2x;
		intercept_max_points[iy] := pt2y;
	      end
	    else
	      begin
		intercept_max_points[ix] := pt1x;
		intercept_max_points[iy] := pt1y;
		intercept_min_points[ix] := pt2x;
		intercept_min_points[iy] := pt2y;
	      end;
	  end
	else
	  begin
	    intercept_min_points[edge_index] := normal_vertex;
	    intercept_max_points[edge_index] := normal_vertex;
	    intercept_min_points[ix] := pt1x;
	    intercept_min_points[iy] := pt1y;
	    intercept_max_points[ix] := pt2x;
	    intercept_max_points[iy] := pt2y;
	  end;
      end;
  end;

  procedure calc_vertex_info (  edge_a : integer;
				edge_b : integer);

  { Purpose : To mark points which should not be used when calc fill line }
  {           end points.                                                 }

  var
    a_min,
    a_max,
    b_min,
    b_max  : integer;

  begin
    with intercept_list_ptr^[edge_b] do
      begin
	b_min  := intercept_p_min;
	b_max  := intercept_p_max;
      end;

    with intercept_list_ptr^[edge_a] do
      begin
	a_min := intercept_p_min;
	a_max := intercept_p_max;
	if (intercept_max_points[edge_index] <> edge_vertex) then
	  begin
	    if a_min = b_max then
	      intercept_min_points[edge_index] := short_vertex
	    else
	    if a_max = b_min then
	      intercept_max_points[edge_index] := short_vertex;
	  end;
      end;
  end;

  procedure sort( starting, ending, inc : integer );

  { Purpose : To sort the P_LIST array.  }

  var
    sx         : gle_shortint;
    sy         : gle_shortint;
    index      : gle_shortint;
    test_point : integer;
    temp_point : integer;
    done       : boolean;

  begin
    if x_major then               { sort by x }
      begin sx := 1; sy := 0; end
    else                          { sort by y }
      begin sx := 0; sy := 1; end;

    repeat
      index := starting + inc;
      done := true;
      test_point := p_list_ptr^[starting,sx];
      while index <> ending + inc do
	begin
	  temp_point := p_list_ptr^[index,sx];
	  if test_point > temp_point then
	    begin
	      p_list_ptr^[index,sx] := p_list_ptr^[index-inc,sx];
	      p_list_ptr^[index-inc,sx] := temp_point;

	      temp_point := p_list_ptr^[index,sy];
	      p_list_ptr^[index,sy] := p_list_ptr^[index-inc,sy];
	      p_list_ptr^[index-inc,sy] := temp_point;

	      done := false;
	    end
	  else
	    test_point := temp_point;
	  index := index + inc;
	end;
    until done
  end;         { sort }

begin { poly }

  with gcb^ do
    begin
      intercept_list_ptr := addr(work);
      hatch           := dgl_current_polygon_crosshatch;
      local_spacing   := dgl_current_polygon_spacing;

      saved_color     := dgl_current_color;
      if dgl_current_color <> dgl_current_polygon_color then set_color(dgl_current_polygon_color);

      with gle_gcb^ do
	repeat                     { cross hatching loop }

	  hatch := not hatch;

	  { Calc slope in terms of dx, dy }
	  { Calc x or y spacing  (intercept_inc)   }

	  x_major := true;
	  major_index := 1;
	  if abs(normalized_sin) = normalized_one  { 90 deg } then
	    begin
	      dy := display_max_y;
	      dx := 0;
	      intercept_inc := local_spacing;
	    end
	  else
	  if abs(normalized_sin) <= abs(normalized_cos) { <= 45 deg } then
	    begin
	      dx := display_max_x;
	      dy := int_div(dx * normalized_sin,normalized_cos);
	      x_major := false;
	      major_index := 0;
	      intercept_inc := abs(int_div(local_spacing * normalized_one,normalized_cos));
	    end
	  else
	    begin
	      dy := display_max_y;
	      dx := int_div(dy * normalized_cos,normalized_sin);
	      intercept_inc := abs(int_div(local_spacing * normalized_one,normalized_sin));
	    end;

	  if intercept_inc < 1 then intercept_inc := 1;

	  { Calc end point intercepts }

	  intercept_count := 1;
	  intercept_min := maxint;
	  intercept_max := minint;

	  vector_index := 1;
	  while vector[vector_index] <> 0 do
	    begin
	      num_vert := vector[vector_index];
	      vector_index := vector_index + 1;
	      for i := 2 to num_vert do
		calc_intercept ( vector_index+(i-1)*2,vector_index+(i-2)*2,x_major);
	      last_index := vector_index+((num_vert-1)*2);
	      calc_intercept ( vector_index,last_index,x_major);
	      vector_index := last_index + 2;
	    end;

	  intercept_count := intercept_count - 1;

	  vector_index := 1;
	  vedge_index := 1;
	  while vector[vector_index] <> 0 do
	    begin
	      num_vert := vector[vector_index];
	      first_index := vedge_index;
	      last_index := vedge_index + num_vert;
	      for i := 1 to num_vert do
		begin
		  nxt_edge := vedge_index + 1;
		  { The following while statement should read }
		  {  'while (nxt_edge < last_index) and ...'  }
		  { however this "bug" was not found until after }
		  { QA.  It will not proceduce a user bug though }
		  { since the following 'if' stmt with not use the }
		  { bad results                                  }
		  while (nxt_edge < last_index) and
			(intercept_list_ptr^[nxt_edge].
			 intercept_max_points[edge_index] = edge_vertex) do
		    nxt_edge := nxt_edge + 1;
		  if nxt_edge >= last_index then
		    begin
		      nxt_edge := first_index;
			while (nxt_edge < vedge_index) and
			      (intercept_list_ptr^[nxt_edge].
			       intercept_max_points[edge_index] = edge_vertex) do
			  nxt_edge := nxt_edge + 1;
		    end;
		  if (intercept_list_ptr^[nxt_edge].
		      intercept_max_points[edge_index] <> edge_vertex) then
			  calc_vertex_info ( vedge_index,nxt_edge);
		  vedge_index := vedge_index + 1;
		end;
	      vector_index := vector_index + num_vert * 2 + 1;
	    end;

	  { Calc first fill line intercept value, adjust with lower left
	    of display                                                    }

	  p_list_ptr := addr(work,(intercept_count+1)*32);

	  intercept_min := intercept_min - (intercept_min mod intercept_inc);
	  xmin := 0;
	  ymin := 0;
	  top_down_sort := true;

	  { Fill polygon }
	  while intercept_min <= intercept_max do
	    begin
	      if x_major then
		xmin := intercept_min
	      else
		ymin := intercept_min;

	      { Find intersections }
	      p_count := 0;
	      found_fill_line_on_edge := false;
	      for i := 1 to intercept_count do
		begin
		  with intercept_list_ptr^[i] do
		    begin
		      if (intercept_min = intercept_p_min) and
			 (intercept_min = intercept_p_max) then
			  found_fill_line_on_edge := true
		      else
		      if (intercept_min >= intercept_p_min) and
			 (intercept_min <= intercept_p_max) then
			{ intersection }
			begin
			  if (intercept_min = intercept_p_min) then
			    begin
			     if (intercept_min_points[edge_index] = normal_vertex) then
			       begin
				 p_count := p_count + 1;
				 p_list_ptr^[p_count,0] := intercept_min_points[0];
				 p_list_ptr^[p_count,1] := intercept_min_points[1];
			       end;
			    end
			  else
			  if (intercept_min = intercept_p_max) then
			    begin
			      if (intercept_max_points[edge_index] = normal_vertex) then
				begin
				  p_count := p_count + 1;
				  p_list_ptr^[p_count,0] := intercept_max_points[0];
				  p_list_ptr^[p_count,1] := intercept_max_points[1];
				end;
			    end
			  else
			    begin
			      p_count := p_count + 1;
			      line_line_intersection(xmin,ymin,xmin+dx,ymin+dy,
				intercept_min_points[0],intercept_min_points[1],
				intercept_max_points[0],intercept_max_points[1],
				p_list_ptr^[p_count,0],p_list_ptr^[p_count,1]);
			    end;
			end;
		    end;
		end;

	      if found_fill_line_on_edge then  { add edge points }
		begin
		  if p_count > 1 then sort(1,p_count,1); { sort bottom up }
		  if odd(p_count) then p_count := p_count-1; { remove last move }
		  for i := 1 to intercept_count do
		    with intercept_list_ptr^[i] do
		      begin
			if (intercept_min = intercept_p_min) and
			   (intercept_min = intercept_p_max) then
			  begin
			    p_count := p_count + 1;
			    p_list_ptr^[p_count,0] := intercept_min_points[0];
			    p_list_ptr^[p_count,1] := intercept_min_points[1];
			    p_count := p_count + 1;
			    p_list_ptr^[p_count,0] := intercept_max_points[0];
			    p_list_ptr^[p_count,1] := intercept_max_points[1];
			  end;
		      end;
		  i := 1;
		  repeat
		    j := i + 2;
		    while j < p_count do
		      begin
			if (p_list_ptr^[i,major_index] <=
			    p_list_ptr^[j+1,major_index]) and
			   (p_list_ptr^[j,major_index] <=
			    p_list_ptr^[i+1,major_index]) then
			  begin
			    if p_list_ptr^[i,major_index] >
			      p_list_ptr^[j,major_index] then
			      begin
				p_list_ptr^[i,0] := p_list_ptr^[j,0];
				p_list_ptr^[i,1] := p_list_ptr^[j,1];
			      end;
			    if p_list_ptr^[i+1,major_index] <
			      p_list_ptr^[j+1,major_index] then
			      begin
				p_list_ptr^[i+1,0] := p_list_ptr^[j+1,0];
				p_list_ptr^[i+1,1] := p_list_ptr^[j+1,1];
			      end;
			    for t := j to p_count-2 do
			      begin
				p_list_ptr^[t,0] := p_list_ptr^[t+2,0];
				p_list_ptr^[t,1] := p_list_ptr^[t+2,1];
			      end;
			    p_count := p_count - 2;
			    j := i + 2;
			  end
			else
			  j := j + 2;
		      end;
		    i := i + 2;
		  until i > p_count;
		end;

	      { Sort points }
	      if p_count > 1 then
		begin
		  top_down_sort := not top_down_sort;
		  if top_down_sort then sort(p_count,1,-1)
		  else sort(1,p_count,1);
		end;

	      { draw a fill line }
	      move_it := true;
	      for i := 1 to p_count do
		begin
		  end_x := p_list_ptr^[i,0];
		  end_y := p_list_ptr^[i,1];
		  if move_it then call ( move,gle_gcb )
		  else            call ( draw,gle_gcb );
		  move_it := not move_it;
		end;

	      intercept_min := intercept_min + intercept_inc;
	    end;  { of filling loop }

	  if (not hatch) and dgl_current_polygon_crosshatch then
	    begin
	      t := normalized_sin;
	      normalized_sin := -normalized_cos;
	      normalized_cos := t;
	    end;
	until hatch; { end of hatching loop }

      if saved_color <> dgl_current_polygon_color then set_color(saved_color);
    end;
end;

procedure draw_polygon ( anyvar vector, work : gint_list );

{ PURPOSE:  To draw a polygon using the current polygon attributes     }

{           The input format for vector is as follows (GLE polygon format):

	      VECTOR [ Number of pts in segment 1 ( 1st subpolygon ) ]
		     [          X1                                   ]
		     [          Y1                                   ]
		     [          X2                                   ]
		     [          Y2                                   ]
		     [           :                                   ]
		     [           :                                   ]
		     [          Xn                                   ]
		     [          Yn                                   ]

		     [ Number of pts in segment 2 ( 2nd subpolygon   ]
		     [          X1                                   ]
		     [          Y1                                   ]
		     [           :                                   ]
		     [           :                                   ]
		     [          Xm                                   ]
		     [          Ym                                   ]

				 :
				 :

		     [           0                                   ] }

  { normalized_one = 32768 }

var
  local_angle   : real;
  hatch         : boolean;
  local_spacing : integer;
  rad_angle     : real;
  sin_angle,
  cos_angle     : integer         { normalized fixed point numbers };

begin { draw_polygon }

  with gcb^ do
    begin
      if dgl_current_polygon_density <> 0 then
	begin
	  local_angle := dgl_current_polygon_angle;
	  hatch := dgl_current_polygon_crosshatch and (dgl_current_polygon_density <> 1);
	  if dgl_current_polygon_density = 1 then
	    local_spacing := gle_gcb^.polygon_solid_fill
	  else
	    local_spacing :=
	      abs(trunc(1/dgl_current_polygon_density * gle_gcb^.polygon_fill_factor));
	  if local_spacing < 1 then local_spacing := 1;
	  if hatch then local_spacing := local_spacing * 2;
	  if local_spacing = 1 then local_angle := 0;
	  rad_angle := deg_to_rad * local_angle;
	  sin_angle := trunc(sin(rad_angle) * normalized_one);
	  cos_angle := trunc(cos(rad_angle) * normalized_one);
	  draw_pg(vector,work,dgl_current_polygon_color,dgl_current_polygon_linestyle,
		  sin_angle,cos_angle,hatch,local_spacing);
	end;
    end;
end;

procedure setup_for_polygon ( real_format  : boolean;
			      num_points   : integer;
		       anyvar xvec, yvec   : gshortint_list;
		       anyvar rxvec, ryvec : greal_list;
		       anyvar opcodes      : gshortint_list;
		       anyvar vector       : vec_ptr_def;
			      work_mult    : integer;
			  anyvar work_ptr  : work_ptr_def;
			  var last_subpoly : integer );

{ Purpose : To prepare for drawing a polygon set.  This includes          }
{           setting up attributes, creating work space, performing error  }
{           checks, and creating a GLE format polygon.                    }

var
  i              : integer;
  sub_poly_start : integer;
  sub_poly_count : integer;
  point_count    : integer;
  vector_count   : integer;
  local_angle    : real;
  rad_angle      : real;

begin
  ck_system_init;
  ck_display_init;
$ovflcheck on$
  if num_points <= 0 then error (err_neg_points);
  if opcodes[1] <> 2 then error (err_bad_parms);

  { allocate worst possible space for vector array }
  mark(stack_ptr);                       { mark current base }
  newbytes(vector,12*num_points+4);      { alocate worst case space }

  with gcb^ do
    begin
      saved_linestyle := dgl_current_linestyle;
      saved_linewidth := dgl_current_linewidth;

      if dgl_current_linestyle <> dgl_current_polygon_linestyle then
	set_line_style ( dgl_current_polygon_linestyle );
      if dgl_current_linewidth <> 1 then set_line_width(1);
      if not dgl_polygon_color_current then
       set_polygon_color;
     end;

  sub_poly_start := 1;
  i := 1;
  sub_poly_count := 1;
  point_count := 1;
  last_subpoly := 1;   { last subpolygon in polygon }
  vector_count := 2;      { first spot will hold count }

  while i <= num_points do
    begin
      if (opcodes[I]=2) and (i<>1)  then
	begin
	  vector^[sub_poly_start] := point_count-1;
	  sub_poly_start := vector_count;  { save space to hold count }
	  vector_count := vector_count + 1;
	  point_count := 1;
	  sub_poly_count := sub_poly_count + 1;
	  last_subpoly := i;
	end;
      point_count := point_count + 1;
      if real_format then
	convert_wtod(rxvec[i],ryvec[i],vector^[vector_count],vector^[vector_count+1])
      else
      if short_flag then
	convert_intwtod(xvec[i],yvec[i],vector^[vector_count],vector^[vector_count+1])
      else
	convert_wtod(xvec[i],yvec[i],vector^[vector_count],vector^[vector_count+1]);
      vector_count := vector_count + 2;
      i := i + 1;
    end;
  vector^[sub_poly_start] := point_count-1;
  vector^[vector_count] := 0;

  newbytes(work_ptr,work_mult*vector_count);     { alocate work space for gle }

  with gcb^,gle_gcb^ do
    begin
      if dgl_current_polygon_crosshatch then info1 := 1
      else                                   info1 := 0;

      local_angle := dgl_current_polygon_angle;
      rad_angle := deg_to_rad * local_angle;
      info3 := trunc(sin(rad_angle) * normalized_one);
      info4 := trunc(cos(rad_angle) * normalized_one);

      if dgl_current_polygon_density = 1 then
	info2 := polygon_solid_fill
      else
      if dgl_current_polygon_density = 0 then
	info2 := 0
      else
	begin
	  info2 := abs(trunc(1/dgl_current_polygon_density * polygon_fill_factor));
	  if info2 < 1 then info2 := 1;
	end;
    end;
end;


procedure finish_polygon;

{ Purpose: Restore linestyle and line width to current values }

begin
  with gcb^ do
    begin
      if saved_linestyle <> dgl_current_polygon_linestyle then
	set_line_style(saved_linestyle);
      if saved_linewidth <> 1 then
	set_line_width(saved_linewidth);
    end;
end;

procedure int_polygon_dd ( num_points : integer;
		    anyvar xvec, yvec : gshortint_list;
		    anyvar opcodes    : gshortint_list );

{ Purpose : To output a device dependent polygon set }

var
  t               : array[1..1] of real;
  work_ptr        : work_ptr_def;
  vector_ptr      : vec_ptr_def;
  last_subpolygon : integer;
  use_simulation  : boolean;

begin
  try { must return 'new' space if escape occurs }
    setup_for_polygon ( false, num_points, xvec, yvec, t, t,
			opcodes, vector_ptr,14,work_ptr,last_subpolygon);

    with gle_gcb^ do
      begin
	use_simulation := true;
	if polygon_support = 1 then
	  begin
	    gle_get_polygon_info ( gle_gcb );
	    if error_return = 0 then
	      begin
		info_ptr1 := vector_ptr;
		info_ptr2 := work_ptr;
		gle_polygon ( gle_gcb );
		use_simulation := false;
	      end;
	  end;
      end;
    finish_polygon;
    if gcb^.dgl_current_polygon_edge or (use_simulation) then
      edge_polygon ( num_points, vector_ptr^[1], opcodes,use_simulation);
    int_move(xvec[last_subpolygon],yvec[last_subpolygon]); { update cp }

    release(stack_ptr);                    { return all space }
  recover
    begin
      if escapecode <> -27 then release (stack_ptr);
      escape(escapecode);
    end;
end;

procedure polygon_dev_dep ( num_points : integer;
		       anyvar xvec, yvec : greal_list;
		       anyvar opcodes    : gshortint_list );

{ Purpose : To output a device dependent polygon set }

var
  t               : array[1..1] of real;
  work_ptr        : work_ptr_def;
  vector_ptr      : vec_ptr_def;
  last_subpolygon : integer;
  use_simulation  : boolean;

begin
  try { must return 'new' space if escape occurs }
    setup_for_polygon ( true, num_points, t, t, xvec, yvec,
			opcodes, vector_ptr,14,work_ptr,last_subpolygon);
    with gle_gcb^ do
      begin
	use_simulation := true;
	if polygon_support = 1 then
	  begin
	    gle_get_polygon_info ( gle_gcb );
	    if error_return = 0 then
	      begin
		info_ptr1 := vector_ptr;
		info_ptr2 := work_ptr;
		gle_polygon ( gle_gcb );
		use_simulation := false;
	      end;
	  end;
      end;
    finish_polygon;
    if gcb^.dgl_current_polygon_edge or (use_simulation) then
      edge_polygon ( num_points, vector_ptr^[1], opcodes, use_simulation);
    move(xvec[last_subpolygon],yvec[last_subpolygon]); { update cp }

    release(stack_ptr);                    { return all space }
  recover
    begin
      if escapecode <> -27 then release (stack_ptr);
      escape(escapecode);
    end;
end;

procedure int_polygon ( num_points : integer;  anyvar xvec,yvec : gshortint_list;
				 anyvar opcodes   : gshortint_list );


{ Purpose : To output a device independent polygon set }

var
  t          : array[1..1] of real;
  work_ptr   : work_ptr_def;
  vector_ptr : vec_ptr_def;
  last_subpolygon : integer;

begin
  try { must return 'new' space if escape occurs }
    setup_for_polygon ( false, num_points, xvec, yvec, t, t,
			opcodes, vector_ptr, 40, work_ptr,last_subpolygon );

    draw_polygon ( vector_ptr^[1], work_ptr^[1] );
    finish_polygon;
    if gcb^.dgl_current_polygon_edge then
      edge_polygon ( num_points, vector_ptr^[1], opcodes, false );
    int_move(xvec[last_subpolygon],yvec[last_subpolygon]); { update cp }

    release(stack_ptr);                    { return all space }
  recover
    begin
      if escapecode <> -27 then release (stack_ptr);
      escape(escapecode);
    end;
end;

procedure polygon ( num_points : integer;
		       anyvar xvec, yvec : greal_list;
		       anyvar opcodes    : gshortint_list );

{ Purpose : To output a device independent polygon set }

var
  t          : array[1..1] of real;
  work_ptr   : work_ptr_def;
  vector_ptr : vec_ptr_def;
  last_subpolygon : integer;

begin
  try { must return 'new' space if escape occurs }
    setup_for_polygon ( true, num_points, t, t, xvec, yvec,
			opcodes, vector_ptr,40, work_ptr,last_subpolygon );

    draw_polygon ( vector_ptr^[1], work_ptr^[1] );
    finish_polygon;
    if gcb^.dgl_current_polygon_edge then
      edge_polygon ( num_points, vector_ptr^[1], opcodes, false );
    move(xvec[last_subpolygon],yvec[last_subpolygon]); { update cp }

    release(stack_ptr);                    { return all space }
  recover
    begin
      if escapecode <> -27 then release (stack_ptr);
      escape(escapecode);
    end;
end;

end. {module DGL_POLY}



@


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


56.1
log
@Automatic bump of revision number for PWS version 3.25
@
text
@a0 1256
{                                                                           }
{ Pascal work station graphics library                                      }
{                                                                           }
{ Module    = DGL_POLY                                                      }
{ Programer = BJS                                                           }
{ Date      = 11/10/82                                                      }
{ Rev history:                                                              }
{  Modified    6/01/85 SFB - Added big_color_table stuff for bobcat/gatorbox}

{ Purpose: Hold polygon user 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$
$ALLOW_PACKED ON$ {JWS 3/31/87}
$search 'TYPES',
	'DGL_VARS',
	'GEN',
	'GLE_LIB',
	'LIB',
	'DGL_RAS'$   { DGL_RAS added Nov 84 SFB }


module DGL_POLY;

import dgl_types;

export
  procedure set_pgn_ls ( index : integer);
  procedure set_pgn_color ( index : integer);
  procedure set_pgn_table ( index : integer;
			  pdensity : real;
			  porient : real;
			  pedge   : integer);

  procedure set_pgn_style ( index : integer );
  procedure int_polygon_dd ( num_points : integer;
		       anyvar xvec, yvec : gshortint_list;
		       anyvar opcodes    : gshortint_list );
  procedure polygon_dev_dep ( num_points : integer;
		       anyvar xvec, yvec : greal_list;
		       anyvar opcodes    : gshortint_list );
  procedure int_polygon ( num_points : integer;  anyvar xvec,yvec : gshortint_list;
				 anyvar opcodes   : gshortint_list );
procedure polygon ( num_points : integer;
		       anyvar xvec, yvec : greal_list;
		       anyvar opcodes    : gshortint_list );
implement

import dgl_vars,
       dgl_gen,
       gle_types,
       gle_GEN,
       dgl_lib,
       asm,
       dgl_raster;       {SFB Nov 84}

const
  deg_to_rad     = 0.01745329252;
  normalized_one = 32768;

type vec_ptr_def  = ^gint_list;
     work_ptr_def = ^gshortint_list;

var
  saved_linestyle : integer;
  saved_linewidth : integer;
  stack_ptr       : work_ptr_def;

procedure set_polygon_color;

{ Purpose:  To set the color polygons will be drawn with (send to gle)       }

var
  pass_rgb : boolean;
  h,s,l    : real;

begin
  with gcb^,gle_gcb^ do
    begin
      { If dither is to be used (b&w, moonunit, or 9836C with index > 15) then
	RGB values need to be passed.  Otherwise the index is passed.     }

      pass_rgb :=    (dither_support = 1) and
		  ( ((color_map_support = 1) and
		     (dgl_current_polygon_color > gamut)) or
		    ( color_map_support = 0));
      if pass_rgb then
       begin
	info1 := 0;
	if gamut = 1 { black and white } then
	 with color_table_ptr^[dgl_current_polygon_color] do
	  begin
	   if (display_name <> '98542A') and (display_name <> '98544A') and
	      (display_name <> '98548A') then   {SFB 2/2/88}
	   { define only one parm for dither, use lit to set }
	   { calc brite as defined from CIE diagram          }
	    info2 := trunc((0.3*red+0.59*green+0.11*blue)*1023+0.5)
	   else
	    with big_color_table_ptr_def(
			  color_table_ptr)^[dgl_current_polygon_color] do
	     info2 := trunc(( 0.30*dglfloat(red  )
			     +0.59*dglfloat(green)
			     +0.11*dglfloat(blue ))*1023+0.5);
	   info3 := 0;
	   info4 := 0;
	   gle_fill_index_color(gle_gcb);
	  end { black and white }
	 else         { multi color device }
	  begin
	   if  (display_name = '98700A')
	    or (display_name = '98543A') or (display_name = '98545A')
	    or (display_name = '98547A') or (display_name = '98549A')      {SFB 2/2/88}
	    or (display_name = '98550A')                            {SFB 2/2/88}
	    or (display_name = 'E640  ') or (display_name = 'E1024 ')
	    or (display_name = 'E1280 ') or (display_name = 'E640G ')
	    or (display_name = 'E1280G') then
								   {CFB 30JUL91}
	   with big_color_table_ptr_def(
			  color_table_ptr)^[dgl_current_polygon_color] do
	     begin
	      info2 := trunc(dglfloat(red)*1023+0.5);
	      info3 := trunc(dglfloat(green)*1023+0.5);
	      info4 := trunc(dglfloat(blue)*1023+0.5);
	     end
	   else
	    with color_table_ptr^[dgl_current_polygon_color] do
	     begin
	      info2 := trunc(red*1023+0.5);
	      info3 := trunc(green*1023+0.5);
	      info4 := trunc(blue*1023+0.5);
	     end;
	   gle_fill_index_color(gle_gcb);
	  end; { multi color device }
	end { if pass_rgb }
       else
	begin
	  info1 := 1;
	  info2 := dgl_current_polygon_color;
	  gle_fill_index_color(gle_gcb);
	end;
      dgl_polygon_color_current := true;
    end;
end; { set_polygon_color }

procedure set_pgn_color (index : integer);

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

var
  pass_rgb : boolean;
  h,s,l    : real;

begin
  ck_system_init;
  ck_display_init;

  with gcb^,gle_gcb^ do
    begin                     { Bad values of index are set to index 1 }
      if  (index < 0) or
	 ((index > gamut) and
	 ((color_table_size = 0) or (index > color_table_size))) then index := 1;
      dgl_current_polygon_color := index;
      dgl_polygon_color_current := false;
    end;

end; { set_pgn_color }


procedure set_pgn_ls ( index : integer);

{ Purpose:  To set the linestyle that polygons 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;
      dgl_current_polygon_linestyle := index;
    end;

end; { set_pgn_line_style }

procedure set_pgn_style ( index : integer );

{ Purpose:  To set the polygon style that polygons will be drawn with }

begin
  ck_system_init;
  ck_display_init;

  with gcb^ do
    begin
      if (index < 1) or (index > number_polygon_styles) then index := 1;
      with poly_table_ptr^ [ index ] do
	begin
	  { decode table and setup local vars }
	  dgl_current_polygon_crosshatch := density < 0;
	  dgl_current_polygon_density := density;
	  dgl_current_polygon_angle := orient;
	  dgl_current_polygon_edge  := edge;
	  dgl_current_polygon_style := index;
	end;
    end;
end;

procedure set_pgn_table ( index : integer;
			pdensity : real;
			porient : real;
			pedge   : integer);

{ Purpose:  To define an entry in the polygon table  }

begin
  ck_system_init;
  ck_display_init;

  with gcb^ do
    begin
      if ((index < 1) or (index > number_polygon_styles)) or
	 ((pedge <> 0) and (pedge <> 1)) or
	 ((pdensity < -1) or (pdensity > 1)) or
	 ((porient < -90) or (porient > 90)) then error(err_bad_parms);
      with poly_table_ptr^ [ index ] do
	begin
	  density := pdensity;
	  orient := porient;
	  edge := pedge = 1;
	  if index = dgl_current_polygon_style then set_pgn_style(dgl_current_polygon_style);
	end;
    end;
end;

procedure edge_polygon (        num_points         : integer;
			 anyvar vector             : gint_list;
			 anyvar opcodes            : gshortint_list;
				polygon_simulation : boolean );

{ Purpose : To draw edges around the specified polygon }

var
  vector_count    : integer;
  next_subpolygon : integer;
  i               : integer;
  saved_color     : integer;
  saved_linestyle : integer;
  saved_linewidth : integer;

begin
  with gcb^, gle_gcb^ do
    begin
      if (polygon_simulation) and (dgl_current_polygon_density <> 0) then
	begin
	  saved_color := dgl_current_color;
	  saved_linestyle := dgl_current_linestyle;
	  saved_linewidth := dgl_current_linewidth;
	  set_color(dgl_current_polygon_color);
	  set_line_style(dgl_current_polygon_linestyle);
	  set_line_width(1);
	end;

      vector_count    := 1;
      next_subpolygon := 1;

      for i := 1 to num_points do
	begin
	  if vector_count = next_subpolygon then
	    begin
	      end_x := vector[vector_count+1];
	      end_y := vector[vector_count+2];
	      gle_move ( gle_gcb );
	      next_subpolygon := vector_count + vector[vector_count] * 2 + 1;
	      vector_count := vector_count + 3;
	    end
	  else
	    begin
	      end_x := vector[vector_count];
	      end_y := vector[vector_count+1];
	      if opcodes[i] = 1 then gle_draw ( gle_gcb )
	      else                   gle_move ( gle_gcb );
	      vector_count := vector_count + 2;
	    end;
	end;

      if (polygon_simulation) and (dgl_current_polygon_density <> 0) then
	begin
	  set_color(saved_color);
	  set_line_style(saved_linestyle);
	  set_line_width(saved_linewidth);
	end;
    end;
end;

function int_div ( a, b : integer ) : integer;

{ Purpose : To perform an integer div with rounding }

var temp : integer;

begin
  temp := (2 * a ) div b;
  if odd ( temp ) then
    if temp > 0 then temp := temp + 1
    else             temp := temp - 1;
  int_div := temp div 2;
end;

procedure line_line_intersection ( p1x, p1y, p2x, p2y,
				   p3x, p3y, p4x, p4y : integer;
			       var ix,  iy            : integer );

{ Purpose : To calculate the intersection of two lines }
{           Note: The two lines must intersect.        }

var
  num, denom,
  delta_x_21,
  delta_y_21,
  delta_x_31,
  delta_y_31,
  delta_x_43,
  delta_y_43  : integer;
  real_num,
  real_denom,
  real_factor : real;

begin
$range on$
  delta_x_21 := p2x - p1x;
  delta_y_21 := p2y - p1y;

  delta_x_31 := p3x - p1x;
  delta_y_31 := p3y - p1y;

  delta_x_43 := p4x - p3x;
  delta_y_43 := p4y - p3y;

  try
    denom := delta_y_21 * delta_x_43 - delta_x_21 * delta_y_43;
    num   := delta_x_21 * delta_y_31 - delta_y_21 * delta_x_31;

    {deleted SFB 9/16/86 and replaced as below
    ix := p3x + int_div((p4x-p3x)*num, denom);
    iy := p3y + int_div((p4y-p3y)*num, denom);
    }

    {to help correct uneven polygon crosshatch lines (not complete fix)
     SFB 9/16/86}

    real_factor := num/denom;
    ix := round(p3x + (p4x-p3x)*real_factor);
    iy := round(p3y + (p4y-p3y)*real_factor);

    {end insertion SFB 9/16/86}

$range off$

  recover
    if escapecode = -4 { integer overflow } then
      begin
	real_denom := 1.0 * delta_y_21 * delta_x_43 - 1.0 * delta_x_21 * delta_y_43;
	real_num   := 1.0 * delta_x_21 * delta_y_31 - 1.0 * delta_y_21 * delta_x_31;
	real_factor := real_num / real_denom;
	ix := trunc(p3x + (p4x-p3x) * real_factor + 0.5);
	iy := trunc(p3y + (p4y-p3y) * real_factor + 0.5);
      end
    else
      escape(escapecode);
end;

procedure draw_pg ( anyvar vector, work                   : gint_list;
			   dgl_current_polygon_color,
			   dgl_current_polygon_linestyle,
			   normalized_sin,normalized_cos  : integer;
			   dgl_current_polygon_crosshatch : boolean;
			   dgl_current_polygon_spacing    : integer);

{ PURPOSE:  To draw a polygon using the current polygon attributes     }

{           The input format for vector is as follows (GLE polygon format):

	      VECTOR [ Number of pts in segment 1 ( 1st subpolygon ) ]
		     [          X1                                   ]
		     [          Y1                                   ]
		     [          X2                                   ]
		     [          Y2                                   ]
		     [           :                                   ]
		     [           :                                   ]
		     [          Xn                                   ]
		     [          Yn                                   ]

		     [ Number of pts in segment 2 ( 2nd subpolygon   ]
		     [          X1                                   ]
		     [          Y1                                   ]
		     [           :                                   ]
		     [           :                                   ]
		     [          Xm                                   ]
		     [          Ym                                   ]

				 :
				 :

		     [           0                                   ] }

{       The basic algorithm is as follow:

	  - Calculate dist between fill lines
	  - Calculate fill line slope in terms of dx, dy
	  - For every edge in the polygon, calculate the x intercept
	    ( or y intercept for x major fill slope ) along a line parallel
	    to the fill lines for each end point.  With this information
	    build a record with minimum intercept, maximum intercept, and
	    both end points ordered by maximum intercept value.

	    Maintain a minimum and maximum intercept value for all edge
	    end points in the polygon.  This information will be used to
	    indicate where to start filling the polygon with fill lines.

	  - Calculate using the minimum intercept value the first fill
	    line that may intersect the polygon.

	  - For each possible fill line do the following:

	      - For each intercept record look for intersections.  An
		intersection is determined by the current intercept value
		of the current fill line, falling between the minimum
		and maximum intercept values of the record.

		If an intersection is found, find the end point of
		the intersection and save the point.

		After all intersections for a given fill line are found,
		sort the end points.  The sort alternates between top
		down, and bottom up for each fill line.  This minimizes
		motion on mechanical devices.

		Plot the end points alternating between moves and draws. }

const
  normal_vertex = 0;
  short_vertex  = 1;
  edge_vertex   = 2;

  edge_index    = 2;

type
  point_def1  = array [0..1] of integer;
  point_def   = array [0..2] of integer;

  point_array = array [1..maxint] of point_def1;

  intercept_rec_def = record
	    intercept_p_min,
	    intercept_p_max      : integer;
	    intercept_min_points : point_def;
	    intercept_max_points : point_def;
	  end;

  intercept_array = array [1..maxint] of intercept_rec_def;

var
  intercept_list_ptr  : ^intercept_array;
  p_list_ptr          : ^point_array;
  p_count         : integer;
  t, i, j         : integer;
  intercept_count : integer;
  intercept_min   : integer;
  intercept_max   : integer;
  intercept_inc   : integer;
  xmin, ymin      : integer;
  dx, dy          : integer;
  local_spacing   : integer;
  vector_index    : integer;
  num_vert        : integer;
  last_index      : integer;
  move_it         : boolean;
  top_down_sort   : boolean;
  x_major         : boolean;
  hatch           : boolean;
  saved_color     : integer;
  vedge_index     : integer;
  major_index     : integer;
  first_index     : integer;
  nxt_edge        : integer;
  found_fill_line_on_edge : boolean;

  procedure calc_intercept (  pt_1_index : integer;
			      pt_2_index : integer;
			      switch_xy  : boolean);

  { Purpose : For each end point of the edge defined by pt_1_index and
	      pt_2_index, calculate the intercept of a line which runs
	      though the end point and is parallel with the fill line. }

  var
    p1,p2,tp   : integer;
    pt1x,pt1y  : integer;
    pt2x,pt2y  : integer;
    ix,iy      : integer;
    tdx,tdy    : integer;

  begin
    if switch_xy then
      begin
	ix := 1;    iy := 0;
	tdx := dy;  tdy := dx;
      end
    else
      begin
	ix := 0;    iy := 1;
	tdx := dx;  tdy := dy;
      end;

    with intercept_list_ptr^[intercept_count] do
      begin
	pt1x := vector[pt_1_index+ix];
	pt1y := vector[pt_1_index+iy];
	pt2x := vector[pt_2_index+ix];
	pt2y := vector[pt_2_index+iy];

	p1 := pt1y - int_div(tdy * pt1x,tdx);       { calc intercept }
	p2 := pt2y - int_div(tdy * pt2x,tdx);

	if p1 > p2 then
	  begin                                     { swap points }
	    tp := p2;   p2   := p1;   p1   := tp;
	    tp := pt2x; pt2x := pt1x; pt1x := tp;
	    tp := pt2y; pt2y := pt1y; pt1y := tp;
	  end;
						    { save intercepts }
	intercept_count := intercept_count + 1;
	intercept_p_min := p1;
	intercept_p_max := p2;
	intercept_max := max(intercept_max,intercept_p_max);
	intercept_min := min(intercept_min,intercept_p_min);
	if p1 = p2 then
	  begin
	    intercept_min_points[edge_index] := edge_vertex;
	    intercept_max_points[edge_index] := edge_vertex;
	    if pt1x <= pt2x then
	      begin
		intercept_min_points[ix] := pt1x;
		intercept_min_points[iy] := pt1y;
		intercept_max_points[ix] := pt2x;
		intercept_max_points[iy] := pt2y;
	      end
	    else
	      begin
		intercept_max_points[ix] := pt1x;
		intercept_max_points[iy] := pt1y;
		intercept_min_points[ix] := pt2x;
		intercept_min_points[iy] := pt2y;
	      end;
	  end
	else
	  begin
	    intercept_min_points[edge_index] := normal_vertex;
	    intercept_max_points[edge_index] := normal_vertex;
	    intercept_min_points[ix] := pt1x;
	    intercept_min_points[iy] := pt1y;
	    intercept_max_points[ix] := pt2x;
	    intercept_max_points[iy] := pt2y;
	  end;
      end;
  end;

  procedure calc_vertex_info (  edge_a : integer;
				edge_b : integer);

  { Purpose : To mark points which should not be used when calc fill line }
  {           end points.                                                 }

  var
    a_min,
    a_max,
    b_min,
    b_max  : integer;

  begin
    with intercept_list_ptr^[edge_b] do
      begin
	b_min  := intercept_p_min;
	b_max  := intercept_p_max;
      end;

    with intercept_list_ptr^[edge_a] do
      begin
	a_min := intercept_p_min;
	a_max := intercept_p_max;
	if (intercept_max_points[edge_index] <> edge_vertex) then
	  begin
	    if a_min = b_max then
	      intercept_min_points[edge_index] := short_vertex
	    else
	    if a_max = b_min then
	      intercept_max_points[edge_index] := short_vertex;
	  end;
      end;
  end;

  procedure sort( starting, ending, inc : integer );

  { Purpose : To sort the P_LIST array.  }

  var
    sx         : gle_shortint;
    sy         : gle_shortint;
    index      : gle_shortint;
    test_point : integer;
    temp_point : integer;
    done       : boolean;

  begin
    if x_major then               { sort by x }
      begin sx := 1; sy := 0; end
    else                          { sort by y }
      begin sx := 0; sy := 1; end;

    repeat
      index := starting + inc;
      done := true;
      test_point := p_list_ptr^[starting,sx];
      while index <> ending + inc do
	begin
	  temp_point := p_list_ptr^[index,sx];
	  if test_point > temp_point then
	    begin
	      p_list_ptr^[index,sx] := p_list_ptr^[index-inc,sx];
	      p_list_ptr^[index-inc,sx] := temp_point;

	      temp_point := p_list_ptr^[index,sy];
	      p_list_ptr^[index,sy] := p_list_ptr^[index-inc,sy];
	      p_list_ptr^[index-inc,sy] := temp_point;

	      done := false;
	    end
	  else
	    test_point := temp_point;
	  index := index + inc;
	end;
    until done
  end;         { sort }

begin { poly }

  with gcb^ do
    begin
      intercept_list_ptr := addr(work);
      hatch           := dgl_current_polygon_crosshatch;
      local_spacing   := dgl_current_polygon_spacing;

      saved_color     := dgl_current_color;
      if dgl_current_color <> dgl_current_polygon_color then set_color(dgl_current_polygon_color);

      with gle_gcb^ do
	repeat                     { cross hatching loop }

	  hatch := not hatch;

	  { Calc slope in terms of dx, dy }
	  { Calc x or y spacing  (intercept_inc)   }

	  x_major := true;
	  major_index := 1;
	  if abs(normalized_sin) = normalized_one  { 90 deg } then
	    begin
	      dy := display_max_y;
	      dx := 0;
	      intercept_inc := local_spacing;
	    end
	  else
	  if abs(normalized_sin) <= abs(normalized_cos) { <= 45 deg } then
	    begin
	      dx := display_max_x;
	      dy := int_div(dx * normalized_sin,normalized_cos);
	      x_major := false;
	      major_index := 0;
	      intercept_inc := abs(int_div(local_spacing * normalized_one,normalized_cos));
	    end
	  else
	    begin
	      dy := display_max_y;
	      dx := int_div(dy * normalized_cos,normalized_sin);
	      intercept_inc := abs(int_div(local_spacing * normalized_one,normalized_sin));
	    end;

	  if intercept_inc < 1 then intercept_inc := 1;

	  { Calc end point intercepts }

	  intercept_count := 1;
	  intercept_min := maxint;
	  intercept_max := minint;

	  vector_index := 1;
	  while vector[vector_index] <> 0 do
	    begin
	      num_vert := vector[vector_index];
	      vector_index := vector_index + 1;
	      for i := 2 to num_vert do
		calc_intercept ( vector_index+(i-1)*2,vector_index+(i-2)*2,x_major);
	      last_index := vector_index+((num_vert-1)*2);
	      calc_intercept ( vector_index,last_index,x_major);
	      vector_index := last_index + 2;
	    end;

	  intercept_count := intercept_count - 1;

	  vector_index := 1;
	  vedge_index := 1;
	  while vector[vector_index] <> 0 do
	    begin
	      num_vert := vector[vector_index];
	      first_index := vedge_index;
	      last_index := vedge_index + num_vert;
	      for i := 1 to num_vert do
		begin
		  nxt_edge := vedge_index + 1;
		  { The following while statement should read }
		  {  'while (nxt_edge < last_index) and ...'  }
		  { however this "bug" was not found until after }
		  { QA.  It will not proceduce a user bug though }
		  { since the following 'if' stmt with not use the }
		  { bad results                                  }
		  while (nxt_edge < last_index) and
			(intercept_list_ptr^[nxt_edge].
			 intercept_max_points[edge_index] = edge_vertex) do
		    nxt_edge := nxt_edge + 1;
		  if nxt_edge >= last_index then
		    begin
		      nxt_edge := first_index;
			while (nxt_edge < vedge_index) and
			      (intercept_list_ptr^[nxt_edge].
			       intercept_max_points[edge_index] = edge_vertex) do
			  nxt_edge := nxt_edge + 1;
		    end;
		  if (intercept_list_ptr^[nxt_edge].
		      intercept_max_points[edge_index] <> edge_vertex) then
			  calc_vertex_info ( vedge_index,nxt_edge);
		  vedge_index := vedge_index + 1;
		end;
	      vector_index := vector_index + num_vert * 2 + 1;
	    end;

	  { Calc first fill line intercept value, adjust with lower left
	    of display                                                    }

	  p_list_ptr := addr(work,(intercept_count+1)*32);

	  intercept_min := intercept_min - (intercept_min mod intercept_inc);
	  xmin := 0;
	  ymin := 0;
	  top_down_sort := true;

	  { Fill polygon }
	  while intercept_min <= intercept_max do
	    begin
	      if x_major then
		xmin := intercept_min
	      else
		ymin := intercept_min;

	      { Find intersections }
	      p_count := 0;
	      found_fill_line_on_edge := false;
	      for i := 1 to intercept_count do
		begin
		  with intercept_list_ptr^[i] do
		    begin
		      if (intercept_min = intercept_p_min) and
			 (intercept_min = intercept_p_max) then
			  found_fill_line_on_edge := true
		      else
		      if (intercept_min >= intercept_p_min) and
			 (intercept_min <= intercept_p_max) then
			{ intersection }
			begin
			  if (intercept_min = intercept_p_min) then
			    begin
			     if (intercept_min_points[edge_index] = normal_vertex) then
			       begin
				 p_count := p_count + 1;
				 p_list_ptr^[p_count,0] := intercept_min_points[0];
				 p_list_ptr^[p_count,1] := intercept_min_points[1];
			       end;
			    end
			  else
			  if (intercept_min = intercept_p_max) then
			    begin
			      if (intercept_max_points[edge_index] = normal_vertex) then
				begin
				  p_count := p_count + 1;
				  p_list_ptr^[p_count,0] := intercept_max_points[0];
				  p_list_ptr^[p_count,1] := intercept_max_points[1];
				end;
			    end
			  else
			    begin
			      p_count := p_count + 1;
			      line_line_intersection(xmin,ymin,xmin+dx,ymin+dy,
				intercept_min_points[0],intercept_min_points[1],
				intercept_max_points[0],intercept_max_points[1],
				p_list_ptr^[p_count,0],p_list_ptr^[p_count,1]);
			    end;
			end;
		    end;
		end;

	      if found_fill_line_on_edge then  { add edge points }
		begin
		  if p_count > 1 then sort(1,p_count,1); { sort bottom up }
		  if odd(p_count) then p_count := p_count-1; { remove last move }
		  for i := 1 to intercept_count do
		    with intercept_list_ptr^[i] do
		      begin
			if (intercept_min = intercept_p_min) and
			   (intercept_min = intercept_p_max) then
			  begin
			    p_count := p_count + 1;
			    p_list_ptr^[p_count,0] := intercept_min_points[0];
			    p_list_ptr^[p_count,1] := intercept_min_points[1];
			    p_count := p_count + 1;
			    p_list_ptr^[p_count,0] := intercept_max_points[0];
			    p_list_ptr^[p_count,1] := intercept_max_points[1];
			  end;
		      end;
		  i := 1;
		  repeat
		    j := i + 2;
		    while j < p_count do
		      begin
			if (p_list_ptr^[i,major_index] <=
			    p_list_ptr^[j+1,major_index]) and
			   (p_list_ptr^[j,major_index] <=
			    p_list_ptr^[i+1,major_index]) then
			  begin
			    if p_list_ptr^[i,major_index] >
			      p_list_ptr^[j,major_index] then
			      begin
				p_list_ptr^[i,0] := p_list_ptr^[j,0];
				p_list_ptr^[i,1] := p_list_ptr^[j,1];
			      end;
			    if p_list_ptr^[i+1,major_index] <
			      p_list_ptr^[j+1,major_index] then
			      begin
				p_list_ptr^[i+1,0] := p_list_ptr^[j+1,0];
				p_list_ptr^[i+1,1] := p_list_ptr^[j+1,1];
			      end;
			    for t := j to p_count-2 do
			      begin
				p_list_ptr^[t,0] := p_list_ptr^[t+2,0];
				p_list_ptr^[t,1] := p_list_ptr^[t+2,1];
			      end;
			    p_count := p_count - 2;
			    j := i + 2;
			  end
			else
			  j := j + 2;
		      end;
		    i := i + 2;
		  until i > p_count;
		end;

	      { Sort points }
	      if p_count > 1 then
		begin
		  top_down_sort := not top_down_sort;
		  if top_down_sort then sort(p_count,1,-1)
		  else sort(1,p_count,1);
		end;

	      { draw a fill line }
	      move_it := true;
	      for i := 1 to p_count do
		begin
		  end_x := p_list_ptr^[i,0];
		  end_y := p_list_ptr^[i,1];
		  if move_it then call ( move,gle_gcb )
		  else            call ( draw,gle_gcb );
		  move_it := not move_it;
		end;

	      intercept_min := intercept_min + intercept_inc;
	    end;  { of filling loop }

	  if (not hatch) and dgl_current_polygon_crosshatch then
	    begin
	      t := normalized_sin;
	      normalized_sin := -normalized_cos;
	      normalized_cos := t;
	    end;
	until hatch; { end of hatching loop }

      if saved_color <> dgl_current_polygon_color then set_color(saved_color);
    end;
end;

procedure draw_polygon ( anyvar vector, work : gint_list );

{ PURPOSE:  To draw a polygon using the current polygon attributes     }

{           The input format for vector is as follows (GLE polygon format):

	      VECTOR [ Number of pts in segment 1 ( 1st subpolygon ) ]
		     [          X1                                   ]
		     [          Y1                                   ]
		     [          X2                                   ]
		     [          Y2                                   ]
		     [           :                                   ]
		     [           :                                   ]
		     [          Xn                                   ]
		     [          Yn                                   ]

		     [ Number of pts in segment 2 ( 2nd subpolygon   ]
		     [          X1                                   ]
		     [          Y1                                   ]
		     [           :                                   ]
		     [           :                                   ]
		     [          Xm                                   ]
		     [          Ym                                   ]

				 :
				 :

		     [           0                                   ] }

  { normalized_one = 32768 }

var
  local_angle   : real;
  hatch         : boolean;
  local_spacing : integer;
  rad_angle     : real;
  sin_angle,
  cos_angle     : integer         { normalized fixed point numbers };

begin { draw_polygon }

  with gcb^ do
    begin
      if dgl_current_polygon_density <> 0 then
	begin
	  local_angle := dgl_current_polygon_angle;
	  hatch := dgl_current_polygon_crosshatch and (dgl_current_polygon_density <> 1);
	  if dgl_current_polygon_density = 1 then
	    local_spacing := gle_gcb^.polygon_solid_fill
	  else
	    local_spacing :=
	      abs(trunc(1/dgl_current_polygon_density * gle_gcb^.polygon_fill_factor));
	  if local_spacing < 1 then local_spacing := 1;
	  if hatch then local_spacing := local_spacing * 2;
	  if local_spacing = 1 then local_angle := 0;
	  rad_angle := deg_to_rad * local_angle;
	  sin_angle := trunc(sin(rad_angle) * normalized_one);
	  cos_angle := trunc(cos(rad_angle) * normalized_one);
	  draw_pg(vector,work,dgl_current_polygon_color,dgl_current_polygon_linestyle,
		  sin_angle,cos_angle,hatch,local_spacing);
	end;
    end;
end;

procedure setup_for_polygon ( real_format  : boolean;
			      num_points   : integer;
		       anyvar xvec, yvec   : gshortint_list;
		       anyvar rxvec, ryvec : greal_list;
		       anyvar opcodes      : gshortint_list;
		       anyvar vector       : vec_ptr_def;
			      work_mult    : integer;
			  anyvar work_ptr  : work_ptr_def;
			  var last_subpoly : integer );

{ Purpose : To prepare for drawing a polygon set.  This includes          }
{           setting up attributes, creating work space, performing error  }
{           checks, and creating a GLE format polygon.                    }

var
  i              : integer;
  sub_poly_start : integer;
  sub_poly_count : integer;
  point_count    : integer;
  vector_count   : integer;
  local_angle    : real;
  rad_angle      : real;

begin
  ck_system_init;
  ck_display_init;
$ovflcheck on$
  if num_points <= 0 then error (err_neg_points);
  if opcodes[1] <> 2 then error (err_bad_parms);

  { allocate worst possible space for vector array }
  mark(stack_ptr);                       { mark current base }
  newbytes(vector,12*num_points+4);      { alocate worst case space }

  with gcb^ do
    begin
      saved_linestyle := dgl_current_linestyle;
      saved_linewidth := dgl_current_linewidth;

      if dgl_current_linestyle <> dgl_current_polygon_linestyle then
	set_line_style ( dgl_current_polygon_linestyle );
      if dgl_current_linewidth <> 1 then set_line_width(1);
      if not dgl_polygon_color_current then
       set_polygon_color;
     end;

  sub_poly_start := 1;
  i := 1;
  sub_poly_count := 1;
  point_count := 1;
  last_subpoly := 1;   { last subpolygon in polygon }
  vector_count := 2;      { first spot will hold count }

  while i <= num_points do
    begin
      if (opcodes[I]=2) and (i<>1)  then
	begin
	  vector^[sub_poly_start] := point_count-1;
	  sub_poly_start := vector_count;  { save space to hold count }
	  vector_count := vector_count + 1;
	  point_count := 1;
	  sub_poly_count := sub_poly_count + 1;
	  last_subpoly := i;
	end;
      point_count := point_count + 1;
      if real_format then
	convert_wtod(rxvec[i],ryvec[i],vector^[vector_count],vector^[vector_count+1])
      else
      if short_flag then
	convert_intwtod(xvec[i],yvec[i],vector^[vector_count],vector^[vector_count+1])
      else
	convert_wtod(xvec[i],yvec[i],vector^[vector_count],vector^[vector_count+1]);
      vector_count := vector_count + 2;
      i := i + 1;
    end;
  vector^[sub_poly_start] := point_count-1;
  vector^[vector_count] := 0;

  newbytes(work_ptr,work_mult*vector_count);     { alocate work space for gle }

  with gcb^,gle_gcb^ do
    begin
      if dgl_current_polygon_crosshatch then info1 := 1
      else                                   info1 := 0;

      local_angle := dgl_current_polygon_angle;
      rad_angle := deg_to_rad * local_angle;
      info3 := trunc(sin(rad_angle) * normalized_one);
      info4 := trunc(cos(rad_angle) * normalized_one);

      if dgl_current_polygon_density = 1 then
	info2 := polygon_solid_fill
      else
      if dgl_current_polygon_density = 0 then
	info2 := 0
      else
	begin
	  info2 := abs(trunc(1/dgl_current_polygon_density * polygon_fill_factor));
	  if info2 < 1 then info2 := 1;
	end;
    end;
end;


procedure finish_polygon;

{ Purpose: Restore linestyle and line width to current values }

begin
  with gcb^ do
    begin
      if saved_linestyle <> dgl_current_polygon_linestyle then
	set_line_style(saved_linestyle);
      if saved_linewidth <> 1 then
	set_line_width(saved_linewidth);
    end;
end;

procedure int_polygon_dd ( num_points : integer;
		    anyvar xvec, yvec : gshortint_list;
		    anyvar opcodes    : gshortint_list );

{ Purpose : To output a device dependent polygon set }

var
  t               : array[1..1] of real;
  work_ptr        : work_ptr_def;
  vector_ptr      : vec_ptr_def;
  last_subpolygon : integer;
  use_simulation  : boolean;

begin
  try { must return 'new' space if escape occurs }
    setup_for_polygon ( false, num_points, xvec, yvec, t, t,
			opcodes, vector_ptr,14,work_ptr,last_subpolygon);

    with gle_gcb^ do
      begin
	use_simulation := true;
	if polygon_support = 1 then
	  begin
	    gle_get_polygon_info ( gle_gcb );
	    if error_return = 0 then
	      begin
		info_ptr1 := vector_ptr;
		info_ptr2 := work_ptr;
		gle_polygon ( gle_gcb );
		use_simulation := false;
	      end;
	  end;
      end;
    finish_polygon;
    if gcb^.dgl_current_polygon_edge or (use_simulation) then
      edge_polygon ( num_points, vector_ptr^[1], opcodes,use_simulation);
    int_move(xvec[last_subpolygon],yvec[last_subpolygon]); { update cp }

    release(stack_ptr);                    { return all space }
  recover
    begin
      if escapecode <> -27 then release (stack_ptr);
      escape(escapecode);
    end;
end;

procedure polygon_dev_dep ( num_points : integer;
		       anyvar xvec, yvec : greal_list;
		       anyvar opcodes    : gshortint_list );

{ Purpose : To output a device dependent polygon set }

var
  t               : array[1..1] of real;
  work_ptr        : work_ptr_def;
  vector_ptr      : vec_ptr_def;
  last_subpolygon : integer;
  use_simulation  : boolean;

begin
  try { must return 'new' space if escape occurs }
    setup_for_polygon ( true, num_points, t, t, xvec, yvec,
			opcodes, vector_ptr,14,work_ptr,last_subpolygon);
    with gle_gcb^ do
      begin
	use_simulation := true;
	if polygon_support = 1 then
	  begin
	    gle_get_polygon_info ( gle_gcb );
	    if error_return = 0 then
	      begin
		info_ptr1 := vector_ptr;
		info_ptr2 := work_ptr;
		gle_polygon ( gle_gcb );
		use_simulation := false;
	      end;
	  end;
      end;
    finish_polygon;
    if gcb^.dgl_current_polygon_edge or (use_simulation) then
      edge_polygon ( num_points, vector_ptr^[1], opcodes, use_simulation);
    move(xvec[last_subpolygon],yvec[last_subpolygon]); { update cp }

    release(stack_ptr);                    { return all space }
  recover
    begin
      if escapecode <> -27 then release (stack_ptr);
      escape(escapecode);
    end;
end;

procedure int_polygon ( num_points : integer;  anyvar xvec,yvec : gshortint_list;
				 anyvar opcodes   : gshortint_list );


{ Purpose : To output a device independent polygon set }

var
  t          : array[1..1] of real;
  work_ptr   : work_ptr_def;
  vector_ptr : vec_ptr_def;
  last_subpolygon : integer;

begin
  try { must return 'new' space if escape occurs }
    setup_for_polygon ( false, num_points, xvec, yvec, t, t,
			opcodes, vector_ptr, 40, work_ptr,last_subpolygon );

    draw_polygon ( vector_ptr^[1], work_ptr^[1] );
    finish_polygon;
    if gcb^.dgl_current_polygon_edge then
      edge_polygon ( num_points, vector_ptr^[1], opcodes, false );
    int_move(xvec[last_subpolygon],yvec[last_subpolygon]); { update cp }

    release(stack_ptr);                    { return all space }
  recover
    begin
      if escapecode <> -27 then release (stack_ptr);
      escape(escapecode);
    end;
end;

procedure polygon ( num_points : integer;
		       anyvar xvec, yvec : greal_list;
		       anyvar opcodes    : gshortint_list );

{ Purpose : To output a device independent polygon set }

var
  t          : array[1..1] of real;
  work_ptr   : work_ptr_def;
  vector_ptr : vec_ptr_def;
  last_subpolygon : integer;

begin
  try { must return 'new' space if escape occurs }
    setup_for_polygon ( true, num_points, t, t, xvec, yvec,
			opcodes, vector_ptr,40, work_ptr,last_subpolygon );

    draw_polygon ( vector_ptr^[1], work_ptr^[1] );
    finish_polygon;
    if gcb^.dgl_current_polygon_edge then
      edge_polygon ( num_points, vector_ptr^[1], opcodes, false );
    move(xvec[last_subpolygon],yvec[last_subpolygon]); { update cp }

    release(stack_ptr);                    { return all space }
  recover
    begin
      if escapecode <> -27 then release (stack_ptr);
      escape(escapecode);
    end;
end;

end. {module DGL_POLY}



@


55.3
log
@
pws2rcs automatic delta on Mon Nov  4 13:45:04 MST 1991
@
text
@@


55.2
log
@Added support for High-res and Greyscale - CFB
@
text
@d136 1
a136 1
                                                                   {CFB 30JUL91}
@


55.1
log
@Automatic bump of revision number for PWS version 3.25A
@
text
@d133 4
a136 3
	    or (display_name = 'VGA   ') or (display_name = 'MEDIUM')
	    or (display_name = 'HIRES ') then
								   {CFB 12JUN91}
@


54.4
log
@
pws2rcs automatic delta on Wed Aug 21 12:59:22 MDT 1991
@
text
@@


54.3
log
@removed . from include file names - CFB
@
text
@d135 1
a135 1
                                                                   {CFB 12JUN91}
@


54.2
log
@Added support for WOODCUT graphics hardware - CFB
@
text
@d31 1
a31 1
$include 'OPTIONS.'$
d37 1
a37 1
	'GLE_LIB.',
@


54.1
log
@Automatic bump of revision number for PWS version 3.24
@
text
@d31 1
a31 1
$include 'OPTIONS'$
d37 1
a37 1
	'GLE_LIB',
d132 4
a135 1
	    or (display_name = '98550A')                              then {SFB 2/2/88}
@


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
@d112 2
a113 3
	   if (display_name <> '98542A') and (display_name <> '98544A') then
	   { 3.2i BUG FIX SFB 10/22/86}
	   { 3.1E BUG FIX SFB 6/14/85}
d131 2
a132 4
	   {or (display_name = '98544A') or (display_name = '98545A')}
	    {ABOVE 3.2E BUG FIX - 98543 POLYFILL DEV_DEP NOT WORK SFB 2/17/87}
	    or (display_name = '98547A') or (display_name = '98549A') then
	    { 3.1E BUG FIX SFB 6/14/85}
@


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.2
log
@Pws2unix automatic delta on Wed Apr  1 08:30:27 MST 1987
@
text
@@


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


12.2
log
@Re-entered seconf half of 98543 polygon fix. This fix seems to have been
partly lost in 5.2 or 6.2. Now works OK.
@
text
@@


12.1
log
@Automatic bump of revision number for PWS version 3.2E
@
text
@d130 3
a132 1
	    or (display_name = '98544A') or (display_name = '98545A')
@


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
@d111 2
a112 1
	   if (display_name <> '98542A') and (display_name <> '98543A') then
@


5.2
log
@Changes from Scott Bayes.
@
text
@@


5.1
log
@Automatic bump of revision number for PWS version 3.2j
@
text
@d129 2
a130 1
	    or (display_name = '98544A') or (display_name = '98545A') then
d357 1
d360 11
@


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


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


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


1.1
log
@Initial revision
@
text
@@
