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


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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

36.1
date     89.02.06.10.21.18;  author dew;  state Exp;
branches ;
next     35.2;

35.2
date     89.02.06.09.33.21;  author bayes;  state Exp;
branches ;
next     35.1;

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

7.1
date     86.11.20.13.57.31;  author hal;  state Exp;
branches ;
next     6.1;

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

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

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

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

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

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

1.1
date     86.06.30.15.38.56;  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
@{                                                                           }
{ DGL device dependent init routine                                         }
{                                                                           }
{ Module    = DGL_RASTER                                                    }
{ Programer = BJS                                                           }
{ Date      = 1 - 5-83                                                      }
{                                                                           }
{ Purpose: To provide device dependent initialization for raster devices.   }

{ Rev history                                                               }
{  Created  - 1 - 5-83  BJS                                                 }
{  Modified - 02-17-84  BDS Changed allocations from dynamic to global.     }
{  Modified - 12- 84    SFB Added calls to dglfix/dglfloat                  }
{  Modified - 3 - 85    SFB Added opcodes for dumpgraphics                  }
{  Modified - 4 - 85    SFB Added calls to locator_esc                      }

{     (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                              }

$search 'GLE_LIB',
	'TYPES',
	'DGL_VARS',
	'GEN'$
$modcal$
$include 'OPTIONS.'$  { ******************** COMPILER OPTIONS ****************** }
$linenum 17000$
$ALLOW_PACKED ON$ {JWS 3/31/87}

module DGL_RASTER;

import dgl_types;

export

procedure dgl_raster_init ( control : integer );

implement

import dgl_vars,
       sysdevs,
       asm,
       sysglobals,
       gle_types,
       gle_gen,
       gle_autl,
       gle_ras_out,
       dgl_gen;

type
  init_color_table_def = ARRAY [0..15] of c_def;

const
  init_color_table = init_color_table_def [
c_def [ red :  0, green :  0,  blue :  0 ],  {  0 }
c_def [ red :  1, green :  1,  blue :  1 ],  {  1 }
c_def [ red :  1, green :  0,  blue :  0 ],  {  2 }
c_def [ red :  1, green :  1,  blue :  0 ],  {  3 }
c_def [ red :  0, green :  1,  blue :  0 ],  {  4 }
c_def [ red :  0, green :  1,  blue :  1 ],  {  5 }
c_def [ red :  0, green :  0,  blue :  1 ],  {  6 }
c_def [ red :  1, green :  0,  blue :  1 ],  {  7 }
c_def [ red :  0, green :  0,  blue :  0 ],  {  8 }
c_def[red:0.8              ,green:0.733333333333333,blue:0.2               ], {  9 }
c_def[red:0.2              ,green:0.666666666666667,blue:0.466666666666667 ], { 10 }
c_def[red:0.533333333333333,green:0.4              ,blue:0.666666666666667 ], { 11 }
c_def[red:0.8              ,green:0.266666666666667,blue:0.4               ], { 12 }
c_def[red:1.0              ,green:0.4              ,blue:0.2               ], { 13 }
c_def[red:1.0              ,green:0.466666666666667,blue:0                 ], { 14 }
c_def[red:0.866666666666667,green:0.533333333333333,blue:0.266666666666667 ]];{ 15 }

var
 step : integer;                {SFB 3/11/85}

{procedure hpm_new(var opject:anyptr; numbytes : integer); external;}

procedure raster_linestyle ( index : integer);

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

type
  ls_map_def = packed array [1..13] of gbyte;
const
  ls_map = ls_map_def [0,2,3,4,5,6,1,2,3,4,5,6,1];

begin
  with gle_gcb^ do
    begin
      info1 := ls_map[index];                 { map DGL to GLE def }
      info2 := 1;                             { repeat rate 1% CHANGED FROM 4%
						IN 3.01 SFB 7/8/85 }
      info3 := 0;                             { linestyle mode }
      info4 := raster_patterns[index-1];      { pattern }
      gle_linestyle ( gle_gcb );
    end;


end; { set_line_style }

function return_closest_color ( r,g,b : real;          { target color }
				c_table_ptr : anyptr ) { system color map } : integer;

var
  target_h,
  target_s,
  target_l : real;           { HSL target color values }
  error_h,
  error_h2,                  { hue error distance squared }
  error_l,                   { lightness error distance squared }
  error_s,
  error_l2,
  error_s2 : real;            { saturation error distance squared }
  map_h,
  map_l,
  map_s,                     { Current color map entry in HSL }
  error : real;              { Distance from target to current color map entry }
  closest_error : real;
  i,
  closest_index : integer;   { Best fit color map index }


{ Find closest color from system color map, to match target color.  }
{ The closest color is the color which 'looks' the closest.  This   }
{ algorithm has been derived from a mixture of logic and            }
{ experimentation.  The algorithm calculates for each entry in the  }
{ color map an error factor indicating how far off the color map    }
{ value is from the target color.  It then returns the color map    }
{ index with the least error.                                       }

{ Experimentation has showed that the best looking color is normaly }
{ the color with the least error in hue.  However when the target   }
{ color is near black or white this is not true, and when many color}
{ map entrys have a small hue error the closest hue does not produce}
{ the best color.  The algorithm makes special cases out of the     }
{ above cases and 'weights' the error result to reduce the effects  }
{ of hue.                                                           }

begin
  convert_rgb_to_hsl(r,g,b,target_h,target_s,target_l);
  closest_index := 1;
  closest_error := maxint;                           { worst case error }
  for i := 0 to gle_gcb^.gamut do                    { for each CMAP entry }
   begin
    if not realmap then         {SFB 11/84}
     with big_color_table_ptr_def(c_table_ptr)^[i] do     { force anyptr to known type }
      convert_rgb_to_hsl(dglfloat(red),dglfloat(green),dglfloat(blue),
			 map_h,map_s,map_l)
    else
     with color_table_ptr_def(c_table_ptr)^[i] do     { force anyptr to known type }
      convert_rgb_to_hsl(red,green,blue,map_h,map_s,map_l);

    { Calc errors, note that since Hue is circular it must }
    { be calc as shortest dist of either direction         }

    error_h  := abs(map_h-target_h);
    error_h2 := abs(map_h-1-target_h);
    if error_h2 <= error_h then error_h := error_h2;
    error_h2 := error_h * error_h;
    error_s := abs(map_s-target_s);
    error_l := abs(map_l-target_l);
    error_s2 := error_s * error_s;
    error_l2 := error_l * error_l;

    if target_l < 0.1 then { special case where request is near black }
      begin
	{ With small lum in cmap, sat and hue are undifined and can't }
	{ be used in error calculation                                }
	if map_l < 0.01 then error := error_l
	else
	{ With small sat in cmap, hue is undifined and can't be used  }
	{ in error calculation                                        }
	if map_s < 0.01 then error := error_l + error_s2
	else                 error := error_l + error_h2 + error_s2;
      end
    else
    if target_s < 0.1 then { special casewhere request is near white }
      begin
	{ With small lum in cmap, sat and hue are undifined and can't }
	{ be used in error calculation                                }
	if map_l < 0.01 then error := 3
	else
	{ With small sat in cmap, hue is undifined and can't be used  }
	{ in error calculation                                        }
	if map_s < 0.01 then error := error_l2 + error_s
	else                 error := error_l2 + error_h2 + error_s;
      end
    else                   { normal case }
    { With small lum in cmap, sat and hue are undifined and can't }
    { be used in error calculation                                }
    if map_l < 0.01 then error := 3
    else
    { With small sat in cmap, hue is undifined and can't be used  }
    { in error calculation                                        }
    if map_s < 0.01 then error := 3
    else                 error := error_h2;

    if error < closest_error then
	begin
	  closest_error := error;
	  closest_index := i;
	end;
   end;
  return_closest_color := closest_index;
end;


procedure raster_color ( index : integer );

var
  intensity : real;
  h,s,l     : real;

begin
  with gcb^,gle_gcb^ do
    begin
     if gamut = 1 then { b&w }
       begin
	 { Numbers from Dawn (HP-9000) DGL for 2648 terminal }
	 if realmap then        {MODS SFB 11/84}
	  with color_table_ptr^[index] do
	   intensity := 0.3*red + 0.59*green + 0.11*blue
	 else
	  with big_color_table_def(color_table_ptr^)[index] do
	   intensity := 0.30*dglfloat(red)
		      + 0.59*dglfloat(green)
		      + 0.11*dglfloat(blue);
	 if intensity < 0.06 then info1 := 0
	 else                     info1 := 1;
       end
     else
      if raster_device_rec_ptr(dev_dep_stuff)^.devicetype = 2 then { moonunit }
       with color_table_ptr^[index] do
	info1 := return_closest_color(red,green,blue,addr(init_color_table))
      else                                      { 9836C }
       if (index <= gamut) then
	info1 := index
       else
	if realmap then
	 with color_table_ptr^[index] do
	  info1 := return_closest_color(red,green,blue,color_table_ptr)
	else
	 with big_color_table_def(color_table_ptr^)[index] do
	  info1 := return_closest_color(dglfloat(red),dglfloat(green),
					dglfloat(blue),color_table_ptr);
   gle_index_color ( gle_gcb ); { this function sets color }
 end;
end;

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

var
  color_list : array [1..3] of gle_shortint;
  intensity  : real;

begin
  with gcb^,gle_gcb^ do
    begin
      if dgl_current_color_model = 2 then
	convert_hsl_to_rgb(parm1,parm2,parm3,parm1,parm2,parm3);
      if (index <= gamut) and (color_map_support = 1) then
	begin
	  info1 := index;
	  info2 := index;
	  color_list[1] := trunc(parm1 * 1023 + 0.5);
	  color_list[2] := trunc(parm2 * 1023 + 0.5);
	  color_list[3] := trunc(parm3 * 1023 + 0.5);
	  info_ptr1 := addr(color_list);
	  gle_define_color_map ( gle_gcb );
	end;
      if realmap then
      with color_table_ptr^[index] do           {MODS SFB 11/84}
      begin
	red := parm1;
	green := parm2;
	blue := parm3;
      end
      else
      with big_color_table_def(color_table_ptr^)[index] do
      begin
	red   := dglfix(parm1);
	green := dglfix(parm2);
	blue  := dglfix(parm3);
      end;
      if index = 0 then
       if color_map_support = 1 then
	dgl_background_index := 0
       else
	if gamut = 1 then { b&w }
	begin
	  { Numbers from Dawn (HP-9000) DGL for 2648 terminal }
	  intensity := 0.3*parm1 + 0.59*parm2 + 0.11*parm3;
	  if intensity < 0.06 then
	   dgl_background_index := 0
	  else
	   dgl_background_index := 1;
	end
	else              { moonunit }
	  dgl_background_index :=
	    return_closest_color(parm1,parm2,parm3,addr(init_color_table))
    end;
end;

procedure set_all_color_table ( anyvar list : greal_list ); {MODS SFB 11/84}

var
  color_list : array[0..767] of gle_shortint;
  parm1,
  parm2,
  parm3 : real;
  i,
  adr  : gshortint;

begin
  with gcb^,gle_gcb^ do
    begin
      for i := 0 to color_table_size - 16 do
	begin
	  adr := (i*3)+1; {3.0 BUG SFB 4/29/85:GREAL_LIST INDEXED FROM 1 NOT 0}
	  parm1 := list[adr];
	  parm2 := list[adr+1];
	  parm3 := list[adr+2];
	  if dgl_current_color_model = 2 then
	    convert_hsl_to_rgb(parm1,parm2,parm3,parm1,parm2,parm3);
	  color_list[adr]   := trunc(parm1 * 1023 + 0.5);
	  color_list[adr+1] := trunc(parm2 * 1023 + 0.5);
	  color_list[adr+2] := trunc(parm3 * 1023 + 0.5);
	  begin         {SFB 11/84}
	    if realmap then
	     with color_table_def(color_table_ptr^)[i] do
	     begin
	      red := parm1;
	      green := parm2;
	      blue := parm3;
	     end
	    else
	     with big_color_table_def(color_table_ptr^)[i] do
	     begin
	      red := dglfix(parm1);
	      green := dglfix(parm2);
	      blue := dglfix(parm3);
	     end;
	  end;
	end;

      info1 := 0;
      info2 := color_table_size - 16 {15};
      info_ptr1 := addr(color_list);
      gle_define_color_map ( gle_gcb );
    end;
end;

procedure dummy_on_off ( gcb : graphics_control_block_ptr );

begin
end;

{CHANGED TO DOGRAPHICS_ON_OFF SFB--6/6/85-SEE DGL_INIT_RASTER BELOW}
procedure dographics_on_off ( gcb : graphics_control_block_ptr );

var
  on  : boolean;

begin
 with gcb^ do
   begin
     on := info1 <> 0;
     if ( on and not graphicstate ) or
	( not on and graphicstate ) then
       call (togglegraphicshook);
   end;
end;

procedure dump_graphics ( mask : integer );

{ Purpose:  To dump bit/pixel bit map to standard printer }

label 1;

const
  gbuffersize = 255;

var
  gbuffer : packed array [1..gbuffersize] of char;
  y : integer;
  bytes_wide : integer;


begin
  gbuffer[1] := chr(27); { escape sequence for graphics }
  gbuffer[2] := '*';
  gbuffer[3] := 'b';
  gbuffer[4] := '6';
  gbuffer[5] := '4';
  gbuffer[6] := 'W';

  with gle_gcb^ do
    begin
      bytes_wide := (display_max_x - display_min_x + 8) div 8;
      info_ptr1 := addr(gbuffer[7]);
      info1     := mask;

      for y := display_min_y to display_max_y do
	begin
	  info2 := y;
	  gle_get_raster ( gle_gcb );
	  write(gfiles[4]^,gbuffer:bytes_wide+6);
	  if ioresult <> ord(inoerror) then goto 1;
	end;
    end;
  write(gfiles[4]^,#27'*rB');   { terminate graphics sequence }
1:
end;

procedure raster_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
 ierr := 1;   { no input escape display functions supported }

 call(gcb^.proc_locator_input_esc, opcode, isize, rsize,      {SFB 4/11/85}
      ilist, rlist, ierr); {give locator a chance at the opcode}

end; { input_esc }


{DUMPBITMAP SFB 3/85}
procedure dumpbitmap;  {the global "step" controls whether we print only
 every second pixel (step =2), or every pixel (step =1). step is only
 active if the display has halfwide pixels (at present, lores_bobcat)}

label 1;

type
 gbyte   = 0..255;
 row_def = packed array [0..maxint] of char;
 aptrtype = ^anyptr;

var
 row      : ^row_def;
 gbuffer  : packed array [1..263] of char;
 i,j,
 h,w,fbw,       {added 3/18/88 SFB}
 pos,
 index,
 bit_mask,
 result,
 romptr,
 headerlen,
 planes   : integer;
 halfwide : boolean;
 wstr     : string[10];

function value : shortint;
type
 chptr = ^char;
var
 temp : shortint;
begin
 temp := ord(chptr(romptr)^) * 256;
 value := temp + ord(chptr(romptr+2)^);
end;

begin
 with gle_gcb^,raster_device_rec_ptr(dev_dep_stuff)^ do
  begin
   row := aptrtype(plane1_addr)^;
   planes := gamut + 1;

   if devicetype = 4 then       {gator}
    begin
     fbw := 1024;
     w := 1024;
     h := 768;
     step := 1;                 {force "square pixels" for gator}
    end
   else
    begin                       {standard ID ROM available}
     romptr := control_space + hex('5');
     fbw := value;          {amount to step to get to next scanline. SFB}
     romptr := control_space + hex('d');
     w := value;            {display area width--pixels, from ID ROM}
     romptr := control_space + hex('11');
     h := value;            {display area height--pixels, from ID ROM}
     romptr := control_space + hex('15');
     halfwide := odd(value);
     if not halfwide then       {see if lsb of ROM location $17 is 1}
      step := 1                 {force square pixels on hires bobcat}
     else
      if step = 2 then          {half wide pixels on lores bobcat}
       begin                    {fix for STARS 1650076745/1650076802}
	 w := w div 2;
	 fbw := fbw div 2;      {98542/3 OPDCODE 54 dump was garbaged}
       end;                     {SFB 2/03/89}
    end;
  end; {with}

 write(gfiles[4]^,#27'*rA');    {graphics initiation}
 if ioresult <> 0 then
  goto 1;

 gbuffer[1] := chr(27);         {start creating header}
 gbuffer[2] := '*';
 gbuffer[3] := 'b';

 wstr := '';                    {put number of chars into header}
 strwrite(wstr, 1, i, w div 8:1);
 headerlen := 4 + strlen(wstr);
 for i:=1 to strlen(wstr) do
  gbuffer[i+3] := wstr[i];
 gbuffer[headerlen] := 'W';

 {Note that if ever we mix halfwide with a frame buffer whose fbw is not
  equal the display width (w), this algorithm will need to be replaced. SFB}
 for j:=0 to h-1 do
  begin
   for i:=0 to (w div 8)-1 do
    begin
     result := 0;
    {index := j*w + i*8;}
     index := j*fbw + i*8;
     bit_mask := 256;
     for index := index to index + 7 do
      begin
       bit_mask := bit_mask div 2;
       if ord(row^[index*step]) mod planes <> 0 then
	result := bit_mask + result;
      end;
     gbuffer[i+headerlen+1] := chr(result);
    end;
   write(gfiles[4]^, gbuffer:(w div 8)+headerlen);
   if ioresult <> 0 then
    goto 1;
   if (halfwide) and (step = 1) then    {lores with all pixels dumped}
    write(gfiles[4]^, gbuffer:(w div 8)+headerlen);
   if ioresult <> 0 then
    goto 1;
  end;
 write(gfiles[4]^, #27'*rB');   {graphics termination}
1:
end;    {dumpbitmap}


procedure raster_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                           }

var
  on  : boolean;



begin
 with gle_gcb^,raster_device_rec_ptr(dev_dep_stuff)^  do
   if (opcode = 52) and (devicetype < 4 ) and (devicetype <> 2) then
      begin
	if ierr = 0 then call (dumpgraphicshook);
      end
   else
   if (opcode = 52) and (devicetype = 2) then
      begin
	if ierr = 0 then dump_graphics(-1);
      end
   else
   if (opcode = 52) and (devicetype >= 4) then   {added for gator etc case}
      begin
	if ierr = 0 then        {SFB 3/11/85}
	 begin
	  step := 1;
	  dumpbitmap;
	 end;
      end
   else
   if (opcode = 54) and (devicetype >= 4) then         {SFB 3/11/85}
     begin
      if ierr = 0 then
       begin
	step := 1 + ord(devicetype = 7);
	dumpbitmap;
       end
     end
   else
   if (opcode = 53) and (devicetype = 3) then
      begin
	if ierr = 0 then gle_await_blanking ( gle_gcb );
      end
   else
   if (opcode = 250) {{
		       and
      ((devicetype = 0) or (devicetype = 2))
		     {}  then
      begin                { marmot and aspen and moonunit}
	if ierr = 0 then
	  begin
	    if (rlist[1] > 0.0) and ( rlist[2] > 0.0 ) then
	      begin
		display_res_x := rlist[1];
		display_res_y := rlist[2];
	      end
	    else
	      ierr := 4;
	  end;
      end
   else
   if (opcode = 1050) and (devicetype < 4) then  { graphics on / off }
     begin
       if ierr = 0 then
	 begin
	   info1 := ilist[1];
	   gle_graphics_on_off ( gle_gcb );
	 end;
     end
   else
   if (opcode = 1051) and (devicetype <> 2) and (devicetype < 4) {BUGFIX
								  SFB 3/11/85}
		  then  { alpha on / off }
     begin
       if ierr = 0 then
	 begin
	   on := ilist[1] <> 0;
	   if ( on and not alphastate ) or
	      ( not on and alphastate ) then
	     call(togglealphahook);
	 end;
     end
   else
   if (opcode = 1052) then
     begin
       if ierr = 0 then
	 begin
	   info1 := ilist[1];
	   if (info1 < 0) or (info1 > 3) then info1 := 0;
	   if info1 = 1 then info1 := 2
	   else
	   if info1 = 2 then info1 := 1;
	   gle_define_drawing_mode ( gle_gcb );
	 end;
     end
   else
   if (opcode = 1053) and
      ((devicetype = 3) or (devicetype = 2)) then
      begin
	if ierr = 0 then dump_graphics(ilist[1]);
      end
   else
   if (opcode = 1053) and (devicetype = 4) then         {for GATOR}
      begin
	if ierr = 0 then
	 begin
	  step := 1;
	  dumpbitmap;
	 end;
      end
   else
   if (opcode = 1054) and (devicetype <> 4) then
     begin
       if ierr = 0 then
	 begin
	   info1 := ilist[1];
	   info2 := 0;
	   gle_clear(gle_gcb);
	 end;
     end
   else
   if (opcode = 10050) and
      ((devicetype = 3) or ((devicetype > 4) and (gamut >1)))
    then
     begin
       if (ierr = 3) and (rsize = 3*(gamut+1)) { opcode_ck gave real size err }
       then
	 begin
	   ierr := 0;
	   set_all_color_table(rlist);
	 end;
     end
   else         {MODS SFB 4/11/85}
      ierr := 1;  {locator_output_esc clears this if it processes opcode}

 call(gcb^.proc_locator_output_esc, opcode, isize, rsize,
      ilist, rlist, ierr); {give locator a chance at the opcode}

end; { raster_output_esc }

procedure dgl_raster_init ( control : integer );        {MODS SFB 12/84}

type
  default_poly_table_def = array[1..16] of poly_entry_def;

  control_def = packed record
		  case gshortint of
		    0 : (whole : gshortint);
		    1 : (part  : packed record
				   b15,b14,b13,b12,
				   b11,b10,b9, b8,
				   clr_inhibit,b6,b5,b4,
				   b3,b2,b1,b0 : boolean;
				 end);
		  end;

const
  default_poly_table = default_poly_table_def [
    poly_entry_def [ density :  0.0  , orient :   0.0, edge : true ], { 1 }
    poly_entry_def [ density :  0.125, orient :  90.0, edge : true ], { 2 }
    poly_entry_def [ density :  0.125, orient :   0.0, edge : true ], { 3 }
    poly_entry_def [ density : -0.125, orient :   0.0, edge : true ], { 4 }
    poly_entry_def [ density :  0.125, orient :  45.0, edge : true ], { 5 }
    poly_entry_def [ density :  0.125, orient : -45.0, edge : true ], { 6 }
    poly_entry_def [ density : -0.125, orient :  45.0, edge : true ], { 7 }
    poly_entry_def [ density :  0.25 , orient :  90.0, edge : true ], { 8 }
    poly_entry_def [ density :  0.25 , orient :   0.0, edge : true ], { 9 }
    poly_entry_def [ density : -0.25 , orient :   0.0, edge : true ], { 10 }
    poly_entry_def [ density :  0.25 , orient :  45.0, edge : true ], { 11 }
    poly_entry_def [ density :  0.25 , orient : -45.0, edge : true ], { 12 }
    poly_entry_def [ density : -0.25 , orient :  45.0, edge : true ], { 13 }
    poly_entry_def [ density : -0.5  , orient :   0.0, edge : true ], { 14 }
    poly_entry_def [ density :  1.0  , orient :   0.0, edge : false], { 15 }
    poly_entry_def [ density :  1.0  , orient :   0.0, edge : true ]];{ 16 }

var
  temp_control     : control_def;
  i                : integer;
  temp_color_model : integer;
  c                : real;

begin
  with gle_gcb^ do
   if   (display_name = '9837a ') or (display_name = '98700A') {SFB 6/11/85}
     or (display_name = '98542A') or (display_name = '98543A')
     or (display_name = '98544A') or (display_name = '98545A')
     or (display_name = '98547A') or (display_name = '98548A')      {SFB 2/2/88}
     or (display_name = '98549A') or (display_name = '98550A')      {SFB 2/2/88}
     or (display_name = 'E640  ') or (display_name = 'E1024 ')     {CFB 30JUL91}
     or (display_name = 'E1280 ') or (display_name = 'E640G ')     {CFB 30JUL91}
     or (display_name = 'E1280G') then                             {CFB 30JUL91}
     gle_gcb^.graphics_on_off := dummy_on_off
  else
    if gle_gcb^.display_name <> '98627A' then
      gle_gcb^.graphics_on_off := dographics_on_off; {SFB--6/6/85}

  with gle_gcb^,gcb^,raster_device_rec_ptr(dev_dep_stuff)^ do
    begin
      disp_just := centered;
      clipping_support := true;
      retroactive_polygon_support := false;
      retroactive_color_support := color_map_support = 1;
      number_markers := 19;
      number_dgl_linestyles := 8;
      maximum_polygon_vertices := 32767;

      proc_output_esc  := raster_output_esc;
      proc_input_esc   := raster_input_esc;
      proc_linestyle   := raster_linestyle;
      proc_color       := raster_color;
      proc_color_table := raster_color_table;

      temp_control.whole := control;
      if not temp_control.part.clr_inhibit then
	with gle_gcb^ do
	  begin
	    info1 := -1;                   { clear all planes }
	    info2 := 0;
	    gle_clear ( gle_gcb );
	   end;

      { allocate color table space }

      temp_color_model := dgl_current_color_model;
      dgl_current_color_model := 1; { rgb }

      if gamut>=15 then
       color_table_size := gamut + 16
      else
       color_table_size := 31;
      color_table_ptr := addr(color_table_def_space);

      if (gamut > 1) then
	begin
	   for i := 0 to 15 do
	    with init_color_table[i] do
	      raster_color_table(i,red,green,blue);
	  raster_color_table(16,1,1,1);
	end
      else
	begin
	  raster_color_table(0,0,0,0);
	  for i := 1 to 16 do
	    begin
	      c := ((17-i) / 16);
	      raster_color_table(i,c,c,c);
	    end;
	end;
      for i := 17 to color_table_size {to 31} do
	raster_color_table(i,1,1,1);

      dgl_current_color_model := temp_color_model;

      gle_gcb^.info1 := 1;

      gle_index_color( gle_gcb);

      { allocate polygon table space }

      number_polygon_styles := poly_table_size;
      poly_table_ptr := addr(poly_table_def_space);
      for i := 1 to poly_table_size do
	poly_table_ptr^[i] := default_poly_table[i];

      display_echo_mult := 1;
    end;
end;

end. { dgl_raster }

@


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


56.1
log
@Automatic bump of revision number for PWS version 3.25
@
text
@a0 841
{                                                                           }
{ DGL device dependent init routine                                         }
{                                                                           }
{ Module    = DGL_RASTER                                                    }
{ Programer = BJS                                                           }
{ Date      = 1 - 5-83                                                      }
{                                                                           }
{ Purpose: To provide device dependent initialization for raster devices.   }

{ Rev history                                                               }
{  Created  - 1 - 5-83  BJS                                                 }
{  Modified - 02-17-84  BDS Changed allocations from dynamic to global.     }
{  Modified - 12- 84    SFB Added calls to dglfix/dglfloat                  }
{  Modified - 3 - 85    SFB Added opcodes for dumpgraphics                  }
{  Modified - 4 - 85    SFB Added calls to locator_esc                      }

{     (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                              }

$search 'GLE_LIB',
	'TYPES',
	'DGL_VARS',
	'GEN'$
$modcal$
$include 'OPTIONS.'$  { ******************** COMPILER OPTIONS ****************** }
$linenum 17000$
$ALLOW_PACKED ON$ {JWS 3/31/87}

module DGL_RASTER;

import dgl_types;

export

procedure dgl_raster_init ( control : integer );

implement

import dgl_vars,
       sysdevs,
       asm,
       sysglobals,
       gle_types,
       gle_gen,
       gle_autl,
       gle_ras_out,
       dgl_gen;

type
  init_color_table_def = ARRAY [0..15] of c_def;

const
  init_color_table = init_color_table_def [
c_def [ red :  0, green :  0,  blue :  0 ],  {  0 }
c_def [ red :  1, green :  1,  blue :  1 ],  {  1 }
c_def [ red :  1, green :  0,  blue :  0 ],  {  2 }
c_def [ red :  1, green :  1,  blue :  0 ],  {  3 }
c_def [ red :  0, green :  1,  blue :  0 ],  {  4 }
c_def [ red :  0, green :  1,  blue :  1 ],  {  5 }
c_def [ red :  0, green :  0,  blue :  1 ],  {  6 }
c_def [ red :  1, green :  0,  blue :  1 ],  {  7 }
c_def [ red :  0, green :  0,  blue :  0 ],  {  8 }
c_def[red:0.8              ,green:0.733333333333333,blue:0.2               ], {  9 }
c_def[red:0.2              ,green:0.666666666666667,blue:0.466666666666667 ], { 10 }
c_def[red:0.533333333333333,green:0.4              ,blue:0.666666666666667 ], { 11 }
c_def[red:0.8              ,green:0.266666666666667,blue:0.4               ], { 12 }
c_def[red:1.0              ,green:0.4              ,blue:0.2               ], { 13 }
c_def[red:1.0              ,green:0.466666666666667,blue:0                 ], { 14 }
c_def[red:0.866666666666667,green:0.533333333333333,blue:0.266666666666667 ]];{ 15 }

var
 step : integer;                {SFB 3/11/85}

{procedure hpm_new(var opject:anyptr; numbytes : integer); external;}

procedure raster_linestyle ( index : integer);

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

type
  ls_map_def = packed array [1..13] of gbyte;
const
  ls_map = ls_map_def [0,2,3,4,5,6,1,2,3,4,5,6,1];

begin
  with gle_gcb^ do
    begin
      info1 := ls_map[index];                 { map DGL to GLE def }
      info2 := 1;                             { repeat rate 1% CHANGED FROM 4%
						IN 3.01 SFB 7/8/85 }
      info3 := 0;                             { linestyle mode }
      info4 := raster_patterns[index-1];      { pattern }
      gle_linestyle ( gle_gcb );
    end;


end; { set_line_style }

function return_closest_color ( r,g,b : real;          { target color }
				c_table_ptr : anyptr ) { system color map } : integer;

var
  target_h,
  target_s,
  target_l : real;           { HSL target color values }
  error_h,
  error_h2,                  { hue error distance squared }
  error_l,                   { lightness error distance squared }
  error_s,
  error_l2,
  error_s2 : real;            { saturation error distance squared }
  map_h,
  map_l,
  map_s,                     { Current color map entry in HSL }
  error : real;              { Distance from target to current color map entry }
  closest_error : real;
  i,
  closest_index : integer;   { Best fit color map index }


{ Find closest color from system color map, to match target color.  }
{ The closest color is the color which 'looks' the closest.  This   }
{ algorithm has been derived from a mixture of logic and            }
{ experimentation.  The algorithm calculates for each entry in the  }
{ color map an error factor indicating how far off the color map    }
{ value is from the target color.  It then returns the color map    }
{ index with the least error.                                       }

{ Experimentation has showed that the best looking color is normaly }
{ the color with the least error in hue.  However when the target   }
{ color is near black or white this is not true, and when many color}
{ map entrys have a small hue error the closest hue does not produce}
{ the best color.  The algorithm makes special cases out of the     }
{ above cases and 'weights' the error result to reduce the effects  }
{ of hue.                                                           }

begin
  convert_rgb_to_hsl(r,g,b,target_h,target_s,target_l);
  closest_index := 1;
  closest_error := maxint;                           { worst case error }
  for i := 0 to gle_gcb^.gamut do                    { for each CMAP entry }
   begin
    if not realmap then         {SFB 11/84}
     with big_color_table_ptr_def(c_table_ptr)^[i] do     { force anyptr to known type }
      convert_rgb_to_hsl(dglfloat(red),dglfloat(green),dglfloat(blue),
			 map_h,map_s,map_l)
    else
     with color_table_ptr_def(c_table_ptr)^[i] do     { force anyptr to known type }
      convert_rgb_to_hsl(red,green,blue,map_h,map_s,map_l);

    { Calc errors, note that since Hue is circular it must }
    { be calc as shortest dist of either direction         }

    error_h  := abs(map_h-target_h);
    error_h2 := abs(map_h-1-target_h);
    if error_h2 <= error_h then error_h := error_h2;
    error_h2 := error_h * error_h;
    error_s := abs(map_s-target_s);
    error_l := abs(map_l-target_l);
    error_s2 := error_s * error_s;
    error_l2 := error_l * error_l;

    if target_l < 0.1 then { special case where request is near black }
      begin
	{ With small lum in cmap, sat and hue are undifined and can't }
	{ be used in error calculation                                }
	if map_l < 0.01 then error := error_l
	else
	{ With small sat in cmap, hue is undifined and can't be used  }
	{ in error calculation                                        }
	if map_s < 0.01 then error := error_l + error_s2
	else                 error := error_l + error_h2 + error_s2;
      end
    else
    if target_s < 0.1 then { special casewhere request is near white }
      begin
	{ With small lum in cmap, sat and hue are undifined and can't }
	{ be used in error calculation                                }
	if map_l < 0.01 then error := 3
	else
	{ With small sat in cmap, hue is undifined and can't be used  }
	{ in error calculation                                        }
	if map_s < 0.01 then error := error_l2 + error_s
	else                 error := error_l2 + error_h2 + error_s;
      end
    else                   { normal case }
    { With small lum in cmap, sat and hue are undifined and can't }
    { be used in error calculation                                }
    if map_l < 0.01 then error := 3
    else
    { With small sat in cmap, hue is undifined and can't be used  }
    { in error calculation                                        }
    if map_s < 0.01 then error := 3
    else                 error := error_h2;

    if error < closest_error then
	begin
	  closest_error := error;
	  closest_index := i;
	end;
   end;
  return_closest_color := closest_index;
end;


procedure raster_color ( index : integer );

var
  intensity : real;
  h,s,l     : real;

begin
  with gcb^,gle_gcb^ do
    begin
     if gamut = 1 then { b&w }
       begin
	 { Numbers from Dawn (HP-9000) DGL for 2648 terminal }
	 if realmap then        {MODS SFB 11/84}
	  with color_table_ptr^[index] do
	   intensity := 0.3*red + 0.59*green + 0.11*blue
	 else
	  with big_color_table_def(color_table_ptr^)[index] do
	   intensity := 0.30*dglfloat(red)
		      + 0.59*dglfloat(green)
		      + 0.11*dglfloat(blue);
	 if intensity < 0.06 then info1 := 0
	 else                     info1 := 1;
       end
     else
      if raster_device_rec_ptr(dev_dep_stuff)^.devicetype = 2 then { moonunit }
       with color_table_ptr^[index] do
	info1 := return_closest_color(red,green,blue,addr(init_color_table))
      else                                      { 9836C }
       if (index <= gamut) then
	info1 := index
       else
	if realmap then
	 with color_table_ptr^[index] do
	  info1 := return_closest_color(red,green,blue,color_table_ptr)
	else
	 with big_color_table_def(color_table_ptr^)[index] do
	  info1 := return_closest_color(dglfloat(red),dglfloat(green),
					dglfloat(blue),color_table_ptr);
   gle_index_color ( gle_gcb ); { this function sets color }
 end;
end;

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

var
  color_list : array [1..3] of gle_shortint;
  intensity  : real;

begin
  with gcb^,gle_gcb^ do
    begin
      if dgl_current_color_model = 2 then
	convert_hsl_to_rgb(parm1,parm2,parm3,parm1,parm2,parm3);
      if (index <= gamut) and (color_map_support = 1) then
	begin
	  info1 := index;
	  info2 := index;
	  color_list[1] := trunc(parm1 * 1023 + 0.5);
	  color_list[2] := trunc(parm2 * 1023 + 0.5);
	  color_list[3] := trunc(parm3 * 1023 + 0.5);
	  info_ptr1 := addr(color_list);
	  gle_define_color_map ( gle_gcb );
	end;
      if realmap then
      with color_table_ptr^[index] do           {MODS SFB 11/84}
      begin
	red := parm1;
	green := parm2;
	blue := parm3;
      end
      else
      with big_color_table_def(color_table_ptr^)[index] do
      begin
	red   := dglfix(parm1);
	green := dglfix(parm2);
	blue  := dglfix(parm3);
      end;
      if index = 0 then
       if color_map_support = 1 then
	dgl_background_index := 0
       else
	if gamut = 1 then { b&w }
	begin
	  { Numbers from Dawn (HP-9000) DGL for 2648 terminal }
	  intensity := 0.3*parm1 + 0.59*parm2 + 0.11*parm3;
	  if intensity < 0.06 then
	   dgl_background_index := 0
	  else
	   dgl_background_index := 1;
	end
	else              { moonunit }
	  dgl_background_index :=
	    return_closest_color(parm1,parm2,parm3,addr(init_color_table))
    end;
end;

procedure set_all_color_table ( anyvar list : greal_list ); {MODS SFB 11/84}

var
  color_list : array[0..767] of gle_shortint;
  parm1,
  parm2,
  parm3 : real;
  i,
  adr  : gshortint;

begin
  with gcb^,gle_gcb^ do
    begin
      for i := 0 to color_table_size - 16 do
	begin
	  adr := (i*3)+1; {3.0 BUG SFB 4/29/85:GREAL_LIST INDEXED FROM 1 NOT 0}
	  parm1 := list[adr];
	  parm2 := list[adr+1];
	  parm3 := list[adr+2];
	  if dgl_current_color_model = 2 then
	    convert_hsl_to_rgb(parm1,parm2,parm3,parm1,parm2,parm3);
	  color_list[adr]   := trunc(parm1 * 1023 + 0.5);
	  color_list[adr+1] := trunc(parm2 * 1023 + 0.5);
	  color_list[adr+2] := trunc(parm3 * 1023 + 0.5);
	  begin         {SFB 11/84}
	    if realmap then
	     with color_table_def(color_table_ptr^)[i] do
	     begin
	      red := parm1;
	      green := parm2;
	      blue := parm3;
	     end
	    else
	     with big_color_table_def(color_table_ptr^)[i] do
	     begin
	      red := dglfix(parm1);
	      green := dglfix(parm2);
	      blue := dglfix(parm3);
	     end;
	  end;
	end;

      info1 := 0;
      info2 := color_table_size - 16 {15};
      info_ptr1 := addr(color_list);
      gle_define_color_map ( gle_gcb );
    end;
end;

procedure dummy_on_off ( gcb : graphics_control_block_ptr );

begin
end;

{CHANGED TO DOGRAPHICS_ON_OFF SFB--6/6/85-SEE DGL_INIT_RASTER BELOW}
procedure dographics_on_off ( gcb : graphics_control_block_ptr );

var
  on  : boolean;

begin
 with gcb^ do
   begin
     on := info1 <> 0;
     if ( on and not graphicstate ) or
	( not on and graphicstate ) then
       call (togglegraphicshook);
   end;
end;

procedure dump_graphics ( mask : integer );

{ Purpose:  To dump bit/pixel bit map to standard printer }

label 1;

const
  gbuffersize = 255;

var
  gbuffer : packed array [1..gbuffersize] of char;
  y : integer;
  bytes_wide : integer;


begin
  gbuffer[1] := chr(27); { escape sequence for graphics }
  gbuffer[2] := '*';
  gbuffer[3] := 'b';
  gbuffer[4] := '6';
  gbuffer[5] := '4';
  gbuffer[6] := 'W';

  with gle_gcb^ do
    begin
      bytes_wide := (display_max_x - display_min_x + 8) div 8;
      info_ptr1 := addr(gbuffer[7]);
      info1     := mask;

      for y := display_min_y to display_max_y do
	begin
	  info2 := y;
	  gle_get_raster ( gle_gcb );
	  write(gfiles[4]^,gbuffer:bytes_wide+6);
	  if ioresult <> ord(inoerror) then goto 1;
	end;
    end;
  write(gfiles[4]^,#27'*rB');   { terminate graphics sequence }
1:
end;

procedure raster_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
 ierr := 1;   { no input escape display functions supported }

 call(gcb^.proc_locator_input_esc, opcode, isize, rsize,      {SFB 4/11/85}
      ilist, rlist, ierr); {give locator a chance at the opcode}

end; { input_esc }


{DUMPBITMAP SFB 3/85}
procedure dumpbitmap;  {the global "step" controls whether we print only
 every second pixel (step =2), or every pixel (step =1). step is only
 active if the display has halfwide pixels (at present, lores_bobcat)}

label 1;

type
 gbyte   = 0..255;
 row_def = packed array [0..maxint] of char;
 aptrtype = ^anyptr;

var
 row      : ^row_def;
 gbuffer  : packed array [1..263] of char;
 i,j,
 h,w,fbw,       {added 3/18/88 SFB}
 pos,
 index,
 bit_mask,
 result,
 romptr,
 headerlen,
 planes   : integer;
 halfwide : boolean;
 wstr     : string[10];

function value : shortint;
type
 chptr = ^char;
var
 temp : shortint;
begin
 temp := ord(chptr(romptr)^) * 256;
 value := temp + ord(chptr(romptr+2)^);
end;

begin
 with gle_gcb^,raster_device_rec_ptr(dev_dep_stuff)^ do
  begin
   row := aptrtype(plane1_addr)^;
   planes := gamut + 1;

   if devicetype = 4 then       {gator}
    begin
     fbw := 1024;
     w := 1024;
     h := 768;
     step := 1;                 {force "square pixels" for gator}
    end
   else
    begin                       {standard ID ROM available}
     romptr := control_space + hex('5');
     fbw := value;          {amount to step to get to next scanline. SFB}
     romptr := control_space + hex('d');
     w := value;            {display area width--pixels, from ID ROM}
     romptr := control_space + hex('11');
     h := value;            {display area height--pixels, from ID ROM}
     romptr := control_space + hex('15');
     halfwide := odd(value);
     if not halfwide then       {see if lsb of ROM location $17 is 1}
      step := 1                 {force square pixels on hires bobcat}
     else
      if step = 2 then          {half wide pixels on lores bobcat}
       begin                    {fix for STARS 1650076745/1650076802}
	 w := w div 2;
	 fbw := fbw div 2;      {98542/3 OPDCODE 54 dump was garbaged}
       end;                     {SFB 2/03/89}
    end;
  end; {with}

 write(gfiles[4]^,#27'*rA');    {graphics initiation}
 if ioresult <> 0 then
  goto 1;

 gbuffer[1] := chr(27);         {start creating header}
 gbuffer[2] := '*';
 gbuffer[3] := 'b';

 wstr := '';                    {put number of chars into header}
 strwrite(wstr, 1, i, w div 8:1);
 headerlen := 4 + strlen(wstr);
 for i:=1 to strlen(wstr) do
  gbuffer[i+3] := wstr[i];
 gbuffer[headerlen] := 'W';

 {Note that if ever we mix halfwide with a frame buffer whose fbw is not
  equal the display width (w), this algorithm will need to be replaced. SFB}
 for j:=0 to h-1 do
  begin
   for i:=0 to (w div 8)-1 do
    begin
     result := 0;
    {index := j*w + i*8;}
     index := j*fbw + i*8;
     bit_mask := 256;
     for index := index to index + 7 do
      begin
       bit_mask := bit_mask div 2;
       if ord(row^[index*step]) mod planes <> 0 then
	result := bit_mask + result;
      end;
     gbuffer[i+headerlen+1] := chr(result);
    end;
   write(gfiles[4]^, gbuffer:(w div 8)+headerlen);
   if ioresult <> 0 then
    goto 1;
   if (halfwide) and (step = 1) then    {lores with all pixels dumped}
    write(gfiles[4]^, gbuffer:(w div 8)+headerlen);
   if ioresult <> 0 then
    goto 1;
  end;
 write(gfiles[4]^, #27'*rB');   {graphics termination}
1:
end;    {dumpbitmap}


procedure raster_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                           }

var
  on  : boolean;



begin
 with gle_gcb^,raster_device_rec_ptr(dev_dep_stuff)^  do
   if (opcode = 52) and (devicetype < 4 ) and (devicetype <> 2) then
      begin
	if ierr = 0 then call (dumpgraphicshook);
      end
   else
   if (opcode = 52) and (devicetype = 2) then
      begin
	if ierr = 0 then dump_graphics(-1);
      end
   else
   if (opcode = 52) and (devicetype >= 4) then   {added for gator etc case}
      begin
	if ierr = 0 then        {SFB 3/11/85}
	 begin
	  step := 1;
	  dumpbitmap;
	 end;
      end
   else
   if (opcode = 54) and (devicetype >= 4) then         {SFB 3/11/85}
     begin
      if ierr = 0 then
       begin
	step := 1 + ord(devicetype = 7);
	dumpbitmap;
       end
     end
   else
   if (opcode = 53) and (devicetype = 3) then
      begin
	if ierr = 0 then gle_await_blanking ( gle_gcb );
      end
   else
   if (opcode = 250) {{
		       and
      ((devicetype = 0) or (devicetype = 2))
		     {}  then
      begin                { marmot and aspen and moonunit}
	if ierr = 0 then
	  begin
	    if (rlist[1] > 0.0) and ( rlist[2] > 0.0 ) then
	      begin
		display_res_x := rlist[1];
		display_res_y := rlist[2];
	      end
	    else
	      ierr := 4;
	  end;
      end
   else
   if (opcode = 1050) and (devicetype < 4) then  { graphics on / off }
     begin
       if ierr = 0 then
	 begin
	   info1 := ilist[1];
	   gle_graphics_on_off ( gle_gcb );
	 end;
     end
   else
   if (opcode = 1051) and (devicetype <> 2) and (devicetype < 4) {BUGFIX
								  SFB 3/11/85}
		  then  { alpha on / off }
     begin
       if ierr = 0 then
	 begin
	   on := ilist[1] <> 0;
	   if ( on and not alphastate ) or
	      ( not on and alphastate ) then
	     call(togglealphahook);
	 end;
     end
   else
   if (opcode = 1052) then
     begin
       if ierr = 0 then
	 begin
	   info1 := ilist[1];
	   if (info1 < 0) or (info1 > 3) then info1 := 0;
	   if info1 = 1 then info1 := 2
	   else
	   if info1 = 2 then info1 := 1;
	   gle_define_drawing_mode ( gle_gcb );
	 end;
     end
   else
   if (opcode = 1053) and
      ((devicetype = 3) or (devicetype = 2)) then
      begin
	if ierr = 0 then dump_graphics(ilist[1]);
      end
   else
   if (opcode = 1053) and (devicetype = 4) then         {for GATOR}
      begin
	if ierr = 0 then
	 begin
	  step := 1;
	  dumpbitmap;
	 end;
      end
   else
   if (opcode = 1054) and (devicetype <> 4) then
     begin
       if ierr = 0 then
	 begin
	   info1 := ilist[1];
	   info2 := 0;
	   gle_clear(gle_gcb);
	 end;
     end
   else
   if (opcode = 10050) and
      ((devicetype = 3) or ((devicetype > 4) and (gamut >1)))
    then
     begin
       if (ierr = 3) and (rsize = 3*(gamut+1)) { opcode_ck gave real size err }
       then
	 begin
	   ierr := 0;
	   set_all_color_table(rlist);
	 end;
     end
   else         {MODS SFB 4/11/85}
      ierr := 1;  {locator_output_esc clears this if it processes opcode}

 call(gcb^.proc_locator_output_esc, opcode, isize, rsize,
      ilist, rlist, ierr); {give locator a chance at the opcode}

end; { raster_output_esc }

procedure dgl_raster_init ( control : integer );        {MODS SFB 12/84}

type
  default_poly_table_def = array[1..16] of poly_entry_def;

  control_def = packed record
		  case gshortint of
		    0 : (whole : gshortint);
		    1 : (part  : packed record
				   b15,b14,b13,b12,
				   b11,b10,b9, b8,
				   clr_inhibit,b6,b5,b4,
				   b3,b2,b1,b0 : boolean;
				 end);
		  end;

const
  default_poly_table = default_poly_table_def [
    poly_entry_def [ density :  0.0  , orient :   0.0, edge : true ], { 1 }
    poly_entry_def [ density :  0.125, orient :  90.0, edge : true ], { 2 }
    poly_entry_def [ density :  0.125, orient :   0.0, edge : true ], { 3 }
    poly_entry_def [ density : -0.125, orient :   0.0, edge : true ], { 4 }
    poly_entry_def [ density :  0.125, orient :  45.0, edge : true ], { 5 }
    poly_entry_def [ density :  0.125, orient : -45.0, edge : true ], { 6 }
    poly_entry_def [ density : -0.125, orient :  45.0, edge : true ], { 7 }
    poly_entry_def [ density :  0.25 , orient :  90.0, edge : true ], { 8 }
    poly_entry_def [ density :  0.25 , orient :   0.0, edge : true ], { 9 }
    poly_entry_def [ density : -0.25 , orient :   0.0, edge : true ], { 10 }
    poly_entry_def [ density :  0.25 , orient :  45.0, edge : true ], { 11 }
    poly_entry_def [ density :  0.25 , orient : -45.0, edge : true ], { 12 }
    poly_entry_def [ density : -0.25 , orient :  45.0, edge : true ], { 13 }
    poly_entry_def [ density : -0.5  , orient :   0.0, edge : true ], { 14 }
    poly_entry_def [ density :  1.0  , orient :   0.0, edge : false], { 15 }
    poly_entry_def [ density :  1.0  , orient :   0.0, edge : true ]];{ 16 }

var
  temp_control     : control_def;
  i                : integer;
  temp_color_model : integer;
  c                : real;

begin
  with gle_gcb^ do
   if   (display_name = '9837a ') or (display_name = '98700A') {SFB 6/11/85}
     or (display_name = '98542A') or (display_name = '98543A')
     or (display_name = '98544A') or (display_name = '98545A')
     or (display_name = '98547A') or (display_name = '98548A')      {SFB 2/2/88}
     or (display_name = '98549A') or (display_name = '98550A')      {SFB 2/2/88}
     or (display_name = 'E640  ') or (display_name = 'E1024 ')     {CFB 30JUL91}
     or (display_name = 'E1280 ') or (display_name = 'E640G ')     {CFB 30JUL91}
     or (display_name = 'E1280G') then                             {CFB 30JUL91}
     gle_gcb^.graphics_on_off := dummy_on_off
  else
    if gle_gcb^.display_name <> '98627A' then
      gle_gcb^.graphics_on_off := dographics_on_off; {SFB--6/6/85}

  with gle_gcb^,gcb^,raster_device_rec_ptr(dev_dep_stuff)^ do
    begin
      disp_just := centered;
      clipping_support := true;
      retroactive_polygon_support := false;
      retroactive_color_support := color_map_support = 1;
      number_markers := 19;
      number_dgl_linestyles := 8;
      maximum_polygon_vertices := 32767;

      proc_output_esc  := raster_output_esc;
      proc_input_esc   := raster_input_esc;
      proc_linestyle   := raster_linestyle;
      proc_color       := raster_color;
      proc_color_table := raster_color_table;

      temp_control.whole := control;
      if not temp_control.part.clr_inhibit then
	with gle_gcb^ do
	  begin
	    info1 := -1;                   { clear all planes }
	    info2 := 0;
	    gle_clear ( gle_gcb );
	   end;

      { allocate color table space }

      temp_color_model := dgl_current_color_model;
      dgl_current_color_model := 1; { rgb }

      if gamut>=15 then
       color_table_size := gamut + 16
      else
       color_table_size := 31;
      color_table_ptr := addr(color_table_def_space);

      if (gamut > 1) then
	begin
	   for i := 0 to 15 do
	    with init_color_table[i] do
	      raster_color_table(i,red,green,blue);
	  raster_color_table(16,1,1,1);
	end
      else
	begin
	  raster_color_table(0,0,0,0);
	  for i := 1 to 16 do
	    begin
	      c := ((17-i) / 16);
	      raster_color_table(i,c,c,c);
	    end;
	end;
      for i := 17 to color_table_size {to 31} do
	raster_color_table(i,1,1,1);

      dgl_current_color_model := temp_color_model;

      gle_gcb^.info1 := 1;

      gle_index_color( gle_gcb);

      { allocate polygon table space }

      number_polygon_styles := poly_table_size;
      poly_table_ptr := addr(poly_table_def_space);
      for i := 1 to poly_table_size do
	poly_table_ptr^[i] := default_poly_table[i];

      display_echo_mult := 1;
    end;
end;

end. { dgl_raster }

@


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
@d35 1
a35 1
$search 'GLE_LIB.',
d820 1
a820 1
      for i := 17 to color_table_size {to 31} do 
@


55.1
log
@Automatic bump of revision number for PWS version 3.25A
@
text
@d35 1
a35 1
$search 'GLE_LIB',
d40 1
a40 1
$include 'OPTIONS'$  { ******************** COMPILER OPTIONS ****************** }
d760 3
a762 1
     or (display_name = 'VGA   ') or (display_name = 'MEDIUM') then {CFB 8JUN91}
d820 1
a820 1
      for i := 17 to color_table_size {to 31} do
@


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
@d818 1
a818 1
      for i := 17 to color_table_size {to 31} do 
@


54.2
log
@Added support for WOODCUT graphics hardware - CFB
@
text
@d35 1
a35 1
$search 'GLE_LIB.',
d40 1
a40 1
$include 'OPTIONS.'$  { ******************** COMPILER OPTIONS ****************** }
@


54.1
log
@Automatic bump of revision number for PWS version 3.24
@
text
@d35 1
a35 1
$search 'GLE_LIB',
d40 1
a40 1
$include 'OPTIONS'$  { ******************** COMPILER OPTIONS ****************** }
d286 1
a286 1
	 end;
d288 6
a293 6
       with color_table_ptr^[index] do           {MODS SFB 11/84}
	begin
	 red := parm1;
	 green := parm2;
	 blue := parm3;
	end
d295 6
a300 6
       with big_color_table_def(color_table_ptr^)[index] do
	begin
	 red   := dglfix(parm1);
	 green := dglfix(parm2);
	 blue  := dglfix(parm3);
	end;
d306 1
a306 1
	 begin
d313 1
a313 1
	 end
d759 3
a761 2
     or (display_name = '98549A') or (display_name = '98550A') then {SFB 2/2/88}
    gle_gcb^.graphics_on_off := dummy_on_off
d763 2
a764 2
  if gle_gcb^.display_name <> '98627A' then
    gle_gcb^.graphics_on_off := dographics_on_off; {SFB--6/6/85}
d818 1
a818 1
      for i := 17 to color_table_size {to 31} do
a819 1

@


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.2
log
@Fixed output_esc(54,... for 98542/542 (half-wide dump). Was 
getting garbaged. STARS #1650076745/1650076802.
SFB
@
text
@@


35.1
log
@Automatic bump of revision number for PWS version 3.22
@
text
@d514 4
a517 1
       w := w div 2;
d536 2
@


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
@d466 1
a466 1
 h,w,
d495 1
d502 2
d538 2
a539 1
     index := j*w + i*8;
d611 4
a614 2
   if (opcode = 250) and
      ((devicetype = 0) or (devicetype = 2)) then
d753 2
a754 1
     or (display_name = '98547A') or (display_name = '98549A') then
@


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
@d42 1
@


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.1
log
@Automatic bump of revision number for PWS version 3.2k
@
text
@@


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


5.1
log
@Automatic bump of revision number for PWS version 3.2j
@
text
@d285 1
a285 1
	end;
d745 2
a746 1
     or (display_name = '98544A') or (display_name = '98545A') then
a803 1

@


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
@@
