{ @(#)  BASIC 5.01  DG_COL  3.1  09/30/87  18:52:07 }


$end$
$stackcheck off$
$iocheck off$
$range oFF$
$ovflcheck off$
$DEBUG OFF$
$LIST  OFF$

module gdump_color;

(* GDUMP COLOR UTILITY   Rev. A  11/25/87  *)
(* by MARY SUE ROWAN                       *)
$  copyright 'Hewlett-Packard Company, 1987'$


import
  global,grglobal;

export
  type intvalptr= ^intvaltype;
  procedure gdump_colored(var from_ds,
                          to_ds : realvaltype;
                          dim_len1:dimptr;
                          rotate : strngvlptr; 
                          resolution : intvalptr;
                          dim_len2:dimptr;
                          backgrd : strngvlptr;
                          dim_len3:dimptr;
                          algorithm: strngvlptr);

implement

import
   globvars,prtentry,stackutil,utilities;

   
procedure gcbinit (gcb : anyptr); external;
procedure gon     (gcb : anyptr); external;
procedure gdump   (gcb : anyptr); external;
procedure gdump_red (gcb : anyptr); external;
procedure gdump_red_c (gcb : anyptr); external;
procedure gdump_c (gcb : anyptr); external;
procedure gdump_ed(gcb : anyptr); external;
procedure gdump_red_ed (gcb : anyptr); external;
procedure init_err (xval: integer;gcb : anyptr); external;
procedure gdump_red_edc(cmap: anyptr;gcb:anyptr); external;
procedure gdump_edc(cmap: anyptr;gcb:anyptr); external;
  

procedure gdump_colored(var from_ds,
                        to_ds : realvaltype;
                        dim_len1:dimptr;
                        rotate : strngvlptr; 
                        resolution : intvalptr;
                        dim_len2:dimptr;
                        backgrd : strngvlptr;
                        dim_len3:dimptr;
                        algorithm: strngvlptr);


const
  maxbigbufstr = 263; { 1024 pixels x 2 dots/pixel + esc code seq }
  biggest_xval = 1024;
  planeoffset = 266;  { maxbigbufstr + 2 length + 1 alignment }
  rowoffset = 798;  { 3 * planeoffset }
  err_rowoffset = 2052;  { (2 * biggest_xval) + 4 for the 0th and
                            nth elements }

type
  gcbptr = ^gcbtype;
  bigbufstrtype = packed record     { for the color routines }
                    len : word;
                    c   : packed array [1..maxbigbufstr] of char;
                  end;
  dblbufstrtype = packed record     { for the mono routines }
                    len : word;
                    c   : packed array [1..(2*maxbigbufstr)] of char;
                  end;
    

const 
  dpat1 = 15; {dot patterns for 2x2 dither cell, where 15 = tt }
  dpat2 =  7; {                                             tt }
  dpat3 =  9; { and 7 = ft  and 9 = tf   and 8 = tf and 0 = ff }
  dpat4 =  8; {         tt          ft           ff         ff }
  dpat5 =  0; 

var
  dump_dev_info : io_entry_info;
  devinfo       : devstufftype;
  i             : word;
  tempgcb       : gcbtype;
  temp_dump_sc  : vartype;
  from_var      : vartype;
  to_var        : vartype;
  num_lines     : integer;

  { VARS PECULIAR TO ROTATION AND RESOLUTION }
  rotate_it     : boolean;

  { VARS FOR COLOR }
  sqtcmap       : packed array [1..125,1..3] of byte; {dpat;}
  xmap          : packed array [0..255] of byte; {1..125;}
  pixrow        : array[1..2,1..3] of bigbufstrtype;
  bufptr        : ^bufstringtype;
  dotrow,plane,factor   : byte;
  prtbackgrd    : boolean;
  
  { VARS FOR MONO  }
  dgbuff        : dblbufstrtype;
  
  { VARS FOR ERROR DIFFUSION }
  delta         : byte;
  dither_it     : boolean;
  accum_err_one,
  accum_err_two,
  temp_err      : packed array[1..3,0..(biggest_xval+1)] of word;
  
  
procedure cmapxform;
{ Look at syscmap and make assignments into xmap, an array that
  indexes into my squirt driver color map.  For the case of a 
  color map that has > 125 entries, this mapping will be many to
  one (system color map to squirt color map).  This assumes a
  static dither pattern. USED ONLY FOR THE DITHER ALGORITHM }
  var i,j,k,ind, maxcmapentries: byte;
      rtemp, gtemp, btemp: byte; {dpat;}
      found: boolean;
      rval, gval, bval : byte;
          
  begin
    
  { set up squirt sqtcmap }
  ind := 1;
  for i:= 1 to 5 do
    for j:= 1 to 5 do
      for k:= 1 to 5 do
        begin
        case i of
          1:sqtcmap[ind,1]:=dpat1;
          2:sqtcmap[ind,1]:=dpat2;
          3:sqtcmap[ind,1]:=dpat3;
          4:sqtcmap[ind,1]:=dpat4;
          5:sqtcmap[ind,1]:=dpat5
          end;
        case j of
          1:sqtcmap[ind,2]:=dpat1;
          2:sqtcmap[ind,2]:=dpat2;
          3:sqtcmap[ind,2]:=dpat3;
          4:sqtcmap[ind,2]:=dpat4;
          5:sqtcmap[ind,2]:=dpat5
          end;
        case k of
          1:sqtcmap[ind,3]:=dpat1;
          2:sqtcmap[ind,3]:=dpat2;
          3:sqtcmap[ind,3]:=dpat3;
          4:sqtcmap[ind,3]:=dpat4;
          5:sqtcmap[ind,3]:=dpat5
          end;
        ind := ind + 1;
        end; {for k}
   
  { initialize xmap to be all bits on; or white }
  for i := 0 to 255 do
    xmap[i] := 1;
   
  { find syscmap }
  with gs_ptr(rom_stolen[graph_bin])^ ,tempgcb do 
    begin
    if grdevicetype = crtgbx then maxcmapentries := 255 { all xmap can take } 
    else if grdevicetype = crttpc then maxcmapentries := 64
         else maxcmapentries := 16;   { irrelevant for crt27a }
    if grdevicetype >= crt36c then
      for i := 0 to MAXCMAPENTRIES  do
        begin
        { divide color intensities into ranges of 12%, 37%, 62%, 87%, 100%
          but blue will be ...
          and don't bother to convert DAC values }
        rval := syscmap[i].red;
        if rval <= 30 then rtemp := dpat5
        else if rval <= 94 then rtemp := dpat4
             else if rval <= 158 then rtemp := dpat3
                  else if rval <= 222 then rtemp := dpat2
                       else rtemp := dpat1;
        gval := syscmap[i].grn;
        if gval <= 30 then gtemp := dpat5
        else if gval <= 94 then gtemp := dpat4
             else if gval <= 158 then gtemp := dpat3
                  else if gval <= 222 then gtemp := dpat2
                       else gtemp := dpat1;
        bval := syscmap[i].blu;
        if bval <= 30 then btemp := dpat5
        else if bval <= 94  then btemp := dpat4
             else if bval <= 158 then btemp := dpat3
                  else if bval <= 222 then btemp := dpat2
                       else btemp := dpat1;
        
        j:= 1;
        found := false;
        repeat
          if sqtcmap[j,1]=rtemp
          then if sqtcmap[j,2]=gtemp
               then if sqtcmap[j,3]=btemp
                    then found := true
                    else j:= j+1
               else j:= j+1
          else j:= j+1;
        until found;
        xmap[i] := j;
        end { for }
     else if grdevicetype = crt27a then 
            begin
            xmap[0] := 125;   { black }
            xmap[1] := 25;    { red }
            xmap[2] := 105;   { green }
            xmap[3] := 5;     { yellow }
            xmap[4] := 121;   { blue }
            xmap[5] := 21;    { magenta }
            xmap[6] := 101;   { cyan }
            xmap[7] := 1;     { white }
            end;
            
    
      if not prtbackgrd then xmap[0] := 1;
    
    end; { with }
  end; { cmapxform }

  
  procedure start_dotrow(n: word);
  { my version of int_char plus; for color dumps only }
  var
    chars   : array[1..3] of char;
    indx,i,plane,dotrow  : word;
    digit,m : word;
    
  begin
    indx:=0;
    m:=n;
    while n<>0 do
      begin
        digit:=n mod 10;
        n:=n div 10;
        indx:=indx+1;
        chars[indx]:=chr(digit+48);
      end;
    with gs_ptr(rom_stolen[graph_bin])^,tempgcb do
    begin
      anyptr(addr2):=addr(pixrow[1,1].c[1]); 
              { the asm routine adds the offset for the initial bytes }
      if dither_it 
      then begin
           anyptr(addr3):=addr(sqtcmap[1,1]); 
           anyptr(addr4):=addr(xmap[0]); 
           end
      else begin
           anyptr(addr3) := addr(accum_err_one[1,1]);
           anyptr(addr4) := addr(accum_err_two[1,1]);
           end;
      for dotrow := 1 to 2 do
        for plane := 1 to 3 do
          begin
          pixrow[dotrow,plane].c[1] :=  chr(27);
          pixrow[dotrow,plane].c[2] :=  '*';
          pixrow[dotrow,plane].c[3] :=  'b';
          for i:=1 to indx do pixrow[dotrow,plane].c[4+indx-i]:=chars[i];
          if plane=3 then pixrow[dotrow,plane].c[4+indx]:='W'
            else pixrow[dotrow,plane].c[4+indx] := 'V';
          rgltemp1:= indx+4;    { where to start in pixrow +1 this takes place}
          pixrow[dotrow,plane].len:=m+indx+4;
          pixrow[dotrow,plane].c[m+indx+4]:=' ';
          end;
    end; { with }
  end;
  
  procedure set_row_len(n: word);
  
  var
    chars   : array[1..4] of char;
    indx,i  : word;
    digit,m : word;
    
  begin
    indx:=0;
    while n<>0 do
      begin
        digit:=n mod 10;
        n:=n div 10;
        indx:=indx+1;
        chars[indx]:=chr(digit+48);
      end;
    with gs_ptr(rom_stolen[graph_bin])^,gbuff,tempgcb do
    begin
      for i:=1 to indx do c[4+indx-i]:=chars[i];
      c[4+indx]:='S';
      len:=indx+4;
    end;
  end;
  
  procedure int_char(n: word);
  { monochrome case only }
  
  var
    chars   : array[1..3] of char;
    indx,i  : word;
    digit,m : word;
    
  begin
    indx:=0;
    m:=n;
    while n<>0 do
      begin
        digit:=n mod 10;
        n:=n div 10;
        indx:=indx+1;
        chars[indx]:=chr(digit+48);
      end;
    with gs_ptr(rom_stolen[graph_bin])^,dgbuff,tempgcb do
    begin
      c[1] := chr(27);
      c[2] := '*';
      c[3] := 'b';
      for i:=1 to indx do c[4+indx-i]:=chars[i];
      c[4+indx]:='W';
      anyptr(addr1):=addr(c[5+indx]);
      if dither_it then len:=2*(m+indx+4) {two rows of info per buff}
      else len:=m+indx+4; { one row for errdif }
      c[len]:=' ';
      rgltemp1:=indx+4;  { number chars in buffer }
    end;
  end;

function my_match_str (as : string80; bstr: strngvlptr) : boolean;
   label 1;
   var
     i  : 0..255;
   begin
     my_match_str := false;
     if bstr^.len <> strlen(as) then 
       goto 1
     else for i:= 1 to strlen(as) do
       if bstr^.c[i] <> as[i] then goto 1;
     my_match_str := true;
1: end;


begin  { gdump_colored }
  if gs_ptr(rom_locations[graph_bin])=nil then
    begin
      err_bin_num := graph_bin;
      escape(errromnotfound+err_range);
    end;
  with gs_ptr(rom_stolen[graph_bin])^ do 
  begin
    temp_dump_sc := dump_dev.dump_sc;
    
    {TO device first}
    to_var.typ := realscalar;
    to_var.val.re := to_ds;
    decode_ds(addr(to_var),devinfo);
    if not sc_table[devinfo.selectcode].claimed then
      escape(ioerr_no_interface+err_range);
    if devinfo.selectcode=1 then escape(ioerr_illegal_operation+err_range);
    with dump_dev.dump_sc do
      begin
        typ := intscalar;
        val.int := devinfo.selectcode;
      end;
    
    {FROM device next}
    from_var.typ := realscalar;
    from_var.val.re := from_ds;  
    decode_ds(addr(from_var),devinfo);
    with devinfo do
    if (selectcode=1) or ((selectcode=3) and (not pltr_info[3].valid))
      then selectcode:=internal_sc;
    if devinfo.selectcode=internal_sc
      then
        with pltr_info[internal_sc] do
        begin
          if not valid then escape(no_graphics_ram+err_range);
          if is_init
            then from_sc:=internal_sc
            else escape(err_dev_uninit+err_range);
        end
      else
        with pltr_info[devinfo.selectcode] do
        begin
          if valid
            then
              begin
                if is_init
                  then from_sc:=devinfo.selectcode
                  else escape(err_dev_uninit+err_range);
              end
            else
              begin
                if gr_out_dev_info.idtable_used then escape(err_dev_uninit+err_range);
                if gr_out_dev_info.device_addr.selectcode<>devinfo.selectcode
                  then escape(err_dev_uninit+err_range);
                if gr_out_dev_info.device_addr.devtype<>devinfo.devtype 
                  then escape(err_dev_uninit+err_range);
                if devinfo.devtype<>sc then
                  begin
                    i:=0;
                    repeat
                      i:=i+1;
                      if gr_out_dev_info.device_addr.primsec[i]<>devinfo.primsec[i]
                        then escape(err_dev_uninit+err_range);
                    until gr_out_dev_info.device_addr.primsec[i]=255;
                  end;
                escape(no_dev_support_nop);
              end;
        end;



  { DECODE THE ROTATED PARAMETER; BE LIKE A BASIC KEYWORD AND
    PERMIT ANY CASE BUT NOT MIXED CASE  }
      
  if rotate = nil then rotate_it := false
  else
    if my_match_str('rotate',rotate)
      then rotate_it := true
      else if my_match_str('ROTATE',rotate)
           then rotate_it := true
           else if my_match_str('normal',rotate)
                then rotate_it := false
                else if my_match_str('NORMAL',rotate)
                     then rotate_it := false
                      else escape(errimpv);
 
  { DECODE THE RESOLUTION PARAMETER 
    IF RESOLUTION = nil THEN USE DEFAULT VALUE (180) }
        
  if resolution = nil then resolution^ := 180
  else if resolution^ > 90 then resolution^ := 180
       else resolution^ := 90;
          
  { DECODE BACKGROUND PARAMETER }
  if backgrd = nil then prtbackgrd := true
  else if my_match_str('on',backgrd)
      then prtbackgrd := true
      else if my_match_str('ON',backgrd)
           then prtbackgrd := true
           else if my_match_str('off',backgrd)
                then prtbackgrd := false
                else if my_match_str('OFF',backgrd)
                     then prtbackgrd := false
                      else escape(errimpv);
        
  { DECODE ALGORITHM PARAMETER }
  if algorithm = nil then dither_it := true
  else if my_match_str('dither',algorithm)
      then dither_it := true
      else if my_match_str('DITHER',algorithm)
           then dither_it := true
           else if my_match_str('errdif',algorithm)
                then dither_it := false
                else if my_match_str('ERRDIF',algorithm)
                     then dither_it := false
                      else escape(errimpv);
     
     with tempgcb,gbuff,pltr_info[from_sc] do
       try
         if (from_sc=current_sc) and gcursor_on then call(dd_cursor);
         pushvar(to_var);
         dev_io_init(sp,dump_dev_info);
         sp:=addr(sp^,varsize);
         grdevicetype:=grdevtype;
         monitortype:=montype;
         { replace call to get_dev_addr(from_sc,deviceaddress) with next 3 lines }
         if from_sc>7
           then deviceaddress:=from_sc*hex('10000')+hex('600000')
           else deviceaddress:=from_sc*hex('10000')+hex('500000');
         gcbinit(addr(tempgcb));
         if crt_on and (grdevicetype<=crt36a) then gon(addr(tempgcb));
           
        
        { ADD COLOR MAP TRANSFORMATION HERE--DITHER CASE ONLY }
            
        if dither_it and (cmapped or (grdevicetype = crt27a)) then cmapxform;
 
        { END RASTER GRAPHICS SO CAN RESET PRINTER ATTRIBUTES }
        { BUT SEND NULLS FIRST TO FOOL PRINTER AND ENSURE THAT
          NEXT ESC SEQ IS UNDERSTOOD }
        
        len := 256;
        for i := 1 to 256 do
          c[i] := chr(0);
        ioentry_output(dump_dev_info,gbuff,false);
        
        c[1]:= chr(27);
        c[2] := '*';
        c[3]:='r';
        c[4]:='B';
        len:=4;
        ioentry_output(dump_dev_info,gbuff,false);
        
        { SET RESOLUTION }
        c[2]:='*';
        c[3]:='t';
        if resolution^ = 90 
        then begin
             len:=6;
             c[4]:='9';
             c[5]:='0';
             c[6]:='R';
             end
        else if resolution^ = 180
             then begin
                  len:=7;
                  c[4]:='1';
                  c[5]:='8';
                  c[6]:='0';
                  c[7]:='R';
                  end;
        ioentry_output(dump_dev_info,gbuff,false);
              
        { SET MODE }
        len:=5;
        c[3]:='b';
        c[4]:='0';
        c[5]:='M';
        ioentry_output(dump_dev_info,gbuff,false);
        
        { SET DOTROW LENGTH  }
        c[3]:='r';
        if dither_it 
        then if rotate_it then i := n_glines * 2
             else i := (hard_xmax +1) * 2
        else if rotate_it then i := n_glines
             else i := hard_xmax + 1;  
        set_row_len(i);
        ioentry_output(dump_dev_info,gbuff,false);
        
        { SET FOR THREE PLANES (COLOR) OR ONE PLANE (MONO)}
        len:=5;
        c[3]:='r';
        if cmapped or (grdevicetype = crt27a) 
        then c[4]:='3' else c[4] := '1';
        c[5]:='U';
        ioentry_output(dump_dev_info,gbuff,false);
        
        { TURN ON RASTER GRAPHICS }
        len:=5;
        c[3]:='r';
        c[4]:='0';
        c[5]:='A';
        ioentry_output(dump_dev_info,gbuff,false);
        
        tempgcb.graph_mask := write_mask;   {for gdump call}
        
        { GET CONSTANTS INTO THE GCB }
        rgltemp2 := rowoffset;
        rgltemp3 := planeoffset;
        if not (dither_it) 
        then begin 
             if prtbackgrd then rgltemp5 := 1 
             else rgltemp5 := 0;
             rgltemp4 := err_rowoffset;
             end;
        
        
        { DUMP IT!}
        if dither_it
        then begin
             if rotate_it 
             then 
               begin
               i:=n_glines div 4;
               if (n_glines mod 4)<>0 then i:=i+1;
               if not odd(tempgcb.non_square) { SQUARE PIX } 
                 then factor := 1        
                 else factor := 2;   { non-square pix }
               if (not cmapped) and  (grdevicetype <> crt27a) { monochrome }
               then 
                 begin
                 int_char(i);
                 for i:=0 to hard_xmax do
                   begin
                   index:=i * factor;
                   gdump(addr(tempgcb));
                   bufptr := addr(dgbuff);
                   ioentry_output(dump_dev_info,bufptr^,false);
                   end
                 end
               else { color device }
                 begin
                 start_dotrow(i);
                 for i:=0 to hard_xmax do
                   begin
                   index := i * factor;
                   gdump_c(addr(tempgcb));
                   for dotrow := 1 to 2 do
                     for plane := 1 to 3 do
                       begin
                       bufptr := addr(pixrow[dotrow,plane]);
                       ioentry_output(dump_dev_info,bufptr^,false);
                       end;
                   end;
                 end; { if grdevicetype }
               end{ if rotated dump }
             else    { not rotated }
               begin
                 i:=(hard_xmax+1) div 4;
                 if ((hard_xmax+1) mod 4)<>0 then i:=i+1;
                 
                 if (not cmapped) and (grdevicetype <> crt27a)  { mono } 
                 then 
                   begin
                   int_char(i);
                   for i:=hard_ymax downto 0 do
                     begin
                     index:=i;
                     gdump_red(addr(tempgcb));
                     bufptr := addr(dgbuff);
                     ioentry_output(dump_dev_info,bufptr^,false);
                     end;
                   end
                   else  { color device } 
                     begin
                     start_dotrow(i);
                     for i:=hard_ymax downto 0 do
                       begin
                       index:=i;
                       gdump_red_c(addr(tempgcb));
                       for dotrow := 1 to 2 do
                         for plane := 1 to 3 do
                           begin
                           bufptr := addr(pixrow[dotrow,plane]);
                           ioentry_output(dump_dev_info,bufptr^,false);
                           end;
                       end;
                     end;  { grdevicetype }
               end;   { not rotated }
             end { dithered }
        else  { ERROR DIFFUSION }
        
          begin 
          
          { INITIALIZE  ACCUMULATED ERROR ARRAYS }
          anyptr(addr3) := addr(accum_err_one[1,1]);
          anyptr(addr4) := addr(accum_err_two[1,1]);
          init_err(biggest_xval,addr(tempgcb));
          temp_err := accum_err_one;
          
          if rotate_it 
             then 
               begin
               i:=n_glines div 8;
               if (n_glines mod 8)<>0 then i:=i+1;
               if not odd(tempgcb.non_square) { SQUARE PIX } 
                 then factor := 1        
                 else factor := 2;   { non-square pix }
               if (not cmapped) and  (grdevicetype <> crt27a) { monochrome }
               then 
                 begin
                 int_char(i);
                 for i:=0 to hard_xmax do
                   begin
                   index:=i * factor;
                   gdump_ed(addr(tempgcb));
                   bufptr := addr(dgbuff);
                   ioentry_output(dump_dev_info,bufptr^,false);
                   end
                 end
               else { color device }
                 begin
                 start_dotrow(i);
                     
                 dotrow := 1;
                 for i:=0 to hard_xmax do
                   begin
                   
                   { MOVE ERROR ROW TWO UP TO ERROR ROW ONE AND REINIT ONE }
                   accum_err_one := accum_err_two;
                   accum_err_two := temp_err;
                   
                   index := i * factor;
                   gdump_edc(addr(syscmap[0]),addr(tempgcb));
                   for plane := 1 to 3 do
                     begin
                     bufptr := addr(pixrow[dotrow,plane]);
                     ioentry_output(dump_dev_info,bufptr^,false);
                     end;
                   end;
                 end; { if grdevicetype }
               end{ if rotated dump }
             else    { not rotated }
               begin
                 i:=(hard_xmax+1) div 8;
                 if ((hard_xmax+1) mod 8)<>0 then i:=i+1;
                 
                 if (not cmapped) and (grdevicetype <> crt27a)  { mono } 
                 then 
                   begin
                   int_char(i);
                   for i:=hard_ymax downto 0 do
                     begin
                     index:=i;
                     gdump_red_ed(addr(tempgcb));
                     bufptr := addr(dgbuff);
                     ioentry_output(dump_dev_info,bufptr^,false);
                     end;
                   end
                   else  { color device } 
                     begin
                     start_dotrow(i);
                     
                     { set up rgltemp values }
                     dotrow := 1;
                     for i:=hard_ymax downto 0 do
                       begin
                       
                       { MOVE ERROR ROW TWO UP TO ERROR ROW ONE AND REINIT ONE }
                       accum_err_one := accum_err_two;
                       accum_err_two := temp_err;
                       
                       index:=i;
                       gdump_red_edc(addr(syscmap[0]),addr(tempgcb));
                       for plane := 1 to 3 do
                         begin
                         bufptr := addr(pixrow[dotrow,plane]);
                         ioentry_output(dump_dev_info,bufptr^,false);
                         end;
                       end;  {for}
                     end;  { color device }
               end;  { not rotated }
          
          end;   {ERROR DIFFUSION }
          
          
        { END RASTER GRAPHICS }
        c[3]:='r';
        c[4]:='B';
        len:=4;
        ioentry_output(dump_dev_info,gbuff,false);
        len:=0;
        if (from_sc=current_sc) and gcursor_on then call(dd_cursor);
      recover
        begin
        if (from_sc=current_sc) and gcursor_on then call(dd_cursor);
        escape(escapecode);
        end;
    DUMP_DEV.DUMP_SC := TEMP_DUMP_SC ;
  end;  { WITH GS_PTR }
end;    { PROC GDUMP_COLORED }

end;   {gdump_col module}

$if true$
            
$LIST OFF$

