home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / XDUMP.ZIP / PD.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-08-17  |  12.3 KB  |  405 lines
  1. {A quicky test program for XDUMP V1.x translating screen dump driver}
  2. {Copyright (c) 1988 by Michael Day, all rights reserved}
  3. {first implimentation 1 June 1988}
  4. {this release as of 17 August 1988}
  5.  
  6. program pd;
  7. uses crt,xdump,graph;
  8. var x,y,i,grdriver,grmode:integer;
  9.     A : string; ch : char;
  10.     good : boolean;
  11.     PrnLArea,PrnUArea:rect;
  12.  
  13.     PSR : PSptr;    {pointer variable used to access PSrec}
  14.  
  15. {-----------------------------------------}
  16. {get a Y or N response from keyboard}
  17. function getyorn:char;
  18. var R : string;   A : char;
  19. begin
  20.   repeat
  21.     readln(R);
  22.     if R = '' then
  23.       A := 'Y'
  24.     else
  25.       A := upcase(R[1]);
  26.     if (A <> 'Y') and (A <> 'N') then
  27.       write('Try again:');
  28.   until (A = 'Y') or (A = 'N');
  29.   getyorn := A;
  30. end;
  31.  
  32. {------------------------------------------}
  33. {get a number from the keyboard}
  34. function getnum:integer;
  35. var t, c : integer;
  36.     A : string;
  37. begin
  38.   repeat
  39.     readln(A);
  40.     if A <> '' then
  41.       val(A,t,c)
  42.     else
  43.     begin
  44.       c := 0;
  45.       t := 0;
  46.     end;
  47.     if c <> 0 then
  48.       write('Try again:');
  49.   until c = 0;
  50.   getnum := t;
  51. end;
  52.  
  53. {--------------------------------------------------------}
  54. {pick up new screen limit values}
  55. procedure getscrn(var scrnarea:rect);
  56. begin
  57.    with scrnarea do
  58.    repeat
  59.      writeln;
  60.      writeln('Enter Screen area to use (ret for default):');
  61.      write('Enter screen min X value:');
  62.      xmin := getnum;
  63.      write('Enter screen max X value:');
  64.      xmax := getnum;
  65.      write('Enter screen min Y value:');
  66.      ymin := getnum;
  67.      write('Enter screen max Y value:');
  68.      ymax := getnum;
  69.      if xmax = 0 then xmax := GetMaxX; {not allowed to go beyond screen}
  70.      if ymax = 0 then ymax := GetMaxY;
  71.      writeln;
  72.      writeln('Screen area = ',xmin,',',xmax,',',ymin,',',ymax);
  73.      write('Is this correct? (Y or N): ');
  74.    until getyorn = 'Y';
  75. end;
  76.  
  77.  
  78. {---------------------------------------------------------}
  79. {get printer limit values}
  80. procedure getprn(var prnarea:rect);
  81. begin
  82.    with prnarea do
  83.    repeat
  84.      writeln;
  85.      writeln('Enter Printer area to use (ret for default):');
  86.      write('Enter printer Min X value:');
  87.      xmin := getnum;
  88.      write('Enter printer Max X value:');
  89.      xmax := getnum;
  90.      write('Enter printer Min Y value:');
  91.      ymin := getnum;
  92.      write('Enter printer Max Y value:');
  93.      ymax := getnum;
  94.  
  95.      if xmax = 0 then                 {if they enter 0, assume}
  96.      begin                            {predefined values}
  97.        if psr^.LandScape then
  98.        begin
  99.          case psr^.PStype of
  100.            1 : xmax := 799;   {for correct landscape aspect ratio}
  101.            2 : xmax := 399;   {half as many in this mode}
  102.            3 : xmax := 479;   {for correct VGA aspect ratio}
  103.            4 : xmax := 799;   {for special herc mode}
  104.          end;
  105.        end
  106.        else
  107.        begin
  108.          case psr^.PStype of
  109.            1 : xmax := 959;  {upright value, assumes 8x6 picture}
  110.            2 : xmax := 479;  {only half as many in this mode}
  111.            3 : xmax := 575;  {not a valid selction, use max}
  112.            4 : xmax := 959;  {herc mode}
  113.          end;
  114.        end;
  115.      end;
  116.      if ymax = 0 then
  117.      begin
  118.        if psr^.LandScape then
  119.        begin
  120.          case psr^.PStype of
  121.            1 : ymax := 639;   {optimal undistored size for landscape}
  122.            2 : ymax := 639;   {same in this mode}
  123.            3 : ymax := 639;   {for correct VGA aspect ratio}
  124.            4 : ymax := 719;   {for special herc mode}
  125.          end;
  126.        end
  127.        else
  128.        begin               {upright value, assumes 8x6 picture}
  129.          case psr^.PStype of
  130.            1 : ymax := 431;  {upright value, assumes 8x6 picture}
  131.            2 : ymax := 399;  {shortened one just for the heck of it}
  132.            3 : ymax := 431;  {not a valid selction, use max}
  133.            4 : ymax := 431;  {special herc mode}
  134.          end;
  135.        end;
  136.      end;
  137.      writeln;
  138.      writeln('Printer area = ',xmin,',',xmax,',',ymin,',',ymax);
  139.      write('Is this correct? (Y or N): ');
  140.    until GetYorn = 'Y';
  141. end;
  142.  
  143. {------------------------------------------------------------------}
  144. {force graphics mode to desired state}
  145. procedure ForceMode(var grdriver, grmode : integer);
  146. begin
  147.   case grdriver of
  148.      1 : grmode := 0; {CGA}
  149.      2 : grmode := 0; {MCGA}
  150.      3 : grmode := 1; {EGA}
  151.      4 : grmode := 0; {EGA64}
  152.      5 : grmode := 3; {EGAmono}
  153.      7 : grmode := 0; {Herc}
  154.      8 : grmode := 0; {ATT400}
  155.      9 : grmode := 2; {VGA}
  156.     10 : grmode := 0; {PC3270}
  157.   end;
  158.   SetGraphMode(grmode);   {init any new screen mode}
  159. end;
  160.  
  161. {++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  162. {make some stupid assumptions on what the printer should look like}
  163. procedure StartPrn(var PSR:PSptr);
  164. begin
  165.    GetMem(PSR,sizeof(PSrec));
  166.    FillChar(PSR^,sizeof(PSrec),0); {clear prnscr record to zero}
  167.    with PSR^ do
  168.    begin
  169.       GPage := 0;            {use graphics page 0}
  170.       LPTnum := 0;           {assume printer on LPT1}
  171.       ScrnType := grdriver;  {use turbo's driver number}
  172.       PStype := 1;           {use standard mode}
  173.       LandScape := true;     {define the print mode (landscape/upright}
  174.       mono := true;          {assume monochrome mode}
  175.  
  176.       PrnLArea.Xmin := 0;    {define the printer landscape defaults}
  177.       PrnLArea.Ymin := 0;
  178.       PrnLArea.Xmax := 799;
  179.       PrnLArea.Ymax := 639;
  180.  
  181.       PrnUArea.Xmin := 0;     {define the printer upright defaults}
  182.       PrnUArea.Ymin := 0;
  183.       PrnUArea.Xmax := 959;
  184.       PrnUArea.Ymax := 431;
  185.  
  186.       PrnArea := PrnUArea;    {start with upright print default}
  187.  
  188.       ScrnArea.Xmin := 0;     {define the screen defaults}
  189.       ScrnArea.Ymin := 0;
  190.       ScrnArea.Xmax := 319;   {CGA graphics assumed}
  191.       ScrnArea.Ymax := 199;
  192.  
  193.       initprn(PSR^);           {now go initialize it}
  194.    end;
  195. end;
  196.  
  197. {************************************************************************}
  198. {get the parameters to use for testing the printer driver}
  199.  
  200. begin
  201.  
  202.   grdriver := detect;   {find out what kind of graphics setup is out there}
  203.   grmode := EGAhi;      {assume EGA for now}
  204.   initgraph(grdriver,grmode,'');  {and initialize it}
  205.   ForceMode(grdriver,grmode);     {force mode to desired default}
  206.   RestoreCrtMode;    {then switch back to crt mode for the following}
  207.  
  208.     repeat
  209.       writeln('       XDUMP V1.x DEMO program');
  210.       writeln('Written by Michael Day  Copyright (c) 1988');
  211.       writeln('        as of 25 July 1988');
  212.       writeln;        {check if they want to change the screen mode/type}
  213.       good := false;
  214.       write('Screen mode = ',grmode,'  Screen type = ',grdriver);
  215.       write('  Correct? (Y or N): ');
  216.       if GetYorn = 'N' then
  217.       begin
  218.         write('Enter new screen Mode: ');
  219.         grmode := GetNum;
  220.         if (grmode < 0) or (grmode > 3) then grmode := 0;
  221.         write('Enter new screen Type: ');
  222.         grdriver := GetNum;
  223.         if (grdriver < 0) or (grdriver > 10) then grmode := 0;
  224.       end
  225.       else
  226.         good := true;
  227.     until good;
  228.  
  229.   CloseGraph;                    {close old graphics mode}
  230.   initgraph(grdriver,grmode,'');  {and reinitialize new one}
  231.   RestoreCrtMode;         {and go back to text mode again}
  232.  
  233.   StartPrn(PSR);  {startup the printer driver}
  234.  
  235.   with PSR^ do
  236.   begin
  237.     repeat
  238.       writeln;
  239.       with ScrnArea do      {get the screen area to use}
  240.       begin
  241.         if xmax > GetMaxX then xmax := GetMaxX;
  242.         if ymax > GetMaxY then ymax := GetMaxY;
  243.         writeln('Screen Default = ',xmin,',',xmax,',',ymin,',',ymax);
  244.         write('Do you wish to use the default values? (Y or N): ');
  245.         if GetYorn = 'N' then GetScrn(ScrnArea);
  246.       end;
  247.  
  248.       writeln;
  249.       repeat
  250.         write('Use LandScape or UpRight mode (L or U):');
  251.         readln(A);
  252.         if A = '' then       {check if they want upright or landscape}
  253.           ch := 'L'
  254.         else
  255.           ch := upcase(A[1]);
  256.         if (ch = 'L') then
  257.            LandScape := true
  258.         else
  259.            LandScape := false;
  260.       until (ch = 'L') or (ch = 'U');
  261.  
  262.       writeln;      {check out which print mode to use}
  263.       repeat
  264.         writeln('Normal = 1, Quick := 2, VGA (landscape) = 3, Herc = 4');
  265.         write('Enter print mode to use (1-4):');
  266.         PStype := GetNum;
  267.       until (PStype > 0) and (PStype < 5);
  268.  
  269.       writeln;
  270.       if LandScape then
  271.       begin
  272.         with PrnLArea do       {get the landscape printer area to use}
  273.         begin
  274.           writeln('Printer Default = ',xmin,',',xmax,',',ymin,',',ymax);
  275.           write('Do you wish to use the default values? (Y or N):');
  276.           if GetYorn = 'N' then
  277.             GetPrn(PrnLArea);
  278.         end;
  279.         PrnArea := PrnLArea;
  280.       end
  281.       else
  282.       begin                   {or the upright printer area to use}
  283.         with PrnUArea do
  284.         begin
  285.           writeln('Printer Default = ',xmin,',',xmax,',',ymin,',',ymax);
  286.           write('Do you wish to use the default values? (Y or N):');
  287.           if GetYorn = 'N' then
  288.             GetPrn(PrnUArea);
  289.         end;
  290.         PrnArea := PrnUArea;
  291.       end;
  292.  
  293.       writeln;               {new Coke or Classic?}
  294.       repeat
  295.         write('Use Monochrome or Color printer (M or C):');
  296.         readln(A);
  297.         if A = '' then
  298.           ch := 'M'
  299.         else
  300.           ch := upcase(A[1]);
  301.         if (ch = 'M') then
  302.            mono := true
  303.         else
  304.            mono := false;
  305.       until (ch = 'M') or (ch = 'C');
  306.  
  307.  
  308.       writeln;   {now show 'em what they selected}
  309.       with ScrnArea do
  310.         writeln('Screen area = ',xmin,',',xmax,',',ymin,',',ymax);
  311.       with PrnArea do
  312.         writeln('Printer area = ',xmin,',',xmax,',',ymin,',',ymax);
  313.       if LandScape then
  314.         writeln('LandScape mode')
  315.       else
  316.         writeln('UpRight mode');
  317.       if mono then
  318.         writeln('Monochrome printer')
  319.       else
  320.         writeln('Color printer');
  321.       writeln('Print mode = ',PStype);
  322.  
  323.       write('Is this correct? (Y or N): ');
  324.     until GetYorn = 'Y';
  325.   end;
  326.  
  327.   {--------------------------------------}
  328.   {setup done, now go do the graphics.}
  329.  
  330.   SetGraphMode(grmode);   {switch to the selected graphics mode}
  331.  
  332.   if psr^.mono then          {do up a mono display}
  333.   begin                     {by showing a grid pattern}
  334.     setcolor(white);        {in white}
  335.     i := 0;
  336.     while i < getmaxy do
  337.     begin
  338.       moveto(0,i);
  339.       lineto(getmaxx,i);
  340.       inc(i,8);
  341.     end;
  342.     moveto(getmaxx,0);
  343.     lineto(getmaxx,getmaxy);
  344.  
  345.     i := 0;
  346.     while i < getmaxx do
  347.     begin
  348.       moveto(i,0);
  349.       lineto(i,getmaxy);
  350.       inc(i,8);
  351.     end;
  352.     moveto(0,getmaxy);
  353.     lineto(getmaxx,getmaxy);
  354.  
  355.  
  356.     setfillstyle(solidfill,white);   {then slap a couple of pie slices}
  357.     setcolor(white);                    {on it just for the heck of it}
  358.     pieslice(getmaxx div 4,getmaxy div 2,0,99,50);
  359.     moveto( (getmaxx div 4) + 16,(getmaxy div 2) - 16);
  360.     setcolor(black);
  361.     outtext('1');
  362.     setcolor(white);
  363.     setfillstyle(solidfill,white);
  364.     pieslice(getmaxx div 4 * 3,getmaxy div 2,0,99,50);
  365.     moveto( (getmaxx div 4 * 3) + 16,(getmaxy div 2) - 16);
  366.     setcolor(black);
  367.     outtext('2');
  368.     setcolor(white);
  369.   end
  370.  
  371.   else
  372.  
  373.   begin
  374.     for y := 0 to 44 do                 {for color mode we just put up}
  375.       for x := 0 to 79 do               {a simple color pattern}
  376.       begin
  377.         setcolor((x + y) and GetMaxColor);
  378.     {    moveto(x*8,y*8);     }
  379.     {    outtext(char(219)); }  {the block char doesn't print}
  380.     {     outtext(char($40));  }  {with all BGI drivers sigh...}
  381.  
  382.         setfillstyle(solidfill,(x + y) and GetMaxColor);
  383.         bar(x*8,y*8,x*8+7,y*8+7);       {so do it with a bar}
  384.       end;
  385.  
  386.     setcolor(cyan);
  387.     moveto(0,0);                        {outlined in cyan}
  388.     lineto(getmaxx,0);                  {(to show edge priorities)}
  389.     lineto(getmaxx,getmaxy);
  390.     lineto(0,getmaxy);
  391.     lineto(0,0);
  392.  
  393.   end;
  394.  
  395.   initprn(PSR^);      {now init the XDUMP to the selected values}
  396.   PScreen(PSR^);      {and take a dump}
  397.  
  398.   if keypressed then ch := readkey; {clear old key if there was an abort}
  399.   repeat until keypressed;          {then wait for any key to exit}
  400.  
  401.   closegraph;                   {close up shop and go home}
  402. end.
  403.  
  404.  
  405.