home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / XDUMP.ZIP / XDUMP.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1988-08-17  |  20.9 KB  |  533 lines
  1. {$S-,R-,I-,V-,B-}
  2.  
  3. {XDUMP - V1.03 translating screen dump program}
  4. {Copyright (c) 1988 Michael Day - all rights reserved}
  5. {first release 1 June 1988}
  6. {second release 24 July 1988}     {first public release}
  7. {third release as of 28 July 1988} {fixed printer and GetP}
  8. {this release as of 17 August 1988} {fixed range check problem}
  9.  
  10.  
  11. {This is a shareware program. Refer to the license agreement for further}
  12. {information. If you do not have the license documentation you may}
  13. {obtain it by writting to me at: }
  14.  
  15. {     Michael Day                                               }
  16. {     C/O Day Research                                          }
  17. {     P.O. Box 22902                                            }
  18. {     Milwaukie, OR 97222                                       }
  19. {                                                               }
  20. {     CIS [73577,2225]                                          }
  21. {     Mike Day  UUCP:...!tektronix!reed!qiclab!bakwatr!mikeday  }
  22.  
  23. {If you include $10.00 I will also send you a current copy of the full}
  24. {shareware package.}
  25.  
  26. {Note: If you agree to the terms of the shareware license you may}
  27. {use this program free of royalties, and you may use this program}
  28. {in conjunction with any program you may develop, that XDUMP is a}
  29. {part of, in private or commercial applications free of royalty payments.}
  30. {The catch is that you must provide a copy of any enhancments to XDUMP}
  31. {to be distributed among the other XDUMP developers.}
  32. {See the license agreement for further details.}
  33.  
  34.  
  35. {XDUMP is a screen dump program that can scale up or down from the screen}
  36. {to the printer. Currently it assumes an Epson or compatible printer is}
  37. {attached. Minimal definition required is landscape or upright, mono or}
  38. {color, screen area to read, and printer area to use (seperate for}
  39. {landscape or upright), printer LPT number, and print mode: Normal,}
  40. {quick, or VGA (VGA works for landscape mode only). And Screen type.}
  41. {Note that there currently are no limit checks done, if you give the}
  42. {wrong values, no telling what will happen.}
  43.  
  44. Unit xdump;
  45.  
  46. Interface
  47.  
  48. uses crt,graph;
  49.  
  50. const        MaxCrt = 999; {maximum crt/prn buffer size}
  51.  
  52. type
  53.      string8 = string[8];
  54.  
  55.      rect  = record
  56.                Xmin, Ymin, Xmax, Ymax : word;
  57.              end;
  58.  
  59.      PDbufType = array [0..7] of array [0..maxcrt] of byte;
  60.  
  61.      PSptr = ^PSrec;
  62.  
  63.      PSrec = record  { 11577 bytes }
  64.  
  65.              {these vars are set by the calling program to specify}
  66.              {what the print out is supposed to look like. Initprn}
  67.              {then uses this information to set things up}
  68.              {25 bytes}
  69.                LandScape  : boolean; {landscape=true, upright=false}
  70.                Mono       : boolean; {Monochrome=true, Color=false}
  71.                ScrnType   : word; {screen type in use}
  72.                PStype     : word; {print mode}
  73.                LPTnum     : word; {printer port to use}
  74.                GPage      : byte; {graphics page to use}
  75.                PrnArea    : rect; {printer definition area}
  76.                ScrnArea   : rect; {screen area to use for dump}
  77.  
  78.              {these arrays are stuffed by initprn for use by prnscrn}
  79.              {2521 bytes}
  80.                px         : array [0..maxcrt] of word; {prn x translation}
  81.                py         : array [0..maxcrt] of word; {prn y translation}
  82.                CPriority  : array [0..255] of byte; {color priority}
  83.                PCSelect   : array [0..255] of byte; {screen to printer colors}
  84.                PGmode     : string8;          {graphics mode entry string}
  85.  
  86.              {this is the virtual screen buffer created by prnscrn}
  87.              {8000 bytes}
  88.                PDbuf      : PDbufType;  {raw screen -> print data buffer}
  89.  
  90.              {these vars are used by various procedures inside}
  91.              {prnscrn and cannot be used by external programs}
  92.              {1031 bytes}
  93.                PCmax      : byte; {max print color}
  94.                pXmod      : real; {screen to print translation factor}
  95.                pYmod      : real;
  96.                Pbuf       : array [0..maxcrt] of byte; {print dot buffer}
  97.                X1,X2,Y1,Y2: word;     {current work area definition}
  98.                PBcnt      : integer;  {print buf byte count}
  99.                gy         : word;     {screen row being read}
  100.                id         : byte;     {print head pin reference}
  101.                pc         : byte;     {print color being used}
  102.              end;
  103.  
  104.  
  105. {--------------------------------------}
  106. {how to get access from the outside world}
  107. procedure PScreen(var PSR:PSrec);
  108. procedure initprn(var PSR:PSrec);
  109. {--------------------------------------}
  110.  
  111. Implementation
  112.  
  113. const STDmode : string = #$1b#$4C;       {misc strings for communicating}
  114. const QICmode : string = #$1b#$4B;       {with the Epson printer}
  115. const VLSmode : string = #$1b#$2A#5;
  116. const hercmode : string = #$1b#$4C;      {herc is really just standard}
  117.  
  118. const TAGmode : string = #$1b#$4A#24;    {this all needs to be}
  119. const PGenter : string = #13;            {cleaned up sometime}
  120. const PGline : string  = #13;
  121. const PGexit : string  = #13#10#12;
  122.  
  123. type string4 = string[4];
  124.  
  125. {how to select a ribbon color}
  126. const pcolor : array [1..4] of string4 =
  127. (#$1b#$72#0,#$1b#$72#1,#$1b#$72#2,#$1b#$72#4);
  128. {pc=1=black, pc=2=red,  pc=3=blue, pc=4=yellow }
  129. {   $01        $02        $04        $08       }
  130.  
  131. {----------------------------------------------}
  132. {your basic kludge initialization mechanism. Hopefully to be cleaned up}
  133. {as more knowledge is gained about how to make this mess work}
  134. procedure initprn(var PSR:PSrec);
  135. var i,iL : integer;
  136. begin
  137.   if @PSR = nil then Exit;    {don't do anything if never allocated}
  138.   with PSR do
  139.   begin
  140.     PCmax := 4;               {the Epson printer has four ribbon colors}
  141.     for i := 0 to 255 do      {for now color priority is linear}
  142.       CPriority[i] := i;
  143.  
  144.     case ScrnType of
  145.       5,6,7,10 : mono := true; {mono only type displays}
  146.     end;
  147.  
  148.     if mono then             {in mono any color is black on the printer}
  149.     begin
  150.       FillChar(PCSelect,sizeof(PCSelect),$0f);
  151.       PCSelect[0] := 0;      {except black on the screen}
  152.     end
  153.     else
  154.     begin
  155.       case ScrnType of
  156.         EGA, EGA64, VGA :
  157.         begin
  158.            {screen}    {printer}
  159.           PCSelect[0] := $00;    {crude and rude this way, but it gets}
  160.           PCSelect[1] := $04;    {the color translation identified}
  161.           PCSelect[2] := $0c;
  162.           PCSelect[3] := $04;    {the color translation uses a bit map}
  163.           PCSelect[4] := $02;    {- $01 is black}
  164.           PCSelect[5] := $06;    {- $02 is red}
  165.           PCSelect[6] := $08;    {- $04 is blue}
  166.           PCSelect[7] := $01;    {- $06 is violet (blue+red)}
  167.           PCselect[8] := $00;    {- $08 is yellow}
  168.           PCSelect[9] := $04;    {- $0A is orange (red+yellow)}
  169.           PCSelect[10] := $0c;   {- $0C is green (blue+yellow)}
  170.           PCSelect[11] := $04;
  171.           PCSelect[12] := $02;
  172.           PCSelect[13] := $06;
  173.           PCSelect[14] := $08;
  174.           PCSelect[15] := $01;
  175.         end;
  176.         CGA, MCGA, ATT400 :
  177.         begin
  178.            {screen}    {printer}
  179.           PCSelect[0] := $00;    {crude and rude this way, but it gets}
  180.           PCSelect[1] := $0c;    {the color translation identified}
  181.           PCSelect[2] := $02;
  182.           PCSelect[3] := $08;    {the color translation uses a bit map}
  183.         end;
  184.       end;
  185.     end;
  186.  
  187.     {this selects the graphics entry string to use}
  188.     case PStype of
  189.       1 : PGmode := STDmode;  {normal landscape / upright}
  190.       2 : PGmode := QICmode; {quick landscape / upright}
  191.       3 : PGmode := VLSmode; {vga landscape - requires late model Epson}
  192.       4 : PGmode := Hercmode {hercules landscape mode}
  193.     else
  194.       PGmode := STDmode;  {if not one of the three, then assume STDmode}
  195.     end;
  196.  
  197.     {-----------------------------------------------------------------}
  198.     {now convert the screen and printer definitions into pixel access}
  199.     {array values. In landscape mode the screen X axis is given to the}
  200.     {printer Y axis, and the screen Y axis to the printer X axis}
  201.  
  202.     FillChar(px,sizeof(px),0);  {clear the translation arrays}
  203.     FillChar(py,sizeof(py),0);
  204.  
  205.     if LandScape then
  206.     begin
  207.       pXmod := succ(PrnArea.Xmax-PrnArea.Xmin) /          {determine the}
  208.                  succ(ScrnArea.Ymax-ScrnArea.Ymin);      {scaling factor}
  209.       pYmod := succ(PrnArea.Ymax-PrnArea.Ymin) /          {returning the}
  210.                  succ(ScrnArea.Xmax-ScrnArea.Xmin);      {result as real}
  211.  
  212.       {this fills the px array with the screen pixel reference locations}
  213.       {in landscape mode the printer's X axis is inverted}
  214.       iL := succ(PrnArea.Xmin);
  215.       for i := pred(PrnArea.Xmax) downto succ(PrnArea.Xmin) do
  216.       begin
  217.         px[i] := ScrnArea.Ymin+trunc((iL-PrnArea.Xmin) / pXmod);
  218.         inc(iL);
  219.       end;
  220.       px[PrnArea.Xmin] := ScrnArea.Ymax;      {force printer's first and}
  221.       px[PrnArea.Xmax] := ScrnArea.Ymin;      {last to be same as screen}
  222.       {one pixel past max must be the same as the last pixel}
  223.       px[succ(PrnArea.Xmax)] := ScrnArea.Ymin;
  224.  
  225.       {this fills the py array with the screen pixel reference locations}
  226.       for i := succ(PrnArea.Ymin) to pred(PrnArea.Ymax) do
  227.       begin
  228.         py[i] := ScrnArea.Xmin+trunc((i-PrnArea.Ymin) / pYmod);
  229.       end;
  230.       py[PrnArea.Ymin] := ScrnArea.Xmin;      {force printer's first and}
  231.       py[PrnArea.Ymax] := ScrnArea.Xmax;      {last to be same as screen}
  232.       {one pixel past max must be the same as the last pixel}
  233.       py[succ(PrnArea.Ymax)] := ScrnArea.Xmax;
  234.     end
  235.  
  236.     {in upright mode both arrays contain incrementing values,}
  237.     {and the screen X axis matches the printer X axis}
  238.     else
  239.     begin
  240.       pXmod := (succ(PrnArea.Xmax-PrnArea.Xmin)) /        {determine the}
  241.                   (succ(ScrnArea.Xmax-ScrnArea.Xmin));   {scaling factor}
  242.       pYmod := (succ(PrnArea.Ymax-PrnArea.Ymin)) /        {returning the}
  243.                   (succ(ScrnArea.Ymax-ScrnArea.Ymin));   {result as real}
  244.  
  245.       {this fills the px array with the screen pixel reference locations}
  246.       for i := succ(PrnArea.Xmin) to pred(PrnArea.Xmax) do
  247.       begin
  248.         px[i] := ScrnArea.Xmin+trunc((i-PrnArea.Xmin) / pXmod);
  249.       end;
  250.       px[PrnArea.Xmin] := ScrnArea.Xmin;      {force printer's first and}
  251.       px[PrnArea.Xmax] := ScrnArea.Xmax;      {last to be same as screen}
  252.       {one pixel past max must be the same as the last pixel}
  253.       px[succ(PrnArea.Xmax)] := ScrnArea.Xmax;
  254.  
  255.       {this fills the py array with the screen pixel reference locations}
  256.       for i := succ(PrnArea.Ymin) to pred(PrnArea.Ymax) do
  257.       begin
  258.         py[i] := ScrnArea.Ymin+trunc((i-PrnArea.Ymin) / pYmod);
  259.       end;
  260.       py[PrnArea.Ymin] := ScrnArea.Ymin;     {force printer's first and}
  261.       py[PrnArea.Ymax] := ScrnArea.Ymax;     {last to be same as screen}
  262.       {one pixel past max must be the same as the last pixel}
  263.       py[succ(PrnArea.Ymax)] := ScrnArea.Ymax;
  264.     end;
  265.   end;
  266. end;
  267.  
  268. {-----------------------------------------------}
  269. {this reads gets the pixel data from the screen}
  270. {X= column, Y=row, P=page}
  271.  
  272. function GetP(X,Y,P:word):byte;
  273. begin
  274.   SetVisualPage(P);
  275.   GetP := GetPixel(X,Y);
  276. end;
  277.  
  278. (*
  279. {to use the BIOS instead for none TP supported displays, or to allow}
  280. {use of this unit in a TSR replace the TP graph function call above}
  281. {with this inline function code. Warning: Your BIOS must support }
  282. {the ReadDot function (int 10, ah 13) for this to work. Hercules }
  283. {boards seem to have problems with this.}
  284. function GetP(X,Y,P:word):byte;
  285. Inline($5B               {    pop bx}
  286.       /$5A               {    pop dx}
  287.       /$59               {    pop cx}
  288.       /$88/$DF           {    mov bh,bl}
  289.       /$B4/$0D           {    mov ah,13}
  290.       /$CD/$10);         {    int $10}
  291. *)
  292.  
  293. {-----------------------------------------------}
  294. {a pair of inline macros to return the min or max}
  295. {of two word values. Note: these are WORDs not integers}
  296. function MinWord(A,B:word):word;
  297. Inline($58               {    pop ax}
  298.       /$5B               {    pop bx}
  299.       /$39/$D8           {    cmp ax,bx}
  300.       /$72/$02           {    jb minok}
  301.       /$89/$D8);         {    mov ax,bx}
  302.                          {minok:}
  303.  
  304. function MaxWord(A,B:word):word;
  305. inline($58               {    pop ax}
  306.       /$5B               {    pop bx}
  307.       /$39/$D8           {    cmp ax,bx}
  308.       /$73/$02           {    jnb maxok}
  309.       /$89/$D8);         {    mov ax,bx}
  310.                          {maxok:}
  311.  
  312.  
  313. {-----------------------------------------------}
  314. {a simple and crude printer interface}
  315. {to be replaced with something better later}
  316. function prnstat(LPTnum:word):byte;
  317. inline($5A/          {pop dx}
  318.        $B4/$02/      {mov ah,2}
  319.        $CD/$17/      {int 17h}
  320.        $86/$E0);     {xchg al,ah}
  321.  
  322. function prndata(LPTnum:word; ch:char):byte;
  323. inline($58/          {pop ax}
  324.        $5A/          {pop dx}
  325.        $B4/$00/      {mov ah,0}
  326.        $CD/$17/      {int 17h}
  327.        $86/$E0);     {xchg al,ah}
  328.  
  329.  
  330. {----------------------------------------------}
  331. procedure OutPrn(LPTnum:word; PStr: string);
  332. var r : boolean;
  333.     i : integer;
  334. begin
  335.    for i := 1 to length(PStr) do
  336.    begin
  337.      if (prndata(LPTnum,PStr[i]) and 1) = 1 then halt(1);
  338.    end;
  339. end;
  340.  
  341. {++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  342. {this reads in a row of pixels from the screen into the printer buffer}
  343. procedure GetYrow(var PSR:PSrec);
  344. var ix, gx, gd, ox : word;
  345. begin
  346.   with PSR do
  347.   begin
  348.     gx := px[X1];        {get the first pixel of the screen row}
  349.     if LandScape then    {note the different getpixel in landscape mode}
  350.       PDbuf[id][X1] := maxword(CPriority[GetP(gy,gx,GPage)],CPriority[PDbuf[id][X1]])
  351.     else
  352.       PDbuf[id][X1] := maxword(CPriority[GetP(gx,gy,GPage)],CPriority[PDbuf[id][X1]]);
  353.  
  354.     for ix := succ(X1) to X2 do           {now go get the rest of the pixels}
  355.     begin
  356.       ox := px[pred(ix)];              {get the previous pixel for reference}
  357.       gx := px[ix];                                   {get the pixel to read}
  358.       if gx = ox then                   {if we already have the pixel, don't}
  359.         PDbuf[id][ix] := PDbuf[id][pred(ix)] {waste time by reading it again}
  360.       else                                 {if not the same pixel go read it}
  361.       begin
  362.         gd := PDbuf[id][ix];             {read in a copy of background color}
  363.         while gx <> ox do               {then read in all intervening pixels}
  364.         begin                              {prioritizing them based on color}
  365.           if LandScape then        {the color with the highest priority wins}
  366.           begin
  367.             gd := maxword(CPriority[GetP(gy,gx,GPage)],CPriority[gd]);
  368.             inc(gx)
  369.           end
  370.           else                           {do backwards read for upright mode}
  371.           begin
  372.             gd := maxword(CPriority[GetP(gx,gy,GPage)],CPriority[gd]);
  373.             dec(gx);
  374.           end;
  375.         end;
  376.         PDbuf[id][ix] := gd;      {save the resulting highest priority color}
  377.       end;
  378.     end;
  379.   end;
  380. end;
  381.  
  382. {---------------------------------------------------------------------}
  383. {this copies the pixel data from the screen to the printer buffer.}
  384. {In the process it translates colors and scales the pixels to the}
  385. {requested size. The end result is a virtual screen of the size needed}
  386. {for the printer. One psuedo screen pixel for each printer dot.}
  387. {The routine reads in all the pixels needed in each printer row (from}
  388. {one to eight printer rows). The printer rows being created are specified}
  389. {by the Y1, and Y2 variables. The dots used in each row are specified by the }
  390. {X1 and X2 variables. The entire printer data virtual screen is cleared at}
  391. {the beginning of the procedure, so any unread pixels will be set to zero.}
  392. {Note: py[] always indexes in a positive direction. px[] indexes positive }
  393. {in upright mode, and negative in landscape mode. If pYmod and pXmod are }
  394. {equal or greater than one, all the screen pixels will be presented on the }
  395. {printer. If pYmod and/or pXmod is less than one, missing pixels will be }
  396. {prioritized from the CPriority array to select the highest pixel to print.}
  397. {A final note, (Y1 and 7) must always be less than (Y2 and 7) so that the.}
  398. {proper print wires will be used for printing.}
  399.  
  400. procedure PYfill(var PSR:PSrec);
  401. var iy, oy : word;
  402. begin
  403.   with PSR do
  404.   begin
  405.     {fill the printer data buffer with the}
  406.     {background color (lowest priority color)}
  407.     FillChar(PDbuf,sizeof(PDbuf),CPriority[0]);
  408.  
  409.     for iy := Y1 to Y2 do                {always in a range of 1 to 8}
  410.     begin                        {Y1 > Y2 are the printer rows to get}
  411.       gy := py[iy];                    {get current screen row number}
  412.       oy := py[succ(iy)];         {get next row number for comparison}
  413.       id := byte(iy and 7); {convert current row number to pin number}
  414.  
  415.       if gy = oy then
  416.       begin
  417.         GetYrow(PSR);           {if duplicate row, read only this row}
  418.       end
  419.  
  420.       else
  421.       begin
  422.         while gy < oy do            {The printer data starts out as 0}
  423.         begin                     {GetYrow will prioritize the pixels}
  424.           GetYrow(PSR);         {such that any screen pixel read that}
  425.           inc(gy);                {has a higher priority will replace}
  426.         end;                    {the current pixel value in the print}
  427.       end;                                               {data buffer}
  428.     end;
  429.  
  430.   end;
  431. end;
  432.  
  433. {--------------------------------------}
  434. {fills graphic print buffer with dots to print (if any)}
  435. {returns true if there are dots to print, false if none}
  436.  
  437. function PBfill(var PSR:PSrec):boolean;
  438. var ix, iy : word;
  439.     bm, cm : byte;
  440. begin
  441.    PBfill := false;                            {assume no data found}
  442.    with PSR do                         {use printer record variables}
  443.    begin
  444.      if mono then
  445.        cm := $0f                      {for monochrome, use any color}
  446.      else
  447.        cm := 1 shl pred(pc);    {convert color to mask for later use}
  448.      FillChar(Pbuf,sizeof(Pbuf),0);    {clear the print buffer first}
  449.      for iy := Y1 to Y2 do     {printer rows to read (diff = 1 to 8)}
  450.      begin
  451.        id := byte(iy and 7); {convert data buffer index to print wire num}
  452.        bm := $80 shr id;               {convert wire num to bit mask}
  453.        for ix := X1 to X2 do       {individual column test for color}
  454.        begin
  455.          if (PCSelect[PDbuf[id][ix]] and cm) <> 0 then
  456.          begin                            {if there is a color match}
  457.            Pbuf[ix] := Pbuf[ix] or bm;    {then add it to the buffer}
  458.            PBfill := true;     {and mark that there is data to print}
  459.          end;
  460.        end;
  461.      end;
  462.      PBcnt := succ(X2);                 {return total bytes in PBcnt}
  463.    end;
  464. end;
  465.  
  466. {---------------------------------------------}
  467. {print a graphics print line}
  468. procedure GLPrint(var PSR:PSrec);
  469. var i : integer;
  470. begin
  471.   if PBfill(PSR) then  {Tie it all together and send it to the printer}
  472.   begin
  473.     with PSR do
  474.     begin
  475.       if not(mono) then OutPrn(LPTnum,Pcolor[pc]);
  476.       OutPrn(LPTnum,PGmode+char(lo(PBcnt))+char(hi(PBcnt)));
  477.       for i := 0 to pred(PBcnt) do
  478.       begin
  479.         OutPrn(LPTnum,char(Pbuf[i]));
  480.       end;
  481.       OutPrn(LPTnum,PGline);
  482.     end;
  483.   end;
  484. end;
  485.  
  486. {---------------------------------------------}
  487. procedure PScreen(var PSR:PSrec);
  488. var i,fc : integer;
  489.     Yend : word;
  490. begin
  491.   if @PSR = nil then Exit; {don't do anything if never allocated}
  492.   with PSR do
  493.   begin
  494.     OutPrn(LPTnum,PGenter); {make sure the printer is in proper mode for graphics}
  495.     for i := 0 to ((PrnArea.Ymin div 8) and $FFF8) do
  496.       OutPrn(LPTnum,TAGmode);  {no point in sending data on blank lines}
  497.  
  498.     X1 := PrnArea.Xmin;     {define the printer area to start with}
  499.     X2 := PrnArea.Xmax;
  500.     Y1 := PrnArea.Ymin;
  501.     Y2 := Y1;
  502.     Yend := PrnArea.Ymax;
  503.  
  504.     while Y2 < Yend do
  505.     begin
  506.       Y2 := (Y1 and $7ff8) + 7;      {Y2 must be one less than boundry}
  507.       if Y2 > Yend then Y2 := Yend;         {unless it is the last row}
  508.  
  509.       PYfill(PSR);    {go read the virtual screen into the data buffer}
  510.  
  511.       pc := 1;                                {print mono in black ink}
  512.       if mono then
  513.         GLPrint(PSR)                        {and we only need one pass}
  514.       else
  515.         for fc := 1 to PCmax do         {check for all colors to print}
  516.         begin
  517.           pc := fc;
  518.           GLPrint(PSR);
  519.         end;
  520.       OutPrn(LPTnum,TAGmode);    {finally move the paper up for the next line}
  521.       Y1 := succ(Y2);                      {Y1 starts at old Y2 plus one}
  522.  
  523.       if keypressed then Y2 := succ(Yend); {if a key was pressed, then abort}
  524.  
  525.     end;
  526.     OutPrn(LPTnum,PGexit);  {if needed clear the printer mode to non-graphics}
  527.   end;
  528. end;
  529.  
  530. {---------------------------------------------------------------------}
  531. begin
  532. end.
  533.